|10 ' *** PROGRAM '|01' Using PDS*BASE Version 4.02 02-15-89 ***
20 '
30 ' *** This program operates a PDS*BASE Data Base
35 ' ** Almost all variables will start with the letter Y or Z to allow you to use any other variable name.
|40 KEY OFF:COL$="|25" 'change this to COL$="C" if you have a color monitor or COL$="M" if you have a non-color monitor
42 DIM COLA%(21),COLB%(21):IF COL$="C" THEN FOR J=0 TO 21:COLA%(J)=J:COLB%(J)=J:NEXT ELSE FOR J=0 TO 20:COLA%(J)=7:COLB%(J)=0:NEXT
45 ZFOPEN=0 'sets open sort file flag to zero
50 ' *** OPEN THE DATA BASE FILES ***
|60 CLS:ZO$=CHR$(44):ZB$="|11":ZQ=|02 ' Comma, Base Name, Number of files
|65 '**** Be sure to start BASICA with the command extenders as follows: 'BASICA/F:|03' as you have more than 3 files
*01 |70 DIM ZS$(|02,|09),ZS%(|02,10),ZT%(|02,|05,4),ZDATE$(|02),ZTIME$(|02),ZCHGFLAG(|02)
*02 ,ZH(|04),ZE(|04),ZH$(|02,|04),ZE$(|02,|04)
*03 ,YC%(|06,50),YC(|06)
71 ' ZS$(X,Y) Y=1 is name of set, Y=2-10 is name of associated sets
72 ' ZS%(X,1)=Set type (1=Master, 2=Detail)
73 ' ZS%(X,2)=Set capacity (number of records)
74 ' ZS%(X,3)=Record size or width
75 ' ZS%(X,4)=Number of associated sets
76 ' ZS%(X,5)=Number of drives required
77 ' ZS%(X,6)=Number of records assigned
78 ' ZS%(X,7)=Number of variables in the set
79 ' ZS%(X,8)=Pointer to next record to be created if a Detail file
80 ' ZS%(X,9)=1 If a companion active/sort file is present
81 ' ZS%(X,10)=Field number for search field hashing
83 ' For multi-disc files the location of records is located in ZT%(X,Y,Z). The file name will be the same, with the program keeping track of the correct file buffer number for the appropriate drive.
84 ' ZT%(X,Y,Z) X=Set number
85 ' Y=File section number (multi-disc files)
86 ' Z=1 = Starting record
87 ' Z=2 = Ending record
88 ' Z=3 = Drive 1=A and 2=B, etc.
89 ' Z=4 = File buffer number for this section
|90 DIM ZI$(|07,|02),Y$(|07,|02),ZC$(|02),ZP$(|02),ZNEXT$(|02),ZB$(|02),ZF$(|02) 'Input and buffer arrays
300 PRINT TAB(27);"PDS*BASE DATA BASE SYSTEM":PRINT:PRINT TAB(32);"OPENING FILE(S)":PRINT:PRINT
*35 301 PRINT TAB(21);"Insert data disc(s) and press any key":YQ$=INPUT$(1):PRINT
304 ON ERROR GOTO 390
305 Z5=0
|310 FOR Z1=1 TO |02
*10 315 FOR Z2=1 TO ZS%(Z1,5) 'number of disc drives for this file
*11 315 Z2=1
*12 320 ZF$=CHR$(64+ZT%(Z1,Z2,3))+":"+ZS$(Z1,1) 'Add correct drive letter to the front of this section
*13 320 ZF$=ZS$(Z1,1) 'data file name
322 OPEN ZF$ AS ZT%(Z1,Z2,4) LEN=ZS%(Z1,3):YC1=0:YC2=0:YC3=0:YC4=0
324 IF ZS%(Z1,1)=1 THEN FIELD ZT%(Z1,Z2,4), 5 AS ZC$(Z1), 5 AS ZP$(Z1), 5 AS ZNEXT$(Z1) : YC1=15
*14 325 IF ZS%(Z1,1)=2 THEN FIELD ZT%(Z1,Z2,4), 5 AS ZB$(Z1), 5 AS ZF$(Z1) : YC1=10
*14 326 IF ZS%(Z1,1)=1 AND ZS%(Z1,4)>0 THEN FOR Z3=1 TO ZS%(Z1,4):FIELD ZT%(Z1,Z2,4), YC1 AS DUMMY1$, 5 AS ZH$(Z1,Z3), 5 AS ZE$(Z1,Z3):YC1=YC1+10:NEXT 'Z3
330 FOR Z3=1 TO ZS%(Z1,7):Y0=ZSIZE%(Z1,Z3):FIELD ZT%(Z1,Z2,4),YC1 AS DUMMY1$,YC2 AS DUMMY2$,YC3 AS DUMMY3$,YC4 AS DUMMY4$,YC5 AS DUMMY5$,Y0 AS Y$(Z3,Z1)
331 IF YC1+Y0<256 THEN YC1=YC1+Y0 ELSE IF YC2+Y0<256 THEN YC2=YC2+Y0 ELSE IF YC3+Y0<256 THEN YC3=YC3+Y0 ELSE IF YC4+Y0<256 THEN YC4=YC4+Y0 ELSE YC5=YC5+Y0
332 NEXT 'Z3
*10 335 IF Z2=ZS%(Z1,5) AND ZS%(Z1,1)=1 THEN GET ZT%(Z1,Z2,4),(ZT%(Z1,Z2,2)-ZT%(Z1,Z2,1)+2):ZS%(Z1,6)=VAL(ZC$(Z1)):ZDATE$(Z1)=ZP$(Z1):ZTIME$(Z1)=ZNEXT$(Z1) 'ZDATE$ & ZTIME$ give date & time this master file was last changed
*11 335 IF ZS%(Z1,1)=1 THEN GET ZT%(Z1,Z2,4),ZS%(Z1,2)+1 : ZS%(Z1,6)=VAL(ZC$(Z1)) : ZDATE$(Z1)=ZP$(Z1) : ZTIME$(Z1)=ZNEXT$(Z1) 'ZDATE$ & ZTIME$ give date and time this master file was last changed
336 IF ZS%(Z1,1)=1 THEN IF MID$(ZTIME$(Z1),3,1)<>":" THEN BEEP:PRINT:COLOR COLA%(4),0:PRINT TAB(13);"THE BLANK DATA BASE FILE(S) HAVE NOT BEEN PRE-CREATED":COLOR 7,0:STOP
*15 337 IF Z2=ZS%(Z1,5) AND ZS%(Z1,1)=2 THEN GET ZT%(Z1,Z2,4),(ZT%(Z1,Z2,2)-ZT%(Z1,Z2,1)+2) : ZS%(Z1,6)=VAL(ZB$(Z1)) : ZS%(Z1,8)=VAL(ZF$(Z1))
*16 337 IF ZS%(Z1,1)=2 THEN GET ZT%(Z1,Z2,4),ZS%(Z1,2)+1 : ZS%(Z1,6)=VAL(ZB$(Z1)) : ZS%(Z1,8)=VAL(ZF$(Z1))
*10 340 NEXT 'Z2
*17
341 IF ZS%(Z1,6)=ZS%(Z1,2) THEN BEEP:COLOR COLA%(4),0:PRINT "WARNING - THE ";ZS$(Z1,1):PRINT "DATA FILE IS FULL.":COLOR 7,0:FOR Z2=1 TO 3000:NEXT Z2
*18
342 IF ZS%(Z1,1)=1 GOTO 370
*19 343 ZR=ZS%(Z1,8):IF ZR=0 THEN BEEP:COLOR COLA%(4),0:PRINT "Detail file ";ZF$;" has Zero for the next vacant record pointer":COLOR 7,0:GOTO 360
*20 343 ZR=ZS%(Z1,8):IF ZR=0 THEN Z5=1:GOTO 360
344 ZA=Z1:ZZ=1:ZR=ZS%(Z1,8):GOSUB 610:Z5=0:FOR Y1=1 TO ZS%(ZA,7):IF Y$(Y1,Z1)<>STRING$(ZSIZE%(Z1,Y1),32) THEN Z5=1
345 NEXT 'Y1
*20 360 IF Z5>0 THEN PRINT:BEEP:COLOR 0,COLA%(4):PRINT "The DETAIL file pointers are in error":PRINT "for ";ZF$:PRINT "Generate and RUN the UTILITY Program to fix - Must cancel":COLOR 7,0:CLOSE:SYSTEM
*19 360 IF Z5>0 THEN BEEP:COLOR COLA%(4),0:PRINT "WARNING - The Detail file pointers in":PRINT ZF$;" are in error. Select Option 1 on the next screen to fix this.":PRINT:PRINT TAB(15);"(Press any key to continue)":COLOR 7,0:ZQ$=INPUT$(1):PRINT
370 NEXT 'Z1
380 ON ERROR GOTO 0:GOTO 2000 'to the main program
390 RESUME 392
|392 PRINT:PRINT "You have more than the 3 file default for BASIC.":PRINT "Restart BASICA or GWBASIC as 'BASICA/F:|03/S:|10'":PRINT "Be sure your CONFIG.SYS file has the 'FILES=20' command."
395 PRINT "Strike any key to return to DOS":ZQ$=INPUT$(1):SYSTEM
400 ' ** CLOSE ALL FILES **"
*21 402 IF ZREPTFLAG<>1 THEN 445 'no corrections to housekeeping records necessary
*11 405 Z2=1
|410 FOR Z1=1 TO |02
*10 415 FOR Z2=1 TO ZS%(Z1,5)
420 IF ZS%(Z1,1)=1 THEN RSET ZC$(Z1)=STR$(ZS%(Z1,6)):ELSE RSET ZB$(Z1)=STR$(ZS%(Z1,6)):RSET ZF$(Z1)=STR$(ZS%(Z1,8))
425 IF ZS%(Z1,1)=1 AND ZCHGFLAG(Z1)=1 THEN RSET ZC$(Z1)=STR$(ZS%(Z1,6)):LSET ZP$(Z1)=LEFT$(DATE$,2)+MID$(DATE$,4,2)+RIGHT$(DATE$,1):LSET ZNEXT$(Z1)=LEFT$(TIME$,5) ELSE LSET ZP$(Z1)=ZDATE$(Z1):LSET ZNEXT$(Z1)=ZTIME$(Z1)
*10 430 IF Z2=ZS%(Z1,5) THEN PUT ZT%(Z1,Z2,4),(ZT%(Z1,Z2,2)-ZT%(Z1,Z2,1)+2)
*11 430 PUT ZT%(Z1,Z2,4),ZS%(Z1,2)+1:CLOSE ZT%(Z1,1,4)
*10 435 NEXT 'Z2
440 NEXT 'Z1
445 CLOSE:IF ZQ=1 THEN PRINT
450 PRINT "ALL DONE";
460 ' END OF PROGRAM
*52 470 ON ERROR GOTO 485
*52 480 RUN"MENU" ' ** ALL DONE ** If you wish to return to the BASIC Ok prompt, replace the RUN command with END. If you wish to return to DOS, replace with SYSTEM.
*53 480 SYSTEM ' ** ALL DONE ** If you wish to return to the BASIC Ok prompt, replace SYSTEM with END. If you are setting up a MENU program use RUN with the menu program name in quotes.
*54 480 END ' ** ALL DONE ** If you wish to return to DOS, replace END with SYSTEM. If you are setting up a MENU program use RUN with the menu program name in quotes.
*52 485 BEEP:IF ERR=53 THEN RESUME 487
*52 486 END
*52 487 PRINT:PRINT " You haven't copied MENU.BAS to this disk. Strike any key to return to DOS":ZQ$=INPUT$(1):SYSTEM
*56
500 ' ** SUBROUTINE TO CALCULATE THE RANDOM ACCESS RECORD NUMBER **
502 '
504 ' Before calling this subroutine, ZA must=the number of the data set. Set ZR$=the search item. If necessary convert integer or real search items to a string for ZR$.
505 ZTESTFLD%=ZS%(ZA,10) 'Search field number you specified when defining this data base file. Also see line 610
506 '
510 Z3#=0:Z1=LEN(ZR$):Z2=ZS%(ZA,2)
520 FOR Z4=1 TO Z1:Z44#=Z4:IF Z1>12 THEN Z44#=1/Z44# 'better random spread if search string length is > 12. This is the major change in Version 3.1
522 Z0#=ASC(MID$(ZR$,Z4,1)):IF Z0#<>32 THEN Z0#=Z0#*Z44#:Z3#=Z3#+(Z0#*Z0#*Z0#) 'Skip blanks to reduce clumping in the random spread. See pages 3 & 4 of README.DOC
525 NEXT
530 Z2#=Z2:ZR=INT(Z3#-(Z2*(INT((Z3#-1)/Z2#)))):IF ZR<=0 THEN ZR=1
535 IF Z1<ZSIZE%(ZA,ZTESTFLD%) THEN ZR$=ZR$+STRING$((ZSIZE%(ZA,ZTESTFLD%)-Z1),32) 'pads blanks if necessary to make sure the search string is the proper length for testing in line 675
540 RETURN 'Version 4.02 converted many of the above variables to double precision (#) FOR MORE ACCURATE HASHING
550 '
600 ' ** SUBROUTINE TO DIRECT READ A DATA SET **
601 ' * Be sure that 'ZA'=the number of the desired set and ZR=the desired record number (from subroutine at 500). If a master is being read ZR$=the search item value. Y$(X,ZA) returned with the data.
605 ZZ=0:YZ=0:Z1=ZR ' when this subroutine is called from 800 or 1300 subroutines then ZZ will=1 and return will be at 665.
610 YR=ZR:Y1=1:ZTESTFLD%=ZS%(ZA,10):IF ZS%(ZA,5)=1 AND YZ=1 THEN YZ=0:RETURN 'ZS%(ZA,10) was specified by you during definition as the search field. Also see line 505
*10 615 IF ZS%(ZA,5)=1 THEN Y1=1:GOTO 630
*10 620 FOR Y2=1 TO ZS%(ZA,5):IF ZR >= ZT%(ZA,Y2,1) AND ZR <= ZT%(ZA,Y2,2) THEN Y1=Y2 : Y2=ZS%(ZA,5) 'locate correct file buffer for record ZR when file spans more than 1 disk drive
*10 622 NEXT 'Y2
*10 625 YR=ZR-ZT%(ZA,Y1,1)+1:IF YZ=1 THEN YZ=0:RETURN
630 GET ZT%(ZA,Y1,4),YR
635 ZV=0 ' ZV=0 if record found and ZV=1 if record not found
650 ZL$=Y$(ZTESTFLD%,ZA)
*23 660 IF ZS%(ZA,1)=2 THEN ZB=VAL(ZB$(ZA)):ZF=VAL(ZF$(ZA))
665 IF ZS%(ZA,1)=1 THEN ZC=VAL(ZC$(ZA)):ZP=VAL(ZP$(ZA)):ZN=VAL(ZNEXT$(ZA))
*23 666 IF ZS%(ZA,1)=1 AND ZS%(ZA,4)>0 THEN FOR Y24=1 TO ZS%(ZA,4):ZH(Y24)=VAL(ZH$(ZA,Y24)):ZE(Y24)=VAL(ZE$(ZA,Y24)):NEXT 'Y24
670 ' ** If a Detail data set, ZB=the backward pointer and ZF=the forward pointer. If a Master, ZC=number of secondary Masters, ZP=previous secondary pointer, ZN=next secondary Master rec # pointer.
671 ' ** With a Master, ZH(X)=the chain head of the Xth Detail set chain and ZE(X)=the chain end of the Xth chain.
*23 672 IF ZS%(ZA,1)=2 THEN RETURN 'need no further info for a detail set.
673 IF ZR$=STRING$(ZSIZE%(ZA,ZTESTFLD%),32) OR ZZ=1 THEN ZZ=0:RETURN 'it's a Master but, no test for search item is desired.
674 ' ** TEST FOR SEARCH ITEM **"
675 IF ZL$=ZR$ THEN RETURN 'Found it! If you are having trouble finding a match, see line 535. your string lengths must be the same.
680 IF ZN=0 THEN IF NOMSG%=0 THEN BEEP:COLOR COLA%(4),0:PRINT "No Master for ";ZR$;" in the data base.":COLOR 7,0:ZV=1:RETURN ELSE ZV=1:RETURN
685 ZR=ZN:GOTO 610 ' look at the next secondary master
695 '
*24 1500 ' ** SUBROUTINE TO CREATE ZI$(ZA,X) FROM Y$(ZA,X) **
*24 1510 ' ** ZA MUST=THE NUMBER OF THE DATA SET
*24 1520 FOR Z1=1 TO ZS%(Z1,7) : ZI$(ZA,Z1)=Y$(ZA,Z1) : NEXT 'Z1
*24 1530 RETURN
*24 1540 '
*24 2000 ' *******MAIN PROGRAM******
*25
700 ' ** SUBROUTINE TO UP-DATE OR CREATE A RECORD USING Y$(X,ZA) BUFFER **
701 ' ** Be sure that 'ZA'=The number of the data set and ZR=the desired record number
*10 705 YZ=1:GOSUB 610 'for multi-disc files GOSUB 610 to get the file record numbers
*26 710 IF ZS%(ZA,1)=1 THEN RSET ZC$(ZA)=MID$(STR$(ZC),2):RSET ZP$(ZA)=MID$(STR$(ZP),2):RSET ZNEXT$(ZA)=MID$(STR$(ZN),2)
*27 :IF ZS%(ZA,4)>0 THEN FOR Y24=1 TO ZS%(ZA,4):RSET ZH$(ZA,Y24)=MID$(STR$(ZH(Y24)),2):RSET ZE$(ZA,Y24)=MID$(STR$(ZE(Y24)),2):NEXT 'Y24
*59 :IF ZS%(ZA,4)>0 THEN FOR Y24=1 TO ZS%(ZA,4):RSET ZH$(ZA,Y24)=MID$(STR$(ZH(Y24)),2):RSET ZE$(ZA,Y24)=MID$(STR$(ZE(Y24)),2):NEXT 'Y24
*23 720 IF ZS%(ZA,1)=2 THEN RSET ZB$(ZA)=MID$(STR$(ZB),2):RSET ZF$(ZA)=MID$(STR$(ZF),2)
730 ' The data must be in Y$(X,ZA)
740 PUT ZT%(ZA,Y1,4), ZR:RETURN 'write the record
750 ' ** SUBROUTINE TO UP-DATE OR CREATE A RECORD USING ZI$(X) VARIABLES **
751 ' ** Be sure that 'ZA'=the number of the data set and ZR=the desired record number and that ZI$(X,ZA)=the data
*10 755 YZ=1:GOSUB 610 'for multi-disc files GOSUB 610 to get the file and record numbers
*26 760 IF ZS%(ZA,1)=1 THEN RSET ZC$(ZA)=MID$(STR$(ZC),2):RSET ZP$(ZA)=MID$(STR$(ZP),2):RSET ZNEXT$(ZA)=MID$(STR$(ZN),2)
*27 :IF ZS%(ZA,4)>0 THEN FOR Y24=1 TO ZS%(ZA,4):RSET ZH$(ZA,Y24)=MID$(STR$(ZH(Y24)),2):RSET ZE$(ZA,Y24)=MID$(STR$(ZE(Y24)),2):NEXT 'Y24
*59 :IF ZS%(ZA,4)>0 THEN FOR Y24=1 TO ZS%(ZA,4):RSET ZH$(ZA,Y24)=MID$(STR$(ZHC(Y24)),2):RSET ZE$(ZA,Y24)=MID$(STR$(ZEC(Y24)),2):NEXT 'Y24
*23 770 IF ZS%(ZA,1)=2 THEN RSET ZB$(ZA)=MID$(STR$(ZB),2):RSET ZF$(ZA)=MID$(STR$(ZF),2)
780 FOR Y24=1 TO ZS%(ZA,7):LSET Y$(Y24,ZA)=ZI$(Y24,ZA):NEXT 'Y24
790 PUT ZT%(ZA,Y1,4), ZR:RETURN 'write the record
800 ' ** SUBROUTINE TO CREATE A NEW MASTER DATA SET **
801 ' ** Be sure that 'ZA'=the number of the data set, ZR$=the search item, ZI$(X)=the new data variables **
805 GOSUB 500:ZZ=1 ' ZR now=the calculated record # in 'ZA' and with ZZ=1 any calls to subroutine at 610 will return from 665.
810 GOSUB 610 ' check record to see if record already exists at this calculated location.
820 IF ZL$ <> STRING$(ZSIZE%(ZA,ZTESTFLD%),32) THEN 880 ' if ZL$=blank then no Master exists at this location
825 ZC=1:ZP=0:ZN=0 ' set header variables
*23 830 IF ZS%(ZA,4)=0 OR ZCLONEIN%=1 THEN GOTO 840 'ZCLONEIN% used by Resize Data Base program that you get when you register
*23 835 FOR ZI=1 TO ZS%(ZA,4):ZH(ZI)=0:ZE(ZI)=0:NEXT
840 GOSUB 750 ' create the record
850 ZS%(ZA,6)=ZS%(ZA,6)+1:ZCHGFLAG(ZA)=1 'bump number of records and set the change flag
*12 852 IF ZS%(ZA,1)=1 AND ZFOPEN<>ZA THEN CLOSE ZQ+1:ZF$=CHR$(64+ZT%(ZA,1,3))+":"+LEFT$(ZS$(ZA,1),(LEN(ZS$(ZA,1))-4))+".SRT":OPEN ZF$ FOR APPEND AS ZQ+1:ZFOPEN=ZA 'open the sort key file
*13 852 IF ZS%(ZA,1)=1 AND ZFOPEN<>ZA THEN CLOSE ZQ+1:ZF$=LEFT$(ZS$(ZA,1),(LEN(ZS$(ZA,1))-4))+".SRT":OPEN ZF$ FOR APPEND AS ZQ+1:ZFOPEN=ZA 'open the sort key file
854 WRITE #ZQ+1,ZR 'append the newly created record # to the report sort file
860 RETURN
880 ' ** RECORD ALREADY EXISTS AT THE CALCULATED LOCATION **
885 IF ZL$=ZR$ THEN BEEP:LOCATE 25,1,0:COLOR 15,0:PRINT ZR$;" Already in the data base - Strike any key to continue";:COLOR 7,0:ZQ$=INPUT$(1):ZV=2:RETURN
890 IF ZC=0 GOTO 950 ' if ZC>=1 then we are at the head of a master chain
900 GOSUB 1800:IF ZV>0 THEN RETURN ELSE ZZ=1:GOSUB 610 ' Z1 will= a vacant record number
905 IF ZC>1 GOTO 920 'if ZC=1 then there are no present secondary masters
910 ZC=2:ZN=Z1:GOSUB 700 ' update the pointers on the chain head Master
*23 915 ZC=0:ZP=ZR:ZN=0:ZR=Z1:GOTO 830 ' set header variables, GOTO 830 to create the new Master
*28 915 ZC=0:ZP=ZR:ZN=0:ZR=Z1:GOTO 840 ' set header variables, GOTO 840 to create the new Master
920 Z2=ZR:ZR=ZN ' we got here from 905 when there are already secondary Masters
925 ZZ=1:GOSUB 610:IF ZL$=ZR$ THEN BEEP:LOCATE 25,1,0:COLOR 15,0:PRINT ZR$;" Already exists in the data base - Strike any key to continue";:COLOR 7,0:ZQ$=INPUT$(1):ZV=2:RETURN
930 IF ZN=0 GOTO 940
935 ZR=ZN:GOTO 925 ' read the next secondary Master
940 ZN=Z1:Z3=ZR:GOSUB 700:ZR=Z2:ZZ=1:GOSUB 610:ZC=ZC+1:GOSUB 700 ' set the pointers on the former last record in the chain and on the head Master record.
*23 945 ZR=Z1:ZN=0:ZP=Z3:ZC=0:GOTO 830 ' create the new Master at 830
*28 945 ZR=Z1:ZN=0:ZP=Z3:ZC=0:GOTO 840 ' create the new Master at 840
950 GOSUB 1800:IF ZV>0 THEN RETURN ELSE ZZ=1:GOSUB 610:Z2=ZR:ZR=Z1:GOSUB 700 ' read secondary Master at calculated position, find a new vacant record and xfer the secondary Master to it.
955 Z1=ZR:ZR=ZP:Z3=ZN:ZZ=1:GOSUB 610:ZN=Z1:GOSUB 700 ' read and reset pointers of the previous record for the secondary we just moved
960 IF Z3=0 GOTO 970
965 ZR=Z3:ZZ=1:GOSUB 610:ZP=Z1:GOSUB 700 ' reset the pointers on the next record in the chain of the secondary that we just moved
970 ZR=Z2:ZC=0:ZP=0:ZN=0:GOTO 825 ' set ZR back to the calculated value then GOTO 825 to create the new Master chain head
975 '
*29
1000 ' ** SUBROUTINE TO CREATE A DETAIL DATA SET **"
1001 ' ** ZR$ must= the search item of the Detail's Master so the chain head and end of the Detail chain can be updated
1002 ' ** It is assumed that the chain head Master has already been read as ZR. ZM=Master set num, ZS=Detail set num. Save ZR as YM **
1010 YM=ZR:ZA=ZS
1020 Z6=0
|1025 FOR ZI=2 TO |09
|1030 IF ZS$(ZM,ZI)=ZS$(ZS,1) THEN Z6=ZI-1:ZI=|09
1035 NEXT:IF Z6=0 THEN BEEP:PRINT ZS$(ZS,1);" DOES NOT MATCH ";ZS$(ZM,1):PRINT "PROGRAMMING ERROR":GOTO 400 ' Z6=which Detail set for the Master
1040 Z7=ZH(Z6):Z8=ZE(Z6) ' save the existing chain head and end pointers from the Master
1050 IF ZS%(ZS,1)<>2 THEN BEEP:PRINT "PROGRAMMING ERROR-";ZS$(ZS,1);" ISN'T A DETAIL SET.":GOTO 400
1060 Z1=ZS%(ZS,8):IF Z1=0 THEN BEEP:LOCATE 25,15,0:COLOR 15,0:PRINT "THIS DATA SET IS FULL - Strike any key to continue";:COLOR 7,0:YQ$=INPUT$(1):RETURN
1100 Z2=ZR:ZR=Z1:ZZ=1:GOSUB 610:ZS%(ZS,8)=ZF:ZR=Z2 ' read the new Detail to get the pointer to the next vacant Detail for future reference in ZS%(ZS,8)
1125 Z2=ZE(Z6):ZE(Z6)=Z1:ZA=ZM:ZR=YM:GOSUB 700:ZR=Z2 ' set new chain end in Master
1130 ZA=ZS:ZZ=1:GOSUB 610
1135 ZF=Z1:GOSUB 700:ZB=Z2 ' set forward pointer for previous chain end data set
1140 ZA=ZS:ZF=0:ZR=Z1:GOSUB 750 ' write new Detail record
1145 ZS%(ZA,6)=ZS%(ZA,6)+1 ' add 1 to the active records count
1150 ZR=YM:RETURN
1160 '
1200 ' ** DELETE A MASTER RECORD **
1201 ' ** ZA must=# of the set, ZR$ must=value of search item. It is assumed that the record has been read
1205 Y4=ZR:IF ZC=0 THEN GOSUB 500:Y5=ZR
*23 1210 IF ZS%(ZA,4)=0 GOTO 1220
*23 1213 FOR ZI=1 TO ZS%(ZA,4):IF ZH(ZI)<>0 OR ZE(ZI)<>0 THEN BEEP:LOCATE 25,1,0:COLOR 15,0:PRINT "CAN'T DELETE THIS MASTER RECORD AS IT STILL HAS DETAIL DATA. - Strike any key";:COLOR 7,0:ZQ$=INPUT$(1):ZV=1:RETURN
*23 1215 NEXT
1220 IF ZC=0 GOTO 1240 ' ZC=0 if it is a secondary Master
1225 IF ZC>1 GOTO 1280 ' if ZC>1 then there are secondary Masters to deal with
1230 FOR Y11=1 TO ZS%(ZA,7):ZI$(Y11,ZA)=STRING$(ZSIZE%(ZA,Y11),32):NEXT Y11:ZC=0:ZP=0:ZN=0:GOSUB 750:ZS%(ZA,6)=ZS%(ZA,6)-1:ZCHGFLAG(ZA)=1 'set fields blank, update record, subtract 1 from number of records assigned, set change flag
1235 RETURN
1240 Y2=ZP:Y3=ZN:ZR=Y2:ZZ=1:GOSUB 610:ZN=Y3:IF Y2=Y5 THEN ZC=ZC-1
1245 GOSUB 700 ' reset the pointers on the previous record
1250 IF Y3<>0 THEN ZR=Y3:ZZ=1:GOSUB 610:ZP=Y2:GOSUB 700 ' reset pointers in next record
1255 IF Y2<>Y5 THEN ZR=Y5:ZZ=1:GOSUB 610:ZC=ZC-1:GOSUB 700 ' reset the number of Masters in the chain head
1260 ZR=Y4:GOTO 1230
1280 Y2=ZR:ZR=ZN:Y9=ZN:ZX=ZC:ZZ=1:GOSUB 610:Y3=ZN 'we are removing the chain head that has secondary masters. thus, we move the 1st secondary to the chain head record number
1285 ZC=ZX-1:ZP=0:ZR=Y2:GOSUB 700 'this moved the 1st secondary Master to the chain head
1290 IF Y3<>0 THEN ZR=Y3:ZZ=1:GOSUB 610:ZP=Y2:GOSUB 700 'reset pointer on next record
1295 ZR=Y9:GOTO 1230
*30
1300 ' ** DELETE A DETAIL RECORD **"
1301 ' ** assumes that YS=the record number of the Detail record that has previously been read (in ZS), and that YM=the record number of the associated Master record (in ZM).
1305 ZA=ZS:Z1=YS
1310 FOR Y11=1 TO ZS%(ZA,7):ZI$(Y11,ZA)=STRING$(ZSIZE%(ZA,Y11),32):NEXT Y11:Z2=ZF:ZF=ZS%(ZA,8):Z3=ZB:ZB=0:GOSUB 750:ZS%(ZA,8)=YS:ZS%(ZA,6)=ZS%(ZA,6)-1
1311 ' set the record to blanks, save the record # in ZS%(ZA,8) & set forward pointer to next vacant record
1315 IF Z3=0 THEN GOTO 1340
1325 ZR=Z3:ZZ=1:GOSUB 610 'read the previous record in the chain
1330 ZF=Z2:GOSUB 700 'up-date the forward pointer in the previous record in the detail chain
1340 IF Z2=0 THEN GOTO 1360
1345 ZR=Z2:ZZ=1:GOSUB 610 'read the next record in the Detail chain
1350 ZB=Z3:GOSUB 700 'up-date the backward pointer in the next record in the chain
1360 ' up-date the associated Master if necessary
1365 IF Z2<>0 AND Z3<>0 THEN RETURN ' the deleted Detail was in the middle of a detail chain
1370 ZA=ZM:ZR=YM:ZZ=1:GOSUB 610 'read the associated Master
1375 Z6=0:FOR ZI=2 TO ZS%(ZA,4)+1:IF ZS$(ZM,ZI)=ZS$(ZS,1) THEN Z6=ZI-1:ZI=ZS%(ZA,4)+1
1380 NEXT:IF Z3=0 THEN ZH(Z6)=Z2
1385 IF Z2=0 THEN ZE(Z6)=Z3
1390 GOSUB 700:RETURN 'up-date the chain head and chain ends if the associated Master"
1395 '
1500 ' ** SUBROUTINE TO CREATE ZI$(X) FROM Y$(X) **
1510 ' ** ZA must=the number of the data set
1520 FOR Z1=1 TO ZS%(ZA,7):ZI$(Z1,ZA)=Y$(Z1,ZA):NEXT 'Z1
1530 RETURN
1540 '
1800 ' ** SUBROUTINE TO LOCATE A VACANT MASTER RECORD **
1810 Z1=ZR:Z2=ZR:ZV=0:IF ZS%(ZA,6)=ZS%(ZA,2) THEN BEEP:LOCATE 25,15,0:COLOR 15,0:PRINT "DATA SET ";ZS$(ZA,1);" IS FULL - Strike any key to continue";:COLOR 7,0:ZQ$=INPUT$(1):ZV=1:RETURN
1820 Z1=Z1-1:IF Z1=0 THEN Z1=ZS%(ZA,2) 'search downward for a vacant record
1830 ZZ=1:ZR=Z1:GOSUB 610:IF ZL$ <> STRING$(ZSIZE%(ZA,ZTESTFLD%),32) THEN 1820 'read the lower record and check for blank search field
1840 ZR=Z2 'found a blank record
1850 RETURN
1860 '
1981 ' ** THE MAIN PROGRAM FOLLOWS **
1982 ' ** THE FOLLOWING SUBROUTINES CAN BE CALLED **
1983 ' 500 - TO CALCULATE A RECORD NUMBER
1984 ' 600 - TO DIRECT READ A RECORD
1985 ' 700 - TO UPDATE A RECORD USING Y$(X) BUFFER
1986 ' 750 - TO UPDATE A RECORD USING ZI$(X) BUFFER
1987 ' 800 - TO CREATE A NEW MASTER
*23 1988 ' 1000 - TO CREATE A NEW DETAIL DATA SET
1989 ' 1200 - TO DELETE A MASTER RECORD
*23 1990 ' 1300 - TO DELETE A DETAIL RECORD
1991 ' 1500 - TO CREATE ZI$(X) FROM Y$(X) BUFFER
1995 ' 1800 - TO LOCATE A VACANT RECORD
2000 ' *******MAIN PROGRAM******
*31 this line indicates end of .SRC file - do NOT remove it. Copyright 1987 by PRO DEV Software
