         PCC      0
*
*M*      PURGE    FILE DELETING MODULE OF THE FILL PROCESSOR
*
*
*P*      NAME:    PURGE
*P*
*P*      PURPOSE: TO DELETE FILES FROM THE PERMANENT FILE SYSTEM IN A
*P*               SELECTIVE MANNER.
*P*      DESCRIPTION:  THE PURGE PROCESSOR IS INVOKED BY THE OPERATOR.
*P*               PURGE WILL NOTIFY THE OPERATOR WHEN A PRE-SET THRESHOLD
*P*               HAS BEEN EXCEEDED, BUT WILL TAKE NO INDEPENDENT ACTION.
*P*               THE OPERATOR MAY PURGE FILES IN ANY OF THE FOLLOWING WAYS:
*P*               1.  ALL EXPIRED FILES MAY BE PURGED.
*P*               2.  ALL EXPIRED FILES WHICH HAVE NOT BEEN ACCESSED
*P*               FOR A SPECIFIED PERIOD OF TIME MAY BE DELETED.
*P*               3.  EXPIRED FILES MAY BE PURGED BY ORDER OF ACCESS DATE
*P*               UNTIL A DESIRED LEVEL OF FREE PREMANENT GRANULES HAS BEEN
*P*               REACHED.
*P*               4.  ALL FILES MAY BE DELETED BY ONE OF THE ABOVE METHODS.
*P*               5.  ALL FILES WHICH HAVE A CURRENT BACKUP MAY BE CONSIDERED
*P*               FOR DELETION BY ONE OF THE ABOVE SCHEMES.  FILES WITHOUT
*P*               A CURRENT TAPE BACKUP WILL BE IGNORED.
*P*      REFERENCES:  CPV OPERATIONS REFERENCE MANUAL
*P*
         PAGE
         SYSTEM   SIG7D
*
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
R8       EQU      8
R9       EQU      9
R10      EQU      10
R11      EQU      11
R12      EQU      12
R13      EQU      13
R14      EQU      14
R15      EQU      15
SR1      EQU      8
SR2      EQU      9
SR3      EQU      10
SR4      EQU      11
D1       EQU      12
D2       EQU      13
D3       EQU      14
D4       EQU      15
         PAGE
*
*        ALL DEFS IN PURGE FOLLOW
*
         DEF      BADCOM            ENTRY POINT TO RECOVER FROM AN
*,*                                 ILLEGAL COMMAND
         DEF      BINTODEC          SUBROUTINE TO CONVERT SUPPLIED
*,*                                 HEX NUMBER TO EBCDIC DECIMAL
         DEF      DATEAD            WORD CONTAINING THE LOCATION OF A
*,*                                 WINDOW TO MONITOR'S 'DATE'
         DEF      DOPURLIST         SUBROUTINE TO PRINT THE LINE-
*,*                                 PRINTER MESSAGE WHEN A FILE IS
*,*                                 DELETED
         DEF      GETCOM            ENTRY POINT TO REQUEST FILL COMMANDS
         DEF      GRANCYLAD         WORD CONTAINING THE LOCATION OF A
*,*                                 WINDOW TO MONITOR'S 'GRANCYL'
         DEF      GRANMINAD         WORD CONTAINING THE LOCATION OF A
*,*                                 WINDOW TO MONITOR'S 'GRANMIN'
         DEF      GRANPACKAD        WORD CONTAINING THE LOCATION OF A
*,*                                 WINDOW TO MONITOR'S 'GRANPACK'
         DEF      GRANRADAD         WORD CONTAINING THE LOCATION OF A
*,*                                 WINDOW TO MONITOR'S 'GRANRAD'
         DEF      INT               WORD WHICH IS SET NON-ZERO WHEN
*,*                                 AN OPERATOR INTERRUPT OCCURS
         DEF      PURDYN            WORD CONTAINING THE FIRST WORD OF
*,*                                 A CORE BUFFER USED DURING A
*,*                                 'PURGE UNTIL' OPERATION
         DEF      PURGE             ENTRY POINT TO CHECK FOR A THRESHOLD
*,*                                 VIOLATION OR AN OPERATOR INTERRUPT
         DEF      PURGED            DEF FOR PATCHING PURGE DATA
         DEF      PURGEFLAGAD       WORD CONTAINING THE LOCATION OF A
*,*                                 WINDOW TO MONITOR'S 'PURGEFLAG'
         DEF      PURGEINT          ENTRY POINT FOR BREAK/INTERRUPT
         DEF      PURGEP            DEF FOR PATCHING PURGE PROCEDURE
         DEF      TIMEAD            WORD CONTAINING THE LOCATION OF A
*,*                                 WINDOW TO MONITOR'S 'TIME'
         PAGE
*
*        ALL REFS IN PURGE FOLLOW
*
         REF      AUTOBACK          SAVE TO-BE-PURGED FILE TO TAPE
         REF      BLDMAIL           SET AND/OR DISPLAY STATUS OF MAIL-
*,*                                 BOXES IN USER'S ACCOUNTS, IE
*,*                                 ARE THEY BUILT OR NOT
         REF      COMPDAT           CHECK IF PURGE CANDIDATE IS OLDER
*,*                                 THAN SPECIFIED ('PURGE OLDER') OR
*,*                                 SORT FILES BY ACCESS DATES ('PURGE
*,*                                 UNTIL')
         REF      CONACCT           DISPLAY CURRENT ACCOUNT FOR STATUS
         REF      DATE              SET UP CUT-OFF DATE FOR 'PURGE OLDER'
         REF      DEBUG             DON'T DELETE ANY FILES IN DEBUG MODE
         REF      DENSITY           SET AND/OR DISPLAY CURRENT OUTPUT
*,*                                 TAPE DENSITY
         REF      DO:REGS4          SET UP CONSTANT REGISTERS R0 - R3
         REF      EI:DESC           HAS FILE BEEN BACKED UP AND IS IT
*,*                                 EXEMPT FROM PURGE PROCESS
         REF      ENDTAPE           CLOSE OUT A TAPE CLEANLY FOR A
*,*                                 'DISMOUNT' COMMAND OR NORMAL PURGE
*,*                                 TERMINATION OR SUSPENSION
         REF      ENVIR             STACK USED FOR TEMPORARY STORAGE
*,*                                 OF REGISTERS CLOBBERED BY SUBROUTINES
         REF      ITHRESH           RESETS THRESH TO THIS WHEN GRANULES
*,*                                 ARE AVAILABLE AGAIN
         REF      ERR:RET           SYNTAX ERROR RETURN FROM SCAN OF
*,*                                 PURGE COMMAND REPLIES
         REF      ERR:RET1          REMEMBER THE INITIAL LOCATION THAT
*,*                                 WAS CONTAINED IN ERR:RET
         REF      F:EI              GET FILE DATES, DESCRIPTORS FOR
*,*                                 PURGE CANDIDATES; READ THE FILE TO
*,*                                 SAVE TO TAPE AND THEN DELETE FILE
         REF      F:EO              GET INSN OF TAPE, IF ANY, A PURGED
*,*                                 FILE WAS SAVED TO BEFORE ZAPPING
         REF      FIND:STRG         MAKE KEYWORD CHECKS IN 'PURGE COM-
*,*                                 MAND' REPLIES
         REF      FMAILBX           FAST ENTRY FOR MAILBOX ROUTINE
*,*                                 (M:TIME CAL IS SKIPPED FOR THIS)
         REF      FPAR              BUFFER USED TO FORMAT OUTPUT OC
*,*                                 MESSAGES OR TO CONTAIN FPARAM DATA
*,*                                 FROM AN OPEN
         REF      GRANCYL           DETERMINE TOTAL NUMBER OF FREE
*,*                                 GRANULES TO CHECK FOR THRESHOLD
*,*                                 VIOLATION
         REF      GRANMIN           THRESHOLD VALUE FOR REMAINING GRAN-
*,*                                 ULES THAT WILL CAUSE ALLYCAT TO
*,*                                 AWAKEN FILL
         REF      GRANPACK          DETERMINE TOTAL NUMBER OF FREE
*,*                                 GRANULES TO CHECK FOR THRESHOLD
*,*                                 VIOLATIONS
         REF      GRANRAD           DETERMINE TOTAL NUMBER OF FREE
*,*                                 GRANULES TO CHECK FOR THRESHOLD
*,*                                 VIOLATION
         REF      HI                CHECK VALIDITY OF LASTREEL INSN
         REF      INCRMNTL          EXIT TO PROCESS 'BEGIN INCREMENTAL'
         REF      KEYIN             PROMPT WITH 'FILL COMMAND?' AND
*,*                                 GET REPLY IN COMBUF BUFFER; PROMPT
*,*                                 WITH 'PURGE COMMAND?' AND GET
*,*                                 REPLY IN SEL:COM:BUF
         REF      LASTREEL          SET AND/OR DISPLAY CURRENT REEL #
         REF      LASTRUN           STATUS DISPLAY OF CURRENTLY ACTIVE
*,*                                 OPERATION (BACKUP, FILL, PURGE)
         REF      LOCCODE1          GET ACCESS DATE,EXPIRATION DATE,
*,*                                 AND SIZE OF PURGE CANDIDATE
         REF      LOW               CHECK VALIDITY OF LASTREEL INSN
         REF      MAILBOX           TELL THE OWNER OF A PURGED FILE
*,*                                 WHAT HAS HAPPENED TO IT
         REF      MTIME             IF THIS CELL HAS NOT BEEN CHANGED,
*,*                                 A FAST ENTRY TO MAILBOX MAY BE USED
         REF      NOTAPE            SET UP SERIAL NUMBER FOR DISPLAY
*,*                                 IF NOT ALREADY DONE
         REF      NOTAPFG           PREVENT CLOBBERING LASTREEL IF A
*,*                                 TAPE IS CURRENTLY IN USE
         REF      OCDISP            SET AND/OR DISPLAY STATUS OF ACCOUNT
*,*                                 MESSAGES ON THE OC; ARE THEY OR ARE
*,*                                 THEY NOT PRINTED?
         REF      PURGEFLAG         KEEP ALLOCAT FROM INTERFERING WHILE
*,*                                 FILL IS RUNNING
         REF      PURGTAP           SET AND/OR DISPLAY STATUS OF FILES
*,*                                 SUBJECT TO PURGE:  ALL SAVED, ONLY
*,*                                 UPDATED SAVED, OR NONE SAVED
         REF      QUIT              EXIT TO PROCESS 'QUIT'
         REF      REGS              SAVE REGISTERS BEFORE TAKING SNAP
         REF      RESTART           EXIT TO PROCESS 'RESTART'
         REF      SAVEALL           EXIT TO PROCESS 'BEGIN SAVEALL'
         REF      SEL:COM           END OF BUFFER CONTAINING RESPONSE
*,*                                 TO PURGE COMMAND KEYINS
         REF      SEL:COM:BUF       BEGINNING OF BUFFER CONTAINING
*,*                                 RESPONSE TO PURGE COMMAND KEYINS
         REF      SELFILL           EXIT TO PROCESS 'BEGIN SELFILL'
         REF      SK:BL             SKIP BLANKS IN PURGE COMMAND REPLIES
         REF      SL:BKUP           SAVE EXPIRED FILES IF NON-ZERO
         REF      SLP:FPT           DELAY 30 SECONDS BEFORE BEGINNING
*,*                                 A PURGE THAT DOES NOT SAVE FILES
         REF      SNAPPER           EXIT TO PROCESS 'SNAP'
         REF      SQMOUNT           SET AND/OR DISPLAY STATUS OF USER-
*,*                                 INITIATED BACKUP TAPES, IE. LEFT
*,*                                 MOUNTED OR TAKEN DOWN EACH TIME
         REF      SQUIRREL          EXIT TO PROCESS 'BEGIN SQUIRREL'
         REF      SUSPACCT          STATUS DISPLAY OF ACCOUNT WHICH
*,*                                 WAS ACTIVE WHEN OPERATION SUSPENDED
         REF      SUSPEND           EXIT TO PROCESS 'SUSPEND'
         REF      SUSPNDED          STATUS DISPLAY OF SUSPENDED OPERATION
         REF      TAPETYP           SET AND/OR DISPLAY TAPE DEVICE TYPE
         REF      TAPETYPE          STATUS MESSAGE OF CURRENT/SUSPENDED
*,*                                 OPERATION OR START MESSAGE
         REF      THRESH            SET AND/OR DISPLAY CURRENT THRESHOLD
         REF      TIME              SET UP CUT-OFF DATE FOR PURGE OLDER'
         REF      TYPE              SEND MESSAGES TO OPERATOR'S CON-
*,*                                 SOLE CONCERNING THRESHOLDS, DIS-
*,*                                 PLAY REQUESTS,STATUS, ETC.
         REF      USERBKUP          SET AND/OR DISPLAY STATUS OF USER-
*,*                                 INITIATED BACKUP, IE. ALLOWED OR
*,*                                 NOT ALLOWED
         REF      WRT:SAV           SAVE MODIFIED PARAMETERS TO FILE
         REF      YESFL             EXIT TO PROCESS 'BEGIN FILL'
         PAGE
PURE     CSECT    1
DATA     CSECT    0
         USECT    DATA
*
*        THE FOLLOWING ARE CONTROL PARAMETERS THAT MAY BE VARIED TO SUIT
*          THE INDIVIDUAL INSTALLATION
*
PURGED   RES      0
BACKUPALLD DATA   SL:BKUP       IF 1, EXPIRED FILES MUST BE BACKED UP
*                    INDIRECT ADDRESSES FOR TABLES ITEMS
INDADS   EQU      %
GRANMINAD DATA    GRANMIN
PURGEFLAGAD DATA  PURGEFLAG
GRANRADAD DATA    GRANRAD
GRANPACKAD DATA   GRANPACK
GRANCYLAD DATA    GRANCYL
DATEAD   DATA     DATE
DATE1AD  DATA     DATE+1
TIMEAD   DATA     TIME
NINADS   EQU      %-INDADS
SAD:FPT  DATA     7**24+GRANRAD
         DATA     0                 ADDRESS OF VIRT PAGE FOR SAD FPT
*
*                 FOLLOWING ARE ORDINARY WORK TABLES AND ITEMS
PTYPE    DATA     0                 PURGE TYPE,A-AUTO,O-OLDER,U-UNTIL
PNUM     DATA     0                 NUMBER OF GRANS TO MAKE AVAILABLE
         BOUND    8
PDATE    DATA     0,0               DATE FOR PURGE OLDER
CDATE    DATA     0,0               CURRENT DATE FOR COMPARISON
MOVE:FID DATA     BA(F:EI+23)+1
         DATA     BA(PURGMSG)+21
INT      DATA     0                 1=ENTRY DUE TO OPERATOR 'INT'
ALLFLAG  DATA     0                 1='ALL' COMMAND
ENDAC    DATA     0                 IF 1, LAST FILE OF ACCT
PURGEXIT PZE
PURALLX  DATA     0                 IF 1, PURGE ALL EXPIRED FILES
EXPIRCNT  DATA    0                 CNT OF EXPIRED FILES DELETED
EXPIRFG  DATA     0                 NONZERO--PURGE ONLY EXPIRED FILES
LOGGED   PZE
DYNBYT   DATA     2040              NO. BYTES FOR GETTING PGS
MAXABN   EQU      20                MAX UNUSUAL ABNS PER ACCT
ABNCT    DATA     MAXABN
MAXABNAC EQU      5                 MAX ACCTS WITH MAX ABNS
ABNACCT  DATA     MAXABNAC
DOPURX   DATA     0                 INDIRECT FOR DOPURGE EXIT
SR3RET   DATA     0                 INDIRECT RETURN FOR SOME SR3 SBR'S
BKQX     DATA     0                 INDIRECT RETURN FOR DOPURBKQ
PURDYN   DATA     0                 ADDRESS OF DYNAM FAGE FOR PURGE TBL
PURDYNPRE DATA    0                 BASE ADDRESS 1 ENTRY LESS PURDYN
PURDYNIX DATA     0                 INDEX OF 1ST UNUSED WORD IN DYM PG
PURIX    DATA     0                 CURRENT PURDYN IX
PURFPAR  RES,4    90                FPARAM AREA
COMBUF   RES      20
CBUFEND  EQU      %
*            ***   TPY TABLE FOR BUILDING PURGE ENTRIES
ENACS    DATA     0                 ACCESS DATE-COMPRESSED
ENDSZ    DATA     0                 DESCRIPTORS-SIZE
ENACT    DATA     0,0               ACCOUNT
ENFID    DATA     0,0,0,0,0,0,0,0   FID
*            ***   END TPY TABLE
PURGMSG  TEXTC    'ON DDLD PURGED FILE '
         TEXT     '                                '
MAILFPT  DATA     PURGMSG
         DATA     F:EI+32           ADDRESS OF ACCOUNT NAME
PURGEMESSX EQU    %                 RESET COUNT SO ABOVE LOOKS LIKE ONE
         ORG      PURGMSG
         DATA,1   BA(PURGEMESSX)-BA(PURGMSG)-1
         ORG      PURGEMESSX
ENTPURGE TEXTC    'PURGE COMMAND? '
GRANSAV  TEXTC    'CURRENT THRESHOLD =        ;';
                  ,' CURRENT GRANULES =        '
         TITLE    'CONSTANTS'
COMMSG   TEXTC    'FILL COMMAND? '
         BOUND    8
DSMTMBS  DATA     BA(COMBUF)+1
         GEN,8,24 4,BA(DSMTXT)
CURGMBS  DATA     D3*4              BINTODEC LOADS D3-D4
         GEN,8,24 8,BA(GRANSAV)+48
THRESMBS DATA     D3*4
         GEN,8,24 8,BA(GRANSAV)+20
NEWTHMBS DATA     D3*4
         GEN,8,24 8,BA(NEWTHMSG)+16
SYSTEXT  TEXT     ':SYS    '
BADCMSG  TEXTC    'EH? '
DSMTXT   TEXT     'DISM'
XFFFF    DATA     X'FFFF'
COMEXIT  PZE                        RETURN ADDRESS FROM GETCOM
NONE     TEXT     'NONE'
NONETEXTC TEXTC   'NONE'
PURGETEXTC TEXTC  'PURGE'
MINTEXTC TEXTC    'MIN'
ALLTEXTC TEXTC    'ALL'
UNTILTEXTC TEXTC  'UNTIL'
OLDERTEXTC TEXTC  'OLDER'
XTXT     TEXTC    'X'
NEWTHMSG TEXTC    'NEW THRESHOLD =        '
THEXCEED TEXTC    'CURRENT AVAILABLE GRANULES IS BELOW THRESHOLD'
REELTXT  TEXTC    'CURRENT REEL NUMBER = '
TYPETXT  TEXTC    'DEVICE TYPE = '
DENSTXT  TEXTC    'OUTPUT TAPE DENSITY IS '
USERBTXT TEXTC    'USER-INITIATED BACKUP IS '
SQTXT    TEXTC    'USER-INITIATED BACKUP TAPES ARE '
USERMAIL TEXTC    'MAILBOXES IN USER''S ACCOUNTS ARE '
OCTXT    TEXTC    'OPERATOR''S CONSOLE DISPLAY IS '
PURGTXT1 TEXTC    'PURGED FILES ARE NOT SAVED TO TAPE'
         CSECT    1
PURGTXT2 TEXTC    'ALL PURGED FILES ARE SAVED TO TAPE'
PURGTXT3 TEXTC    'ONLY UPDATED PURGED FILES ARE SAVED TO TAPE'
         USECT    DATA
DITABLE  EQU      %
         DATA     0
         DATA     BA(REELTXT)
         DATA     BA(TYPETXT)
         DATA     BA(DENSTXT)
         DATA     BA(USERBTXT)
         DATA     BA(SQTXT)
         DATA     BA(USERMAIL)
         DATA     BA(OCTXT)
PURGMSGS DATA     BA(PURGTXT1)
         DATA     BA(PURGTXT2)
         DATA     BA(PURGTXT3)
         RES      4                 PATCHABLE EXPANSION
NEVER    TEXT     'NEVER'
BLANKS   DATA     C'    '
TEN      DATA     10
GET:DYN1 GEN,8,24 8,1               FPT-GET 1 DYNAMIC PAGE FOR SAD
FREE:VIR  GEN,1,7,24  1,5,SAD:FPT+1  FPT-FREE LAST DYN PAGE FOR SAD
GET:DYN  GEN,8,24 8,4               FPT-GET 4 DYNAMIC PAGES
FREE:DYN GEN,8,24 9,4               FPT-FREE 4 DYNAMIC PAGES
ACCIX    EQU      %-1               INDEX SEQUENCE FOR FETCHING AND -
         DATA,1   11,4,5,6,7,8,0,10    PACKING A DATE VLP
*                  DAYS PER MONTH USED IN DATE CALCULATIONS
DAYS:MON DATA,2   0,31,28,31,30,31,30,31,31,30,31,30,31,0
         TITLE    ' FPT '
NXACT    GEN,8,7,17   X'14',X'44',F:EI      TEST FILE - NXTA
         DATA     X'C0000009'
         DATA     PURERR,PURABN     ABN/ERR
         DATA     X'01000001',X'01000000'    FID=NULL
         DATA     X'02010202'                ACCT
PURACT   DATA     0,0
         SPACE    3
NXFID    GEN,8,7,17    X'14',4,F:EI      TEST FILE-NXTF
         DATA     X'C0000400'
         DATA     PURERR,PURABN
         SPACE    3
PURADJ   GEN,8,7,17   X'14',0,F:EI     ADJ DCB TO SET  FNE,ACCT
         DATA     X'E001',0
PURADJFID DATA    X'01000808',0,0,0,0,0,0,0,0
PURADJACT DATA    X'02010202',0,0
         DATA    0,0,0,0,0            ALLOW ROOM FOR PASS,PURGE
         SPACE    2
PURGEOPN GEN,8,24 X'14',F:EI
         DATA     X'C1000000'
         DATA     PURERR
         DATA     PURABN
         DATA     4
         SPACE    2
PURGECLS GEN,8,24 X'15',F:EI
         PZE      *0
         DATA     1
         SPACE    2
CLSPURGE GEN,8,24 X'15',F:EI
         DATA     0
         SPACE    2
WAITONE  GEN,8,24 X'F',50
         PAGE
         USECT    PURE
PURGEP   EQU      %
*
*        BAL,SR4  PURGELOG
*
*        INPUT:   NONE
*        OUTPUT:  CURRENT THRESHOLD AND GRANULE COUNT TO OC
PURGELOG EQU      %
         LW,SR1   *GRANRADAD
         AW,SR1   *GRANPACKAD
         AW,SR1   *GRANCYLAD
         BAL,SR3  BINTODEC
         LD,R4    CURGMBS           MOVE CURRENT GRAN COUNT TO MESSAGE
         MBS,R4   0
         LW,SR1   THRESH
         BAL,SR3  BINTODEC
         LD,R4    THRESMBS
         MBS,R4   0                 CURRENT THRESHOLD TO MESSAGE
         LI,R5    GRANSAV
         CAL1,2   TYPE              PRINT ON OC
         B        *SR4
         PAGE
*
*F*      NAME:    BINTODEC
*F*
*F*      PURPOSE: CONVERT THE INPUT HEXADECIMAL NUMBER TO ITS EQUIVALENT
*F*               DECIMAL EBCDIC FORRM, COMPLETE WITH COMMA.
*F*
BINTODEC EQU      %   ****
*                   CONVERTS SR1 TO DECIMAL DDD,DDD IN D3-D4 WITH
*                   LEADING BLANKS
         LI,R7    7                 6 DIGITS AND COMMA
         SLD,SR1  -32
         LW,D3    BLANKS
         LW,D4    BLANKS
BINDEC1  EQU      %
         CI,R7    4
         BNE      BINDEC2
         LI,SR1   C','              INSERT COMMA
         B        BINDEC3
BINDEC2  EQU      %                 DO CONVERSION
         DW,SR1   TEN
         AI,SR1   X'F0'
BINDEC3  EQU      %                 SET CHAR
         STB,SR1  D3,R7
         CI,SR2   0
         BE       *SR3
         LI,SR1   0
         BDR,R7   BINDEC1
         B        *SR3
         PAGE
GET:NUM  EQU      %   ****
*                 THE DECIMAL NUMBER IN SEL:COM,IX R4, IS CONVERTED TO
*                   BINARY IN D2. R4 IS STEPPED TO NON-NUMBER. EXITS
*                   VIA ERR:RET IF END IMAGE DETECTED.
         LI,D2    0
GET:NUM1 EQU      %
         LB,D1    SEL:COM,R4
         CI,D1    C','
         BE       GET:NUM2          SKIP COMMAS
         CI,D1    X'15'             NEW LINE TERMINATES STRING
         BLE      *SR4
         CI,D1    C' '              BLANK TERMINATES STRING
         BE       *SR4
         CI,D1    C'0'
         BL       *ERR:RET
         CI,D1    C'9'
         BG       *ERR:RET
         MI,D2    10
         AND,D1   L(X'F')
         AW,D2    D1
GET:NUM2 EQU      %
         BIR,R4   GET:NUM1
         B        *ERR:RET
         PAGE
GET:ACCESS EQU    %   ****
*                 LOADS SR2 WITH THE ACCESS DATE FOUND IN PURFPAR, IN
*                   PACKED FORM- YYMMDDHH. USES SR1,R1,LOCCODE1 REGS
         LI,D4    FPAR
         LI,D1    X'F'
         LI,SR2   0
         BAL,R5   LOCCODE1
         B        *SR4
         LI,R6    9
         LB,SR1   *D4,R6            GET BYTES,H,H,D,D,M,M,Y,Y
         SLD,SR1  -4
         LB,R6    ACCIX,R6
         BNEZ     %-3
         LB,R6    SR2
         AI,R6    X'FFF80'          -80 IN PACKED DECIMAL TO MAKE
         STB,R6   SR2                  NUMBER ALWAYS POSITIVE
         B        *SR4
*
*F*      NAME:    PURGEINT
*F*
*F*      PURPOSE: HANDLE PROGRAM INTERRUPTS GENERATED BY 'INT,FILL.' KEYINS.
*F*      DESCRIPTION:  THE FILL MODULE ESTABLISHES BREAK CONTROL TO ENTER
*F*               AT PURGEINT; THE DATA CELL INT IS SET TO 1 AND CONTROL
*F*               RETURNED TO THE INTERRUPTED PROCESS.  THE CELL INT
*F*               IS CHECKED PERIODICALLY FOR BEING NON-ZERO IN THE OTHER
*F*               ROUTINES; WHEN DETECTED AS NON-ZERO, ENTRY IS MADE TO PURGE
*F*               ROUTINE.
*F*
PURGEINT EQU      %
*               RECEIVES INTERRUPT AND WAKES JOB
         MTW,1    INT
         CAL1,9   5                 M:TRTN
         PAGE
GETCOM0  EQU      %
         STW,SR4  COMEXIT           SAVE EXIT ADDRESS
GETCOM   EQU      %
         LI,R5    COMMSG
         LI,R6    COMBUF
         LI,R7    79
GETCOM1  CAL1,2   KEYIN
         LB,R7    COMBUF
         LB,R8    COMBUF,R7
         CI,R8    X'15'             MUST TERMINATE WITH N/L
         BNE      GETCOM
         CI,R7    1
         BLE      COMX              RETURN TO INTERRUPTED TASK
         LW,R8    COMBUF
         SLS,R8   8
         SLS,R8   -16
         LI,R7    COMTBLSZ
GETCOM2  EQU      %
         LH,R9    COMTABLE,R7
         AND,R9   XFFFF
         CW,R8    R9
         BE       COMVECT,R7
         BDR,R7   GETCOM2
         PAGE
*
*F*      NAME:    BADCOM
*F*
*F*      PURPOSE: INFORM OPERATOR OF ERRORS IN FILL COMMAND? RESPONSES.
*F*      DESCRIPTION:  WHEN THE SYNTAX ERROR IS DETECTED IN THE
*F*               OPERATOR'S RESPONSE TO THE FILL COMMAND? QUERY,
*F*               THE MESSAGE 'EH?' IS OUTPUT TO THE OC AND THE READ
*F*               FOR A COMMAND IS REPEATED.
*F*
BADCOM   EQU      %
         LI,R5    BADCMSG
         LI,R6    COMBUF
         LI,R7    79
         B        GETCOM1
GOGETCOM BAL,R5   WRT:SAV
         B        GETCOM
*
COMX     EQU      %
         STW,R0   INT
         B        *COMEXIT          RETURN TO INTERRUPTED TASK
*
PRINT    CAL1,9   6
         B        GETCOM
*
SNAP     LCI      0
         STM,R0   REGS
         BAL,R3   SNAPPER
         B        PRINT
         PAGE
COMTABLE EQU      %
         DATA,2   0,'QU','SU','MO','DI','PU','RE','BE','SE',;
                  'ST','PR','SN'
         RES      2                 PATCHABLE EXPANSION
*
         BOUND    4
COMVECT  NOP
         B        QUIT
         B        SUSPEND
         B        MOUNTUB
         B        DITYPE            (DISPLAY OR DISMOUNT)
         B        PURGSTRT
         B        RESTART
         B        BEGIN
         B        SET
         B        STATUS
         B        PRINT
         B        SNAP
COMTBLSZ EQU      %-COMVECT-1
         RES      4                 PATCHABLE EXPANSION
         PAGE
DITYPE   EQU      %
         LD,R4    DSMTMBS
         CBS,R4   0
         BE       DISMOUNT
         BAL,R5   SKP:FLD           GET NEXT FIELD
         B        DISPALL           NO NEXT FIELD => ALL
         BAL,R5   SKP:BL
         B        DISPALL
         CI,R9    'A'
         BE       DISPALL
         SLS,R9   8
         AI,R7    1
         LB,R8    CBUFEND,R7
         STB,R8   R9,R3
         LI,SR4   GETCOM            EXIT FROM DISP ROUTINES IS *SR4
DITYPE1  EQU      %
         BAL,R5   FINDSET
         B        BADCOM
         CI,R6    DISPSIZ           PURGE MESSAGES ARE SPECIAL
         BE       PURGEMSG
         LI,R5    BA(COMBUF)+1
         LW,R4    DITABLE,R6        SOURCE STRING
         LB,R8    0,R4
         STB,R8   R5
         MBS,R4   1
         B        FINDISP,R6        GET REST OF MESSAGE
*
DISPALL  EQU      %
         LI,R6    1
DISPALL1 EQU      %
         LH,R9    SETTABLE,R6
         AND,R9   XFFFF
         BAL,SR4  DITYPE1
         AI,R6    1
         CI,R6    DISPSIZ
         BLE      DISPALL1
         B        GETCOM
*
FINDISP  EQU      %
         DATA     0
         B        REELMSG
         B        TYPEMSG
         B        DENSMSG
         B        USERBMSG
         B        SQTAPMSG
         B        MAILMSG
         B        OCDIMSG
         B        PURGEMSG
DISPSIZ  EQU      %-FINDISP-1
         RES      4                 PATCHABLE EXPANSION
         PAGE
SET      EQU      %
         LI,R6    SET2              RETURN ADDRESS
SET1     EQU      %
         BAL,R5   SKP:FLD
         B        BADCOM            NEEDS A SECOND FIELD
         CI,R9    '='
         BE       BADCOM            NEED THAT SECOND FIELD FIRST
         BAL,R5   SKP:BL
         B        BADCOM            NO SECOND FIELD HERE EITHER
         SLS,R9   8
         AI,R7    1
         LB,R8    CBUFEND,R7
         STB,R8   R9,R3
         B        0,R6
SET2     EQU      %
         BAL,R5   FINDSET
         B        BADCOM            NO SUCH ANIMAL
SET3     EQU      %
         BAL,R5   SKP:FLD1          LOOK FOR THE '='
         B        BADCOM            NOT THERE => ERROR
         CI,R9    X'40'
         BNE      SET4              IF NOT BLANK, MUST BE '='
         BAL,R5   SKP:BL            SKIP INTERVENING BLANKS
         B        BADCOM
         B        SET3              LOOK FOR THAT '='
SET4     EQU      %
         AI,R7    1                 BUMP PAST THE '='
         BAL,R5   SKP:BL            GET THE NEXT FIELD
         B        BADCOM            ALL BLANKS FOLLOW TO N/L
         B        SETVECT,R6
         PAGE
SETVECT  EQU      %
         PZE      SETVECT
         B        REELCHG
         B        TYPECHG
         B        DENSCHG
         B        USERBCHG
         B        SQMTCHG
         B        MAILCHG
         B        OCDICHG
         B        PURGCHG
         RES      4                 PATCHABLE EXPANSION
         PAGE
BEGIN    EQU      %
         BAL,R6   SET1              GET TWO CHARACTER OPTION IN R9
*                                    ERRORS IN SET GO TO BADCOM.
         LI,R6    BGNTBLSZ
BEGIN1   EQU      %
         LH,R10   BGNTBL,R6
         AND,R10  XFFFF
         CW,R9    R10
         BE       BEGIN2
         BDR,R6   BEGIN1
         B        BADCOM
BEGIN2   EQU      %
         LW,R7    LASTRUN           CHECK TO SEE IF ALREADY ACTIVE
         BEZ      BEGIN3
         LD,R4    TAPETYPE,R7       GET NAME OF ACTIVE PROCESS
         AI,R5    -BA(FPAR)+BA(COMBUF)
         MBS,R4   0
         LI,R4    BA(ACTIVTXT)
         LB,R8    0,R4
         STB,R8   R5
         MBS,R4   1
         B        TYPEIT            TELL THE GUY WHAT'S ACTIVE
BEGIN3   EQU      %
         STW,R0   INT               CLEAR THE BREAK
         B        BGNVECT,R6
*
BGNVECT  DATA     0
         B        SAVEALL
         B        SQUIRREL
         B        INCRMNTL
         B        PURGSTRT
         B        YESFL
         B        SELFILL
BGNTBLSZ EQU      %-BGNVECT-1
         RES      4                 PATCHABLE EXPANSION
*
BGNTBL   EQU      %
         DATA,2   0,'SA','SQ','IN','PU','FI','SE'
         RES      2                 PATCHABLE EXPANSION
*
ACTIVTXT TEXTC    ' IS CURRENTLY ACTIVE - MUST QUIT OR SUSPEND'
         PAGE
REELMSG  EQU      %
         LI,R4    4
         STB,R4   R5
         LW,R4    LASTREEL          HAS REEL # BEEN SET UP?
         BNEZ     REELMSG1          YES.
         LCI      7                 SAVE REGISTERS 5,6,11
         PSM,R5   ENVIR
         BAL,SR4  NOTAPE
         LCI      7                 RESTORE REGISTERS 5,6,11
         PLM,R5   ENVIR
         LI,R4    BA(LASTREEL)
         MBS,R4   0
         STW,R0   LASTREEL          PUT LASTREEL THE WAY YOU FOUND IT
         B        TYPEIT
REELMSG1 EQU      %
         LI,R4    BA(LASTREEL)
         MBS,R4   0
*
TYPEIT   AI,R5    -BA(COMBUF)-1
         STB,R5   COMBUF
         LI,R5    COMBUF
         CAL1,2   TYPE
         B        *SR4
*
REELCHG  EQU      %
         LW,R4    NOTAPFG
         BEZ      REELCHG1
         LI,R5    NOTNOW            CAN'T CHANGE WHEN ALREADY MOUNTED
         CAL1,2   TYPE
         B        GETCOM
REELCHG1 EQU      %
         LI,R4    3
REELCHG3 EQU      %
         SLS,R9   8
         AI,R7    1
         LB,R8    CBUFEND,R7
         STB,R8   R9,R3
         BDR,R4   REELCHG3
*
         BAL,R5   CHKREEL           VERIFY FORMAT OF REEL #
         B        BADCOM
         STW,R9   LASTREEL
         B        GOGETCOM
*
NOTNOW   TEXTC    'COMMAND NOT LEGAL WHEN TAPE IS ALREADY MOUNTED'
         PAGE
TYPEMSG  EQU      %
         LI,R4    BA(TAPETYP)
         STB,R2   R5
         MBS,R4   2
         B        TYPEIT
*
TYPECHG  EQU      %
         SLS,R9   8
         AI,R7    1
         LB,R8    CBUFEND,R7
         STB,R8   R9,R3
         STW,R9   TAPETYP
         B        GOGETCOM
         PAGE
USERBMSG EQU      %
         LW,R4    USERBKUP
         LW,R4    USERBTBL,R4       GET APPROPRIATE FINISHING TEXT
         LB,R8    0,R4
         STB,R8   R5
         MBS,R4   1
         B        TYPEIT
*
USERBTBL DATA     BA(NALLOWD)
         DATA     BA(IALLOWD)
*
NALLOWD  TEXTC    'NOT ALLOWED'
IALLOWD  TEXTC    'ALLOWED'
*
USERBCHG EQU      %
         LI,R4    1
         CI,R9    'Y'
         BE       USBCHG2
         LI,R4    0
         CI,R9    'N'
         BNE      BADCOM
USBCHG2  EQU      %
         STW,R4   USERBKUP
         MTW,0    NOTAPFG
         BEZ      GOGETCOM
         LW,R4    USERBKUP
         BNEZ     GOGETCOM          IF = 1, LEAVE TAPE ALONE
         BAL,SR4  ENDTAPE
         B        GOGETCOM
         PAGE
SQTAPMSG EQU      %
         LW,R4    SQMOUNT
         LW,R4    SQTAPTBL,R4
         LB,R8    0,R4
         STB,R8   R5
         MBS,R4   1
         B        TYPEIT
*
SQTAPTBL DATA     BA(DSMNTED)
         DATA     BA(MOUNTED)
*
DSMNTED  TEXTC    'DISMOUNTED AFTER EACH CALL'
MOUNTED  TEXTC    'LEFT MOUNTED'
*
SQMTCHG  EQU      %
         LI,R4    1
         CI,R9    'Y'
         BE       SQMTCHG2
         LI,R4    0
         CI,R9    'N'
         BNE      BADCOM
SQMTCHG2 EQU      %
         STW,R4   SQMOUNT
         CI,R4    0
         BNE      GOGETCOM          LEAVE IT MOUNTED
         BAL,SR4  ENDTAPE
         B        GOGETCOM
*
MOUNTUB  EQU      %
         LI,R4    1                 SET TO LEAVE SQ TAPE MOUNTED
         B        SQMTCHG2
*
DISMOUNT EQU      %
         LW,R4    LASTRUN           IS A SQUIRREL ACTIVE?
         BNEZ     BADCOM            NO, QUIT SHOULD BE USED
         BAL,SR4  ENDTAPE           TAKE DOWN THE TAPE IN GOOD FASHION
         B        GOGETCOM
         PAGE
MAILMSG  EQU      %
         LW,R4    BLDMAIL
         LW,R4    MAILTBL,R4
         LB,R8    0,R4
         STB,R8   R5
         MBS,R4   1
         B        TYPEIT
*
MAILTBL  DATA     BA(NOTBLT)
         DATA     BA(AREBLT)
*
NOTBLT   TEXTC    'NOT BUILT'
AREBLT   TEXTC    'BUILT'
*
MAILCHG  EQU      %
         LI,R4    1
         CI,R9    'Y'
         BE       MAILCHG2
         BDR,R4   %+1
         CI,R9    'N'
         BNE      BADCOM
MAILCHG2 EQU      %
         STW,R4   BLDMAIL
         B        GOGETCOM
         PAGE
OCDIMSG  EQU      %
         LW,R4    OCDISP
         LW,R4    OCDITBL,R4
         LB,R8    0,R4
         STB,R8   R5
         MBS,R4   1
         B        TYPEIT
*
OCDITBL  DATA     BA(DISPOFF)
         DATA     BA(DISPON)
*
DISPOFF  TEXTC    'TURNED OFF'
DISPON   TEXTC    'TURNED ON'
*
OCDICHG  EQU      %
         LI,R4    1
         CI,R9    'Y'
         BE       OCDICHG2
         BDR,R4   %+1
         CI,R9    'N'
         BNE      BADCOM
OCDICHG2 EQU      %
         STW,R4   OCDISP
         B        GOGETCOM
         PAGE
PURGEMSG EQU      %
         AW,R6    PURGTAP
         LW,R4    DITABLE,R6
         LI,R5    BA(COMBUF)+1
         LB,R8    0,R4
         STB,R8   R5
         MBS,R4   1
         B        TYPEIT
*
PURGCHG  EQU      %
         LI,R4    2
         CI,R9    'S'
         BE       PURGCHG2
         LI,R4    1
         CI,R9    'O'
         BE       PURGCHG2
         LI,R4    0
         CI,R9    'N'
         BNE      BADCOM
PURGCHG2 EQU      %
         STW,R4   PURGTAP
         MTW,0    NOTAPFG
         BEZ      GOGETCOM
         MTW,0    PURGTAP
         BNEZ     GOGETCOM
         LW,R4    LASTRUN
         CI,R4    4                 IS A PURGE RUNNING NOW?
         BNE      GOGETCOM           NO, LEAVE TAPE ALONE
         BAL,SR4  ENDTAPE
         B        GOGETCOM
         PAGE
DENSMSG  EQU      %
         LW,R4    DENSITY
         LW,R4    DENSTBL,R4
         LB,R8    0,R4
         STB,R8   R5
         MBS,R4   1
         B        TYPEIT
*
DENSTBL  DATA     BA(1600BPI)
         DATA     BA(800BPI)
*
1600BPI  TEXTC    '1600 BPI'
800BPI   TEXTC    '800 BPI'
*
DENSCHG  EQU      %
         LI,R4    1
         CI,R9    '8'               ONLY 800 OR 1600 UNDERSTOOD
         BE       DENSCHG1
         LI,R4    0
         CI,R9    '1'
         BNE      BADCOM
DENSCHG1 EQU      %
         STW,R4   DENSITY
         B        GOGETCOM
         PAGE
DOPURDEL EQU      %
*                 DELETES THE FILE DESCRIBED IN THE F:EI DCB AND
*                   LOGS ITS DESCRIPTION
         STW,SR3  SR3RET
         MTW,0    DEBUG
         BNEZ     %+3
         CAL1,1   PURGEOPN
*                 ERR,ABN= PURERR,PURABN; INOUT
         CAL1,1   PURGECLS
         LW,SR4   LOGGED            HAS ACTION BEEN LOGGED YET?
         BNEZ     *SR3RET           YES, BACKUP LOGGED IT
         BAL,SR4  DOPURLIST         FILE WAS NOT SAVED, MUST LOG
         B        *SR3RET
         PAGE
*
*        BAL,R5   SKP:FLD           START AT BEGINNING OF COMBUF
*            * OR *
*        BAL,R5   SKP:FLD1          BUFFER POINTER IN R7 ALREADY
*
*        INPUT:   R7 <= NEGATIVE INDEX INTO COMBUF (OPTIONAL)
*        OUTPUT:  R7 <= NEGATIVE INDEX TO FIRST BLANK OR '='
*                  FOLLOWING THE INPUT STRING. EXITS SKIPPING
*                 * OR *
*                 EXITS NORMALLY IF (N/L) DETECTED BEFORE A BLANK.
*
*        USES:    R7,R9
*
SKP:FLD  EQU      %
         LI,R7    -79               SKIP THE COUNT IN BYTE 1
SKP:FLD1 EQU      %
         LB,R9    CBUFEND,R7
         CI,R9    X'40'
         BE       1,R5
         CI,R9    '='
         BE       1,R5
         CI,R9    X'15'
         BE       0,R5
         BIR,R7   SKP:FLD1
         B        BADCOM
         PAGE
*
*        BAL,R5   SKP:BL
*
*        INPUT:   R7 <= NEGATIVE INDEX OF BLANK IN COMBUF
*        OUTPUT:  R7 <= NEGATIVE INDEX OF NEXT NON-BLANK IN COMBUF
*                  EXITS SKIPPING UNLESS (N/L) DETECTED FIRST;
*                   THEN EXIT IS NORMAL, IE TO CALL + 1
*
SKP:BL   EQU      %
         LB,R9    CBUFEND,R7
         CI,R9    X'15'
         BE       0,R5
         CI,R9    X'40'
         BNE      1,R5
         BIR,R7   SKP:BL
         B        BADCOM
*
*        BAL,R5   CHKREEL
*
*        INPUT:   R9 <= REEL NUMBER TO BE CHECKED
*        OUTPUT:  EXITS SKIPPING IF OK, NORMALLY OTHERWISE
*        USES:    R4,R8
*
CHKREEL  EQU      %
         LI,R4    -4
CHKREEL1 EQU      %
         LB,R8    R10,R4
         CB,R8    LOW,R4
         BL       0,R5
         CB,R8    HI,R4
         BG       0,R5
         BIR,R4   CHKREEL1
         B        1,R5
         PAGE
*
*        BAL,R5   FINDSET
*
*        INPUT:   R9 <= 2 BYTE FIELD TO FIND IN SETTABLE
*        OUTPUT:  R6 <= INDEX TO ENTRY IN SETTABLE
*                 EXITS SKIPPING
*                 * OR *
*                 IF NOT FOUND, EXIT TO CALL+1
*        USES:    R6,R10
*
FINDSET  EQU      %
         LI,R6    SETBLSZ
FINDSET1 EQU      %
         LH,R10   SETTABLE,R6
         AND,R10  XFFFF
         CW,R9    R10
         BE       1,R5              GOT IT
         BDR,R6   FINDSET1
         B        0,R5              NOT FOUND
*
SETTABLE EQU      %
         DATA,2   0,'RE','TY','DE','US',;
                  'SQ','MA','OC','PU'
SETBLSZ  EQU      HA(%)-HA(SETTABLE)-1
         RES      2                 PATCHABLE EXPANSION
         PAGE
         BOUND    4
STATUS   EQU      %
         LI,R6    0
         LW,R7    LASTRUN
         BEZ      SUSPSTAT          NOTHIN ACTIVE
         LI,D1    SUSPSTAT
STATSUBR EQU      %
         LD,R4    TAPETYPE,R7
         AI,R5    -BA(FPAR)+BA(COMBUF) MAKE COMBUF THE PRINT BUFFER
         MBS,R4   0
         LW,R4    STFILLER,R6
         LB,R8    0,R4
         STB,R8   R5
         MBS,R4   1
         LW,R4    ACCTADDR,R6
         LI,R8    8
         STB,R8   R5
         MBS,R4   0
         BAL,SR4  TYPEIT
         B        *D1
*
SUSPSTAT EQU      %
         LI,R6    1
         LW,R7    SUSPNDED
         BEZ      GRANDISP
         BAL,D1   STATSUBR          TELL OF SUSPENDED OPERATION
*
GRANDISP EQU      %
         BAL,SR4  PURGELOG
         B        GETCOM
*
ACTEXT   TEXTC    ' IS ACTIVE - ACCOUNT = '
SUSPTXT  TEXTC    ' IS SUSPENDED - ACCOUNT = '
*
STFILLER DATA     BA(ACTEXT)
         DATA     BA(SUSPTXT)
*
ACCTADDR DATA     BA(CONACCT)
         DATA     BA(SUSPACCT)
         PAGE
*
*F*      NAME:    DOPURLIST
*F*
*F*      PURPOSE: PRINT FILE NAME, ACCOUNT, AND LAST SAVED REEL NUMBER
*F*               OF ALL PURGED FILES  ON THE LINE PRINTER AND IN
*F*               MAILBOX FILES IN AFFECTED USER'S ACCOUNTS.
*F*
DOPURLIST EQU     %
*                 PRINTS PURGE MESSAGE FOR FID.ACCT IN M:PURGE DCB
         LB,R5    F:EO+11           POS OF SN
         LW,D1    F:EO+X'47',R5     GET SN OF OUTPUT TAPE
         MTW,0    LOGGED            HAS FILE BEEN SAVED TO TAPE?
*                                   (SN MEANINGLESS IF NOT)
         BNEZ     %+2               FILE HAS BEEN SAVED
         LW,D1    NONE              FILE HAS NOT BEEN SAVED
         STW,D1   PURGMSG+1
*                 MOVE FID W/ TRAILING BLANKS
         LD,R6    MOVE:FID          ADDRESSES FOR MBS
         LB,D1    F:EI+23           GET COUNT OF FILE NAME
         STB,D1   R7                COUNT
         MBS,R6   0                 MOVE FID
         AI,D1    20                NUMBER OF CHARACTERS IN BASE MSG
         STB,D1   PURGMSG           TOTAL MESSAGE LENGTH
*    PRINT MESSAGE    'HH:MM MMM DD BY 'ACCOUNT' ON DDLD   PURGED FILE "F I L E
*
         LI,SR3   MAILFPT           ADDR. OF MSG
         LW,D4    BLDMAIL           0 => NO MAILBOX
*                 CHECK WHETHER TIME HAS CHANGED
         LW,R6    *TIMEAD
         XW,R6    MTIME
         CW,R6    MTIME
         BNE      MAILBOX           RET MAILBOX IS *SR4
         B        FMAILBX           TIME HAS NOT CHANGED
         PAGE
DOPURTAP  EQU     %
         STW,SR4  BKQX              SAVE LINK REG
         STW,R1   LOGGED            SET LOGGED IN BACKUP FLAG
*
         BAL,SR4  AUTOBACK          GO BACKUP FILE ON TAPE
*
         B        *BKQX
         TITLE    'MAIN PROGRAM--PURGE'
*                 PURGE IS ENTERRED FROM BACKUP ON EACH EXECUTION OF
*                 THE PROGRAMAND AT VARIOUS POINTS DURING
*                 BACKUP AND FILL.
*
*                 INITIALIZE
PURGE    EQU      %
         STW,SR4   PURGEXIT
         BAL,SR4   DO:REGS4
*                   CHK IF ANY THING TO DO
         LW,SR4   PURGEXIT          GET EXIT ADDRESS FOR GETCOM
         MTW,0    INT
         BG       GETCOM0
         LW,R5    *GRANRADAD        CALCULATE CURRENT NUMBER
         AW,R5    *GRANPACKAD        OF PFA GRANULES AVAILABLE.
         AW,R5    *GRANCYLAD
         BLZ      PURGEX            COUNTS HAVEN'T BEEN SET UP YET
         CW,R5    THRESH
         BL       PURGESET          WE'RE UNDER THE THRESHOLD
         CW,R5    ITHRESH           HAVE WE GONE ABOVE INITIAL THRESHOLD
         BL       PURGEX            NO, LEAVE THINGS ALONE AND EXIT
         LW,R5    ITHRESH           PUT THRESHOLD BACK TO INITIAL
         STW,R5   THRESH             VALUE AND
         BAL,R5   WRT:SAV             WRITE IT OUT TO F:BREC
         B        PURGEX            OK, NOW GET OUT
PURGESET EQU      %
         LI,R5    THEXCEED
         CAL1,2   TYPE
         BAL,SR4  PURGELOG          TELL THE CURRENT SITUATION
         LW,R5    THRESH            PICK UP CURRENT THRESHOLD AND
         SLS,R5   -2                 REDUCE TO 1/4 PREVIOUS VALUE
         STW,R5   THRESH
         MTW,0    DEBUG
         BNEZ     %+2
         STW,R5   *GRANMINAD        TELL ALLYCAT ABOUT THE CHANGE
         BAL,R5   WRT:SAV           SAVE NEW INFORMATION IN F:BREC
         LW,SR1   THRESH            PRINT NEW THRESHOLD.
         BAL,SR3  BINTODEC
         LD,R4    NEWTHMBS
         MBS,R4   0
         LI,R5    NEWTHMSG
         CAL1,2   TYPE
         B        PURGEX
*
PURGSTRT EQU      %
         LI,R5    ENTPURGE
         LI,R6    SEL:COM:BUF
         LI,R7    40
         CAL1,2   KEYIN
*
         STW,R0   INT               CLEAR INTERRUPT FLAG
         STW,R0   EXPIRFG           CLEAR EXPIRED FLAG
         STW,R0   PURALLX           CLEAR PURGE ALL EXP. IND.
         LI,R4    -79               INITIALIZE INDEX FOR SCAN OF INPUT
         LI,D1    PURGEKNO          SET ERROR EXIT AND SAVE PREVIOUS
         XW,D1    ERR:RET
         STW,D1   ERR:RET1
*                   DETERMINE COMMAND
         BAL,SR3  SK:BL             FIND START OF COMMAND,D1=1ST CHAR
         CI,D1    'M'               MIN,PURGE,OR (DEFAULT) NONE
         BE       PURMIN
         LI,SR2   PURGETEXTC        ASSUME 'PURGE', SBR EXITS TO NONE
         BAL,SR3  FIND:STRG           IF NOT PURGE
         BAL,SR3  SK:BL
         STW,R0   ALLFLAG
         LI,SR2   ALLTEXTC
         CI,D1    'A'
         BNE      %+3
         BAL,SR3  FIND:STRG
         STW,R1   ALLFLAG           IS 'ALL'-SET FLAG
         BAL,SR3  SK:BL
         CI,D1    'U'
         BE       PURUNTIL
         CI,D1    'O'               WAS KEYIN  'ALL OLDER'
         BE       OLDER             YES
         LI,SR2   XTXT              ' ALL X' KEYIN
         BAL,SR3  FIND:STRG
         MTW,1    EXPIRFG           FLAG PURGE ONLY EXPIRED FILES
         LB,D1    SEL:COM,R4        GET NEXT CHAR
         CI,D1    X'15'             N/L OR L/F
         BLE      ALLEXPUR          YES--PURGE ALL EXP.
         BAL,SR3  SK:BL
         CI,D1    'U'               WAS KEYIN 'ALLX UNTIL'
         BE       PURUNTIL          YES
         CI,D1    'O'
         BE       OLDER
         B        PURGEKNO
*
*  HERE TO PURGE ALL EXPIRED FILES
*
ALLEXPUR EQU      %
         MTW,1    PURALLX           SET PURGE ALL EXP IND
         BAL,SR2  DOPURGE
         BAL,SR4  PURGELOG
         B        PURGEX
*
OLDER    EQU      %
*
         LI,SR2   OLDERTEXTC
         BAL,SR3  FIND:STRG
         BAL,SR3  SK:BL
*                   NOW,1-4 DIGIT DAYS OR COLON 2-DIGIT HOURS
         LI,D2    'O'
         STW,D2   PTYPE             PURGE TYPE IS 'OLDER'
         CI,D1    ':'
         BE       PURHRS            COLON SAYS HOURS, NONE SAYS DAYS
         BAL,SR4  GET:NUM
         MI,D2    24                CONVERT TO HOURS
         B        PUROLD
PURHRS   EQU      %
         AI,R4    1                 SKIP :
         BAL,SR4  GET:NUM
PUROLD   EQU      %                 D2=HRS FOR BACKING DATE
         LW,R5    *DATEAD           SET PDATE IN BINARY 1/2-WDS
         STW,R5   PDATE
         LW,R5    *DATE1AD
         STW,R5   PDATE+1
         LH,R5    *TIMEAD
         STH,R5   PDATE+1
         LI,R5    -4
PUROLD1  EQU      %                 NOW CONVERT 4 1/2-WDS TO BINARY
         LH,D1    PDATE+2,R5
         AND,D1   L(X'F0F')
         LB,D4    D1,R2
         MI,D4    10
         LB,D1    D1,R3
         AW,D1    D4
         STH,D1   PDATE+2,R5
         BIR,R5   PUROLD1
*                   SUBTRACT HOURS FROM PDATE--FIRST HOURS
         LH,D4    PDATE,R2          HRS
         LH,D3    PDATE,R1          DAYS
         SW,D4    D2
         BGEZ     PUROLD2
         AI,D3    -1                -1 DAY
         AI,D4    24                + 24 HRS
         B        %-3
PUROLD2  EQU      %
         STH,D4   PDATE,R2          HRS ALL SET-NOW FIX DAYS
         LH,R7    PDATE             NO
         CI,D3    1
         BGE      PUROLD4           DAY OK
PUROLD2A EQU      %
         BDR,R7   PUROLD3
         MTH,-1   PDATE,R3          MO=0,DECR YR
         AI,R7    12
PUROLD3  EQU      %
         AH,D3    DAYS:MON,R7       ADD DAYS/MO  (IGNORE LEAP YEAR)
         BL       PUROLD2A
PUROLD4  EQU      %                 UPDATE FINISHED-STORE & CONVERT
         STH,D3   PDATE,R1          DAYS
         STH,R7   PDATE             MO
*                   NOW CONVERT BACK TO BINARY
         LI,R7    -4
PUROLD5  EQU      %
         LH,D1    PDATE+2,R7
         SAD,D1   -32
         DW,D1    L(10)
         STB,D2   D1,R2
         OR,D1    L(C'00')          MAKE EBCDIC
         STH,D1   PDATE+2,R7
         BIR,R7   PUROLD5
         B        PURGEM            GO DO PURGE
         SPACE    3
PURUNTIL EQU      %
         LI,D1    'U'
         STW,D1   PTYPE             PURGE TYPE='UNTIL'
         LI,SR2   UNTILTEXTC
         BAL,SR3  FIND:STRG         VERIFY 'UNTIL'
         BAL,SR3  SK:BL
         BAL,SR4  GET:NUM           GET BINARY NUMBER
         STW,D2   PNUM              PURGE UNTIL PNUM GRANULES AVALABLE
*
*
PURGEM   EQU      %
         BAL,SR2  DOPURGE
         BAL,SR4  PURGELOG          LOG GRANS NOW AVAIL
PURGESET1 EQU     %
*                                   RESTORE ERR:RET
         LW,D1    ERR:RET1
         STW,D1   ERR:RET
         LW,SR4   PURGEXIT
         B        PURGE
         SPACE    3
PURGEKNO EQU      %
*                  COMMAND WAS 'NONE' OR HAD AN ERROR
         LI,R5    NONETEXTC
         CAL1,2   TYPE
         LW,SR4   PURGEXIT
         B        PURGE
         SPACE    3
PURMIN   EQU      %
*                   ROUTINE TO RESET  THRESHOLD VALUE
         LI,SR2   MINTEXTC
         BAL,SR3  FIND:STRG
         BAL,SR3  SK:BL
         CI,D1    '='
         BNE      %+2
         BIR,R4   %-3               IGNORE = IN MIN COMMAND
         BAL,SR4  GET:NUM
         STW,D2   THRESH            SET NEW THRESHOLD
         STW,D2   ITHRESH
         MTW,0    DEBUG
         BGEZ     %+2
         STW,D2   *GRANMINAD
         BAL,R5   WRT:SAV            AND SAVE IS IN F:BREC
         B        GETCOM
*              EXIT ROUTINE
*
PURGEX   EQU      %
         STW,R0   INT               CLEAR THE INT FLAG
         B         *PURGEXIT
         TITLE    'DOPURGE SUBROUTINE'
         SPACE    2
DOPURGE  EQU      %
         STW,SR2  DOPURX            SAVE EXIT
         LI,R4    4
         STW,R4   LASTRUN
         LW,D1    *DATE1AD          SETUP CDATE FOR COMPARISONS
         STW,D1   CDATE+1
         LH,D1    *TIMEAD
         STH,D1   CDATE+1           HHYY
         LW,D1    *DATEAD
         STW,D1   CDATE             MMDD
         STW,R0   PURACT
         STW,R0   PURACT+1
         LI,SR2   MAXABN            INITIALIZE ABN COUNTS
         STW,SR2  ABNCT
         LI,SR2   MAXABNAC
         STW,SR2  ABNACCT
*
         LW,R4    PURGTAP
         LW,R5    PURGMSGS,R4
         SLS,R5   -2                MAKE A WORD ADDRESS
         CAL1,2   TYPE              TELL THE DISPOSITION OF FILES
         LI,R6    25                HALF A MINUTE WAIT FOR NONE SAVED
         LW,R4    R4
         BNEZ     PURNXA            FILES WILL BE SAVED
         STH,R6   SLP:FPT,R1
         CAL1,8   SLP:FPT           GIVE OPERATOR HALF A MINUTE TO
*                                    THINK ABOUT NOT SAVING FILES.
PURNXA   EQU      %
         STW,R0   ENDAC
         CAL1,1   NXACT             GET NEXT ACCT-IF NONE,RETURN PURABN
         LCI      2
         LM,D1    F:EI+32           GET ACCOUNT FROM DCB
         STM,D1   PURACT
         STM,D1   CONACCT           SET CURRENT ACCOUNT FOR DISPLAY
         CD,D1    SYSTEXT
         BE       PURNXA            DONT PURGE :SYS
PURNXF   EQU      %
         MTW,0    INT
         BEZ      %+2
         BAL,SR4  GETCOM0           SEE WHAT HE WANTS NOW.
         STW,R0   LOGGED            SET NOT LOGGED FLAG.
         CAL1,1   NXFID             GET NEXT FID -ETC
         LI,D1    2
         CW,D1    EI:DESC+1
         BAZ       %+2              NOT LAST FID THIS ACCT
         STW,R1   ENDAC
         LI,D1    X'200'
         CW,D1    EI:DESC+1
         BANZ     DOPURNXT          NOPURGE SET...SKIP
*                   CHK IF EXPIRED
         LI,D4    FPAR
         LI,D1    4                 EXPIRATION CODE
         BAL,R5   LOCCODE1
         B        PURNXP            EXP NOT FOUND--VERY STRANGE
         AI,D4    1
         LW,D2    NEVER
         CW,D2    *D4
         BE       DOPURNXT
         MTW,0    EXPIRFG           PURGE ONLY EXPIR. FILES
         BEZ      PURNXP            NO
         LI,D2    CDATE
         BAL,R5   COMPDAT
         B        DOPURNXT
         MTW,0    PURALLX           PURGE ALL EXPIR.
         BEZ      PURNXP            NO
*                 EXPIRED, CHK BACKUP BITS
         MTW,1    EXPIRCNT          CNT NO. EXPIRED FILES PURGED
*
         LW,D2    L(X'F0000')
         CS,D2    EI:DESC+1
         BNE      SAVECHK
         LW,D2    BACKUPALLD        IS BACKUP REQUIRED
         BNEZ     PURNXP1           GO BACKUP ON TAPE
         B        SAVECHK
         SPACE    2
DOPURNXT EQU      %
         LW,D1    ENDAC
         BEZ      PURNXF            TRY NEXT FILE
         B        PURNXA            TRY NEXT ACCOUNT
PURNXP   EQU      %         UNEXPIRED
*                     SKIP IF SYNON
         LI,D4    X'4000'
         CW,D4    EI:DESC+1
         BANZ     DOPURNXT
*                   CHK ACCORDING TO PURGE TYPE, 'O' OR 'U'
         LW,D1    PTYPE
         CI,D1    'U'
         BE       PURGEU            'UNTIL' TYPE
*                   DO PURGE 'OLDER'
*                   COMPARE ACCESS DATE WITH PURGE DATE
         LI,D4    FPAR
         LI,D1    X'F'              ACCESS VLP
         BAL,R5   LOCCODE1
         B        DOPURNXT          NOT FOUND-NEVER HAPPEN
         LB,D1    *D4,R2
         BEZ      DOPURNXT          NO ACCESS DATE SET
         LI,D2    PDATE
         AI,D4    1
         BAL,R5   COMPDAT
         B        DOPURNXT          ACCESS SINCE PURGE DATE
*                   PURGE IF BACKED UP OR,IF 'ALL',PURGE IF NOBACK UP
*                     SET OR ENQUEUE FOR BACKUP-PURGE IF NOBACKUP=0
         LW,D2    L(X'F0000')
         CS,D2    EI:DESC+1
         BNE      SAVECHK           BACKED UP.  CHECK FOR SAVE ANYWAY
         LW,D1    ALLFLAG
         BEZ      DOPURNXT          NOT BACKED UP, NOT AN 'ALL' => SKIP
PURNXP1  EQU      %
         LW,D1    PURGTAP
         CI,D1    1
         BL       PURZAP            DELETE WITHOUT SAVING
*                                   FALL THROUGH => SAVE ON ONE SET
*                                    OR SAVE IF NOT DONE ALREADY
PURENQ   EQU      %
         BAL,SR4  DOPURTAP          MAKE THE PURGE TAPE
PURZAP   EQU      %
         BAL,SR3  DOPURDEL
         B        DOPURNXT          GET NEXT FILE
*
SAVECHK  LW,D1    PURGTAP
         CI,D1    1
         BE       PURENQ            ALL FILES ARE TO BE SAVED
         B        PURZAP            HAS BEEN SAVED ALREADY OR
*                                    WE DON'T CARE.
PURGEU   EQU      %
*                   DO PURGE 'UNTIL'
         LW,D2    L(X'F0000')
         CS,D2    EI:DESC+1
         BNE      %+3
         LW,D2    ALLFLAG
         BEZ      DOPURNXT          NOT BACKED, NOT AN 'ALL'--SKIP IT
*                   MERGE INTO PURGE TABLE
         LW,SR2   PURDYN
         BNEZ     PURDOENT
         CAL1,8   GET:DYN
         BCR,8    PURSPG
         B        DOPURNXT
PURSPG   EQU      %
         STW,SR2  PURDYN
         AI,SR2   -12
         STW,SR2  PURDYNPRE         ADDRESS TO REFERENCE PREVIOUS ENTRY
         STW,R0   PURDYNIX
PURDOENT EQU      %
         LW,R7    PURDYNIX
         CW,R7    DYNBYT            START WITH 2040 BYTES I.E. 1 PG
         BL       PURMOVENT
*                   TABLE IS FULL-CHK IF THIS FID OLDER
         BAL,SR4  GET:ACCESS
         AI,R7    -12               IX OF LAST ENTRY
         CW,SR2   *PURDYN,R7
         BGE      DOPURNXT          TABLE ENTRY IS OLDER
*                                   REPLACE ENTRY
PURMOVENT EQU     %
         BAL,SR4  GET:ACCESS
         STW,SR2  ENACS
*                   GET DYNAM & STAT DESC AND SIZE
         LI,D4    FPAR
         LI,D1    X'D'              SIZE
         BAL,R5   LOCCODE1
         B        DOPURNXT
         LW,SR2   *D4,R1
         LW,SR1   EI:DESC+1
         SLS,SR1  -8
         STH,SR1  SR2
         STW,SR2  ENDSZ
*               MOVE ACCT AND FID
         LCI      2
         LM,SR1   F:EI+32           GET ACCOUNT FROM DCB
         STM,SR1  ENACT
         LCI      8
         LM,SR1   F:EI+23
         STM,SR1  ENFID
         AI,R7    12
         STW,R7   PURDYNIX          SAVE NEW INDEX
*               NOW SORT TABLE ON INCREASING ACCESS DATE
PURSORT  EQU      %
         AI,R7    -12               STEP TO PRECEEDING ENTRY
         BEZ      PURMERGE          TOP OF TABLE
         LW,D1    ENACS             ACCESS DATE
         CW,D1    *PURDYNPRE,R7
         BGE      PURMERGE          FOUND SLOT
*                  SHOVE ENTRY DOWN
         LCI      12
         LM,SR1   *PURDYNPRE,R7
         STM,SR1  *PURDYN,R7
         B        PURSORT
*              MOVE IN NEW ENTRY
PURMERGE EQU      %
         LCI      12
         LM,SR1   ENACS
         STM,SR1  *PURDYN,R7
*                 RESTORE R0-R3
         LI,R0    0
         LI,R1    1
         LI,R2    2
         LI,R3    3
         B        DOPURNXT            NEXT!
         PAGE
*
*F*      NAME:    PURABN
*F*      ENTRY:   PURERR
*F*
*F*      PURPOSE: HANDLE ERROR AND ABNORMAL RETURNS FROM THE F:EI DCB
*F*               WHICH OCCUR DURING A PURGE PROCESS.  PRIMARY PURPOSE
*F*               IS TO DETECT THE 'NO MORE ACCOUNTS' ABNORMAL FROM
*F*               THE OPEN-NEXT CAL.
*F*      DESCRIPTION:  CONTENTS OF REGISTER 10 DETERMINE ACTION TAKEN.
*F*      REFERENCES:  BATCH PROCESSING REFERENCE MANUAL, APPENDIX B
*F*               (MONITOR ERROR MESSAGES)
*F*
PURABN   EQU      %
PURERR   EQU      %
*
         SLS,SR3  -17
         CI,SR3   X'101'            END ACCTS CODE
         BE       PURCHTY            YES
         CI,SR3   X'100'            NOMORE FILES THIS ACCT--SHOULDNT BE
         BE       PURNXA
         SLS,SR3  -7
         CI,SR3   X'A'              CLOSED A CLOSED DCB-IGNORE
         BE       *SR1
         CI,SR3   3                 NON-EXISTENT FILE
         BE       *SR3RET
         CI,SR3   X'2E'             ALREADY OPEN
         BNE      PURABN1
         CAL1,1   CLSPURGE
*                 NO OPTIONS
         B        DOPURABC
PURABN1  EQU      %
         CI,SR3   X'55'             SYSTEM OVERLOAD
         BNE      DOPURABC          CHK ABN LOOP
         CAL1,8   WAITONE           WAIT A MINUTE & TRY AGAIN
         AI,SR1   -1
         B        *SR1
DOPURABC EQU      %                 CHK FOR POSSIBLE ABN LOOP
         MTW,-1   ABNCT
         BG       DOPURNXT
         LI,SR3   MAXABN            RESET CTR AND GO TO NXT ACCT
         STW,SR3  ABNCT
         MTW,-1   ABNACCT
         BG       PURNXA
         B        DOPUROUT          TOO MUCH TRUBL--GET OUT
         SPACE    3
PURCHTY  EQU      %
         LW,D1    PTYPE
         CI,D1    'U'
         BNE      DOPUROUT          NOT 'UNTIL' SO IS DONE
*               PROCESS PURGE TABLE
         LW,D1    PURDYN
         BEZ      DOPUROUT          IF NO PAGES,FOUND NONE TO PURGE
         LI,R7    -12
PURUN    EQU      %
         STW,R0   LOGGED            SET NOT LOGGED FLAG
         AI,R7    12
         STW,R7   PURIX
         CW,R7    PURDYNIX
         BGE      DOPUROUT          NO MORE ENTRIES
*               MOVE FID & ACCT INTO DCB
         AI,R7    2                 START OF ACCT
         LCI      2
         LM,SR1   *PURDYN,R7        ACCT
         STM,SR1  PURADJACT+1
         AI,R7    2
         LCI      8
         LM,SR1   *PURDYN,R7        FNE
         STM,SR1  PURADJFID+1
         CAL1,1   PURADJ            ADJUST DCB
*               CHK WHETHER BACKED UP
         AI,R7    -3
         CW,R1    PURGTAP           WAS BACKUP TO TAPE REQUESTED?
         BL       PURDEL            NO BACKUP AT ALL REQUESTED
         BE       PURTAP            BACKUP OF EVERYTHING REQUESTED
*                                   FALL THRU => SELECTIVE BACKUP
         LW,D2    L(X'F000000')
         CS,D2    *PURDYN,R7
         BNE      PURDEL            IS BACKED
         LW,D2    L(X'80000')
         CW,D2    *PURDYN,R7
         BANZ     PURDEL            'NOBACKUP' IS SET
*                 BACKUP ON TAPE
PURTAP   EQU      %
         BAL,SR4  DOPURTAP
*               DELETE FILE
PURDEL   EQU      %
         BAL,SR3  DOPURDEL
*              CHECK IF ANY MORE NECESSARY
PURTHRU  EQU      %
         LW,R7    PURIX
         LW,D1    *GRANRADAD
         AW,D1    *GRANPACKAD
         CW,D1    PNUM
         BL       PURUN             NEED MORE
*               PURGE COMPLETED
DOPUROUT EQU      %
         CAL1,9   6                 CLOSE OUT SYMBIONTS AND PRINT
         BAL,SR4  ENDTAPE           CLOSE OUT THE TAPE, IF ANY.
*               RELEASE DYNAM PAGE, IF ANY
         LI,D1    0
         XW,D1    PURDYN
         BEZ      %+2
         CAL1,8   FREE:DYN
         B        *DOPURX
         PAGE
*
*F*      NAME:    DO:TABLES:ADS
*F*
*F*      PURPOSE: OBTAIN ACCESS TO CERTAIN MONITOR DATA AREAS
*F*      DESCRIPTION:  THE MONITOR ADDRESS GRANRESET, GRANMIN, PURGEFLAG,
*F*               GRANRAD, GRANPACK, DATE AND TIME ARE MAPPED INTO FILL
*F*               WITH AN M:CVM CAL.  THESE LOW-CORE CELLS THEN BECOME
*F*               AVAILABLE TO FILL FOR READ AND STORE.
*F*
DO:TABLES:ADS  EQU  %
         DEF      DO:TABLES:ADS
         CAL1,8   GET:DYN1
         STW,SR2  SAD:FPT+1
         CAL1,8   FREE:VIR
         CAL1,8   SAD:FPT
         LI,SR3   X'1FE00'
         AND,SR3  INDADS
         LW,SR1   SAD:FPT+1
         SW,SR1   SR3
         LI,R5    NINADS
         AWM,SR1  INDADS-1,R5
         BDR,R5   %-1
         LW,SR1   SAD:FPT+1
         LI,SR2   X'1FE00'
         CS,SR1   TIMEAD
         BE       *SR4
         LI,R5    X'200'
         AWM,R5   SAD:FPT+1
         AWM,R5   SAD:FPT
         CAL1,8   GET:DYN1
         CAL1,8   FREE:VIR
         CAL1,8   SAD:FPT
         B        *SR4
         END

