home *** CD-ROM | disk | FTP | other *** search
/ Share Gallery 1 / share_gal_1.zip / share_gal_1 / DB / DB004A.ZIP / BASEPROG.EXE / lha / DBREPORT.SRC < prev    next >
Text File  |  1990-03-10  |  11KB  |  156 lines
  1. |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
  2. |2020 DIM YA$(|12),YA%(|12,2),ZS9(|13,1)
  3. |2030 ZPASS=1:ZF$="|15":ZA=|16
  4. 2040 ON ERROR GOTO 2090
  5. 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
  6. |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
  7. 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
  8. 2080 ON ERROR GOTO 0:GOTO 2120
  9. 2090 RESUME 2100
  10. *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
  11. *40 2100 IF ZPASS=2 THEN 2110 ELSE ZF$=LEFT$(ZS$(ZA,1),(LEN(ZS$(ZA,1))-4))+".SRT":ZPASS=2:GOTO 2050
  12. *41 2105 RESUME 2110
  13. *42 2110 ON ERROR GOTO 0:GOTO 2150
  14. *41 2110 PRINT "The sort key file can not be used - Run the sort program again.":GOTO 400
  15. *42 2120 ZZ5=0 'read the sort key file
  16. *42 2130 WHILE NOT EOF(ZQ+1):ZZ5=ZZ5+1:INPUT #ZQ+1, YA%(ZZ5,2):WEND 'read the live record numbers
  17. *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
  18. *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
  19. *42 2160 ZJJ=ZS%(ZA,2):IF ZPASS=2 AND ZZ5=ZS%(ZA,6) THEN ZJJ=ZZ5
  20. *42 2170 FOR ZJ=1 TO ZJJ
  21. *42 2180 IF ZZ5=ZS%(ZA,6) AND ZPASS=2 THEN ZR=YA%(ZJ,2) ELSE ZR=ZJ
  22. *42 2190 ZZ=1:GOSUB 610
  23. *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$;
  24. *42 2210 NEXT 'ZJ
  25. *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.
  26. *42 2230 BEEP:PRINT "There will be a file sort delay.":PRINT:PRINT
  27. *42 2240 ZZT$=TIME$:ZT1=(VAL(LEFT$(ZZT$,2))*3600)+(VAL(MID$(ZZT$,4,2))*60)+(VAL(RIGHT$(ZZT$,2)))
  28. *42 2250 ZI1=1:ZJ1=Z5:ZP=0
  29. *42 2260 ZI=ZI1:ZJ=ZJ1
  30. *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)
  31. *42 2280 ZI=ZI+ZZS%:ZJ=ZJ-(1-ZZS%):IF ZI<ZJ THEN 2270
  32. *42 2290 IF ZI+1<ZJ1 THEN ZP=ZP+1:ZS9(ZP,0)=ZI+1:ZS9(ZP,1)=ZJ1
  33. *42 2300 ZJ1=ZI-1:IF ZI1<ZJ1 THEN 2260
  34. *42 2310 IF ZJ>0 THEN LOCATE ,1,1:PRINT YA$(YA%(ZJ,1)); 'remove this warm fuzzy line to speed up sort
  35. *42 2320 IF ZP THEN ZI1=ZS9(ZP,0):ZJ1=ZS9(ZP,1):ZP=ZP-1:GOTO 2260
  36. *42 2330 ZZT$=TIME$:ZT2=(VAL(LEFT$(ZZT$,2))*3600)+(VAL(MID$(ZZT$,4,2))*60)+(VAL(RIGHT$(ZZT$,2))):PRINT:PRINT
  37. *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"
  38. *42 |2350 ZPASS=1:ZF$="|15"
  39. *42 2360 OPEN ZF$ FOR OUTPUT AS ZQ+1:IF ZPASS=1 THEN WRITE #ZQ+1,ZDATE$(ZA);ZTIME$(ZA):PRINT #ZQ+1,Z5
  40. *42 2370 FOR ZI=1 TO Z5:PRINT #ZQ+1,YA%(ZI,2):NEXT 'ZI
  41. *42 2380 CLOSE #ZQ+1
  42. *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
  43. *40 2390 IF ZPASS=2 THEN 2400 ELSE ZF$=LEFT$(ZS$(ZA,1),(LEN(ZS$(ZA,1))-4))+".SRT":ZPASS=2:GOTO 2360
  44. 2400 '****** WRITE THE REPORT ******
  45. *43 2410 PRINT:PRINT "Enter the date (Return = Today) ? ";:LINE INPUT;ZD$:IF ZD$="" THEN ZD$=DATE$:PRINT ZD$:PRINT ELSE PRINT:PRINT
  46. 2412 ZNLQ$="Y"
  47. *46 2413 ZNLQ$="N"  'Many printers do not handle NLQ and Compressed at the same time
  48. 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
  49. 2415 IF ASC(QA$)=13 THEN QA$=ZNLQ$
  50. 2416 PRINT QA$;:COLOR 7,0:PRINT:ZNLQ$=QA$
  51. 2420 PRINT:PRINT "Turn on the printer - Strike (gently) any key when ready":QA$=INPUT$(1):PRINT QA$
  52. |2430 YP=0:ZL=|21 + 5 'page and line counters"
  53. |2440 DIM YT%(|18,10),YT$(|18),YR$(|18),ZFORM$(|18)
  54. *59 |2445 DIM GROUPTOTAL#(|18),GRANDTOTAL#(|18),ZTOTZFORM$(|18)
  55. *23 |2450 DIM YH%(|02,|04),YE%(|02,|04)
  56. |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
  57. 2470 NEXT 'ZI
  58. 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
  59. 2490 ' 7=justification code (1=left, 2=right, 3=center), 8=Detail fld action code (1=1st Detail, 2=last, 3=all)
  60. 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
  61. 2510 ' ZFORM$ will contain the format string to be used in the print using statements
  62. *44
  63. 2570 YL$="":ZA=0
  64. *59 2575 FIRSTRECORD%=1:TYPETOTAL$="   Sub "
  65. *45 2580 WIDTH "LPT1:",254 'Set up more than 80 columns
  66. |2590 IF ZNLQ$ = "Y" THEN LPRINT |26 'Turn on Near Letter Quality printing - remove this line for faster draft quality
  67. *46 |2595 LPRINT |19 'Set up compressed printing.
  68. 2600 FOR ZI=1 TO Z5 'loop for each record in the sort file
  69. |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
  70. |2620 FOR ZJ=YJ TO |18 'loop for each field in the report
  71. 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
  72. *47 2640 IF ZS%(YT%(ZJ,1),1)=2 GOTO 2700
  73. 2650 IF ZA=YT%(ZJ,1) THEN LSET YT$(ZJ)=Y$(YT%(ZJ,2),ZA):GOTO 2830 'additional field in the same master
  74. 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
  75. 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
  76. *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
  77. *48 2680 REM continuation line - do not remove
  78. *47 2690 GOTO 2800
  79. *47 2700 'handle the detail record DO NOT remove this REM line
  80. *47 2710 IF YT%(ZJ,1) = YT%(ZJ-1,1) THEN GOTO 2800
  81. *47 2720 ZR=0:ZA=YT%(ZJ,1)
  82. *47 2730 IF YF>0 THEN ZR=YF:GOTO 2760
  83. *47 2740 IF YT%(ZJ,8)<>2 THEN ZR=YH%(YT%(ZJ,9),YT%(ZJ,10))
  84. *47 2750 IF YT%(ZJ,8)=2 THEN ZR=YE%(YT%(ZJ,9),YT%(ZJ,10))
  85. *47 2760 IF ZR>0 THEN ZZ=1:GOSUB 610 'read the 1st, last or next detail record
  86. *47 |2770 IF ZR=0 THEN ZJ=|18:GOTO 2830 'Skip remaining report fields if no Details for this Master
  87. *47 2780 IF YT%(ZJ,8)=3 AND ZF>0 THEN MOREDETAIL%=1
  88. *47 2790 IF MOREDETAIL%=1 THEN IF ZF>0 THEN YJ=ZJ:YF=ZF ELSE YF=0 'set up to read additional details
  89. *47 2800 IF YT%(ZJ,5)<>999 THEN LSET YT$(ZJ)=Y$(YT%(ZJ,2),ZA)
  90. |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
  91. 2820 NEXT 'Z1
  92. 2830 NEXT 'ZJ
  93. 2840 GOSUB 2900 'print line
  94. 2850 IF YF>0 THEN GOTO 2620 'repeat for additional Details
  95. 2860 NEXT 'ZI
  96. *59 |2861 GOSUB 5000:FOR ZJ=1 TO |18:GROUPTOTAL#(ZJ)=GRANDTOTAL#(ZJ):NEXT:TYPETOTAL$="  Grand ":GOSUB 5000
  97. *46 |2862 LPRINT |20 'Shut off compressed printing
  98. |2865 LPRINT |27 'Turn off Near Letter Quality printing - remove this line if if you removed LINE 2595
  99. *55 2870 LPRINT CHR$(12) 'Form feed
  100. 2880 'all done"
  101. 2890 GOTO 400
  102. 2900 '***** PRINT LINE SUBROUTINE *****
  103. *55 |2910 IF ZL > |21 THEN GOSUB 4500 'page head if necessary
  104. |2920 FOR ZJ=1 TO |18 'check justification for each field
  105. 2930 IF YT%(ZJ,5)=999 GOTO 3050 'invisible report field
  106. 2940 IF YT%(ZJ,7)>1 THEN 2980
  107. 2950 IF LEFT$(YT$(ZJ),1)<>" " THEN 3050 ' already left justified
  108. 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
  109. 2970 NEXT ZK:LSET YT$(ZJ)=MID$(YT$(ZJ),Z3):GOTO 3050 'moves the stuff left
  110. 2980 IF YT%(ZJ,7)>2 THEN 3020 'right justify for code 2
  111. 2990 IF RIGHT$(YT$(ZJ),1)<>" " THEN 3050 'already right justified
  112. 3000 Z3=1:FOR ZK=LEN(YT$(ZJ)) TO 1 STEP -1:IF MID$(YT$(ZJ),ZK,1)<>" " THEN Z3=ZK:ZK=1
  113. 3010 NEXT ZK:RSET YT$(ZJ)=MID$(YT$(ZJ),1,Z3):GOTO 3050 'moves stuff right
  114. 3020 IF LEFT$(YT$(ZJ),1) <> " " AND RIGHT$(YT$(ZJ),1) <> " " THEN 3050 'Can't center justify as the field is filled
  115. 3030 Z3=1:FOR ZK=LEN(YT$(ZJ)) TO 1 STEP -1:IF MID$(YT$(ZJ),ZK,1)<>" " THEN Z3=ZK:ZK=1
  116. 3040 NEXT ZK:LSET YT$(ZJ)=STRING$(INT((Z3-1)/2),32)+MID$(YT$(ZJ),1) 'centers stuff
  117. 3050 NEXT 'ZJ
  118. *60 |3060 IF GROUPTEST$ <> YT$(|32) THEN GOSUB 5000
  119. *59 |3070 FOR ZJ=1 TO |18:IF YT%(ZJ,9) <> 99 THEN GOTO 3090
  120. *59 3080 GROUPTOTAL#(ZJ)=GROUPTOTAL#(ZJ)+VAL(YT$(ZJ)):GRANDTOTAL#(ZJ)=GRANDTOTAL#(ZJ)+VAL(YT$(ZJ))
  121. *59 3090 NEXT 'ZJ
  122. *50
  123. 3300 LPRINT:ZL=ZL+1 ' print blank line before next record - remove this line if you wish to single space
  124. 3310 RETURN
  125. 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
  126. *55 4500 '***** PAGE HEADING SUBROUTINE *****
  127. *55 4520 IF ZI>1 THEN LPRINT CHR$(12) 'form feed"
  128. *43 4525 LPRINT ZD$;SPC(2);
  129. *55 |4530 YP=YP+1:LPRINT TAB(INT((|31-LEN(TITLE$))/2));TITLE$;TAB(|31-8)"Page";YP:LPRINT
  130. *49
  131. *55 |4550 Dashes%=|24:IF Dashes%>0 THEN LPRINT STRING$(Dashes%,95):LPRINT ELSE LPRINT
  132. *55 |4560 ZL=|23:RETURN
  133. *59 5000 'Group Or Grand totals subroutine
  134. *59 5010 WHILE FIRSTRECORD%=1
  135. *60 |5020 GROUPTEST$=YT$(|32)
  136. *59 |5030 FOR ZJ=1 TO |18
  137. *59 5040 IF YT%(ZJ,9) <> 99 THEN GOTO 5070
  138. *59 5050 M%=INSTR(ZFORM$(ZJ),",")
  139. *59 5060 IF M%>0 THEN ZTOTFORM$(ZJ)="###,"+LEFT$("###",4-M%)+ZFORM$(ZJ) ELSE ZTOTFORM$(ZJ)="###"+ZFORM$(ZJ)
  140. *59 5070 GRPTAB%(ZJ)=YT%(ZJ,6)-LEN(ZTOTFORM$(ZJ))+1:IF GRPTAB%(ZJ)<1 THEN GRPTAB%(ZJ)=1
  141. *59 5080 NEXT
  142. *59 5090 FIRSTRECORD%=0
  143. *59 5100 RETURN
  144. *59 5110 WEND
  145. *59 |5120 IF ZL > |21 - 3 THEN GOSUB 4500 'page head if not enough room for group totals
  146. *59 5130 P%=1
  147. *59 |5140 FOR ZJ=1 TO |18
  148. *59 5150 IF YT%(ZJ,9) <> 99 THEN GOTO 5180
  149. *59 5160 IF P% > GRPTAB%(ZJ) THEN ZL=ZL+1
  150. *59 5170 LPRINT TAB(GRPTAB%(ZJ));:LPRINT USING ZTOTFORM$(ZJ);GROUPTOTAL#(ZJ);:P%=GRPTAB%(ZJ)+LEN(ZTOTFORM$(ZJ))-1
  151. *59 5180 GROUPTOTAL#(ZJ)=0
  152. *59 5190 NEXT 'ZJ
  153. *59 |5200 LPRINT TYPETOTAL$;"Total":LPRINT:ZL=ZL+2:GROUPTEST$=YT$(|32)
  154. *59 5210 RETURN
  155. *31 Copyright 1987 by PRO DEV Software
  156.