         SYSTEM   SIG7P
*
*        ALL DEFS IN FILL FOLLOW
*
         DEF      FILL,FILLD,COMPDAT
         DEF      KEYIN,TYPE,TRUNC
         DEF      ERBCK,USRABN,USRERR
         DEF      SEL:COM,SEL:COM:BUF,FIND:STRG
         DEF      SK:BL,SELKEY,TAPETYPE
         DEF      DEBUG,PATCH,SELFILL
         DEF      HI,LOW,YESFL
         DEF      NO:FILL
*
*        ALL REFS IN FILL FOLLOW
*
         REF      DO:TIME,DO:TABLES:ADS,BSR1
         REF      PURGE,SLP:FPT,F:BREC
         REF      F:TI,F:SEL,F:BACK
         REF      F:USR,RELEASE,NMPG
         REF      BUFSZ,BUF,DATACCT
         REF      BLABL,MAILBOX,PURGEINT
         REF      GETBUF,TVLPTBL,LOCCODE
         REF      MOVEVLP,VLPTBL,FPAR
         REF      DUMMY,DEFAULT,SL:EX
         REF      LOCCODE1,LASTREELX,REELTMP
         REF      DATEAD,TIMEAD,TAPETYP
         REF      DATE1AD,BACKXT,BB1
         REF      BACKUP,TRAPPER,SNAPPER
         REF      J:JIT,UB:PRIOB,FUSR:DESC
         REF      EOACCT,BACKUPD,PURGED
         REF      PURGEP,MAILD,MAIL
         REF      VLPTSIZ,TVLPTSZ,GRANRADAD
         REF      GRANPACKAD,PRDCRM,PRDPRM
         REF      PGINCRM,NOTAPFG,LASTRUN
         REF      LASTACCT
**
**                DEFINE STANDARD REGISTERS AND CONDITION CODES
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
SR1      EQU      8
SR2      EQU      9
SR3      EQU      10
SR4      EQU      11
D1       EQU      12
D2       EQU      13
D3       EQU      14
D4       EQU      15
R8       EQU      8
R9       EQU      9
R10      EQU      10
R11      EQU      11
R12      EQU      12
R13      EQU      13
R14      EQU      14
R15      EQU      15
**  DISPLACEMENT VALUES FOR DCB
VPT:SIZ  EQU      112
FL:TAPE  EQU      F:TI
FUSRACCT EQU      F:USR+32
LBLACCT  EQU      BLABL+1
LBLORG   EQU      BLABL+3
LBLRSTOR EQU      BLABL+4
LBLDATE  EQU      BLABL+5
LBLVLPS  EQU      BLABL+7
         TITLE    '**  DATA  **'
*                 THE FOLLOWING MUST BE CONTIGUOUS & IN ORDER
FILLD    EQU      %
         TEXT     'FILL LOCATIONS: DATA,PROCEDURE'
         DATA     FILLD,FILL
         TEXT     'BACKUP'
         DATA     BACKUPD,BACKUP
         TEXT     'PURGE'
         DATA     PURGED,PURGEP
         TEXT     'MAILBOX'
         DATA     MAILD,MAIL
FILL:TEXTC TEXTC  'FILL'
         TEXTC    '='
         TEXTC    '('
RTPAREN  TEXTC    ')'
         TEXTC    ','
         TEXTC    '('
         TEXTC    'REEL'
         TEXTC    '='
         TEXTC    ')'
*                 UP TO THIS POINT.
*
*                 THESE STRINGS ARE FOR LEGAL RANGES OF VALUES IN
*                  REEL NUMBERS (DDLD).  NEGATIVE INDEXING IS USED
         TEXT     '00AA'
LOW      EQU      %
         TEXT     '99Z9'
HI       EQU      %
SELKEY   TEXTC    'SEL:FIL'
FSAVE    TEXT     'FSAVE'
SQRL     TEXT     'SQUIRREL'
INCR     TEXT     'INCREMENTAL'
SAVALL   TEXT     'SAVEALL'
PURG     TEXT     'PURGE'
FILLTXT  TEXT     'FILL'
SELFILTX TEXT     'SELECTIVE FILL'
FILLER   TEXT     ' TAPE CREATED ON '
         BOUND    8
MBS:T:SB DATA     TACT0,16**22+1
CBS:ACT1 DATA     BA(LBLACCT),8**24+BA(FUSRACCT)
CBS:ACT2 DATA     BA(LBLACCT),8**24+BA(ZAPACCT)
TAPETYPE DATA     BA(FSAVE)
         GEN,8,24 5,BA(FPAR)+1
         DATA     BA(SAVALL)
         GEN,8,24 7,BA(FPAR)+1
         DATA     BA(INCR)
         GEN,8,24 11,BA(FPAR)+1
         DATA     BA(SQRL)
         GEN,8,24 8,BA(FPAR)+1
         DATA     BA(PURG)
         GEN,8,24 5,BA(FPAR)+1
         DATA     BA(FILLTXT)
         GEN,8,24 4,BA(FPAR)+1
         DATA     BA(SELFILTX)
         GEN,8,24 14,BA(FPAR)+1
CUR:ACCT DATA     0,0
MAIL:AC  DATA     0,0               DONT MOVE FROM DOUBLE WORD
MLBXNM   TEXT     ' MAILBOX'
*
*                 TPY SELFIL ENTRY
TACT0    DATA     0
TACT1    DATA     0
TFIDPTR  DATA     0
TSN      DATA     0
*                 TPY ENTRY FOR FID FOR SELFIL
TFID     DATA     0,0,0,0,0,0,0,0
NO:FILL:MESS TEXTC  'UNFILLED REQUEST - FID'
NO:FILL:FID EQU  %
         DO1      8
         DATA     C'    '
*                 BAD SELFIL COMMAND BUFFER
BAD:COM:MESS TEXTC  'BAD SEL:FIL INPUT  '
SEL:COM:BUF EQU   %
         DO1      20
         DATA     '    '
SEL:COM  EQU      %                 LABEL FOR PRECEEDING 20 WORD BUFFER
ERR:RET  PZE      BAD:SEL:COM
ERR:RET1 DATA     0
         DEF      ERR:RET1,ERR:RET
SEL:BUF  DATA     0
SELFID:PTR DATA   0
SELECT   DATA     0                 1=SELECTIVE FILL
SPBYCT   RES      1
SR1X     DATA     0
57ERR    PZE                        RETURN ADDRESS FOR A 57 ERR
R47      DATA     0,0,0,0
MAILPAR  PZE      NOMSG
         PZE      MAIL:AC
MAILSUC  PZE      SUCCESS
         PZE      MAIL:AC
NO:FILL:PAR  DATA NO:FILL:MESS
         DATA     MAIL:AC
DAYMONTH DATA,1   0,31,28,31,30,31,30,31,31,30,31,30,31,0
         BOUND    4
SUCCESS TEXTC     'FILLED                   '
         RES      9
NOMSG    TEXTC    'ERROR      FAILED TO RECOVER                  '
         RES      9
KADR     TEXTC    'BACKUP'
FILLINIT TEXTC    'FILL GHOST INITIATED - ';
                  ,'USE ''INT,FILL.'' FOR COMMANDS'
OPERMSG  TEXTC    'ARE THERE MORE SETS OF BACKUP TAPES(Y/N)'
BADSEQ   TEXTC    'FILE OUT OF SEQUENCE-QUIT OR CONTINUE(Q/C)'
NTRREEL  TEXTC    'FILL REEL NUMBER='
STARTFILE TEXTC   'SKIP TO FILE '
NOGRANS  TEXTC    'INSUFFICIENT PHYSICAL STORAGE TO COMPLETE FILL'
NOMSG:FAIL TEXT   'FAILED TO RECOVER'
NOMSG:FOLL TEXT   'FOLLOWING FILE   '
FILCNT   DATA     0
         BOUND    8
ZAPFLAG  EQU      %
YES      PZE                        DONT DISTURB ORDER FOR DW STUFF
FID:ACCT EQU      %                 INPUT BUFFER--FID & ACCT
         DO1      11
         DATA     0
START:ACCT  DATA  0,0               STARTING ACCT FOR FILL
TIME     RES      2
SYNFLAG  PZE                        SYNON FILE FLAG
         TITLE    '**  FPT  **'
*F:USR
*                 OPEN USER OR TEST USER (DISK)
USER:FIL:RES GEN,8,7,17  X'14',0,F:USR      RESTORE USER:FIL
USER:FIL GEN,8,7,17 X'14',,F:USR    PARAMETER LIST TO OPEN USR FILE
         DATA     X'C7681B39'
         PZE      USRERR
         PZE      USRABN
USER:ORG DATA     0
         DATA     1                 SEQUENTIAL ACCESS
USER:MOD DATA     2                 OUTPUT MODE
         DATA     2                 SAVE
         DATA     USER:FPAR
KEYMAX   DATA     0
URSTORE  DATA     0
USER:VPT RES      VPT:SIZ
USER:FPAR RES     VPT:SIZ
         PAGE
*FL:TAPE
*                 TAPE READ
         BOUND    8
*
*  FPT  FOR M:MOVE FOR 'FILL'
*
TAPEREAD   GEN,8,7,17    X'0E',0,FL:TAPE
         DATA     X'F8000000'
         DATA     MOERR             ERR RET
         DATA     MOABN             ABN RET
         DATA     F:USR             OUTPUT DCB
BUFRD    DATA     0                 BUF LOC
         DATA     0                 BUF SIZ
         SPACE    2
*                 TEST FILE/ADJUST DCB FPTS
         SPACE 2
FL:TAPE:OPN EQU   %
         GEN,8,7,17 X'14',0,FL:TAPE ADJUST DCB  W/VLPS
         DATA     X'00006002'
         DATA     X'01010000'
         DATA     1                 IN
FL:VOL   DATA     0                 VOL
FL:TAPE:SN DATA,1 7,1,36,36
         DATA  '   0','   1','   2','   3','   4','   5','   6','   7'
         DATA  '   8','   9','   A','   B','   C','   D','   E','   F'
         DATA  '   G','   H','   I','   J','   K','   L','   M','   N'
         DATA  '   O','   P','   Q','   R','   S','   T','   U','   V'
         DATA  '   W','   X','   Y','   Z'
*
         SPACE    2
FPT:SPEC GEN,8,7,17  X'14',4,F:USR  TEST FILE W/FPARAM
         DATA     X'C0200000'
         DATA     SPECERR
         DATA     SPECABN
         DATA     USER:FPAR
         SPACE    2
TF:SPEC  GEN,8,7,17  X'14',4,F:USR   TEST FILE W/O FPARAM
         DATA     X'C0200400'       NXTF
         DATA     SPECERR,SPECABN,0  ERR,ABN,FPARAM
         SPACE    2
INTPURGE GEN,8,24 X'0E',PURGEINT
         SPACE    2
KEYIN    GEN,8,24 4,0
         DATA     X'E0000000'
         PZE      *R5
         PZE      *R6
         PZE      *R7
         SPACE    2
OPENBREC GEN,8,24 X'14',F:BREC
         DATA     X'C3400000'
         DATA     SELO
         DATA     SELO
         DATA     2,4,2
         SPACE    2
READBREC GEN,8,24 X'10',F:BREC
         DATA     X'F8000000'
         DATA     SEL:OPN:SELF
         DATA     SEL:OPN:SELF
         PZE      *SEL:BUF
         DATA     X'800'
         DATA     SELKEY
         SPACE    2
TRAPC    GEN,8,24 X'14',TRAPPER
         DATA     X'003F8300'       TRAP ON EVERYTHING.
         SPACE    2
OPENSEL  GEN,8,24 X'14',F:SEL
         DATA     X'C1000000'
         DATA     NO:SEL:FILE
         DATA     NO:SEL:FILE
         DATA     4
         SPACE    2
READSEL  GEN,8,24 X'10',F:SEL
         DATA     X'C0000000'
         DATA     SEL:FIL:EOF
         DATA     SEL:FIL:EOF
         SPACE    2
OPNBRECO GEN,8,24 X'14',F:BREC
         DATA     X'C7400000'
         DATA     BSR1
         DATA     BSR1
         DATA     2,2,2,2
         SPACE    2
CLOSBREC GEN,8,24 X'15',F:BREC
         PZE      *0
         DATA     2
         SPACE    2
WRITBREC GEN,8,24 X'11',F:BREC
         DATA     X'F8000040'
         DATA     BSR1
         DATA     BSR1
         PZE      *SEL:BUF
         DATA     X'800'
         DATA     SELKEY
         SPACE    2
DELREC   GEN,8,24 X'0D',F:SEL
         DATA     0
         SPACE    2
CLOSSEL  GEN,8,24 X'15',F:SEL
         PZE      *0
         DATA     2
         SPACE    2
TRUNC    GEN,1,7,24   1,X'12',R7
         DATA     0
         SPACE    2
DELSEL   GEN,8,24 X'0D',F:BREC
         PZE      *0
         DATA     SELKEY
         SPACE    2
TYPE     GEN,8,24 X'02',0
         PZE      *0
         PZE      *R5
         SPACE    2
OPNXTAP  GEN,8,24 X'14',FL:TAPE
         DATA     X'C0000400'
         DATA     BSR1
         DATA     BSR1
         SPACE    2
CLSTPREM GEN,8,24 X'15',FL:TAPE
         DATA     X'20'
         SPACE    2
OPNUSREL GEN,8,24 X'14',F:USR
         DATA     X'C0000000'
         DATA     BSR1
         DATA     BSR1
         SPACE    2
CLSUSREL GEN,8,24 X'15',F:USR
         PZE      *0
         DATA     1
         SPACE    2
PFILEOF  GEN,8,24 X'1C',FL:TAPE
         DATA     0
         SPACE    2
CLSTAPSV GEN,8,24 X'15',FL:TAPE
         PZE      *0
         DATA     2
         SPACE    2
OPNBACKO GEN,8,24 X'14',F:BACK
         DATA     X'C1400000'
         DATA     GO:BACK1
         DATA     GO:BACK1
         DATA     2,2
         SPACE    2
OPNDEVTP GEN,8,24 X'14',FL:TAPE
         DATA     X'C0040000'
         DATA     BSR1
         DATA     BSR1
         DATA     X'D4E3'           'MT'
         SPACE    2
OPENBACK GEN,8,24 X'14',F:BACK
         DATA     X'C1000000'
         DATA     ERBCK
         DATA     ERBCK
         SPACE    2
CLSBACK  GEN,8,24 X'15',F:BACK
         PZE      *0
         DATA     2
         SPACE    2
PRECORDT GEN,8,24 X'1D',FL:TAPE
         DATA     X'10'
         SPACE    2
PRECORDF GEN,8,24 X'1D',F:USR
         DATA     X'10'
         SPACE    2
CLSUSRSV GEN,8,24 X'15',F:USR
         PZE      *0
         DATA     2
         SPACE    2
OPENTAPE GEN,8,24 X'14',FL:TAPE
         DATA     X'C124040A'
         DATA     TPERR
         DATA     TPABN
         DATA     1                 OPEN INPUT
         DATA     FPAR
TAPTYPE  DATA     0
         DATA     X'02010202'
TAPACCT  TEXT     ':SYS    '
         SPACE    2
READSPEC GEN,8,24 X'10',FL:TAPE
         DATA     X'F0000000'
         DATA     TPERR
         DATA     TPABN
         PZE      *BUF
         PZE      *BUFSZ
         SPACE    2
READDAT  GEN,8,24 X'10',FL:TAPE
         DATA     X'F0000000'
         DATA     ENDFILE1
         DATA     ENDFILE1
         DATA     BLABL
         DATA     24
         SPACE    2
TFFDNA   GEN,8,7,17  X'14',X'44',F:USR   TEST FILENX ACCT,FILDIR
         DATA     X'C0000001'
         DATA     SPECERR,SPECABN
         DATA     X'01000101',X'01000000'
         DATA     X'02010202'
ZAPACCT  DATA     0,0
         SPACE    2
SYS      GEN,8,24 8,0
DEBUG    PZE      0
PATCH    RES      200
         TITLE    '**MAIN PROGRAM-STARTUP & OPEN TAPE**'
         CSECT    1
FILL     EQU      %
         BAL,SR4  DO:TABLES:ADS
         CAL1,8   INTPURGE
         CAL1,8   TRAPC             ESTABLISH TRAP CONTROL FOR DUMPS
         BAL,SR4  DO:TIME           SET UP START SN FOR BACKUP
         LI,R4    X'FC'
         LB,R5    J:JIT
         BEZ      FILL1             DON'T FOOL AROUND FOR BATCH
         LB,R5    J:JIT,R3          GET SYSID
         CAL1,6   SYS               MASTER MODE
         STB,R4   UB:PRIOB,R5
         LPSD,0   SLAVE             RETURN TO SLAVE MODE
FILL1    EQU      %
         MTW,0    DEBUG
         BEZ      FILL2
         LCI      2                 STRAIGHTEN OUT ACCOUNTS
         LM,R4    J:JIT+1            USED IN FPTS TO AVOID
         STM,R4   TAPACCT             UNNECESSARY ABNORMALS.
         STM,R4   EOACCT
         STM,R4   DATACCT
FILL2    EQU      %
         LW,R6    REELTMP
         AI,R6    X'C000'           C'A'-1
         STW,R6   LASTREELX
         LI,R5    FILLINIT
         CAL1,2   TYPE
         B        NO:FILL
         BOUND    8
SLAVE    DATA     X'00C00000'+FILL1,0
YESFL    EQU      %
DO:SN    EQU      %                 GET STARTING REEL NO. FROM
*                    OPERATOR AND SET 8 SN'S
         LW,R8    TAPETYP
         STW,R8   TAPTYPE           PUT DEVICE TYPE IN FPT
         LI,R5    5                 FILL TYPE OPERATION
         STW,R5   LASTRUN
         LI,R5    NTRREEL
         LI,R6    FID:ACCT
         LI,R7    5
         CAL1,2   KEYIN
         STW,R0   ZAPACCT
         STW,R0   ZAPACCT+1
         LW,R4    FID:ACCT
         LW,R5    FID:ACCT+1
         SCD,R4   8                 4-CHAR NUMBER NOW ASSEMBLED
         LB,R5    FID:ACCT          CHECK INPUT LENGTH
         CI,R5    5                 4 CHARS + LINE FEED
         BNE      DO:SN             ILLEGAL INPUT
         LB,R5    FID:ACCT,R5
         CI,R5    X'15'             N/L
         BNE      DO:SN             5TH CHAR MUST BE LINE FEED
*                    SAVE SN OF TODAYS LAST SET
         LI,R5    X'F0000'
         CS,R4    LASTREELX
         BNE      SN:DO
         LI,R5    X'FF00'
         CS,R4    LASTREELX
         BL       SN:DO
         STW,R4   LASTREELX
SN:DO    EQU      %
         LI,R6    -36
         LI,R5    X'FFF00'
NXT:SN   EQU      %
         STS,R4   FL:TAPE:SN+37,R6
         CW,R4    FL:TAPE:SN+37,R6
         BNE      %+2
         STW,R6   FL:VOL            SAVE INDEX TO COMPUTE VOL
         BIR,R6   NXT:SN
         LI,R6    37                CONVERT NEG INDEX TO + VOL
         AW,R6    FL:VOL
         STW,R6   FL:VOL
         AI,R6    -1
         STW,R6   ZAPFLAG           0 IF 1ST VOL, NON-ZERO IF NOT
*                 CHECK FOR SKIPPING
GET:START EQU     %
         STW,R0   START:ACCT        ZAP START OF ACCT
         STW,R0   START:ACCT+1
         LI,R5    STARTFILE
         LI,R6    FID:ACCT
         LI,R7    42
         CAL1,2   KEYIN
         LB,R5    FID:ACCT,R1       NULL REPLY
         CI,R5    X'15'             NL
         BE       SET:SN            NULL--LEAVE ACCT=0
FID:ACCTX EQU     FID:ACCT+11       ADDR FOR NEGATIVE IX
         LI,R5    -43               MSG INPUT IX
         LI,R6    0                 FNE LENGTH
         LB,R4    FID:ACCTX,R5
         CI,R4    C'.'
         BE       MOVE:ACCT         ACCT ONLY
*                    SETUP FILE NAME
GET:FNE EQU       %
         BAL,SR4  CHK:TERM          CHK FOR TERMINATOR
         B        END:FNE
         AI,R6    1
         BIR,R5   GET:FNE
         B        GET:START         NO TERMINATOR
END:FNE  EQU      %
         CI,R4    C'.'
         BNE      GET:START         NAME TERMINATOR NOT '.'
*                    HANDLE ACCT
MOVE:ACCT EQU     %
         STB,R6   FID:ACCT          SET FNE LENGTH
         LI,R6    -8
MOVE:ACCT1 EQU    %
         BIR,R5   %+2               STEP TO NEXT INPUT CHARACTER
         B        GET:START
         BAL,SR4  CHK:TERM
         B        MOVE:ACCT2        END ACCT
MOVE:ACCT3 EQU    %
         STB,R4   START:ACCT+2,R6
         BIR,R6   MOVE:ACCT1
         STW,R3   ZAPFLAG           SKIP PRECEEDING ACCTS IN DO:FILDR
         B        SET:SN
MOVE:ACCT2 EQU    %
         LI,R4    C' '              SET BLANKS
         AI,R5    -1                FORCE REPEAT TO BLANK FILL
         B        MOVE:ACCT3
CHK:TERM EQU      %
*                 FETCHES NEXT CHARACTER FROM FID:ACCTX,R5 AND
*                   CHECKS FOR TERMINATOR    EXIT NORMAL IF DATA
*                   EXIT SKIPPING IF TERMINATOR
         LB,R4    FID:ACCTX,R5
         CI,R4    C'.'
         BE       *SR4
         CI,R4    C' '
         BE       *SR4
         CI,R4    X'15'
         BE       *SR4
         AI,SR4   1
         B        *SR4
         TITLE    '**  MAIN PROGRAM--SELECTIVE FILL  **'
SELFILL  EQU      %
         CAL1,8   L(X'08000001')    GET ONE DYNAMIC DATA PAGE
         BCS,8    BB1               NO PAGES AVAILABLE
         STW,SR2  SEL:BUF           SAVE START ADDRESS OF PAGE
*                 INITIALIZE SELFIL TABLE
         LI,R7    511
         STW,R0   *SEL:BUF,R7       ZERO WORDS 1-511
         BDR,R7   %-1
         LI,R7    2*4
         STW,R7   *SEL:BUF          NEXT ENTRY CTL WD
         LI,R7    512*4
         STW,R7   *SEL:BUF,R1       FIRST FID ENTRY CTL WD
*                 OPEN :BREC AND READ SEL:FIL RECORD
         CAL1,1   OPENBREC
*                 ER,ABN=SELO;DIRECT;INOUT;SAVE
         CAL1,1   READBREC
*                 ERR,ABN=SEL:OPN:SELF;BUF=SEL:BUF;KEY=SELKEY
SEL:OPN:SELF EQU  %                 OPEN SEL:FIL FILE
         CAL1,1   OPENSEL
*                 ERR,ABN=NO:SEL:FILE;INOUT
READ:SEL  EQU     %
         CAL1,1   READSEL
*                 ERR,ABN=SEL:FIL:EOF;BUF=SEL:COM:BUF
*                 TRANSLATE AND CHEK INPUT COMMAND,BUILDING AN ENTRY IN
*                 THE TEMPORARY TABLES
         BAL,SR4  FIND:FILL         VERIFY CHARS PRECEEDING FID
         BAL,SR4  DO:FID            HANDLES FID IF PRESENT
         BAL,SR4  DO:ACCT           HANDLES ACCT
         BAL,SR4  FIND:REEL         HANDLES REEL NBR AND OTHER CHARS
*                     CHK SEL:FIL SN = CURRENT BACKUP SN
         LW,D1    TSN
         LW,D2    L(X'FFFFFF00')
         CS,D1    LASTREELX         COMPARE IF SAME TAPE SET
         BNE      %+3
         LW,D1    NOTAPFG           & CURRENT TAPE IS IN USE
         BNEZ     BAD:SEL:COM       YES-REJECT COMMAND
*                 FINISH ENTRY IN TEMP FOR FID, IF PRESENT
         STW,R0   TFIDPTR
         LB,D1    TFID
         BEZ      NO:FID
         LI,R7    504*4             LAST FID ENTRY IN TABLE
NXT:FID  EQU      %
         LB,D1    *SEL:BUF,R7
         BEZ      MTFID             EMPTY ENTRY FOUND
         AI,R7    -32
         B        NXT:FID
SELO     EQU      %                 CREATE THE :BREC FILE
         LB,D1    SR3
         CI,D1    X'13'             RECORD DOESNT EXIST ON DELREC
         BE       SEL:MT13
         CI,D1    3                 FILE DOESNT EXIST
         BNE      SEL:OPN:SELF
         CAL1,1   OPNBRECO
*                 ERR,ABN=BSR1;KEYED;DIRECT;OUT;SAVE
         CAL1,1   CLOSBREC
*                 SAVE
         CAL1,1   OPENBREC
*                 ER,ABN=SELO;DIRECT;INOUT;SAVE
         B        SEL:OPN:SELF
MTFID    EQU      %
         STW,R7   TFIDPTR           SAVE IX OF FID
         LI,R6    -32
         CW,R7    *SEL:BUF,R1
         BGE      %+2
         STW,R7   *SEL:BUF,R1       SET NEW HI WATER FOR FIDS
*                 MOVE FI//NAME INTO FID AREA OF SEL:BUF
         LB,D1    TFID+8,R6
         STB,D1   *SEL:BUF,R7
         AI,R7    1
         BIR,R6   %-3
NO:FID   EQU      %
*                 MOVE ENTRY INTO SEL:BUF
         LW,R7    *SEL:BUF
         SLS,R7   -2
         AI,R7    -1
NXT:SEL  EQU      %
         LW,D1    TSN
         CB,D1    LOW-1             ('F0')
         BL       %+4
         LI,R6    X'80'             ZERO OUT THE HIGH
         EOR,D1   R6                 ORDER BIT OF THE 'F'
         STW,D1   TSN               (MAKES #'S < LETTERS)
         CI,R7    2
         BL       ENT:FOUND         TOP OF STACK
         CW,D1    *SEL:BUF,R7
         BGE      ENT:FOUND
         AI,R7    -3
         LW,R6    R7
         AI,R6    4
         LCI      4
         LM,D1    *SEL:BUF,R7
         STM,D1   *SEL:BUF,R6
         AI,R7    -1
         B        NXT:SEL
ENT:FOUND EQU     %                 MOVE DATA INTO ENTRY
         LD,D1    MBS:T:SB
         AW,D2    R7
         AW,D2    SEL:BUF
         SLD,D1   2                 WA TO BA
         MBS,D1   0
         LI,R7    16
         AW,R7    *SEL:BUF          UPDATE ENTRY POINTER
         STW,R7   *SEL:BUF
         CAL1,1   WRITBREC
*                 ERR,ABN=BSR1;ONEWKEY;BUF=SEL:BUF;KEY=SELKEY
DEL:SEL  EQU      %
         CAL1,1   DELREC
*                 NO OPTIONS
         AI,R7    48                CHECK FOR FULL BUFFER
         CW,R7    *SEL:BUF,R1
         BLE      READ:SEL
*                 OUTPUT FULL--SAVE REST OF SEL:FIL FILE
         CAL1,1   CLOSSEL
*                 SAVE
         LI,R7    F:SEL
         CAL1,1   TRUNC
NO:SEL:FILE EQU   %
         STW,R1   SELECT            SET SELECTIVE FILL FLAG
*                 ANY SELECTIVE FILLS TO DO
         LW,R7    *SEL:BUF
         CI,R7    2*4
         BG       SEL:SET:SN
SEL:MT   EQU     %
         CAL1,9   SUPERCLOSE
         CAL1,8   L(X'09000001')    RELEASE DYNAMIC PAGE
         CAL1,1   DELSEL
*                 F:BREC;KEY=SELKEY
SEL:MT13 EQU      %
         CAL1,1   CLOSBREC
*                 SAVE
         B        GO:BACK
SEL:SET:SN EQU    %
*                   SETUP SN'S
         LI,R7    5
         LI,D1    X'80'
         OR,D1    *SEL:BUF,R7       RESTORE THE 'F' TO #'S
         LI,R6    -36
         LI,D2    X'FFF00'
SEL:SET:SN1 EQU   %
         STS,D1   FL:TAPE:SN+37,R6
         CW,D1    FL:TAPE:SN+37,R6   FIND WHICH SN IS START
         BNE      %+2
         STW,R6   FL:VOL            SAVE INDEX FOR VOL
         BIR,R6   SEL:SET:SN1
         LI,R6    37                CONVERT -INDEX TO +VOL
         AW,R6    FL:VOL
         STW,R6   FL:VOL
         LI,R6    6                 SELECTIVE FILL OPERATION
         STW,R6   LASTRUN
NXT:SN:ENT EQU    %
         CS,D1    *SEL:BUF,R7       ZERO REEL NBRS FOR THIS SET
         BNE      SET:SN            ALL DONE--GO
         STW,R0   *SEL:BUF,R7
         AI,R7    4
         B        NXT:SN:ENT
         SPACE 3
SEL:FIL:EOF EQU   %
         LB,SR3   SR3               IF SHORT-WILL CATCH LATER
         CI,SR3   7
         BE       *SR1
*                 HIT EOF--ZAP THE SEL:FIL FILE AND START PROCESSING
         CAL1,1   WRITBREC
*                 ERR,ABN=BSR1;ONEWKEY;BUF=SEL:BUF;KEY=SELKEY
         LI,R7    F:BREC
         CAL1,1   TRUNC
         LI,R7    1
         XW,R7    CLOSSEL+2
         CAL1,1   CLOSSEL
*                 RELEASE
         XW,R7    CLOSSEL+2
         B        NO:SEL:FILE
         SPACE    3
*                 BAD SEL:FIL COMMAND--LOG AND SKIP
BAD:SEL:COM EQU   %
         LB,D1    BAD:COM:MESS
         CI,D1    80
         BG       %+2
         AI,D1    80                INCLUDE COMMAND
         STB,D1   BAD:COM:MESS
         LI,R5    BAD:COM:MESS
         CAL1,2   TYPE
         B        DEL:SEL
         SPACE    3
SET:SN   EQU      %
         CAL1,1   FL:TAPE:OPN          ADJ.DCB TO SET SN
         STW,R0   TIME
         STW,R0   FILCNT            PRESET FOR EACH SET OF TAPES
         MTW,0    SELECT
         BEZ      %+3               WE HAVE TYPE ALREADY
         LW,R8    TAPETYP
         STW,R8   TAPTYPE
         LI,R6    X'FF'             PUT LARGE BUFFER SIZE
         STB,R6   BLABL              IN BLABL FOR USER LABEL
         CAL1,1   OPENTAPE
*                 ERR,ABN=TPERR,TPABN;NXTF;IN
         LD,R6    LBLACCT
         STD,R6   CUR:ACCT
         LCI      2
         STM,R6   LASTACCT
         CI,R6    0
         BNEZ     CUL               NOT A BEGINNING DAT FILE
         CAL1,1   READDAT
*                 ERR,ABN=ENDFILE1;SIZE=24;BUF=BLABL
         LB,R6    BLABL+5,R3        GET WHO WROTE IT
*                                   0 => FSAVE
*                                   1 => SAVEALL
*                                   2 => INCREMENTAL
*                                   3 => SQUIRREL
*                                   4 => PURGE
*
*        BUILD APPROPRIATE MESSAGE IN FPAR
*
         CI,R6    4
         BG       ENDFILE1          GARBAGE IN DAT FILE
         LD,R8    TAPETYPE,R6
         MBS,R8   0
         LI,R8    BA(FILLER)
         LI,R7    17
         STB,R7   R9                FILLER SIZE FOR MBS
         MBS,R8   0
         LI,R8    BA(BLABL)         DATE PART OF MESSAGE
         LI,R7    16
         STB,R7   R9
         MBS,R8   0
         AI,R9    -BA(FPAR)-1
         STB,R9   FPAR              TOTAL LENGTH OF MESSAGE
         LI,R5    FPAR
         CAL1,2   TYPE              TELL OPERATOR
         B        ENDFILE1          PROCEED WITH THE REST
         PAGE
*
*
OPN:NXT  EQU      %                 PREPARE TO OPEN NEXT TAPE FILE
         BAL,SR4  PURGE
         LI,R6    X'FF'
         STB,R6   BLABL             PUT SIZE OF BUFFER IN 1ST BYTE
         CAL1,1   OPENTAPE
*                 ERR,ABN=TPERR,TPABN;NXTF;INOUT
**
** CONVERT USER LABEL TO OPEN FOR USER FILE
**
CUL      EQU      %
         LD,R4    LBLDATE
         MTW,0    TIME
         BEZ      GO:ON             SKIP COMPARE THE FIRST TIME
         CD,R4    TIME
         BL       BADTIME
GO:ON    STD,R4   TIME
         MTW,1    FILCNT
         LB,R4    LBLORG
         CI,R4    X'FF'
         BNE      USERLAB
         TITLE    '**MAIN PROGRAM-FILE INDEX RECORD**'
         LB,R5    LBLORG,R3         END OF INCREMENTAL?
         CI,R5    X'FF'
         BE       ENDEND            YES
         LW,R5    START:ACCT        CHK IF STILL SKIPPING
         BNEZ     SKIPPING          IGNORE INDEX IN SKIP AREA
         LW,D1    SELECT
         BEZ      DO:FILDIR         NON-SELECTIVE FILL-PROCESS LIST
*                 IN THE SELECTIVE MODE AND A FILE LIST HAS BEEN
*                   DETECTED.  IF THE ACCOUNT IS ONE THAT HAS BEEN
*                   SEARCHED FOR, THE ENTRY MUST BE ZAPPED.
ZAPENTRY EQU      %
         LI,R7    2
         LI,R5    0
ZAP:LUP  EQU      %
         LCI      4
         LM,D1    *SEL:BUF,R7
         CI,D4    0                 IF SN=0, IS CURRENT ENTRY
         BL       ZAP:DONE          END OF CURRENT ENTRIES
         CW,D1    LBLACCT
         BNE      NXT:ZAP
         CW,D2    LBLACCT+1
         BNE      NXT:ZAP
         CW,D3    0                 ONLY ZAP ACCT REQUESTS
         BE       ZAP:DONE
NXT:ZAP  EQU      %
         AI,R7    4
         SLS,R7   2
         CW,R7    *SEL:BUF          CHK FOR END OF TABLE
         BGE      SKIPPING          END LIST
         SLS,R7   -2
         B        ZAP:LUP
ZAP:DONE EQU      %
         STW,R0   *SEL:BUF,R7
*                 SEARCH FOR ANY REMAINING ENTRIES FOR THIS TAPE.
*                 IF ANY, CONTINUE, IF NONE BUT MORE TAPES, DO
*                 END TAPE TYPE PROCESS.  IF NO MORE LIVE ENTRIES,
*                 RETURN TO SELFIL
         LW,R6    *SEL:BUF
         SLS,R6   -2
         LI,R7    2
LUK:LUP  EQU      %
         LCI      4
         LM,D1    *SEL:BUF,R7
         CI,D4    0                 CHK FOR THIS TAPE
         BL       END:SEL:TAPC
         CI,D1    0                 CHK LIVE ENTRIES THIS TAPE
         BNE      SKIPPING
         AI,R7    4                 CHK END TABLE
         CW,R7    R6
         BL       LUK:LUP
         LI,SR4   SEL:MT            REL DY, DEL SELFIL, B BACKUP
         B        REM:TAPE
END:SEL:TAPC EQU  %                 MORE, BUT NOT THIS TAPE
         LI,SR4   END:SEL:TAP
REM:TAPE EQU      %
         LW,SR3   L(X'200000')
         CW,SR3   FL:TAPE
         BANZ     REM:TAPE1         DCB OPEN
         CAL1,1   OPNXTAP
*                 FL:TAPE;ERR,ABN=BSR1;NXTF
REM:TAPE1 EQU     %
         CAL1,1   CLSTPREM
*                 FL:TAPE;REMOVE
         B        *SR4
         PAGE
*                    PROCESS ACCT FILE LIST
DO:FILDIR EQU     %
         CAL1,1   TFFDNA            FIND NEXT ACCT
         LD,R4    CBS:ACT2
         CBS,R4   0                 LBLACCT : ZAPACCT
         BE       SPPAGREL          DONE
         LD,R4    CBS:ACT1
         CBS,R4   0                 LBLACCT : FUSRACCT
         BG       SPLSTEND1         DO NULL ACCT
         BL       SPPAGREL          DONE
         LB,R4    LBLORG,R3         0 => NORMAL, 1 => BYPASS
         BNEZ     SPLSTEND2         TRUNCATED LIST-ACCEPT ALL FILES
         LD,R6    LBLACCT
         CD,R6    CUR:ACCT          HAS ACCOUNT CHANGED?
         BE       USERLAB1          NO.
         STD,R6   CUR:ACCT          UPDATE CURRENT TAPE ACCOUNT
         MTW,0    SELECT
         BEZ      USERLAB1          NOT SELECTIVE
         LB,R5    LBLORG,R1         GET TAPE TYPE (SA,IN,SQ)
         CI,R5    3
         BGE      USERLAB1          LOOK AT ALL TAPES IN SET
         BAL,SR4  ZAPENTRY
USERLAB1 EQU      %
         STW,R0   ZAPFLAG           ENABLE FURTHER ACCT ZAPS
         LB,R5    LBLORG,R2         SIZE IN PAGES OF FILE LIST
         BAL,SR4  GETBUF            GET THAT BIG A BUFFER
         CB,R7    LBLORG,R2         DID WE GET ENOUGH
         BL       SPPAGREL          NO.
         CAL1,1   READSPEC
*                 ERR,ABN=TPERR,TPABN;BUF=*BUF;SIZE=*BUFSZ
         LW,R6    BUF
         SLS,R6   2                 BYTE ADDRESS
         LW,R4    FL:TAPE+13        RWS
         AW,R4    R6
         STW,R4   SPBYCT            R4 <= BA(END OF BUFFER)
         BE       SPPAGREL
* REGISTER 6 CONTAINS BYTE ADDRESS OF SPECIAL LIST THROUGHOUT
SPNXNM   EQU      %
         STB,R0   FPT:SPEC+1,R2     NOT NXTF FOR COMP:AGE
         STW,R6   SR4               SAVE START ADDRESS OF TABLE
SPDONE   EQU      %
         LW,R6    SR4
         CAL1,1   TF:SPEC           FIND FILE IN ACCT SPECIFIED
SPCONT   EQU      %
         LI,R7    BA(F:USR+X'17')   FILE NAME
         LB,R4    0,R6              BYTE COUNT IN FIRST BYTE
         LB,R5    0,R7
         AI,R7    1
         CW,R5    R4
         BG       %+3
         STB,R5   R7                COMPARE SHORTER FIELD
         B        %+2
         STB,R4   R7
         CBS,6    1
         BE       SPCLSAV           IF EQUAL, SAVE THIS FILE
         BG       SPCLREL           DELETE THIS FILE
SPLSNX   EQU      %
         LW,R6    SR4
         LB,R5    0,R6              COUNT OF THIS NAME
         AW,6     R5                ADD TO TOTAL COUNT TO GET NEXT NAME
         AI,6     1                 PLUS 1 FOR COUNT BYTE
         STW,R6   SR4
         CW,6     SPBYCT            ARE WE THROUGH WITH SPECIAL LIST
         BGE      SPLSTEND          IF LIST AT END, RELEASE REMAINING
         B        SPCONT
SPCLREL  BAL,SR1  COMP:AGE
         B        SPDONE
SPCLSAV  CW,R4    R5                WERE THEY REALLY EQUAL?
         BG       SPCLREL           RELEASE-LIST IS GT FILE NAME
         BL       SPLSNX            GET NEXT LIST ENTRY
         AI,R6    1
         CW,6     SPBYCT
         BL       SPNXNM            GET NEXT FILE
         B        SPLSTEND1
SPLSTEND EQU      %
         BAL,SR1  COMP:AGE          RELEASE ALL REMAIN OLD FILES
         LB,SR1   FUSR:DESC+1,R3
         CI,SR1   2                 EOF
         BAZ      SPLSTEND1
SPLSTEND2 EQU     %
         LW,SR1   FUSRACCT          YES-MOVE ACCT NBR
         STW,SR1  ZAPACCT
         LW,SR1   FUSRACCT+1
         STW,SR1  ZAPACCT+1
         B        DO:FILDIR
SPLSTEND1 EQU     %
         MTW,0    ZAPFLAG
         BNEZ     SPLSTEND2         SKIP ACCT IF FLAG SET
         LI,SR2   X'400'            NXTF
         STS,SR2  FPT:SPEC+1
         B        SPLSTEND
         TITLE    '**MAIN PROGRAM-DATA FILE**'
USERLAB  EQU      %
         LW,R5    USER:FIL:RES      INITIALIZE FPT
         STW,R5   USER:FIL
         STW,R0   SYNFLAG           CLEAR SYNON FLAG
         LI,R6    TVLPTSZ
         LI,D3    USER:VPT
USERLAB2 EQU      %
         LB,D1    TVLPTBL,R6
         BAL,R5   LOCCODE
         BAL,R7   DUMMY
         BAL,R5   MOVEVLP
         BDR,R6   USERLAB2
         LI,R6    VLPTSIZ
         LI,D1    X'0B'             SYNON FILE VLP
         LI,D4    LBLVLPS
         BAL,R5   LOCCODE1
         B        MOVELOOP          NOT SYNONOMOUS
         STW,R1   SYNFLAG
         BAL,R5   MOVEVLP           PUT NAME INTO PLIST
MOVELOOP LI,D4    LBLVLPS           DUMMY CLOBBERS D4
         LB,D1    VLPTBL,R6
         BAL,R5   LOCCODE1
         BAL,R7   DUMMY
         BAL,R5   MOVEVLP
         BDR,R6   MOVELOOP
         LW,R5    L(X'02010202')
         LD,R6    LBLACCT
         LCI      3
         STM,R5   *D3
         LI,D3    USER:VPT+1        FILE NAME VLP IS FIRST
         LB,R6    *D3
         LB,SR2   *D3,6
         STB,SR2  NOMSG+8,R6
         BDR,R6   %-2
         LB,R6    *D3
         AI,R6    32
         STB,R6   NOMSG
         LI,D1    9                 FIND KEYMAX FROM '09' VLP
         BAL,R5   LOCCODE
         NOP                        MUST BE THERE
         LW,R4    *D4,R1
         LB,R4    R4,R1             KEYMAX FIELD
         STW,R4   KEYMAX
         LB,R4    LBLORG
         STW,R4   USER:ORG
         LI,R5    0
         CI,R4    3                 IS IT RANDOM?
         BNE      %+2               NO
         LW,R5    LBLRSTOR
         STW,R5   URSTORE
         LW,R7    SELECT
         BEZ      OKACCT1           0=NON-SELECTIVE
*                 SEARCH SELFIL TABLE FOR ACCT/FID MATCH
         LI,R7    2
         LW,R6    *SEL:BUF
         SLS,R6   -2
         STW,R0   SELFID:PTR
CHK:ACCT EQU      %
         LCI      4
         LM,SR1  *SEL:BUF,R7
         CI,SR4   0                 ENTRY FOR THIS TAPE
         BL       SKIPPING  END OF CURRENT ENTRIES
         CD,SR1   LBLACCT
         BNE      CHK:NXAC
*                 RIGHT ACCT--CHK FID
         CI,SR3   0                 IF NO FID THEN IS ALL FOR ACCT,--OK
         BE       OKSEL             OK
         LW,R5    SR3
         LB,SR1   *SEL:BUF,R5       FID LENGTH
         AI,SR1   1
         LW,SR4   SEL:BUF
         SLS,SR4  2
         AW,SR4   SR3
         STB,SR1  SR4
         LW,SR3   D3
         SLS,SR3  2
         CBS,SR3  0
         BNE      CHK:NXAC
*                 ENTRY FOUND FOR THIS FILE
         STW,R7   SELFID:PTR
OKSEL    EQU      %
         AI,R7    3
         MTW,1    *SEL:BUF,R7       COUNT FILLS FOR THIS REQUEST
         LW,R7    D2
         B        JITLP1
*                 STILL SEARCHING
CHK:NXAC EQU      %
         AI,R7    4
         CW,R7    R6
         BL       CHK:ACCT
*                 DOESNT MATCH ANYTHING--SKIP IT
         B        SKIPPING
OKACCT1  EQU      %
         LD,R6    START:ACCT
         BEZ      NOSKIP
         CD,R6    LBLACCT
         BL       NOSKIP            LBLACCT > START:ACCT
         BG       SKIPPING          START:ACCT > LBLACCT
*                 ACCT MATCHES--CHK FID
         LB,R6    FID:ACCT
         BEZ      NOSKIP            OK--NO FID TEST
         LI,D4    BA(FID:ACCT)+1
         STB,R6   D4
         SLS,D3   2
         CBS,D3   1
         BL       SKIPPING          NOT YET THERE
NOSKIP   EQU      %
         MTW,0    SELECT
         BEZ      JITLP1
         LI,D1    4                 GET EXPIRATION
         LI,D4    LBLVLPS            DATE OF
         BAL,R5   LOCCODE1            INCOMING FILE
         NOP
         AI,D4    1
         LW,SR4   L(C'NEVE')
         CW,SR4   *D4               IS EXPIRATION NEVER?
         BE       JITLP1
         LW,SR4   *DATE1AD
         LH,SR3   *TIMEAD
         STH,SR3  SR4
         LW,SR3   *DATEAD
         LI,D2    SR3
         BAL,R5   COMPDAT           EXIT SKIPPING IF EXPIRED
         B        JITLP1            FILE HAS NOT EXPIRED
         PAGE
*
*        GIVE EXPIRED FILES A NEW LEASE ON LIFE
*
         LI,D1    SL:EX             DEFAULT EXPIRATION PERIOD
         SAD,D1   -32
         LI,SR1   24
         DW,D1    SR1
*
*        SR3 => M M D D
*        SR4 => H H Y Y
*        D1  => BINARY HOURS
*        D2  => BINARY DAYS
*
         LI,R4    3
*
*        CONVERT DECIMAL EBCDIC TO BINARY IN EACH OF FOUR FIELDS
*
NEWEXP   LH,SR1   SR3,R4
         AND,SR1  L(X'F0F0FFFF')
         BAL,R5   DECTOBIN
         STH,SR2  SR3,R3            SR2 CONTAINS BINARY EQUIV
         AI,R4    -1
         BGEZ     NEWEXP
*
         AH,D1    SR4               ADD HOURS AND ADJUST DAYS
NEWEXP1  STH,D1   SR4
         CI,D1    24
         BL       NEWEXP2
         AI,D1    -24
         AI,SR3   1                 BUMP DAY COUNT
         B        NEWEXP1
*
NEWEXP2  AW,D2    SR3               ADD DAYS AND ADJUST MONTHS
         LH,R7    D2                R7 <= MONTH
         LI,SR1   X'FFFF'
         AND,D2   SR1
NEWEXP3  CI,R7    12
         BLE      NEWEXP4
         AI,R7    -12
         AI,SR4   1                 BUMP THE YEAR
         B        NEWEXP3
*
NEWEXP4  LB,SR1   DAYMONTH,R7       GET NUMBER OF DAYS FOR THIS MONTH
         CW,D2    SR1
         BLE      NEWEXP6           MONTH NOT AFFECTED
         CI,R7    2                 IS IT FEBRUARY?
         BL       NEWEXP6           NO
         CI,SR4   3                 IS IT A LEAP YEAR?
         BANZ     NEWEXP6           (THIS WONT WORK FOR 2100 A.D.)
         CI,R7    2
         BNE      %+3
         CI,D2    29
         BE       NEWEXP6           29 IS OK FOR FEBRUARY
         AI,D2    -1
*
NEWEXP5  SW,D2    SR1               SUBTRACT CURRENT MONTH'S
         AI,R7    1                  DAYS AND BUMP MONTH.
         B        NEWEXP3
*
NEWEXP6  STH,R7   D2
         STW,D2   SR3
         LI,R4    3
         LI,D1    10
         LI,D2    X'F0F0'
*
*        CONVERT BACK TO DECIMAL EBCDIC
*
NEWEXP7  LH,SR1   SR3,R4
         SAD,SR1  -32
         DW,SR1   D1                DIVIDE BY 10
         SLS,SR1  24
         SCD,SR1  8
         OR,SR2   D2                MAKE EBCDIC
         STH,SR2  SR3,R4             AND PUT BACK
         AI,R4    -1
         BGEZ     NEWEXP7
*
         LCI      2
         STM,SR3  *D4               PUT NEW DATE IN VLPS
*
JITLP1   EQU      %
         LD,R6    LBLACCT
         STD,R6   MAIL:AC
         LW,R5    L(X'80000')
         STS,R5   USER:FIL
         STW,R1   USER:MOD          INPUT
         CAL1,1   USER:FIL          TEST FILE
         STW,R2   USER:MOD          OUTPUT
*                 FILE EXISTS..CHK STATUS
         LB,R5    FUSR:DESC+1
         CI,R5    1
         BG       ENDFILE1          OPEN FOR MOD--SKIP
         LI,D1    X'A'
         LI,D4    LBLVLPS           GET BACKUP DATE FROM
         BAL,R5   LOCCODE1           TAPE'S USER LABEL
         NOP
         LW,D2    D4
         LI,D4    USER:FPAR         DISK COPY
         BAL,R5   LOCCODE1
         NOP
         AI,D2    1
         AI,D4    1
         BAL,R5   COMPDAT
         B        ENDFILE1          TAPE COPY NOT NEWER
         LI,R6    4                 INOUT MODE FOR SYNON FILE
         MTW,0    SYNFLAG
         BNEZ     MODESET           IS SYNON, SET UP INOUT OPEN
         LW,R6    NOMSG+8           IS THE FILE MAILBOX
         LW,R7    NOMSG+9
         CD,R6    MLBXNM
         BNE      OPEN:USER
         MTW,0    SELECT
         BEZ      ENDFILE1
         LI,R6    4             YES OPEN IN UPDATE MODE
MODESET  STW,R6   USER:MOD
OPEN:USER EQU     %
         LW,R5    DEFAULT
         BAL,SR4  GETBUF
         LW,R5    L(X'FFF7FFFF')    RESET FPT TO OPEN
         AND,R5   USER:FIL
         STW,R5   USER:FIL
*
         CAL1,1   USER:FIL          OPEN FOR REAL
** READ TAPE RECORD
RD:USR   EQU      %
         MTW,0    SYNFLAG           IS THIS SYNONOMOUS
         BNEZ     ENDFILE           YES, NO DATA TRANSFER
         LW,R4    BUF
         LW,R5    BUFSZ
         STW,R4   BUFRD             BUF LOC
         STW,R5   BUFRD+1           BUF SIZE
         SPACE    2
*
         CAL1,1   TAPEREAD          M:MOVE CAL
*
*        RETURN FROM MOVE CAL IS TO
*          MOERR OR MOABN
*
         PAGE
*                 SBR TO RELEASE FILE IF ITS MOD DATE IS OLDER
*                   THAN THE DATE ON THE TAPE
COMP:AGE EQU      %
         STW,SR1  SR1X
         CAL1,1   FPT:SPEC          TESTFILE W/FPARAM
         LCI      4
         STM,R4   R47
         LB,D1    FUSR:DESC+1
         BNEZ     FIL:SAVE          IN USE
         LB,D1    FUSR:DESC+1,R2
         CI,D1    2                 NO PURGE BIT=PO TAPE FILE
         BANZ     FIL:SAVE
         LI,D1    X'A'
         LI,D4    USER:FPAR
         BAL,R5   LOCCODE1          FIND DISK MOD DATE
         NOP
         AI,D4    1
         LI,D2    BLABL+5
         LH,R7    *D4,R2
         BAL,R5   COMPDAT
         BL       FIL:SAVE          DISC LATER--SAVE
         BG       FIL:REL           TAPE LATER--RELEASE
         CI,R7    X'FF2F4'          CHK FROM PO
         BE       FIL:SAVE
FIL:REL  EQU      %
         CAL1,1   OPNUSREL
*                 F:USR;ERR,ABN=BSR1
         CAL1,1   CLSUSREL
*                 F:USR;RELEASE
FIL:SAVE EQU      %
         LCI      4
         LM,R4    R47
         B        *SR1X
         TITLE    '**  SUBROUTINES  **'
COMPDAT  EQU      %
*                 COMPARES EBCDIC DATES AT D2,D4 AND RETURNS
*                  SKIPPING IF D2 DATE IS THE LATER
         LCI      2
         LM,D1    *D2
         LM,D3    *D4
         SCD,D1   -16
         SCD,D3   -16
         CD,D1    D3
         BG       1,R5
         B        *R5
         SPACE    2
*
*        BAL,R5   DECTOBIN
*        INPUT    SR1 = EBCDIC DECIMAL NUMBER
*        OUTPUT   SR2 = BINARY EQUIVALENT
*        CLOBBERS R6,R7
*
DECTOBIN LI,SR2   0
         LI,R6    X'F'
DECLOOP  LB,R7    SR1
         BEZ      0,R5
         MI,SR2   10
         AND,R7   R6
         AW,SR2   R7
         SLS,SR1  8
         B        DECLOOP
         PAGE
*          THE FOLLOWING ROUTINES PROCESS THE SELECTIVE FILL CHARACTER
*                 STRINGS COMPRISING THE COMMANDS TO SELECTIVE FILL
*          LINKAGE TO PRIMARY ROUTINES IS VIA SR4 AND TO SECONDARY
*                 ROUTINES VIA SR3.  ALL ERROR EXITS ARE *ERR:RET
*          INPUTS ARE IN THE 80 BYTE BLOCK PRECEEDING SEL:COM, CHARACTERS
*                 ARE REFERENCED VIA A NEGATIVE VALUE IN R4.
*                 R7, AND D1-D4, MAY BE USED AS WORK REGS.
*                 SR2 IS USED TO POINT TO ADDITIONAL PARAMETERS,AS NEEDED
*          OUTPUT IS PLACED IN THE TEMPORARY ENTRIES AT
*                 TACT0, TACT1, TFID, TSN
*
*
         SPACE 5
SK:BL    EQU      %   ****          SKIP BLANKS
*                 FINDS THE NEXT NON-BLANK, NON-TAB, CHARACTER IN
*                 THE INPUT STREAM.  TAKES ERROR EXIT IF COL 80 OR
*                 OTHER CONTROL CHARACTER IS FOUND.
         LB,D1    SEL:COM,R4
         CI,D1    ' '
         BG       *SR3              FOUND NON-BLANK, EXIT
         BL       SK:BL:TT          CHK FOR TAB
SK:BL:T80 EQU     %
         BIR,R4   SK:BL
         B        *ERR:RET          PAST COL 80
SK:BL:TT EQU      %
         CI,D1    X'05'             CODE FOR TAB CHAR
         BE       SK:BL:T80
         B        *ERR:RET          ILLEGAL CONTROL CHAR
         SPACE    5
FIND:STRG EQU     %   ****          FIND STRING
*                 CHECKS THE NEXT N CHARACTERS FOR MATCH WITH INPUT
*                 STRING.  INPUT IS TEXTC FORMAT AT *SR2.  IF STRING
*                 MATCHES FOR LENGTH IN TEXTC, NORMAL RETURN, OTHERWISE
*                 RETURNS *ERR:RET.  SR2 IS UPDATED TO FIRST WORD AFTER
*                 THE TEXTC.
         LI,D2    BA(SEL:COM)
         AW,D2    R4
         LB,D1    *SR2
         STB,D1   D2
         LW,D1    SR2
         SLS,D1   2
         CBS,D1   1
         BNE      *ERR:RET          STRING IN ERROR
*
         AI,D1    4                 STEP TO SOMEWHERE IN NXT WORD
         SLS,D1   -2
         LW,SR2   D1                SET SR2 TO NEXT WORD
         AI,D2    -BA(SEL:COM)
         LW,R4    D2                RESTORE R4 TO NEXT CHAR
         B        *SR3
         SPACE    5
FIND:FILL EQU     %   ****          FIND FILL
*                 POSITIONS INPUT TO THE BEGINNING OF FID, OR '.'
*                 PRECEEDING ACCT IF NO FID, VERIFYING THE FIELDS
*                 'FILL', '=', AND '('.  IGNORES BLANKS IMBEDDED
*                 BETWEEN FIELDS.
*                 ERROR RETURN IS *ERR:RET
         LI,R4    -80
         BAL,SR3  SK:BL             FIND START OF FILL
         LI,SR2   FILL:TEXTC
         BAL,SR3  FIND:STRG
*                 NOW FIND =
         BAL,SR3  SK:BL
         BAL,SR3  FIND:STRG
*                 THEN FIND (
         BAL,SR3  SK:BL
         BAL,SR3  FIND:STRG
*                 THEN SKIP ANY BLANKS UP TO FID OR '.'
         BAL,SR3  SK:BL
         B        *SR4
         SPACE    5
DO:FID   EQU      %   ****          SET TFID
*                 IF THE NEXT STRING DOES NOT START WITH A '.', THE
*                 STRING OF UP TO 31 CHARACTERS IS SET INTO TFID IN
*                 TEXTC FORMAT.  IF MORE THAN 31 CHARACTERS, COL80
*                 IS ENCOUNTERED, OR NOT TERMINATED BY A PERIOD, THE
*                 ERROR EXIT IS TAKEN.  IF THE FIRST CHARACTER IS A
*                 '.', TFID IS SET TO 0, AND THE NORMAL RETURN IS MADE.
         STW,R0   TFID
DO:FID:NXT EQU    %
         LB,D1    SEL:COM,R4
         CI,D1    '.'
         BE       DO:FID:XIT
         CI,D1    ' '               CHECK FOR BLANK OR CTL CHAR
         BE       DO:FID:BL         BLANK AND TAB OK TERMINATORS
         BG       DO:FID:SAV
         CI,D1    X'05'             TAB
         BNE      *ERR:RET          NEITHER  IS ERROR
DO:FID:BL EQU     %
         BAL,SR3  SK:BL
         LB,D1    SEL:COM,R4
         CI,D1    '.'               MUST BE A PERIOD
         BNE      *ERR:RET
         B        DO:FID:XIT
DO:FID:SAV EQU    %
         LB,R7    TFID
         AI,R7    1
         CI,R7    31
         BG       *ERR:RET          TOO MANY CHARS
         STB,D1   TFID,R7           SAVE CHAR
         STB,R7   TFID
         BIR,R4   DO:FID:NXT
DO:FID:XIT EQU    %
         BIR,R4   DO:FID:OUT
         B        *ERR:RET          PAST END OF LINE
DO:FID:OUT EQU    %
         BAL,SR3  SK:BL             FIND START OF ACCT
         B        *SR4
         SPACE    5
DO:ACCT  EQU      %   ****          FETCH ACCOUNT
*                 THE NEXT 1-8 CHARACTERS ARE MOVED TO TACT0,TACT1
*                 AS THE ACCOUNT NUMBER.  UPDATES R4 TO FOLLOWING THE
*                 LAST CHARACTER. USES R7 AND D1
*                 EXITS *ERR:RET IF COL 80 IS PASSED
         LI,R7    -8
DO:ACCT:LUP EQU   %
         LB,D1    SEL:COM,R4
         CI,D1    C')'
         BNE      %+3
         AI,R4    -1                BLANK FILL ACCT TO 8 CHARACTERS
         LI,D1    C' '
         STB,D1   TACT0+2,R7
         BIR,R4   %+2
         B        *ERR:RET          PASSED COL 80--ERROR
         BIR,R7   DO:ACCT:LUP
         B        *SR4
         SPACE    5
FIND:REEL EQU     %   ****          FIND REEL NUMBER
*                 MOVES THE REEL NUMBER (SN) INTO TSN, AND VERIFIES
*                 ALL THE OTHER CHARACTER STRINGS FOLLOWING THE ACCT
*                 NUMBER.  USES R7 AND D1.  IF ANY CHARACTER IN THE
*                 PRESCRIBED FORMAT IS INCORRECT OR COL 80 IS PASSED
*                 THE ERROR RETURN IS TAKEN (*ERR:RET).
         BAL,SR3  SK:BL
         LI,SR2   RTPAREN
         BAL,SR3  FIND:STRG         CHK ) AFTER ACCT
         BAL,SR3  SK:BL
         BAL,SR3  FIND:STRG         CHK , BETWEEN FIELDS
         BAL,SR3  SK:BL
         BAL,SR3  FIND:STRG         ( BEFORE REEL
         BAL,SR3  SK:BL
         BAL,SR3  FIND:STRG         'REEL'
         BAL,SR3  SK:BL
         BAL,SR3  FIND:STRG         =
         BAL,SR3  SK:BL
*                 NOW MOVE 4 CHAR SN
         LI,R7    -4
FIND:REEL:LUP EQU  %
         LB,D1    SEL:COM,R4
         STB,D1   TSN+1,R7
*                 CHECK LEGAL CHARACTERS--DDLD
         CB,D1    LOW,R7
         BL       *ERR:RET
         CB,D1    HI,R7
         BG       *ERR:RET
         BIR,R4   %+2
         B        *ERR:RET          ERROR--PAST COL 80
         BIR,R7   FIND:REEL:LUP
         BAL,SR3  SK:BL
         BAL,SR3  FIND:STRG         FINAL )
         B        *SR4
         SPACE    5
         TITLE    'ERROR AND ABNORMAL ROUTINES FOR FILL'
** USER FILE ERRORS
USRABN   EQU      %
         LB,R5    SR3
         CI,R5    X'14'
         BNE      CONT1
NO:GO    EQU      %
         LCF      FL:TAPE,R1
         BCR,2    NO:OPEN           DCB NOT OPEN
         CAL1,1   PFILEOF
*                 FL:TAPE; EOF
         CAL1,1   CLSTAPSV
*                 FL:TAPE; SAVE
         BAL,SR2  NO:RCV            MAILBOX
         B        OPN:NXT
NO:OPEN  EQU      %
         BAL,SR2  NO:RCV2           LOG ERROR
         B        OPN:NXT
CONT1    EQU      %
         CI,R5    X'0A'             ALREADY CLOSED
         BE       *SR1
         CI,R5    X'16'             KEY ALREADY EXISTS
         BE       *SR1
         CI,R5    X'18'             KEY DOES NOT CONFORM
         BE       SHORT
         CI,R5    X'2E'             ALREADY OPEN
         BE       *SR1
         CI,R5    X'03'             UPDATE MAILBOX DOESNT EXIST
         BNE      SHORT             ALL OTHER ABNS
         LI,R6    2                 OUTPUT MODE
         MTW,0    SYNFLAG
         BEZ      MODESET           NOT SYNONOMOUS
         LI,R6    4                 SET UP INOUT OPEN
         B        MODESET
         B        MODESET
         SPACE    5
**
ERBCK    EQU      %
         LB,R5    SR3
         CI,R5    X'03'             DOESNT EXIST
         BNE      *SR1
         CAL1,1   OPNBACKO
*                 ERR,ABN=GO:BACK1; OUT; SAVE
         B        GO:BACK1
         SPACE    5
** BACKUP TAPE ERRORS
TPABN    EQU      %
         LB,R5    SR3
         CI,R5    2                 END
         BE       ENDEND
         CI,R5    X'1A'             ABN COND.
         BNE      CONT              NO -- CHECK OTHERS
         SLS,R5   8
         LB,R5    R5                SUB CODE
         BEZ      NOERAB2           NO ERR OR ABN RET
         CI,R5    1
         BE       HETDCB2           NO
         CI,R5    2                 DCB'S NOT OPEN
         BE       ABORFILL
         CI,R5    3                 RIGHT MODE
         BE       ABORFILL
         LB,R5    SR3
         B        CONT              CHECK FURTHR
ENDEND   EQU      %
         LW,D1    SELECT
         BEZ      ENDEND1           NON-SELECTIVE
         CAL1,1   OPNXTAP
*                 FL:TAPE;ERR,ABN=BSR1;NXTF
         CAL1,1   CLSTPREM
*                 FL:TAPE; REMOVE
END:SEL:TAP EQU   %
         LW,R7    *SEL:BUF
         SLS,R7   -2
         LI,R6    5
*                 FIND HOW MANY ENTRIES WERE FOR THE TAPE JUST
*                   COMPLETED AND DELETE THOSE ENTRIES
NXT:SEL:DEL EQU   %
         CW,R6    R7
         BG       SEL:MT            NO MORE ENTRIES--ZAP TABLE
         LW,D1    *SEL:BUF,R6
         BLZ      SEL:HAS           SN=0 MEANS IS FOR THIS TAPE
         BNEZ     NO:FILL:LOG2
         LI,D2    18
         AW,R6    SEL:BUF
         LW,R4    -1,R6
         BEZ      NO:FILL:LOG1
         LW,R5    SEL:BUF
         SLS,R5   2
         AW,R4    R5
         LB,D2    0,R4
         LI,R5    BA(NO:FILL:FID)
         STB,D2   R5
         MBS,R4   1
         AI,D2    23
NO:FILL:LOG1 EQU  %
         STB,D2   NO:FILL:MESS
         LCI      2
         LM,R4    -3,R6
         STM,R4   MAIL:AC
         SW,R6    SEL:BUF
         LI,SR3   NO:FILL:PAR
         BAL,SR4  GOMAIL
NO:FILL:LOG2 EQU  %
         AI,R6    4
         B        NXT:SEL:DEL
*
ABORFILL DATA     ABORFILL          THIS WILL TRAP WITH REGS INTACT
*
*  GET ERR & ABN RETS
*
NOERAB2  EQU      %
         LI,R5    MOERR
         STW,R5   TAPEREAD+2        SET ERROR RET
         LI,R5    MOABN
         STW,R5   TAPEREAD+3        SET ABN IN FPT
         B        RD:USR
*
*   GET OUTPUT DCB
*
HETDCB2  EQU      %
         LI,R5    F:USR
         STW,R5   TAPEREAD+4        SET DCB2 IN FPT
         B        RD:USR
SEL:HAS  EQU      %
         LI,R5    2
         AI,R6    -3                ADJUST TO START OF ENTRY
SEL:HAS1 EQU      %
         LCI      4
         LM,D1    *SEL:BUF,R6       PULL UP ENTRIES OF DELETIONS
         STM,D1   *SEL:BUF,R5
         AI,R5    4
         AI,R6    4
         CW,R6    R7
         BL       SEL:HAS1
*                 FINISHED SLIDES, RESET POINTER
         SLS,R5   2                 WD IX TO BYTE IX
         STW,R5   *SEL:BUF
         CAL1,1   WRITBREC
*                 ERR,ABN=BSR1;ONEWKEY;BUF=SEL:BUF;KEY=SELKEY
         LI,R7    F:BREC
         CAL1,1   TRUNC
         B        SEL:OPN:SELF
ENDEND1  EQU      %
         LW,SR4   ZAPACCT
         BEZ      ENDEND2           NOT INCR TAPE W/FILDIR
         LB,R4    LBLORG,R3         IF NOT X'FF',
         CI,R4    X'FF'              INCREMENTAL DID NOT
         BNE      ENDEND2             COMPLETE NORMALLY.
         LI,SR4   -1                SET MAX ACCT NBR
         STW,SR4  BLABL+4
         B        DO:FILDIR
ENDEND2  EQU      %
         STW,R0   ZAPACCT
         BAL,SR4  DO:TIME
         LH,R4    FL:TAPE
         CI,R4    X'20'
         BANZ     UNLOAD
         CAL1,1   OPNXTAP
*                 FL:TAPE;ERR,ABN=BSR1;NXTF
         CAL1,1   OPNDEVTP
*                 ERR,ABN= BSR1; DEVICE = 'MT'
UNLOAD   CAL1,1   CLSTPREM
*                 REMOVE
SUPERCLOSE EQU    6
         CAL1,9   SUPERCLOSE
UNLOAD1  EQU      %
         LI,R5    OPERMSG
         LI,R6    YES
         LI,R7    1
         CAL1,2   KEYIN
         LB,R6    YES,R1
         CI,R6    'Y'
         BE       YESFL
         CI,R6    'N'
         BNE      UNLOAD1
NO:FILL  LI,R0    0
         LI,R1    1
         CAL1,1   OPENBACK
*                 ERR,ABN=ERBCK; INOUT
*                   CREATE A :BACKUP FILE IF NONE EXISTS
GO:BACK1 EQU      %
         CAL1,1   CLSBACK
*                 SAVE
GO:BACK  EQU      %
         LI,SR4   BACKUP
         STW,SR4  BACKXT
         B        RELEASE           OVERLAY
*
*  M:MOVE
*                                   FPT ABN RET
MOABN    EQU      %
MOERR    EQU      %
         LB,R5    SR3
         CI,R5    X'1C'             END OF TAPE - IMPOSSIBLE
         BE       SHORT
         CI,R5    5                 END OF DATA
         BE       ENDFILE
         CI,R5    6
         BE       ENDFILE
         CI,R5    7                 LOST DATA
         BE       NXT3
         CI,R5    X'41'             READ ERR
         BE       DONE
         CI,R5    X'57'             RAD SATURATION ABNORMAL
         BNE      SHORT             ALL OTHERS GET CUT OFF
         AI,R8    -1
         STW,R8   57ERR             RETURN ADDRESS FOR RETRY
*
         LW,D1    *GRANRADAD
         AW,D1    *GRANPACKAD       SUM OF AVAILABLE STORAGE
         BL       TOPURGE           FILL PROBLEM, NO GRANS AVAILABLE
*
*        JIT AUTHORIZATHIN NOT ENOUGH, MUST BUMP
*
         LI,D1    -1
         LI,D2    X'3FFF'
         STH,D2   D1                LARGE POSITIVE NUMBER => D1
         LI,R7    PRDCRM
         STW,D1   J:JIT,R7
         LI,R7    PRDPRM
         STW,D1   J:JIT,R7
         CAL1,1   PRECORDT          BACKSPACE BOTH TAPE AND
         CAL1,1   PRECORDF           FILE FOR RETRY
         B        *57ERR            TRY AGAIN
*
TOPURGE  EQU      %                 TELL OPERATOR SITUATION AND WAIT
         STW,R1   INT               SET UP FOR OPERATOR COMMAND
         LI,R5    NOGRANS           TELL HIM THE PROBLEM
         CAL1,2   TYPE
         BAL,R11  PURGE
         B        *57ERR
*
NXT3     EQU      %
         LH,R12   NMPG              REMEMBER WHAT WE HAVE
         LW,R5    R12
         CW,R5    DEFAULT
         BNE      %+3
         AW,R5    PGINCRM           ADD THE FIRST INCREMENT
         B        %+2
         AI,R5    255               GET ALL THERE IS
         BAL,SR4  GETBUF
         CW,R12   R7
         BE       DONE              DIDN'T GET ANY MORE, GIVE UP
         CAL1,1   PRECORDT
*                 REVERSE
         B        RD:USR
CONT     CI,R5    X'14'
         BNE      CONT2
         REF      INT
         MTW,0    INT               CHK FOR ABN 14 CAUSED BY INT
         BE       SHORT
         AI,SR1   -1                YES-REPEAT M:OPEN
         B        *SR1
CONT2    CI,R5    X'0A'             ALREADY CLOSED
         BE       *SR1
         CI,R5    X'B'
         BE       NO:GO             ERROR IN SENTINEL
         REF      ERR49,ERR55
         CI,R5    X'49'
         BE       ERR49
         CI,R5    X'55'
         BE       ERR55
DONE     EQU      %
         LCF      F:USR,R1
         BCR,2    NO:GO             DCB NOT OPEN
         CAL1,1   CLSUSREL
*                 RELEASE
         B        NO:GO
         SPACE    3
GOMAIL   EQU      %                 SELECT MAILBX ENTRY ON TIME CHANGE
         REF      MTIME,FMAILBX
         LW,R4    *TIMEAD
         XW,R4    MTIME
         CW,R4    MTIME
         BNE      MAILBOX           NEW TIME
         B        FMAILBX           SAME TIME
         SPACE    5
TPERR    EQU      TPABN
ENDFILE  EQU      %
         CAL1,1   CLSUSRSV
*                 SAVE
         LI,R4    9
         LW,R6    F:USR+22,R4       TRANSFER FILENAME TO SUCCESS
         STW,R6   SUCCESS+1,4       MESSAGE
         BDR,R4   %-2
         LB,R4    F:USR+23
         AI,R4    8
         STB,R4   SUCCESS
         LI,R4    C' '
         STB,R4   SUCCESS+2
         LI,D4    0                 NO MAILBOX FILE ENTRY
         LI,SR3   MAILSUC
         BAL,SR4  GOMAIL
ENDFILE1 EQU      %
         CAL1,1   CLSTAPSV
*                 SAVE
*                 IF SELFIL OF SINGLE FID,ZAP ENTRY, & CHK TABLE
         LW,R6    SELECT
         BEZ      OPN:NXT
         LW,R7    SELFID:PTR
         BEZ      OPN:NXT
         B        ZAP:DONE
         SPACE    5
USRERR   EQU      %
         LB,R5    SR3
         CI,R5    X'51'
         BE       DONE
         CI,R5    X'55'
         BE       ERR55
         BG       DONE
         LI,R6    30
         STH,R6   SLP:FPT,1
         CAL1,8   SLP:FPT
         B        DONE
**
SHORT    EQU      %                 SHORT RECORD MEANS BAD TAPE FILE
** MAILBOX FAILURE TO RECOVER FILE
         BAL,SR2  NO:RCV
         CAL1,1   CLSUSRSV
*                 SAVE
         CAL1,1   CLSTAPSV
*                 SAVE
         B        OPN:NXT
BADTIME  EQU      %
         LI,R6    BADSEQ            FILE OUT OF SEQUENCE
         STW,R6   KADR-1            TEMP
         B        BDTP
BDTP     EQU      %
         LW,R5    KADR-1
         LI,R6    YES
         LI,R7    1
         CAL1,2   KEYIN
         LB,R6    YES,R1
         CI,R6    'C'
         BE       GO:ON
         CI,R6    'Q'
         BNE      BDTP
         CAL1,1   CLSTAPSV
*                 SAVE
         B        ENDEND
NO:RCV   EQU      %                 SEND NO RECOVERY TO MAILBOX
         LI,D4    1                 WRITE MAILBOX ALSO
         B        NO:RCV1
NO:RCV2  EQU      %
         LI,D4    0                 'FOLLOW' MSG--LOG ONLY
NO:RCV1  EQU      %
         LI,R7    7
         LB,SR1   SR3,R1
         SLS,SR1  15
         LB,SR4   SR3
         STB,SR4  SR1                  CODE,SUB-CODE IN 0-15
SEND:ERR1 EQU     %
         STB,R0   SR1,R3
         SCS,SR1  4
         AI,SR1   C'0'
         LB,SR4   SR1,R3
         CI,SR4   C'9'
         BLE      %+2
         AI,SR4   -X'39'            FA-39=C1, ETC
         STB,SR4  NOMSG,R7
         AI,R7    1
         CI,R7    11
         BL       SEND:ERR1
         LI,SR1   NOMSG:FOLL-1      'FOLLOW' MSG
         LW,D4    D4
         BEZ      %+2
         LI,SR1   NOMSG:FAIL-1      'FAIL' MSG
         LI,R7    5
         LW,SR4   *SR1,R7
         STW,SR4  NOMSG+2,R7
         BDR,R7   %-2
         LI,SR3   MAILPAR
         BAL,SR4  GOMAIL
         B        *SR2
SPECERR  EQU      %
SPECABN  EQU      %
         SPACE    5
         LB,R4    SR3
         CI,R4    2
         BNE      *SR1
         LB,R4    SR3,R1            SUBCODE
         CI,R4    2                 0,1=0, 2,3=1
         BL       SPLSTEND2         END THIS ACCT
         LW,SR3   BLABL+4
         CI,SR3   -1
         BE       ENDEND2
SPPAGREL EQU      %
SKIPPING EQU      %
         LW,SR3   L(X'200000')
         CW,SR3   FL:TAPE
         BAZ      OPN:NXT           DCB ALREADY CLOSED
         CAL1,1   CLSTAPSV
*                 SAVE
         B        OPN:NXT
         END      FILL

