|2010 CLS:TITLE$="|14":PRINT TAB(21);"PDS*BASE Data Base Report Program For":PRINT:PRINT TAB(INT((80-LEN(TITLE$))/2));TITLE$:PRINT:PRINT
|2020 DIM YA$(|12),YA%(|12,2),ZS9(|13,1)
|2030 ZPASS=1:ZF$="|15":ZA=|16
2040 ON ERROR GOTO 2090
2050 PRINT:PRINT "Reading sort keys from file ";ZF$:OPEN ZF$ FOR INPUT AS ZQ+1:IF ZPASS=1 THEN INPUT #ZQ+1, ZTDATE$,ZTTIME$:INPUT #ZQ+1, Z5
|2060 IF ZPASS=1 THEN IF Z5<>ZS%(|16,6) THEN BEEP:PRINT "The number of records in the key file doesn't = Number of records in data base":PRINT:CLOSE #ZQ+1:GOTO 2110
2070 IF ZPASS=1 THEN IF ZDATE$(ZA)<>ZTDATE$ OR ZTIME$(ZA)<>ZTTIME$ THEN BEEP:PRINT "Date & Time for the key file doesn't=Date & Time in the data base":PRINT:CLOSE #ZQ+1:GOTO 2110
2080 ON ERROR GOTO 0:GOTO 2120
2090 RESUME 2100
*39 2100 IF ZPASS=2 THEN 2110 ELSE ZF$=CHR$(ZT%(ZA,1,3)+64)+":"+LEFT$(ZS$(ZA,1),(LEN(ZS$(ZA,1))-4))+".SRT":ZPASS=2:GOTO 2050
*40 2100 IF ZPASS=2 THEN 2110 ELSE ZF$=LEFT$(ZS$(ZA,1),(LEN(ZS$(ZA,1))-4))+".SRT":ZPASS=2:GOTO 2050
*41 2105 RESUME 2110
*42 2110 ON ERROR GOTO 0:GOTO 2150
*41 2110 PRINT "The sort key file can not be used - Run the sort program again.":GOTO 400
*42 2120 ZZ5=0 'read the sort key file
*42 2130 WHILE NOT EOF(ZQ+1):ZZ5=ZZ5+1:INPUT #ZQ+1, YA%(ZZ5,2):WEND 'read the live record numbers
*42 2140 CLOSE #ZQ+1:IF ZZ5=ZS%(ZA,6) THEN IF ZPASS=1 THEN 2400 'the number of records in the sort key file may be larger if a master was deleted and re-created in the same dated session
*42 |2150 PRINT:PRINT "The data base must be re-sorted.":PRINT:PRINT "The sort keys are being loaded from the '";ZS$(|16,1);"' file.":Z5=0:ZA=|16:PRINT:PRINT
*42 2160 ZJJ=ZS%(ZA,2):IF ZPASS=2 AND ZZ5=ZS%(ZA,6) THEN ZJJ=ZZ5
*42 2170 FOR ZJ=1 TO ZJJ
*42 2180 IF ZZ5=ZS%(ZA,6) AND ZPASS=2 THEN ZR=YA%(ZJ,2) ELSE ZR=ZJ
*42 2190 ZZ=1:GOSUB 610
*42 |2200 IF ZL$<>STRING$(ZSIZE%(|16,|17),32) THEN Z5=Z5+1:YA$(Z5)=|22:YA%(Z5,1)=Z5:YA%(Z5,2)=ZR:LOCATE ,10:PRINT ZR,ZL$;
*42 2210 NEXT 'ZJ
*42 |2220 ZREPTFLAG=0:IF Z5<> ZS%(|16,6) THEN ZS%(|16,6)=Z5:ZREPTFLAG=1 ' correct records assigned and set flags to correct the housekeeping record on closing the data base.
*42 2230 BEEP:PRINT "There will be a file sort delay.":PRINT:PRINT
*42 2240 ZZT$=TIME$:ZT1=(VAL(LEFT$(ZZT$,2))*3600)+(VAL(MID$(ZZT$,4,2))*60)+(VAL(RIGHT$(ZZT$,2)))
*42 2250 ZI1=1:ZJ1=Z5:ZP=0
*42 2260 ZI=ZI1:ZJ=ZJ1
*42 2270 IF YA$(YA%(ZI,1))>YA$(YA%(ZJ,1)) THEN SWAP YA%(ZI,1),YA%(ZJ,1):SWAP YA%(ZI,2),YA%(ZJ,2):ZZS%=ABS(ZZS%-1)
*42 2280 ZI=ZI+ZZS%:ZJ=ZJ-(1-ZZS%):IF ZI<ZJ THEN 2270
*42 2290 IF ZI+1<ZJ1 THEN ZP=ZP+1:ZS9(ZP,0)=ZI+1:ZS9(ZP,1)=ZJ1
*42 2300 ZJ1=ZI-1:IF ZI1<ZJ1 THEN 2260
*42 2310 IF ZJ>0 THEN LOCATE ,1,1:PRINT YA$(YA%(ZJ,1)); 'remove this warm fuzzy line to speed up sort
*42 2320 IF ZP THEN ZI1=ZS9(ZP,0):ZJ1=ZS9(ZP,1):ZP=ZP-1:GOTO 2260
*42 2330 ZZT$=TIME$:ZT2=(VAL(LEFT$(ZZT$,2))*3600)+(VAL(MID$(ZZT$,4,2))*60)+(VAL(RIGHT$(ZZT$,2))):PRINT:PRINT
*42 2340 BEEP:ZT3=ZT2-ZT1:IF ZT3 < 120 THEN PRINT "Elapsed time=";ZT3;" seconds" ELSE PRINT "Elapsed time =";INT(ZT3/60);" minutes ";INT( ( (ZT3/60)-INT(ZT3/60) ) * 60 );" seconds"
*42 |2350 ZPASS=1:ZF$="|15"
*42 2360 OPEN ZF$ FOR OUTPUT AS ZQ+1:IF ZPASS=1 THEN WRITE #ZQ+1,ZDATE$(ZA);ZTIME$(ZA):PRINT #ZQ+1,Z5
*42 2370 FOR ZI=1 TO Z5:PRINT #ZQ+1,YA%(ZI,2):NEXT 'ZI
*42 2380 CLOSE #ZQ+1
*39 2390 IF ZPASS=2 THEN 2400 ELSE ZF$=CHR$(ZT%(ZA,1,3)+64)+":"+LEFT$(ZS$(ZA,1),(LEN(ZS$(ZA,1))-4))+".SRT":ZPASS=2:GOTO 2360
*40 2390 IF ZPASS=2 THEN 2400 ELSE ZF$=LEFT$(ZS$(ZA,1),(LEN(ZS$(ZA,1))-4))+".SRT":ZPASS=2:GOTO 2360
2400 '****** WRITE THE REPORT ******
*43 2410 PRINT:PRINT "Enter the date (Return = Today) ? ";:LINE INPUT;ZD$:IF ZD$="" THEN ZD$=DATE$:PRINT ZD$:PRINT ELSE PRINT:PRINT
2412 ZNLQ$="Y"
*46 2413 ZNLQ$="N"  'Many printers do not handle NLQ and Compressed at the same time
2414 PRINT "Turn on Near Letter Quality ";:COLOR 0,7:PRINT ZNLQ$;:LOCATE ,POS(0)-1:QA$="":WHILE QA$="":QA$=INKEY$:WEND:IF ASC(QA$) > 96 THEN QA$=CHR$(ASC(QA$)-32) 'convert to upper case
2415 IF ASC(QA$)=13 THEN QA$=ZNLQ$
2416 PRINT QA$;:COLOR 7,0:PRINT:ZNLQ$=QA$
2420 PRINT:PRINT "Turn on the printer - Strike (gently) any key when ready":QA$=INPUT$(1):PRINT QA$
|2430 YP=0:ZL=|21 + 5 'page and line counters"
|2440 DIM YT%(|18,10),YT$(|18),YR$(|18),ZFORM$(|18)
*59 |2445 DIM GROUPTOTAL#(|18),GRANDTOTAL#(|18),ZTOTZFORM$(|18)
*23 |2450 DIM YH%(|02,|04),YE%(|02,|04)
|2460 FOR ZI=1 TO |18:FOR ZJ=1 TO 10:READ YT%(ZI,ZJ):NEXT ZJ:READ ZFORM$(ZI):IF YT%(ZI,5)<>999 THEN YT$(ZI)=STRING$(YT%(ZI,6)-YT%(ZI,5)+1,32) 'set size of YT$ to allow LSET in lines 2610 & 2630 to prevent garbage collection
2470 NEXT 'ZI
2480 ' YT%(X,Y) X=Field on report, Y=1 is file number, 2=field in that file, 3=lead to file, 4=lead to field, 5=starting tab, 6=ending tab
2490 ' 7=justification code (1=left, 2=right, 3=center), 8=Detail fld action code (1=1st Detail, 2=last, 3=all)
2500 ' 9=Associated Master if this is a Detail OR =99 IF Group Total Reqired IF Master, 10=Which Detail set for this Detail's Master
2510 ' ZFORM$ will contain the format string to be used in the print using statements
*44
2570 YL$="":ZA=0
*59 2575 FIRSTRECORD%=1:TYPETOTAL$="   Sub "
*45 2580 WIDTH "LPT1:",254 'Set up more than 80 columns
|2590 IF ZNLQ$ = "Y" THEN LPRINT |26 'Turn on Near Letter Quality printing - remove this line for faster draft quality
*46 |2595 LPRINT |19 'Set up compressed printing.
2600 FOR ZI=1 TO Z5 'loop for each record in the sort file
|2610 YF=0:MOREDETAIL%=0:YJ=1:FOR ZJ=1 TO |18:LSET YT$(ZJ)=" ":NEXT 'ZJ  LSET is used to reuse memory locations and prevent garbage collection
|2620 FOR ZJ=YJ TO |18 'loop for each field in the report
2630 IF ZJ=1 THEN ZZ=1:ZA=YT%(1,1):ZR=YA%(ZI,2):GOSUB 610:LSET YT$(1)=Y$(YT%(1,2),ZA):GOTO 2680 'read the record for the first field
*47 2640 IF ZS%(YT%(ZJ,1),1)=2 GOTO 2700
2650 IF ZA=YT%(ZJ,1) THEN LSET YT$(ZJ)=Y$(YT%(ZJ,2),ZA):GOTO 2830 'additional field in the same master
2660 IF ZA<>YT%(ZJ,1) AND ZS%(YT%(ZJ,1),1)=1 AND YR$(ZJ)=STRING$(YT%(ZJ,4),32) THEN GOTO 2830 'skip the new field if the field leading to it was blank
2670 IF ZA<>YT%(ZJ,1) AND ZS%(YT%(ZJ,1),1)=1 THEN ZA=YT%(ZJ,1):ZR$=YR$(ZJ):GOSUB 500:GOSUB 600:LSET YT$(ZJ)=Y$(YT%(ZJ,2),ZA) 'field in a different master
*47 2680 IF ZS%(ZA,4)>0 THEN FOR ZK=1 TO ZS%(ZA,4):YH%(ZA,ZK)=ZH(ZK):YE%(ZA,ZK)=ZE(ZK):NEXT 'ZK  store the chain head and ends for this master record
*48 2680 REM continuation line - do not remove
*47 2690 GOTO 2800
*47 2700 'handle the detail record DO NOT remove this REM line
*47 2710 IF YT%(ZJ,1) = YT%(ZJ-1,1) THEN GOTO 2800
*47 2720 ZR=0:ZA=YT%(ZJ,1)
*47 2730 IF YF>0 THEN ZR=YF:GOTO 2760
*47 2740 IF YT%(ZJ,8)<>2 THEN ZR=YH%(YT%(ZJ,9),YT%(ZJ,10))
*47 2750 IF YT%(ZJ,8)=2 THEN ZR=YE%(YT%(ZJ,9),YT%(ZJ,10))
*47 2760 IF ZR>0 THEN ZZ=1:GOSUB 610 'read the 1st, last or next detail record
*47 |2770 IF ZR=0 THEN ZJ=|18:GOTO 2830 'Skip remaining report fields if no Details for this Master
*47 2780 IF YT%(ZJ,8)=3 AND ZF>0 THEN MOREDETAIL%=1
*47 2790 IF MOREDETAIL%=1 THEN IF ZF>0 THEN YJ=ZJ:YF=ZF ELSE YF=0 'set up to read additional details
*47 2800 IF YT%(ZJ,5)<>999 THEN LSET YT$(ZJ)=Y$(YT%(ZJ,2),ZA)
|2810 FOR Z1=1 TO |18:IF ZA=YT%(Z1,3) THEN YR$(Z1)=Y$(YT%(Z1,4),ZA) 'set up future field search value
2820 NEXT 'Z1
2830 NEXT 'ZJ
2840 GOSUB 2900 'print line
2850 IF YF>0 THEN GOTO 2620 'repeat for additional Details
2860 NEXT 'ZI
*59 |2861 GOSUB 5000:FOR ZJ=1 TO |18:GROUPTOTAL#(ZJ)=GRANDTOTAL#(ZJ):NEXT:TYPETOTAL$="  Grand ":GOSUB 5000
*46 |2862 LPRINT |20 'Shut off compressed printing
|2865 LPRINT |27 'Turn off Near Letter Quality printing - remove this line if if you removed LINE 2595
*55 2870 LPRINT CHR$(12) 'Form feed
2880 'all done"
2890 GOTO 400
2900 '***** PRINT LINE SUBROUTINE *****
*55 |2910 IF ZL > |21 THEN GOSUB 4500 'page head if necessary
|2920 FOR ZJ=1 TO |18 'check justification for each field
2930 IF YT%(ZJ,5)=999 GOTO 3050 'invisible report field
2940 IF YT%(ZJ,7)>1 THEN 2980
2950 IF LEFT$(YT$(ZJ),1)<>" " THEN 3050 ' already left justified
2960 Z3=1:FOR ZK=1 TO YT%(ZJ,4)-1:IF MID$(YT$(ZJ),ZK,1)<>" " THEN Z3=ZK:ZK=YT%(ZJ,4)-1
2970 NEXT ZK:LSET YT$(ZJ)=MID$(YT$(ZJ),Z3):GOTO 3050 'moves the stuff left
2980 IF YT%(ZJ,7)>2 THEN 3020 'right justify for code 2
2990 IF RIGHT$(YT$(ZJ),1)<>" " THEN 3050 'already right justified
3000 Z3=1:FOR ZK=LEN(YT$(ZJ)) TO 1 STEP -1:IF MID$(YT$(ZJ),ZK,1)<>" " THEN Z3=ZK:ZK=1
3010 NEXT ZK:RSET YT$(ZJ)=MID$(YT$(ZJ),1,Z3):GOTO 3050 'moves stuff right
3020 IF LEFT$(YT$(ZJ),1) <> " " AND RIGHT$(YT$(ZJ),1) <> " " THEN 3050 'Can't center justify as the field is filled
3030 Z3=1:FOR ZK=LEN(YT$(ZJ)) TO 1 STEP -1:IF MID$(YT$(ZJ),ZK,1)<>" " THEN Z3=ZK:ZK=1
3040 NEXT ZK:LSET YT$(ZJ)=STRING$(INT((Z3-1)/2),32)+MID$(YT$(ZJ),1) 'centers stuff
3050 NEXT 'ZJ
*60 |3060 IF GROUPTEST$ <> YT$(|32) THEN GOSUB 5000
*59 |3070 FOR ZJ=1 TO |18:IF YT%(ZJ,9) <> 99 THEN GOTO 3090
*59 3080 GROUPTOTAL#(ZJ)=GROUPTOTAL#(ZJ)+VAL(YT$(ZJ)):GRANDTOTAL#(ZJ)=GRANDTOTAL#(ZJ)+VAL(YT$(ZJ))
*59 3090 NEXT 'ZJ
*50
3300 LPRINT:ZL=ZL+1 ' print blank line before next record - remove this line if you wish to single space
3310 RETURN
3320 'If you wish to change the order that the fields are printed, just change the order of the above line numbers and modify the following collumn heading starting in line 4535
*55 4500 '***** PAGE HEADING SUBROUTINE *****
*55 4520 IF ZI>1 THEN LPRINT CHR$(12) 'form feed"
*43 4525 LPRINT ZD$;SPC(2);
*55 |4530 YP=YP+1:LPRINT TAB(INT((|31-LEN(TITLE$))/2));TITLE$;TAB(|31-8)"Page";YP:LPRINT
*49
*55 |4550 Dashes%=|24:IF Dashes%>0 THEN LPRINT STRING$(Dashes%,95):LPRINT ELSE LPRINT
*55 |4560 ZL=|23:RETURN
*59 5000 'Group Or Grand totals subroutine
*59 5010 WHILE FIRSTRECORD%=1
*60 |5020 GROUPTEST$=YT$(|32)
*59 |5030 FOR ZJ=1 TO |18
*59 5040 IF YT%(ZJ,9) <> 99 THEN GOTO 5070
*59 5050 M%=INSTR(ZFORM$(ZJ),",")
*59 5060 IF M%>0 THEN ZTOTFORM$(ZJ)="###,"+LEFT$("###",4-M%)+ZFORM$(ZJ) ELSE ZTOTFORM$(ZJ)="###"+ZFORM$(ZJ)
*59 5070 GRPTAB%(ZJ)=YT%(ZJ,6)-LEN(ZTOTFORM$(ZJ))+1:IF GRPTAB%(ZJ)<1 THEN GRPTAB%(ZJ)=1
*59 5080 NEXT
*59 5090 FIRSTRECORD%=0
*59 5100 RETURN
*59 5110 WEND
*59 |5120 IF ZL > |21 - 3 THEN GOSUB 4500 'page head if not enough room for group totals
*59 5130 P%=1
*59 |5140 FOR ZJ=1 TO |18
*59 5150 IF YT%(ZJ,9) <> 99 THEN GOTO 5180
*59 5160 IF P% > GRPTAB%(ZJ) THEN ZL=ZL+1
*59 5170 LPRINT TAB(GRPTAB%(ZJ));:LPRINT USING ZTOTFORM$(ZJ);GROUPTOTAL#(ZJ);:P%=GRPTAB%(ZJ)+LEN(ZTOTFORM$(ZJ))-1
*59 5180 GROUPTOTAL#(ZJ)=0
*59 5190 NEXT 'ZJ
*59 |5200 LPRINT TYPETOTAL$;"Total":LPRINT:ZL=ZL+2:GROUPTEST$=YT$(|32)
*59 5210 RETURN
*31 Copyright 1987 by PRO DEV Software
