home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpmug / cpmug043.ark / A_R03A.BAS < prev    next >
Encoding:
BASIC Source File  |  1984-04-29  |  3.0 KB  |  99 lines
  1.  
  2.     REMARK    *************************************************************
  3.     REMARK    *    ACCOUNTS RECEIVABLE UPDATE SORT    (A/R03A)        *
  4.     REMARK    *        VERS. OF 10.45 PM     5/13/79            *
  5.     REMARK    *  =======================================================  *
  6.     REMARK    *  THIS PROGRAM USES THE SHELL-METZNER SORTING ALGORITHM    *
  7.     REMARK    *  TO SORT A TRANSACTION FILE IN DECREASING INCREMENTS AND  *
  8.     REMARK    *  WRITE THE SORTED RECORDS OUT TO A WORKFILE.            *
  9.     REMARK    *  ONCE THE WORKFILE IS COMPLETELY WRITTEN, IT REPLACES THE *
  10.     REMARK    *  FILE USED AS INPUT.                        *
  11.     REMARK    *************************************************************
  12.  
  13.     ZERO$="000000"
  14.     DIM DATA$(1000),L4(2),D(13)
  15. %INCLUDE CURSOR
  16.     GOTO 6000
  17. %INCLUDE A/R-INV
  18. %INCLUDE A/R-INFO
  19.  
  20.  
  21.  
  22.  
  23. 6000    CONSOLE
  24.     PRINT CLEAR.SCREEN$;"A/R UPDATE"
  25.     PRINT "KEY RETURN TO BEGIN; ENTER 'END' TO EXIT"
  26.     INPUT LINE A$
  27.     IF A$="END" THEN \
  28.         PRINT CLEAR.SCREEN$;"A/R UPDATE LOADING MENU":\
  29.         CHAIN "A/P000"
  30.     PRINT CLEAR.SCREEN$;"SORT PHASE"
  31.     PRINT "WORKING...DO NOT INTERRUPT"
  32.     PRINT
  33.     INPUT.FILE$="A/R0F020.DAT"
  34.     OUTPUT.FILE$="WORKFILE.DAT"
  35.     RECLENGTH=226
  36.     OPEN INPUT.FILE$ RECL RECLENGTH AS 1
  37.     OPEN "A/R0F130.DAT" AS 5
  38.     FILE.NO=5:GOSUB 3.14
  39.     IF AR.TRANFILE.EXTENT=0 THEN 8000
  40.     IF END #1 THEN 7000                        REMARK    SET END-OF-FILE BRANCH
  41.  
  42.     REMARK        **********     READ DATA RECORDS AND STRIP OFF KEY ELEMENTS FOR USE IN THE SORT     **********
  43.  
  44.  
  45. 6050    READ #1; VAR$,VAR1
  46.     RECORD.COUNT%=RECORD.COUNT% + 1
  47.     DATA$(RECORD.COUNT%)=VAR$
  48.     PRINT CURSOR.HOME$:PRINT:PRINT "RECORD #";RECORD.COUNT%
  49.  
  50.     X0$=ZERO$+STR$(VAR1)
  51.     X0$=RIGHT$(X0$,6)                        REMARK    CONVERT INVOICE # TO ALPHANUMERIC
  52.     FOR I%=1 TO 6 STEP 2
  53.     DATA$(RECORD.COUNT%)=DATA$(RECORD.COUNT%)+CHR$(VAL(MID$(X0$,I%,2)))
  54.     NEXT I%                                REMARK    ROUTINE TO PACK INVOICE NUMBER
  55.     X0$=ZERO$+STR$(RECORD.COUNT%)
  56.     X0$=RIGHT$(X0$,4)
  57.     X0%=VAL(LEFT$(X0$,2))
  58.     X1%=VAL(RIGHT$(X0$,2))
  59.     DATA$(RECORD.COUNT%)=DATA$(RECORD.COUNT%)+CHR$(X0%)+CHR$(X1%)
  60.     GOTO 6050                            REMARK    GET THE NEXT RECORD
  61. 7000    CLOSE 1
  62.     OPEN INPUT.FILE$ RECL RECLENGTH AS 1
  63.     PRINT "NUMBER OF RECORDS IN FILE =";RECORD.COUNT%
  64.     M%=RECORD.COUNT%
  65. 7010    M%=M%/2                                REMARK    DIVIDE THE SORT INTERVAL IN HALF
  66.     IF M%=0 THEN GOTO 7150                        REMARK    IF SORT INTERVAL IS EXHAUSTED,\
  67.                                         RE-WRITE THE ORDERED FILE.
  68.     K%=RECORD.COUNT%-M%
  69.     J%=1
  70. 7040    I%=J%
  71. 7050    L%=I% + M%
  72.  
  73.     IF DATA$(I%) <= DATA$(L%) THEN GOTO 7120
  74.     TEMP$=DATA$(I%)
  75.     DATA$(I%)=DATA$(L%)
  76.     DATA$(L%)=TEMP$
  77.     I%=I% - M%
  78.     IF I% > 0 THEN GOTO 7050
  79. 7120    J%=J%+1
  80.     IF J% > K% THEN GOTO 7010 ELSE GOTO 7040
  81. 7150    PRINT CLEAR.SCREEN$;
  82.     PRINT "SORT PHASE ENDED"
  83.     PRINT "WRITING SORTED RECORDS TO WORKFILE"
  84.     PRINT "WORKING... DO NOT INTERRUPT"
  85.     CREATE OUTPUT.FILE$ RECL RECLENGTH AS 2
  86.     FOR OUTPUT.COUNT%=1 TO RECORD.COUNT%
  87.     X0$=RIGHT$(DATA$(OUTPUT.COUNT%),2)
  88.     X0%=ASC(LEFT$(X0$,1))
  89.     POINTER%=X0% * 100
  90.     X0%=ASC(RIGHT$(X0$,1))
  91.     POINTER%=POINTER% + X0%
  92.     FILE.NO=1:REC.NO%=POINTER%:GOSUB 3400
  93.     FILE.NO=2:REC.NO%=OUTPUT.COUNT%:GOSUB 3450
  94.     NEXT OUTPUT.COUNT%
  95.     DELETE 1
  96.     CLOSE 2
  97.     A%=RENAME(INPUT.FILE$,OUTPUT.FILE$)
  98. 8000    CHAIN "A/R03B"
  99.