home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / SIMTEL / CPMUG / CPMUG009.ARK / SORTGL.ASC < prev    next >
Text File  |  1984-04-29  |  6KB  |  201 lines
  1. 10 ' PROGRAM TITLE "SORTGL"
  2. 230 INPUT "ENTER 'Y' TO MOUNT THE FILES";WY$
  3. 240 IF WY$<>"Y" THEN 270
  4. 250 UNLOAD 0,1
  5. 260 MOUNT 0,1
  6. 270 CLEAR 1000
  7. 280 Z=1
  8. 290 DIM DM$(3)
  9. 300 DIM R$(3)
  10. 310 DIM DV$(3)
  11. 320 DIM B#(1750)
  12. 330 DIM BB(1750)
  13. 340 DIM Q(16)
  14. 350 CNT=10000
  15. 360 PRINT "GENERAL LEDGER SORT"
  16. 370 OPEN "R",3,"LEDGER",1  '  OPEN ALL FILES
  17. 380 OPEN "R",1,"LEDGER",1
  18. 390 OPEN "R",2,"LEDGER",0
  19. 400 PRINT "ENTER -A- TO SORT ON ACCT#/CK#/VCH#" ' WHAT KIND OF SORT?
  20. 410 INPUT "ENTER -C- TO SORT ON CK/VCH #";CA$
  21. 420 IF CA$="A" THEN LPRINT "GEN LEDGER SORT ON ACT#/CK-VCH#":GOTO 440
  22. 430 LPRINT "GEN. LEDGER SORT ON CK/VCH #"
  23. 440 INPUT "ENTER DATE TO BE SORTED AS MOYR";A$ ' FILE MONTH AND YEAR
  24. 450 LPRINT "DATE ";A$
  25. 460 GET #3,2037            
  26. 470 FOR Q=1 TO 16           
  27. 480 FIELD #3, (Q-1)*8 AS DB$, 8 AS D1$(Q)
  28. 490 IF A$=MID$(D1$(Q),1,4) THEN 530  
  29. 500 NEXT Q
  30. 510 PRINT "DATE NOT IN TABLE"
  31. 520 GOTO 520           
  32. 530 REC$=MID$(D1$(Q),5,4)  
  33. 540 REC=VAL(REC$)    
  34. 550 K=1
  35. 560 SREC=REC         ' SAVE THE STARTING ADDRESS
  36. 570 CLOSE 3          ' CLOSE THE TABLE FILE
  37. 580 GET #1,REC       
  38. 590 FOR I=1 TO 3      ' LEDGER FILE BLOCKED 3 PER SECTOR
  39. 600 FIELD #1, (I-1)*42 AS D$,42 AS DREC$(I)
  40. 610 IF MID$(DREC$(I),1,3)="EOF" AND LSW=1 THEN 1060 ' IS IT END OF FILE
  41. 620 C$=MID$(DREC$(I),1,2)
  42. 630 C$=(C$)+(MID$(DREC$(I),5,2)) ' EXTRACT DATE FROM LEDGER FILE
  43. 640 IF A$=C$ THEN LSW=1:GOTO 690 ' IS IT THE BEGINNING OF THE FILE
  44. 650 NEXT I      ' NEXT RECORD
  45. 660 REC=REC+1    ' INCREMENT THE RECORD COUNTER
  46. 670 IF REC=2037 THEN 1030  ' IS IT THE END OF THE FILE AREA
  47. 680 GOTO 580    ' GO GET ANOTHER RECORD
  48. 690 N=N+1    
  49. 700 IF N>1750 THEN 1050
  50. 710 IF ISW=1 THEN 740
  51. 720 ISW=1
  52. 730 SI=I
  53. 740 IF CA$="C" THEN 910   ' CHECK NUMBER SORT
  54. 750 DAC$=MID$(DREC$(I),7,4)
  55. 760 IF MID$(DREC$(I),42,1)="1" THEN 990  ' IS IT A BAL FORWARD RECORD
  56. 770 PC$=MID$(DREC$(I),11,5) ' LOAD CK# VCH# WORK AREA
  57. 780 IF MID$(PC$,1,1)="C" THEN MID$(PC$,1,1)="2":GOTO 800 ' IS IT A CHECK
  58. 790 MID$(PC$,1,1)="3"  ' THEN ITS A VOUCHER
  59. 800 DAC$=DAC$+PC$  ' ADD PC TO DAC
  60. 810 I$=STR$(I):RAC=REC
  61. 820 RAC=RAC+1000   ' ADD 1000 TO RECORD NUMBER
  62. 830 REC$=STR$(RAC)
  63. 840 TAG$=MID$(REC$,2,4)+MID$(I$,2,1) ' SAVE REC NUMBER IN TAG
  64. 850 DAC#=VAL(DAC$)
  65. 860 TAG=VAL(TAG$)
  66. 870 B#(K)=DAC#  ' LOAD THE MATRIX FOR SORTING B# = CONTROL NUMBER
  67. 880 BB(K)=TAG       '                         BB = TAG OR RECORD NUMBER
  68. 890 K=K+1       ' INCRECMENT MATRIX SUBSCRIPT
  69. 900 GOTO 650
  70. 910 IF MID$(DREC$(I),42,1)="1" THEN 950  ' IS IT A BAL FWD RECORD
  71. 920 DAC$=MID$(DREC$(I),11,5)   ' LOAD THE WORK AREA
  72. 930 IF MID$(DAC$,1,1)="C" THEN MID$(DAC$,1,1)="2":GOTO 810 ' IS IT A CHE
  73. 940 MID$(DAC$,1,1)="3":GOTO 810  ' THEN IT IS A VOUCHER
  74. 950 CNT=CNT+1    ' BLOCK LOCATION IN THE DISK RECORD
  75. 960 CNT$=STR$(CNT)
  76. 970 DAC$=MID$(CNT$,2,5)
  77. 980 GOTO 810
  78. 990 CNT=CNT+1    ' BLOCK LOCATION IN THE DISK RECORD
  79. 1000 CNT$=STR$(CNT)
  80. 1010 PC$=MID$(CNT$,2,5)
  81. 1020 GOTO 800
  82. 1030 PRINT "DATA OVERLAPS DISK-ILLEGAL"
  83. 1040 GOTO 1040
  84. 1050 PRINT "TOO MANY RECORDS TO SORT":STOP
  85. 1060 IF N>1750 THEN 1050
  86. 1070 LPRINT "TOTAL RECORDS ";N;" FREE MEMORY ";FRE(X)
  87. 1080 '
  88. 1090 M=N'          START OF SORT ROUTINE
  89. 1100 M=INT(M/2)
  90. 1110 EXH=0
  91. 1120 IF M=0 THEN 1270'    END OF SORT-GOTO OUTPUT ROUTINE
  92. 1130 K=N-M
  93. 1140 J=1
  94. 1150 I=J
  95. 1160 L=I+M
  96. 1170 IF B#(I)<=B#(L) THEN 1230
  97. 1180 SWAP B#(I),B#(L)
  98. 1190 SWAP BB(I),BB(L)
  99. 1200 EXH=EXH+1
  100. 1210 I=I-M
  101. 1220 IF I>=1 THEN 1160
  102. 1230 J=J+1
  103. 1240 IF J>K THEN PRINT "M = ";M;" SWAPS MADE = ";EXH:GOTO 1100
  104. 1250 GOTO 1150
  105. 1260 '
  106. 1270 LPRINT 
  107. 1280 LPRINT "ENTERING OUTPUT ROUTINE TO DR O"
  108. 1290 K=1
  109. 1300 A=1
  110. 1310 J=0
  111. 1320 J=J+1
  112. 1330 ZAP=BB(K)    ' THE ACTUAL DISK RECORD ADDRESS IN OLD FILE + 1000
  113. 1340 REC$=STR$(ZAP)
  114. 1350 I$=MID$(REC$,6,1)
  115. 1360 REC$=MID$(REC$,2,4)
  116. 1370 REC=VAL(REC$)
  117. 1380 REC=REC-1000
  118. 1390 XI=VAL(I$)
  119. 1400 I=XI:G=XI:Y=XI   ' I = THE BLOCKING FACTOR
  120. 1410 GET #1,REC
  121. 1420 FOR I=G TO Y
  122. 1430 FIELD #1, (I-1)*42 AS VREC$,42 AS VA$(I)
  123. 1440 DV$(J)=VA$(I)   ' BUILD THE OUTPUT RECORD FOR THE SORTED FILE
  124. 1450 NEXT I
  125. 1460 K=K+1
  126. 1470 IF K>N THEN 1580   ' N = THE NUMBER OF RECORDS IN THE MATRIX
  127. 1480 IF J=3 THEN 1490 ELSE 1320
  128. 1490 FOR L=1 TO 3
  129. 1500 FIELD #2, (L-1)*42 AS DF$,42 AS DP$(L)
  130. 1510 LSET DP$(L)=DV$(L)  ' TRANSFER DATA TO NEW FILES BUFFER
  131. 1520 NEXT L
  132. 1530 PUT #2,A           ' WRITE OUT THE NEW FILES RECORD
  133. 1540 A=A+1              ' INCREMENT THE RECORD COUNTER FOR NEW FILE
  134. 1550 IF EFSW=2 THEN 1710 ' END OF FILE SWITCH FOR DRIVE 1
  135. 1560 IF EFSW=1 THEN 1680 ' END OF FILE SWITCH FOR DRIVE 0
  136. 1570 GOTO 1310
  137. 1580 EFSW=1
  138. 1590 IF J=3 THEN 1490
  139. 1600 EFSW=2
  140. 1610 J=J+1
  141. 1620 DV$(J)="EOF"   ' INSERT EOF FOR NEW FILE
  142. 1630 JS=J
  143. 1640 IF J=3 THEN 1490
  144. 1650 J=J+1
  145. 1660 DV$(J)=BLK$
  146. 1670 GOTO 1640
  147. 1680 J=1
  148. 1690 EFSW=2
  149. 1700 GOTO 1620
  150. 1710 A=A-1
  151. 1720 LPRINT "** EOF ** DR 0 IN OUTPUT SECTOR ";A;" RECORD # ";JS
  152. 1730 CLOSE 1,2
  153. 1740 '
  154. 1750 LPRINT 
  155. 1760 LPRINT "ENTERING COPY-BACK ROUTINE"  ' COPY SORTED FILE TO ORIGINAL
  156. 1770 OPEN "R",1,"LEDGER",0
  157. 1780 OPEN "R",2,"LEDGER",1
  158. 1790 REC=SREC
  159. 1800 EF$="EOF"
  160. 1810 J=SI
  161. 1820 A=1
  162. 1830 GET #1,A    ' GET NEW FILE ON DR 0
  163. 1840 FOR I=1 TO 3
  164. 1850 FIELD #1, (I-1)*42 AS D$,42 AS DREC$(I)
  165. 1860 DM$(I)=DREC$(I)
  166. 1870 IF MID$(DREC$(I),1,3)="EOF" THEN 1990
  167. 1880 NEXT I
  168. 1890 A=A+1
  169. 1900 IF GSW=1 THEN 1990
  170. 1910 GET #2,REC  ' GET OLD FILE ON DR 1 AND CHECK FOR FIRST BLOCK FOR ST
  171. 1920 FOR I=1 TO 3
  172. 1930 FIELD #2, (I-1)*42 AS O$,42 AS ODEC$(I)
  173. 1940 R$(I)=ODEC$(I)
  174. 1950 NEXT I
  175. 1960 IF GSW=1 AND K<4 THEN 2040
  176. 1970 IF GSW=1 AND K>3 THEN 1990
  177. 1980 GSW=1
  178. 1990 FOR K=1 TO 3
  179. 2000 R$(J)=DM$(K)  ' TRANSFER FILE DRIVE 0 TO FILE DRIVE 1
  180. 2010 IF MID$(DM$(K),1,3)="EOF" THEN 2190  ' IS IT END OF FILE DR 0
  181. 2020 J=J+1
  182. 2030 IF J=4 THEN 2060
  183. 2040 NEXT K
  184. 2050 GOTO 1830
  185. 2060 J=1
  186. 2070 FOR I=1 TO 3
  187. 2080 LSET ODEC$(I)=R$(I) '  LOAD OUTPUT FILE DRIVE 1 BUFFER AREA
  188. 2090 NEXT I
  189. 2100 PUT #2,REC     ' WRITE OUT FILE TO DRIVE 1
  190. 2110 IF EFSW=1 THEN 2140   ' HAS EOF BEEN SENSED
  191. 2120 REC=REC+1      ' INCREMENT DRIVE 1 RECORD CONTER
  192. 2130 GOTO 1910
  193. 2140 LPRINT "DR 1 FIRST OUTPUT SECTOR ";SREC;" RECORD # ";SI
  194. 2150 LPRINT "** EOF ** DR 1 IN OUTPUT SECTOR ";REC;" RECORD # ";J
  195. 2160 LPRINT "EOJ"
  196. 2170 PRINT "EOJ"
  197. 2180 STOP          ' END OF JOB
  198. 2190 EFSW=1
  199. 2200 GOTO 2070
  200. 2210 END
  201.