10 ' PROGRAM TITLE "SORTGL"
230 INPUT "ENTER 'Y' TO MOUNT THE FILES";WY$
240 IF WY$<>"Y" THEN 270
250 UNLOAD 0,1
260 MOUNT 0,1
270 CLEAR 1000
280 Z=1
290 DIM DM$(3)
300 DIM R$(3)
310 DIM DV$(3)
320 DIM B#(1750)
330 DIM BB(1750)
340 DIM Q(16)
350 CNT=10000
360 PRINT "GENERAL LEDGER SORT"
370 OPEN "R",3,"LEDGER",1  '  OPEN ALL FILES
380 OPEN "R",1,"LEDGER",1
390 OPEN "R",2,"LEDGER",0
400 PRINT "ENTER -A- TO SORT ON ACCT#/CK#/VCH#" ' WHAT KIND OF SORT?
410 INPUT "ENTER -C- TO SORT ON CK/VCH #";CA$
420 IF CA$="A" THEN LPRINT "GEN LEDGER SORT ON ACT#/CK-VCH#":GOTO 440
430 LPRINT "GEN. LEDGER SORT ON CK/VCH #"
440 INPUT "ENTER DATE TO BE SORTED AS MOYR";A$ ' FILE MONTH AND YEAR
450 LPRINT "DATE ";A$
460 GET #3,2037            
470 FOR Q=1 TO 16           
480 FIELD #3, (Q-1)*8 AS DB$, 8 AS D1$(Q)
490 IF A$=MID$(D1$(Q),1,4) THEN 530  
500 NEXT Q
510 PRINT "DATE NOT IN TABLE"
520 GOTO 520           
530 REC$=MID$(D1$(Q),5,4)  
540 REC=VAL(REC$)    
550 K=1
560 SREC=REC         ' SAVE THE STARTING ADDRESS
570 CLOSE 3          ' CLOSE THE TABLE FILE
580 GET #1,REC       
590 FOR I=1 TO 3      ' LEDGER FILE BLOCKED 3 PER SECTOR
600 FIELD #1, (I-1)*42 AS D$,42 AS DREC$(I)
610 IF MID$(DREC$(I),1,3)="EOF" AND LSW=1 THEN 1060 ' IS IT END OF FILE
620 C$=MID$(DREC$(I),1,2)
630 C$=(C$)+(MID$(DREC$(I),5,2)) ' EXTRACT DATE FROM LEDGER FILE
640 IF A$=C$ THEN LSW=1:GOTO 690 ' IS IT THE BEGINNING OF THE FILE
650 NEXT I      ' NEXT RECORD
660 REC=REC+1    ' INCREMENT THE RECORD COUNTER
670 IF REC=2037 THEN 1030  ' IS IT THE END OF THE FILE AREA
680 GOTO 580    ' GO GET ANOTHER RECORD
690 N=N+1    
700 IF N>1750 THEN 1050
710 IF ISW=1 THEN 740
720 ISW=1
730 SI=I
740 IF CA$="C" THEN 910   ' CHECK NUMBER SORT
750 DAC$=MID$(DREC$(I),7,4)
760 IF MID$(DREC$(I),42,1)="1" THEN 990  ' IS IT A BAL FORWARD RECORD
770 PC$=MID$(DREC$(I),11,5) ' LOAD CK# VCH# WORK AREA
780 IF MID$(PC$,1,1)="C" THEN MID$(PC$,1,1)="2":GOTO 800 ' IS IT A CHECK
790 MID$(PC$,1,1)="3"  ' THEN ITS A VOUCHER
800 DAC$=DAC$+PC$  ' ADD PC TO DAC
810 I$=STR$(I):RAC=REC
820 RAC=RAC+1000   ' ADD 1000 TO RECORD NUMBER
830 REC$=STR$(RAC)
840 TAG$=MID$(REC$,2,4)+MID$(I$,2,1) ' SAVE REC NUMBER IN TAG
850 DAC#=VAL(DAC$)
860 TAG=VAL(TAG$)
870 B#(K)=DAC#  ' LOAD THE MATRIX FOR SORTING B# = CONTROL NUMBER
880 BB(K)=TAG       '                         BB = TAG OR RECORD NUMBER
890 K=K+1       ' INCRECMENT MATRIX SUBSCRIPT
900 GOTO 650
910 IF MID$(DREC$(I),42,1)="1" THEN 950  ' IS IT A BAL FWD RECORD
920 DAC$=MID$(DREC$(I),11,5)   ' LOAD THE WORK AREA
930 IF MID$(DAC$,1,1)="C" THEN MID$(DAC$,1,1)="2":GOTO 810 ' IS IT A CHE
940 MID$(DAC$,1,1)="3":GOTO 810  ' THEN IT IS A VOUCHER
950 CNT=CNT+1    ' BLOCK LOCATION IN THE DISK RECORD
960 CNT$=STR$(CNT)
970 DAC$=MID$(CNT$,2,5)
980 GOTO 810
990 CNT=CNT+1    ' BLOCK LOCATION IN THE DISK RECORD
1000 CNT$=STR$(CNT)
1010 PC$=MID$(CNT$,2,5)
1020 GOTO 800
1030 PRINT "DATA OVERLAPS DISK-ILLEGAL"
1040 GOTO 1040
1050 PRINT "TOO MANY RECORDS TO SORT":STOP
1060 IF N>1750 THEN 1050
1070 LPRINT "TOTAL RECORDS ";N;" FREE MEMORY ";FRE(X)
1080 '
1090 M=N'          START OF SORT ROUTINE
1100 M=INT(M/2)
1110 EXH=0
1120 IF M=0 THEN 1270'    END OF SORT-GOTO OUTPUT ROUTINE
1130 K=N-M
1140 J=1
1150 I=J
1160 L=I+M
1170 IF B#(I)<=B#(L) THEN 1230
1180 SWAP B#(I),B#(L)
1190 SWAP BB(I),BB(L)
1200 EXH=EXH+1
1210 I=I-M
1220 IF I>=1 THEN 1160
1230 J=J+1
1240 IF J>K THEN PRINT "M = ";M;" SWAPS MADE = ";EXH:GOTO 1100
1250 GOTO 1150
1260 '
1270 LPRINT 
1280 LPRINT "ENTERING OUTPUT ROUTINE TO DR O"
1290 K=1
1300 A=1
1310 J=0
1320 J=J+1
1330 ZAP=BB(K)    ' THE ACTUAL DISK RECORD ADDRESS IN OLD FILE + 1000
1340 REC$=STR$(ZAP)
1350 I$=MID$(REC$,6,1)
1360 REC$=MID$(REC$,2,4)
1370 REC=VAL(REC$)
1380 REC=REC-1000
1390 XI=VAL(I$)
1400 I=XI:G=XI:Y=XI   ' I = THE BLOCKING FACTOR
1410 GET #1,REC
1420 FOR I=G TO Y
1430 FIELD #1, (I-1)*42 AS VREC$,42 AS VA$(I)
1440 DV$(J)=VA$(I)   ' BUILD THE OUTPUT RECORD FOR THE SORTED FILE
1450 NEXT I
1460 K=K+1
1470 IF K>N THEN 1580   ' N = THE NUMBER OF RECORDS IN THE MATRIX
1480 IF J=3 THEN 1490 ELSE 1320
1490 FOR L=1 TO 3
1500 FIELD #2, (L-1)*42 AS DF$,42 AS DP$(L)
1510 LSET DP$(L)=DV$(L)  ' TRANSFER DATA TO NEW FILES BUFFER
1520 NEXT L
1530 PUT #2,A           ' WRITE OUT THE NEW FILES RECORD
1540 A=A+1              ' INCREMENT THE RECORD COUNTER FOR NEW FILE
1550 IF EFSW=2 THEN 1710 ' END OF FILE SWITCH FOR DRIVE 1
1560 IF EFSW=1 THEN 1680 ' END OF FILE SWITCH FOR DRIVE 0
1570 GOTO 1310
1580 EFSW=1
1590 IF J=3 THEN 1490
1600 EFSW=2
1610 J=J+1
1620 DV$(J)="EOF"   ' INSERT EOF FOR NEW FILE
1630 JS=J
1640 IF J=3 THEN 1490
1650 J=J+1
1660 DV$(J)=BLK$
1670 GOTO 1640
1680 J=1
1690 EFSW=2
1700 GOTO 1620
1710 A=A-1
1720 LPRINT "** EOF ** DR 0 IN OUTPUT SECTOR ";A;" RECORD # ";JS
1730 CLOSE 1,2
1740 '
1750 LPRINT 
1760 LPRINT "ENTERING COPY-BACK ROUTINE"  ' COPY SORTED FILE TO ORIGINAL
1770 OPEN "R",1,"LEDGER",0
1780 OPEN "R",2,"LEDGER",1
1790 REC=SREC
1800 EF$="EOF"
1810 J=SI
1820 A=1
1830 GET #1,A    ' GET NEW FILE ON DR 0
1840 FOR I=1 TO 3
1850 FIELD #1, (I-1)*42 AS D$,42 AS DREC$(I)
1860 DM$(I)=DREC$(I)
1870 IF MID$(DREC$(I),1,3)="EOF" THEN 1990
1880 NEXT I
1890 A=A+1
1900 IF GSW=1 THEN 1990
1910 GET #2,REC  ' GET OLD FILE ON DR 1 AND CHECK FOR FIRST BLOCK FOR ST
1920 FOR I=1 TO 3
1930 FIELD #2, (I-1)*42 AS O$,42 AS ODEC$(I)
1940 R$(I)=ODEC$(I)
1950 NEXT I
1960 IF GSW=1 AND K<4 THEN 2040
1970 IF GSW=1 AND K>3 THEN 1990
1980 GSW=1
1990 FOR K=1 TO 3
2000 R$(J)=DM$(K)  ' TRANSFER FILE DRIVE 0 TO FILE DRIVE 1
2010 IF MID$(DM$(K),1,3)="EOF" THEN 2190  ' IS IT END OF FILE DR 0
2020 J=J+1
2030 IF J=4 THEN 2060
2040 NEXT K
2050 GOTO 1830
2060 J=1
2070 FOR I=1 TO 3
2080 LSET ODEC$(I)=R$(I) '  LOAD OUTPUT FILE DRIVE 1 BUFFER AREA
2090 NEXT I
2100 PUT #2,REC     ' WRITE OUT FILE TO DRIVE 1
2110 IF EFSW=1 THEN 2140   ' HAS EOF BEEN SENSED
2120 REC=REC+1      ' INCREMENT DRIVE 1 RECORD CONTER
2130 GOTO 1910
2140 LPRINT "DR 1 FIRST OUTPUT SECTOR ";SREC;" RECORD # ";SI
2150 LPRINT "** EOF ** DR 1 IN OUTPUT SECTOR ";REC;" RECORD # ";J
2160 LPRINT "EOJ"
2170 PRINT "EOJ"
2180 STOP          ' END OF JOB
2190 EFSW=1
2200 GOTO 2070
2210 END