*M*      PCLLIST LIST COMMAND PROCESSOR
LIST     DSECT    1
PLSECT   CSECT    1
         SYSTEM   SIG7
VERSION  EQU      2                 1=BPM, 2=UTS
         PAGE
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
* DISPLACEMENTS OF ATTRIBUTES IN PRINT BUFFER
ORG      EQU      2                 BYTE DISP
GRAN     EQU      1                 WORD DISP
REC      EQU      3
DATE     EQU      7
NAME     EQU      10
         TITLE    'LIST'
*P*      NAME:    PCLLIST
*P*
*P*      PURPOSE: TO SCAN THE LIST COMMAND FOR CORRECT SYNTAX AND TO
*P*               LIST THE NAMES OF FILES ON RAD, DISK PACK, OR TAPE AS
*P*               SPECIFIED BY THE COMMAND.  IF ATTRIBUTES ARE
*P*               REQUESTED FOR SINGLE FILES OR A FILE DIRECTORY
*P*               THE ORGANIZATION, RECORD COUNT, SIZE IN GRANULES, AND
*P*               MODIFICATION DATE FOR EACH FILE ARE LISTED.  DATE
*P*               ATTRIBUTES ARE ALSO LISTED IF THE EA OPTION IS USED.
*P*               THIS ROUTINE IS ALSO ENTERED TO PROCESS A REVIEW COMMAND.
*P*               A TAPE MAY BE IDENTIFIED BY THE 'LIST FT#SN' COMMAND.
         SPACE    5
         REF      CLRARG,DEVTRAN,BLDCB,FPARAM,CLOSEI,M:EI,M:UC,ERROR
         REF      DEVICE,TERM,J:JIT,M:LO
         REF      CMBX,GETARG,TEXTARG
         REF      CLOSEO
         REF      BCD2BIN,WRTFPT,ARGBUF4,NCHAR,FPTCONSL,CMDBUF
         REF      FILTRAN
         REF      HEX2BCD           MAKE TEXT OF BITS
         REF      JB:PCW            PLATEN WIDTH
         REF      M:EISN
         REF      PRTERR            PRINT ERRORS BEFORE TOF
         REF      ALLC              TYPE NAME/ERROR FOR DELETEALL
         REF      SKIPTXT           FOR SPE MESSAGE (IS IN COPYTRAN)
         REF      M:EO
         REF      BREAK
         REF      TOSWT
         DO1      VERSION=2
         REF      FPTPROMT
         REF      PRTNOF
         REF      SAVCMBX,PRTBUF
         REF      ARGBUFF,MODE,BIN2BCD
         REF      ATTRB
         REF      RDTBL
         REF      WRTBL
         REF      EXTBL
         REF      UNTBL
         REF      FILE
         REF      TRANSACT,#DELIM
         REF      OPNFPT
         REF      UNPRINT,SYNONYM
         REF      IOBUF
         REF      SYNFLAG
         REF      COBUSED
         REF      ERRFLAG
         REF      LTSTCMBX
         REF      EATTRB,DATETBL
         REF      COPYSK,FROMFILE,TOFILE,DELETEF
         REF      REVIEW
         REF      TLABEL
         REF      GRANCNT
         REF      TLBLSIZE
         REF      COPYPHY
         REF      LISTCMBX,LISTTERM
         REF      SFDEV
         DEF      TESTFNC
         DO1      VERSION=2
         DEF      REVRP             ONE BYTE READ CAL(FOR BREAK INPCL)
         DEF      READONE           ONE BYTE READ SUBROUTINE
         REF      CMBX1             START OF COMMAND INDEX
         REF      SFARG
         REF      RSSAVE
         REF      BOG
         PAGE
         USECT    LIST
         LCI      7
         PSM,R5   *R7
         CAL1,8   TIMECAL
         LI,SR2   0                 INITIALIZE FILE COUNT
         STW,R0   ATTRB,R7          ZERO ATTRIBUTE FLAG
         STW,R0   EATTRB            ZERO EXT ATTRIBUTE FLAG
         STW,R0   COBUSED,R7        ZERO ERR SEV SAVE WORD
         STW,R0   GRANCNT           INITIALIZE GRANULE COUNT
         LI,R2    3
         STW,R2   COLSIZE,R7
LIST24   BAL,SR4  CLRARG            CLEAR ARGTBL
LIST25   EQU      %
         LW,R2    TERM,R7
         CI,R2    X'15'             'LIST' ONLY
         BE       LIST44
         CI,R2    '('               '(A)' POSSIBLE
         BE       LIST8             YES
         CI,R2    '/'               '/N.A.P' POSSIBLE
         BE       LIST9             YES
         LW,R5    CMBX,R7
         STW,R5   SAVCMBX,R7        SAVE POINTER TO DEVICE OR FID
         BAL,SR4  DEVTRAN           GO TRANSLATE DEVICE
         STW,R0   SAVCMBX,R7        ZERO CMBX SAVE WORD
         LW,R2    DEVICE,R7         VALID DEVICE
         CI,R2    3                 RAD
         BE       LIST2             YES
         CI,R2    5
         BE       LIST4             DP
         MTW,0    DELETEF           IF REVIEW, TAPE ISNT OK
         BNEZ     %+5
         CI,R2    4                 LT
         BE       LIST4
         CI,R2    6
         BE       LIST44            FT
         LI,R1    34                ERROR-INVALID DEVICE TYPE
         B        LIST3
LIST2    LW,R1    DEVICE+1,R7       TAPE REEL NO. SPECIFIED
         BEZ      LIST4             NO-O.K.
         LI,R1    22                ERROR-REEL NO. SPECIFIED FOR RAD
LIST3    BAL,SR4  ERROR
LIST4    LW,R5    TERM,R7
         CI,R5    '/'               DOES 'N.A.P' FOLLOW
         BE       LIST9             YES
LIST44   EQU      %
         LW,R5    TERM,R7
         CI,R5    '('               DOES 7T,9T, OR 'A' FOLLOW
         BE       LIST8             YES
         STW,R5   LISTTERM          SET TERMINATOR
         CI,R5    X'15'             PROPER TERMINATION
         BE       LIST5             YES
         CI,R5    ','               MORE TO COME
         BNE      LIST18            NO, SYNTAX ERROR
         MTW,0    ATTRB,R7          COMMA OK IF FILE NAMES
         BGZ      LIST5
         MTW,0    FROMFILE          OR RANGE
         BNEZ     LIST9
LIST18   LI,R1    17                EH
LIST6    BAL,SR4  ERROR
LIST5    EQU      %
         CI,D2    1                 CAN EXECUTE
         BG       LISTEND           NO
         LI,R1    6
         CW,R1    DEVICE,R7    CHECK FOR PCL DEVICE.
         BE       LISTFT       YES.
         PAGE
LIST20   LI,R1    4                 OPEN NEXT, INPUT
         DO       VERSION=2
         LW,R1    =X'80004'         TESTFILE, OPEN NEXT, INPUT
         FIN
         LW,R5    ATTRB,R7          ATTRIBUTES WANTED
         BEZ      LIST23            NO
         LI,R1    2                 FPARAM, INPUT
         CI,R5    1                 'N.A.P' SPECIFIED
         BE       LIST21            YES
         LI,R1    6                 OPEN NEXT, FPARAM, INPUT
LIST21   EQU      %
LIST23   LI,R5    0                 ZERO PASSWORD FLAG
         CAL1,1   FPTSET3           SET ERR/ABN FOR M
         BAL,SR4  BLDCB             GO-BUILD INPUT DCB
         LI,R2    2
         CB,R2    SR3               ANY FILES PRESENT
         BE       LIST50            NO
         MTB,0    SR3               ERR OR ABN IN BLDCB
         BNEZ     ERRADD            YES
         CI,D2    0
         BNE      SOMERR
         CAL1,1   FPTSET3           SET ERR & ABN FOR M:LO
         USECT    PLSECT
FPTSET2  GEN,8,7,17      X'06',0,M:EI
         DATA     X'C0000000'
         DATA     ERRADD
         DATA     ERRADD
FPTSET3  GEN,8,24 6,M:LO
         DATA     X'C0000000'
         DATA     ERRADD2
         DATA     ERRADD2
TIMECAL  GEN,8,24 X'10',DATETBL
         USECT    LIST
LIST1    LI,D3    PRTBUF
         CAL1,1   FPTSET2           SET ERRADD
         BAL,SR4  TESTFNC           TEST IF FILE WANTED
         B        LIST33            NO
         AW,D3    R7                BUFFER ADDRESS
         LI,R6    M:LO
         LI,R1    M:EI+23
         LW,R3    ATTRB,R7
         OR,R3    DELETEF           IF SIMPLE LIST,
         BNEZ     LIST19            DO IT HORIZONTALLY
         AI,SR2   0                 IF FIRST FILE, CLEAR BUFFER
         BNEZ     LIST191
LIST19   LI,R3    63
         LW,R2    ='    '
         STW,R2   *D3,R3
         BDR,R3   %-1
         STW,R2   *D3
         LW,R2    ATTRB,R7
         BNEZ     LISTATB           LIST A,EA
         MTW,0    DELETEF
         BNEZ     LIST17            REVIEW
         STB,R3   *D3               CLEAR BYTE COUNT
LIST191  LB,SR1   *D3
         AW,D3    SR1
         BAL,SR4  UNPRINT
         SW,D3    SR1               RESTORE BUFFER ADDR
         XW,D3    R1                PUT IN 1
         SLD,R2   -2-32             ROUND TO COLUMN SIZE,R7
         AW,R3    COLSIZE,R7
         DW,R3    COLSIZE,R7
         MW,R3    COLSIZE,R7
         LW,R2    SR1               SAVE CURRENT LINE SIZE
         SLS,R2   2                 FOR WRITE CAL
         AW,SR1   R3                HAVE WE OVERFILLED THE PAGE
         STB,SR1  *R1
         LI,R3    1                 SET BTD FOR WRITE
         LI,R5    BA(JB:PCW)        GET PLATEN WIDTH
         LB,R5    0,R5
         SLS,R5   -2
         LI,SR4   3                 ARE WE GOING TO A ME
         CS,SR4   M:LO
         BNE      %+4               NO, NOT EVEN A DEVICE
         LW,SR4   M:LO+1
         CI,SR4   X'6F00'
         BAZ      %+2               YES, USE PCW
         LI,R5    27                NO ASSUME A PRINTER
         CW,SR1   R5
         BLE      LIST30            NO
         AI,R2    0                 IF NOTHING TO PRINT,
         BEZ      LIST30            WE MUST PRINT IT NOW
         CAL1,1   FPTLFILE
         XW,R1    D3
         B        LIST19
COLSIZE  EQU      WRTFPT
LIST17   RES
         BAL,SR4  UNPRINT           ENTER FILE NAME IN BUFFER
         LW,R1    D3
         DO       VERSION=2
         MTW,0    2,R7              IS HEADER PRINTED
         BNEZ     %+3               YES
         MTW,1    2,R7              SET HEADER FLAG
         CAL1,1   REVFPT            PRINT HEADING
         BAL,SR4  ABN14T            TEST FOR ACCSEEABILITY
REVRET1  RES                        RETURN FOR AN14T
         BAL,SR4  LFILE
REVRET2  LB,R3    SR3               DID WE GET ERROR
         CI,R3    X'F7'             BESIDES 08 (SYNON)
         BANZ     LIST26            YES, NO REQUEST
         LI,SR4   LIST22            SET RETURN
READONE  RES
         LCI      4                 SAVE A FEW REGS
         PSM,SR1  *R7
         CAL1,8   TSFPT             READ DIFFERNENTLY IF HALF DUPLEX
         SLS,8    3                 OR 2741..MODE2/X10, MODE6/X80
         OR,SR1   SR4               PUT BOTH BITS TOGETHER
         SLS,8    -21               AND AT 4
         LI,SR2   4
         AND,SR2  SR1
         BNEZ     %+2
         LI,SR2   1                 READ ONE BYTE ON TTYS
REREAD1  STW,R0   CMDBUF,R7         CLEAR INPUT BUFFER
         ANLZ,SR3 %-1               SET ADDRESS
REVRP    EQU      %
         CAL1,1   READFPT           READ REPLY
         BIR,SR1  %+2               GET REPLY FIRST TIME ONLY
         LB,R1    *SR3
         LW,SR4   CMDBUF,R7         MUST HAVE <4 CHAR INPUT
         LI,SR1   -100
         CI,SR4   X'FF'
         BANZ     REREAD1           KEEP TRYING
         CAL1,8   TSFPT             CHECK PLATEN POSITION
         STW,SR2  CMDBUF,R7         SAVE OUTPUT COUNT
         SLS,SR2  -25
         STB,SR2  DELETEF
         LCI      4
         PLM,SR1  *R7
         B        *SR4
LIST27   RES
         MTB,0    DELETEF           DO WE NEED CR
         BEZ      LIST30            NO
         B        LIST26
LIST22   RES
         CI,R1    'E'               IF E, TERMINATE, REVIEW
         BNE      %+2
         MTW,1    BREAK
         CI,R1    'D'               IS DELETE WANTED
         BNE      LIST27            NO
         LW,R6    CMDBUF,R7         CHECK OUTPUT COUNT
         CW,R6    =X'FC0000'
         BAZ      REVDEL            VERY LITTLE, OK
         CAL1,1   WRTQUST
         B        LIST1             TRY AGAINE
WRTQUST  GEN,8,24 17,M:UC
         DATA     X'34000010',QUST,3,0
QUST     TEXT     '??  '
REVDEL   RES
         BAL,SR4  CLOSEI            CLOSE IN CASE OPEN (REV(A))
         LI,R2    0                 SET BUFFER/DISP FOR ABN14T
         LW,R1    D3
         CAL1,1   REVOPN            OPEN FILE
         CAL1,1   FPTDELET          RELEASE FILE
         BAL,R6   RANDCHK           TEST IF RANDOM FILE
         CAL1,1   WRTDEL            WRITE *DELETED*
         AI,SR2   X'10000'          COUNT DELETED FILES
LIST26   CAL1,1   WRTCR             WRITE CARRIAGE RETURN
         STB,R0   DELETEF           RESET CR NEEDED FLAG
        FIN
         USECT    PLSECT
FPTLFILE GEN,8,24 X'91',R6
         DATA     X'34000010'
         PZE      *R1               BUFFER
         PZE      *R2               COUNT
         PZE      *R3               BYTE DISPLACEMENT
TSFPT    GEN,12,20 X'066',0
         USECT    LIST
LIST30   EQU      %
         AI,SR2   1                 INCREMENT FILE COUNT
LIST33   BAL,SR4  CLOSEI            GO CLOSE M:EI
LIST31   EQU      %
         MTW,0    BREAK             BREAK SET
         STW,R0   BREAK             CLEAR BREAK
         BNEZ     LIST40            YES
         MTW,0    TOFILE            ANY MORE LISTING WANTED
         BLZ      LIST40            NO
         MTW,0    ATTRB,R7          WAS FID SPECIFIED
         BLEZ     LIST32            NO
         LW,R1    TERM,R7
         CI,R1    '('               WAS OPTION SPECIFIED
         BNE      LIST35            NO
         LW,R1    LISTCMBX          RESTORE SCAN POINTER
         STW,R1   CMBX,R7
         LW,R1    LISTTERM          GET TERMINATOR
         STW,R1   TERM,R7
LIST35   EQU      %
         CI,R1    ';'               NEW DEVICE
         BE       LIST24            YES
         CI,R1    ','               ANOTHER FID
         BNE      LIST40            NO
         B        LIST9             YES - GO PROCESS
         DO       VERSION=2
LIST28   CAL1,1   WRTFB             WRITE 'FILE BUSY'
         B        LIST26
         FIN
LIST32   EQU      %
         BAL,SR4  OPNNXT
         BCS,8    LIST40            ALL DONE
         BE       LIST7             NOT GETTING ANYWHERE
         B        LIST1
REVOPN   GEN,8,7,17      X'14',0,M:EI
         DATA     X'C1200000'
         DATA     ABN14T,ABN14T
         DATA     4                 INOUT
         DATA     TLABEL            FPARAM
READFPT  GEN,8,24 X'10',M:UC
         DATA     X'34000000'
         PZE      *SR3
         PZE      *SR2
         DATA     0
WRTCR    GEN,8,24 X'11',M:UC
         DATA     X'34000010'
         DATA     REVMSG
         DATA     1
         DATA     0
REVFPT   GEN,8,24 X'11',M:UC
         DATA     X'34000010'
         DATA     REVMSG
         DATA     27
         DATA     0
REVMSG   TEXT     '
--ENTER D TO DELETE FILE.
'
DELMSG   TEXT     ' *DELETED*'
WRTDEL   GEN,8,24 X'11',M:UC
         DATA     X'34000010'
         DATA     DELMSG
         DATA     10
         DATA     0
WRTFB    GEN,8,24 X'11',M:UC
         DATA     X'34000010'
         DATA     FILEBUSY
         DATA     14
         DATA     0
         PAGE
TESTFNC  LB,R2    FROMFILE
         BEZ      TEST1             NO - FILE WANTED
         MTW,0    COPYPHY
         BNEZ     TEST1             COPYING TAPE IN PHYS ORDER
         LI,R4    1
TEST4    EQU      %
         CB,R4    M:EI+23           ARE WE PAST NAME IN DCB
         BG       *SR4              YES - FILE BELOW RANGE
         LB,R3    M:EI+23,R4        COMPARE FILE NAMES
         CB,R3    FROMFILE,R4
         BL       *SR4              BELOW RANGE - EXIT
         BG       TEST1
         AI,R4    1
         BDR,R2   TEST4
         LB,R4    SR3               IF NO SUCH FILE, DONT WANT
         CI,R4    3                 FIRST ONE
         BE       *SR4
TEST1    MTB,0    TOFILE            WAS A TO FILE SPECIFIED
         BEZ      TEST3             NO - FILE WANTED
         LI,R4    1
         LB,R2    TOFILE
         MTW,0    COPYPHY           COPYING TAPE IN PHYS ORDER
         BEZ      TEST5             NO
         CB,R2    M:EI+23           ARE NAME LENGTHS EQUAL
         BNE      TEST3             NO - FILE WANTED
TEST6    LB,R3    M:EI+23,R4
         CB,R3    TOFILE,R4         TEST IF WE HAVE FOUND TO FILE
         BNE      TEST3             NO - FILE WANTED
         AI,R4    1
         BDR,R2   TEST6
         AI,SR4   1
         B        TEST7             FOUND - TAKE WANTED EXIT
TEST5    EQU      %
         CB,R4    M:EI+23           ARE WE PAST NAME IN DCB
         BG       TEST3             YES - FILE IN RANGE
         LB,R3    M:EI+23,R4
         CB,R3    TOFILE,R4         COMPARE FILE NAMES
         BL       TEST3             IN RANGE
         BG       TEST2             OUT OF RANGE
         AI,R4    1
         BDR,R2   TEST5
         LB,R2    M:EI+23
         CB,R2    TOFILE            END OF RANGE HIT
         BNE      TEST2             YES
         AI,SR4   1
         B        TEST2
TEST3    AI,SR4   1
         B        *SR4              EXIT FOR FILE WANTED
TEST2    RES
         LI,R1    2                 IF TAPE FILES, KEEP LOOKING
         CW,R1    M:EI              IF NOT COPYPHY
         BANZ     *SR4
TEST7    RES
         LW,R1    =X'80000000'      SET END OF RANGE FLAG
         STS,R1   TOFILE
         B        *SR4
         PAGE
GETARG6  LI,R1    6
         B        GETARG
LIST8    BAL,SR4  GETARG6           GET NEXT ARGUMENT
         LW,R1    ARGBUFF,R7
         SLS,R1   -8                MAKE CI'C WORK
         CI,R1    X'1D940'          TEST IF 'R'ANGE
         BNE      %+3
         MTW,1    FROMFILE          SET FLAG FOR RANGE
         B        LIST11
         CI,R1    X'1C140'          TEST IF 'A'TTRIBUTES
         BE       LIST10            YES
         CI,R1    X'2C5C1'          TEST IF EA
         BE       LIST16            YES
         LI,R2    3                 MODE CODE FOR 7T
         CI,R1    X'2F7E3'          TEST IF '7T'
         BE       LIST12            7T
         LI,R2    4                 MODE CODE FOR 9T
         CI,R1    X'2F9E3'          TET IF '9T'
         BE       LIST12
         AI,R1    -X'2C3F0'         TEST IF COLUMN WIDTH.'CN'
         BLZ      LIST14            <C0
         BGZ      %+2
         LI,R1    15                C0 MEANS ONE PER LINE
         CI,R1    X'FFFF0'
         BANZ     LIST14            >C9
         STW,R1   COLSIZE,R7
         B        LIST11
LIST12   LW,R1    DEVICE,R7
         CI,R1    4
         BE       LIST13            LT - OK
         CI,R1    6
         BE       LIST13            FT - OK
LIST14   LI,R1    25                ERROR-MODE SPEC NOT VALID
         BAL,SR4  ERROR
         B        LIST11
LIST13   STW,R2   MODE+1,R7         SET CODE FOR 7T OR 9T
LIST11   LW,R2    TERM,R7
         CI,R2    ','               IS THERE ANOTHER OPTION
         BE       LIST8             YES
         CI,R2    ')'               VALID DELIMITER
         BNE      LIST18            NO - ERROR
         BAL,SR4  GETARG6           CHECK NEXT ARG
         MTW,0    ATTRB,R7          IF NO N.A.P YET,
         BLEZ     LIST111           NO DELIMITER HERE
         MTW,0    NCHAR,R7          IS ARGUMENT NULL
         BNEZ     LIST18            NO - ERROR
         LW,R2    TERM,R7
         STW,R2   LISTTERM          SAVE TERMINATOR
         CI,R2    ','               CHECK REASONABLENESS OF DELIMITER
         BE       %+3
         CI,R2    X'15'
         BNE      LIST18
         LW,R1    CMBX,R7
         STW,R1   LISTCMBX          SAVE SCAN POINTER
         B        LIST5
LIST111  LW,R1    LTSTCMBX          REREAD LAST PIECE
         STW,R1   CMBX,R7           IF THERE WAS ONE
         MTW,0    NCHAR,R7
         BEZ      LIST25
         LI,R1    ' '               SET GOOD DELIMITER FOR REVIEW
         MTW,0    FILE,R7           IF ACCOUNT ALREADY THERE, MUST BE RANGE
         BEZ      %+3
         LI,R1    '/'
         MTW,1    FROMFILE
         STW,R1   TERM,R7           IF THERE'S A NAME
         B        LIST25
LIST9    RES
         MTW,0    FROMFILE          IF RANGE, GET IT
         BEZ      %+3
         BAL,SR4  REVIEW
         B        LIST5
         BAL,SR4  FILTRAN
         LI,R1    1
         STW,R1   ATTRB,R7          SET ATTRIBUTE FLAG FOR 1 FILE
         LI,R1    X'FFFF'           ZERO 1 FILE EA FLAG
         STS,R0   EATTRB
         LW,R1    TERM,R7
         STW,R1   LISTTERM
         CI,R1    '('               OPTION FOLLOW
         BNE      LIST5             NO
         B        LIST8             YES - GO SCAN
LIST16   MTW,1    EATTRB            SET 1 FILE EA FLAG
         LI,R1    X'F0001'          AND ALL FILES FLAG IF FIRST
LIST10   MTW,0    ATTRB,R7          WAS FID SPECIFIED
         BGZ      LIST11            YES
         LI,R2    -1
         STW,R2   ATTRB,R7          SET ATTRB FLAG FOR ALL FILES
         BDR,R1   LIST11            IF NOT FROM EA,
         STW,R1   EATTRB            DONT SET ALL FILES EA FLAG
         B        LIST11
         PAGE
WEOFLO   GEN,8,24 2,M:LO
LISTATB  XW,R2    2,R7              IS THIS THE FIRST FILE
         BNEZ     LISTATB1          NO - SKIP HEADER
         LI,R6    M:LO              OUTPUT TO M:LO
         MTW,0    DELETEF           IF REVIEW, ADD DELETE MSG
         BEZ      %+4
         LI,R6    M:UC              AND WRITE THROUGH UC
         CAL1,1   REVFPT
         MTB,-1   DELETEF           SET CR NEEDED FLAG
         MTW,0    ATTRB,R7          NAME LIST OR RAGNE IN ONE ACCOUNT
         BGZ      NODATEHD          LIST, NO DATE/ACCOUNT
         CAL1,1   WEOFLO            TOP OF FORM FOR PRINTERS
         LI,D3    BA(DATETBL)       PREPARE FOR WACCN20
         STW,D3   RSSAVE,R7
         LI,D4    1                 ONE ACCOUNT
         LI,D3    15                15 BYTES INTO BUFFER
         LI,R4    M:EI+31           ACCOUNT IN DCB
         BAL,SR4  ACCTX             FOMAT IT
         ANLZ,D3  PRTBUFI7          RESTORE BUFFER ADDRESS
         LI,R3    0
         LI,R1    DATETBL           OUTPUT THE LINE
         AI,R2    25
         CAL1,1   FPTLFILE
NODATEHD RES
         LB,R2    LISTHEAD          LENGTH OF HEADER
         LI,R1    LISTHEAD          BUFFER ADR
         LI,SR4   LISTATB1
LFILE    RES
         LI,R3    1                 BTD
         LI,R6    M:LO
         MTW,0    DELETEF           IF REVIEW, USE UC, START AT
         BEZ      LFILE1            START OF LINE
         MTB,-1   DELETEF           SET/CHECK CR NEEDED FLAG
         BNC      %+2
         CAL1,1   WRTCR
         LI,R6    M:UC
LFILE1   RES
         CAL1,1   FPTLFILE          PRINT ATTRIBUTE HEADER
         B        *SR4
LISTATB1 EQU      %
         AI,D3    NAME
         LI,R1    M:EI+23
         BAL,SR4  UNPRINT           ENTER FILE NAME IN BUFFER
         LI,R1    PRTBUF
         AW,R1    R7
         AI,R2    NAME*4            LENGTH OF PRINT LINE
         STW,R0   SYNONYM,R7        ZERO SYNON FLAG
         STW,R0   RDTBL             CLEAR ACCN COUNTS
         STW,R0   WRTBL
         STW,R0   EXTBL
         STW,R0   UNTBL
         LI,R6    8
         STW,R0   DATETBL-1,R6      ZERO DATE TABLE
         BDR,R6   %-1
         LI,SR4   LISTATB2
ABN14T   EQU      %
         LB,R3    SR3
         BEZ      *SR4              ALL IS OK
         CI,R3    8                 SYNON IS OK TOO
         BE       *SR4
         LCI      8
         PSM,SR4  *R7
         LB,R1    SR3
         SLS,R1   8
         AH,R1    SR3
         SLS,R1   -1
         BAL,SR4  HEX2BCD
         LCI      3
         PLM,R0   *R7
         STW,R3   D4                CODE TO D4
         LCI      4
         LM,SR4   INACCM            GET *INACCESSIBLE*
         LI,R3    -20
         LB,R4    16,R3
         AI,R2    1
         STB,R4   *R1,R2
         BIR,R3   %-3
         LCI      5
         PLM,SR4  *R7
         MTW,0    ATTRB,R7          SIMPLE ONLINE REVIEW
         BNEZ     LISTATB9          NO
         B        REVRET1           YES
LISTATB2B PSW,1   *R7
         LB,R1    M:EI+12           GET KEYM
         BAL,SR4  BIN2BCD
         PLW,R1   *R7
         LI,R2    ' K'
         STH,R2   R3
         STW,R3   0,R1
         B        LISTATB2A
OPNEI    GEN,8,24 20,M:EI
         DATA     0                 NO OPTIONS
LISTATB2 LW,D3    R2                SAVE LINE LENGTH
         LW,R2    DEVICE,R7
         CI,R2    4            LABELED TAPE?
         BNE      %+4               NO
         LW,R3    TLABEL+1
         CW,R3    ='RFIL'           IS FILE RANDOM
         BE       LISTRAND          YES
         MTB,0    SR3               IF SYNON, OPEN THE REAL FILE
         BEZ      %+2
         CAL1,1   OPNEI
         LI,R2    3
         LB,R3    M:EI+5,R2         GET ORG CODE
         SLS,R3   -4
         LB,R2    ORGN,R3
         BEZ      LISTATB2B         KEYED, DO KEYMAX TOO
         LI,R4    ORG               GET BYTE DISPLACEMENT
         STB,R2   *R1,R4            'K' OR 'C' TO PRINT BUFFER
*
LISTATB2A LI,R4   1                 SET BYTE DISP REGS FOR VLP SEARCH
         LI,R2    2
         LI,R3    3
         LW,SR3   M:EI+11           FPARAM ADDR
LISTATB3 LB,R5    *SR3              GET VLP CODE
         DO1      VERSION=1
         CI,R5    X'10'
         DO1      VERSION=2
         CI,R5    X'15'             MAX CODE
         BG       LISTATB4          NOT USEFUL
         MTB,0    *SR3,R2
         BEZ      LISTATB4          PARAMETER NOT PRESENT
         EXU      VLPTAB-1,R5       BRANCH IF WANTED - OTHERWISE NOP
LISTATB4 MTB,0    *SR3,R4           TEST IF LAST ENTRY
         BNEZ     LISTATB7          YES
         LB,R5    *SR3,R3           GET LENGTH OF PARAMETER
         AW,SR3   R5                INCREMENT VLP POINTER
         AI,SR3   1                 INCREMENT FOR CODE WORD
         B        LISTATB3          GET NEXT CODE
LISTATB7 LI,R3    ORG
         LB,R2    *R1,R3
         CI,R2    'R'               IS ORG RANDOM
         BE       LISTATB6          YES - LEAVE NO. REC BLANK
         STW,R1   RSSAVE,R7         SAVE BUFFER ADR
         LI,R1    X'7FFF'           INITIALIZE PREC COUNT
LISTATB8 CAL1,1   FPTPREC           DO PRECORD TO GET NUM OF RECS
         USECT    PLSECT
FPTPREC  GEN,8,7,17      X'1D',0,M:EI
         DATA     X'C0000000'
         DATA     X'00007FFF'       32767 RECS
         DATA     ABNPREC           ABNORMAL ADR
         USECT    LIST
         AI,R1    X'7FFF'           ANOTHER PREC REQD - BUMP COUNT
         B        LISTATB8
*
ABNPREC  LW,R2    M:EI+4
         SLS,R2   -17               GET ARS FROM DCB
         CI,R2    0                 NULL FILE OR MULTIPLE OF 32K REC
         BNE      %+2               NO
         AI,R1    -32767            REDUCE COUNT TO ACTUAL NUMBER
         SW,R1    R2                COMPUTE NUM OF RECS IN FILE
         BAL,SR4  BIN2BCD           CONVERT TO BCD
         LW,R1    RSSAVE,R7         RESTORE BUFFER ADR
         STW,R2   REC,R1            ENTER NUM OF RECS IN PRINT LINE
         STW,R3   REC+1,R1
LISTATB6 RES
         SLS,R1   2                 SAVE BA(BUFFER IN RSSAVE
         STW,R1   RSSAVE,R7         FOR WACC
         BAL,SR4  SYNONX            PRINT SYNON
         BAL,SR4  RACCTX            PRINT READ ACCOUNTS
         BAL,SR4  WACCTX            PRINT WRITE ACCOUNTS
         DO       VERSION=2
         BAL,SR4  EACCTX       PRINT EXECUTE ACCOUNTS.
         BAL,SR4  UACCTX       PRINT VEHICLE ACCOUNT.
         FIN
         LW,R2    D3                PRINT THE LINE
         LW,R1    RSSAVE,R7
         SLS,R1   -2
         LI,SR3   0                 CLEAR ERROR REG
LISTATB9 BAL,SR4  LFILE             PUT IT OUT
         MTW,0    EATTRB            WAS 'EA' SPECIFIED
         BEZ      %+2
         BAL,SR4  DATELIST          GO LIST DATE ATTRIBUTES
         MTW,0    DELETEF           ARE WE REVIEW
         BNEZ     REVRET2           YES
         B        LIST30            GO CLOSE FILE
LISTRAND LI,R2    'R'               RANDOM FILE ON TAPE
         LI,R4    ORG
         STB,R2   *R1,R4            PUT 'R' IN PRINT BUFFER
         LI,R4    1
         LI,SR3   TLABEL+1          LOC -1 OF NO OF GRANULES
         BAL,SR4  GRANULE           GO PUT GRANULES IN BUFFER
         B        LISTATB2A         GET REST OF ATTRIBUTES
ERRADD   LB,R1    SR3
         LI,R2    X'FF00'           IS THERE A NAME
         CW,R2    M:EI+22
         BAZ      LIST7             NO
         CI,R1    8                 SYNON
         BE       LIST1             YES
         MTW,0    ATTRB,R7          IF SELECTIVE, USE % MESSAGE
         BLEZ     LIST1             NOT
LIST7    EQU      %
         LI,R1    0                 NO-REPORT ERROR
         BAL,SR4  ERROR
SOMERR   RES
         BAL,SR4  D2CHK             UPDATE ERR SEVERITY
         MTW,0    ATTRB,R7          WAS FID SPECIFIED
         BGZ      LIST31            YES
LIST40   RES
         LW,R1    LISTTERM
         CI,R1    X'15'             END OF COMMAND
         BE       %+4
         LI,R1    30                ERROR - IMPROPER TERMINATION
         BAL,SR4  ERROR
         BAL,SR4  D2CHK
         LW,D2    COBUSED,R7        GET ERROR SEVERITY
LISTEND  LI,R5    LSTTEXT           POINTER TO MESSAGE
         MTW,0    DELETEF           IS THIS ONLINE REVIEW
         BNEZ     LIST42            YES, NO LAST LINE
         AI,SR2   0                 ANY FILES LISTED
         BEZ      RETURN            NO
         MTW,0    ATTRB,R7
         BNEZ     LIST42            NOT SIMPLE LIST
         LI,R3    1                 PRINT LAST LINE
         LI,R1    PRTBUF
         AW,R1    R7
         LB,R2    *R1
         SLS,R2   2
         CAL1,1   FPTLFILE
LIST42   BAL,SR4  PRTERR            PUT OUT THE ERRORS
         INT,SR1  SR2               SEPATARE LIST/DELETE COUNT FOR REVIEW
         BAL,SR4  PRTNOF            PRINT 'NNN FILES LISTED'
         LW,SR2   SR1               GET GRANULE COUNT
         LI,R5    DELTEXT
         BAL,SR4  PRTNOF
         LW,SR2   GRANCNT           GET TOTAL GRANULES
         LI,R5    GRANTEXT          ADDRESS OF MESSAGE
         BAL,SR4  PRTNOF            PRINT 'XXX TOTAL GRANULES'
         MTW,0    ATTRB,R7          IF NOT SELECTIVE, TOP OF FORM
         BGEZ     RETURN
         CAL1,1   WEOFLO
RETURN   EQU      %
         BAL,SR4  CLOSEI            MAKE SURE EI IS CLOSED
         LH,R1    M:LO              CLOSE LO IF OPEN
         CI,R1    X'20'
         BAZ      %+2
         CAL1,1   CLOSELO
         LCI      7
         PLM,R5   *R7               RESTORE REGISTERS
         B        *SR4              RETURN
ERRADD2  LI,R1    0                 REPORT M:LO ERROR
         BAL,SR4  ERROR
         LI,R1    56                ERROR WRITING LO
         BAL,SR4  ERROR
         B        RETURN
LIST50   LB,R2    NOFILES           GET MESSAGE COUNT
         LI,R1    M:UC              SELECT BATCH OR ONLINE
         LC       BOG
         BCS,12   %+3               BRANCH IF ONLINE OR GHOST
         LI,R1    M:LO
         AI,R2    -1                REMOVE N/L CHAR
         CAL1,1   FPTNOFIL
         USECT    PLSECT
FPTNOFIL GEN,8,7,17      X'91',0,R1
         DATA     X'34000010'
         DATA     NOFILES           BUFFER
         PZE      *R2               COUNT
         DATA     1                 BTD
NOFILES  TEXTC    'NO FILES IN DIRECTORY
'
CLOSELO  GEN,8,24 21,M:LO
         DATA     X'80000000',2     SAVE
         USECT    LIST
         B        RETURN
D2CHK    CW,D2    COBUSED,R7
         BLE      %+2
         STW,D2   COBUSED,R7        SAVE ERR SEVERITY
         LI,D2    0
         B        *SR4
         PAGE
* SUBROUTINE CDATE MOVES THE CREATION DATE FROM FPARAM TO THE
* PRINT BUFFER.
CDATE    PSW,R4   *R7
         LW,R4    *SR3,R4           GET 1ST WORD OF DATE
         LI,R5    0
         SLD,R4   -16               SEPARATE MONTH AND DAY
         SLS,R5   -16
         OR,R5    =X'40400000'
         CW,R5    =X'4040F0F9'
         BG       %+2
         AND,R5   =X'404040FF'      SUPPRESS LEADING ZERO OF DAY
         STW,R5   DATE,R1           PUT DAY IN BUFFER
         LCI      4
         PSM,R1   *R7
         STW,R4   SYNFLAG,R7        SAVE MONTH
         LI,R1    SYNFLAG+SYNFLAG+SYNFLAG+SYNFLAG+2
         PSW,SR4  *R7
         LI,R2    2                 NCHAR
         BAL,SR4  BCD2BIN           CONVERT MONTH TO BINARY
         PLW,SR4  *R7
         LW,R5    MONTH,R3          GET MONTH FROM TABLE
         LCI      4
         PLM,R1   *R7
         STW,R5   DATE+1,R1         PUT MONTH IN BUFFER
         LW,R4    *SR3,R2           GET 2ND WORD OF DATE
         AND,R4   =X'FFFF'          ISOLATE YEAR
         SLS,R4   8                 POSITION
         OR,R4    =X'40000040'
         STW,R4   DATE+2,R1         PUT YEAR IN BUFFER
         LB,R4    *SR3              CHK IF LOOKING AT FPARAM CODE '0A'
         CI,R4    X'A'
         BNE      RESTPTR           DON'T DO HRS/MIN IF NOT
         LW,R4    *SR3,R3           GET HR AND MIN
         LW,R5    =X'40404040'
         SCD,R4   -16               HRS IN R4; MIN IN R5
         SLS,R5   -8
         LI,R6    ':'
         STB,R6   R5                GENERATE HR:MIN FOR BUFFER
         SCD,R4   -8                AND POSITION THEM
         LCI      2
         STM,R4   DATE-2,R1         AND STORE IN BUFFER
RESTPTR  RES
         PLW,R4   *R7
         B        *SR4              RETURN
         PAGE
* THE FOLLOWING SUBROUTINES HANDLE THE SAVING OF DATE ATTRIBUTES IN
* DATETBL AND LISTING THESE ATTRIBUTES IF THE 'EA' OPTION WAS USED.
EDATE    LI,R5    0                 EXPIRATION DATE
         B        ADATE1
MDATE    LI,R5    2                 CREATION DATE
         B        ADATE1
BDATE    MTB,0    *SR3,R2           BACKUP DATE
         BEZ      *SR4              NO DATE ENTERED
         LI,R5    4
         B        ADATE1
ADATE    LI,R5    6                 ACCESS DATE
ADATE1   LW,R3    *SR3,R4
         STW,R3   DATETBL,R5        MOVE DATE FROM VLP TO DATE TABLE
         LW,R3    *SR3,R2
         STW,R3   DATETBL+1,R5
         LI,R3    3                 RESTORE R3
         B        *SR4
*
DATELIST LI,D3    4                 LIST 4 DATES IF PRESENT
         PSW,SR4  *R7               SAVE LINK
         LW,R1    ='    '
         STW,R1   IOBUF,R7
         LI,SR3   DATETBL
         LI,R6    0                 INDEX INTO TDATE
DATEL2   LW,R5    *SR3
         BEZ      DATEL3            NO DATE IN THIS TABLE ENTRY
         LCI      4
         LM,R1    TDATE,R6          MOVE TEXT INFO TO LINE
         STM,R1   IOBUF+1,R7
         LI,R4    0
         LI,R3    2
         LI,R2    1                 SET UP REGS FOR CDATE
         LW,R1    R7
         AI,R1    IOBUF-2           PUT AT IOBUF+5
         CW,R5    ='NEVE'
         BE       DATEL4            EXP DATE IS NEVER
         BAL,SR4  CDATE             ENTER DATE IN LINE
DATEL5   EQU      %
         AI,R1    2                 START OF BUFFER
         LI,R2    DATE*4+12         LENGTH
         LW,R5    R6                SAVE TDATE INDEX
         BAL,SR4  LFILE
         LW,R6    R5
DATEL3   AI,SR3   2                 INCREMENT DATETBL POINTER
         AI,R6    4                 INCREMENT TDATE INDEX
         BDR,D3   DATEL2            LOOP 4 TIMES
         PLW,SR4  *R7               RESTORE LINK
         B        *SR4
DATEL4   LW,R4    ='    '
         STW,R4   IOBUF+5,R7
         STW,R5   IOBUF+6,R7        PUT 'NEVER' IN LINE
         LW,R5    *SR3,R2
         STW,R5   IOBUF+7,R7
         B        DATEL5
         PAGE
* SUBROUTINE GRANULE GETS THE GRANULE SIZE FROM FPARAM, CONVERTS IT
* TO BCD, AND ENTERS THE VALUE IN THE PRINT BUFFER.
GRANULE  PSW,SR4  *R7               SAVE LINK REG
         LCI      4
         PSM,R1   *R7               SAVE R1-R4
         LW,R1    *SR3,R4           GET NO. OF GRANULES
         LW,R3    SYNONYM,R7        IF SYNONYMOUS
         BNEZ     GRAN1             DONT COUNT IT
         LW,R3    ATTRB,R7          OR SINGLE FILES
         BGZ      GRAN1
         MTW,0    DELETEF           OR REVIEW(A)
         BNEZ     GRAN1
         AWM,R1   GRANCNT           UPDATE GRANULE COUNT
GRAN1    RES
         BAL,SR4  BIN2BCD           CONVERT TO BCD
         LW,SR4   R3
         LW,D4    R2
         LCI      4
         PLM,R1   *R7               RESTORE R1-R4
         STW,D4   GRAN,R1           ENTER VALUE IN PRINT BUFFER
         STW,SR4  GRAN+1,R1
         PLW,SR4  *R7               RESTORE LINK
         B        *SR4              RETURN
*
* SUBROUTINE FNAME IS ENTERED ON A '01' VLP CODE.  EXIT IS MADE TO
* SYNON IF NAME IN FPARAM AND NAME IN DCB DO NOT MATCH.
FNAME    LW,R5    DEVICE,R7         CHECK DEVICE CODE
         CI,R5    5            TEST IF DP.
         BE       %+3          YES.
         CI,R5    3                 RAD FILE
         BNE      *SR4              NO - EXIT
         PSW,R4   *R7
         LW,R4    SR3               GET FPARAM ADDRESS
         AI,R4    1                 ADDRESS OF NAME
         LB,R5    *R4               GET COUNT OF FPARAM NAME
         CB,R5    M:EI+23           SAME LENGTH AS DCB FILE NAME
         BNE      FNAME2            NO - MUST BE SYNON
         LB,R0    M:EI+23,R5        COMPARE NAMES
         CB,R0    *R4,R5
         BNE      FNAME2            NOT THE SAME
         BDR,R5   %-3
         LI,R0    0                 SAME - RESET R0
         PLW,R4   *R7
         B        *SR4              RETURN
FNAME2   PLW,R4   *R7
         LI,R0    0                 RESET R0
SYNON    LCI      3
         PSM,R1   *R7
         LI,R3    IOBUF+210
         AW,R3    R7                COMPUTE DEST ADR
         STW,R3   SYNONYM,R7        SAVE ADR OF SYNON
         LI,R1    8
         LW,R2    *SR3,R1           MOVE SYNON TO TEMP AREA
         STW,R2   *R3,R1
         BDR,R1   %-2
         LCI      3
         PLM,R1   *R7
         B        *SR4              RETURN
*
* SUBROUTINE SYNONX GETS THE SYNON FROM FPARAM AND PRINTS THE LINE
* 'SYNON= XXX'.
SYNONX   EQU      %
         LW,R4    SYNONYM,R7
         BEZ      *SR4              NO SYNONYM
         LI,D4    1                 ONLY ONE
         MTB,1    SR4               FLAG FOR TEXTCC INPUT
         BAL,R5   WACC20            DO EM
         TEXTC    '  SYNON='
*
RACCT    LB,R5    *SR3,R2           GET NO. OF SIGNIFICANT WORDS
         SLS,R5   -1
         STW,R5   RDTBL
         STW,SR3  RDTBL+1
         B        *SR4              RETURN
*
WACCT    LB,R5    *SR3,R2           GET NO. OF SIGNIFICANT WORDS
         SLS,R5   -1
         STW,R5   WRTBL
         STW,SR3  WRTBL+1
         B        *SR4              RETURN
         DO       VERSION=2
EACCT    EQU      %
         LB,R5    *SR3,R2      GET NO. OF SIGNIFICANT WORDS.
         SLS,R5   -1
         STW,R5   EXTBL
         STW,SR3  EXTBL+1
         B        *SR4         RETURN
VACCT    EQU      %
         LB,R5    *SR3,R2      GET NO. OF SIGNIFICANT WORDS
         DW,R5    =3
         STW,R5   UNTBL
         STW,SR3  UNTBL+1
         B        *SR4         RETURN
         FIN
*
* SUBROUTINE RACCTX GETS READ ACCOUNTS FROM TABLE RDACCT, FORMATS THEM
* IN THE PRINT BUFFER, AND PRINTS THE LINE.
RACCTX   LW,D4    RDTBL
         BEZ      *SR4
         LW,R4    RDTBL+1           ADDRESS THEREOF
         LW,R3    1,R4              GET FIRST ACCOUNT
         CW,R3    ='ALL '           IS DEFAULT SPECIFIED
         BNE      RACC10
         LW,R3    2,R4
         CW,R3    ='    '
         BNE      RACC10
         STW,R0   EXTBL             IGNORE EX INFO IF READ ALL
         STW,R0   UNTBL             AND UNDER
         B        *SR4
RACC10   EQU      %
         BAL,R5   WACC20            GO TO  ACCOUNT FORMATTER
         TEXTC    '  READ='
ACCTX    RES
         BAL,R5   WACC20
         TEXTC    ' ACCOUNT='
         DO       VERSION=2
*
* SUBROUTINE EACCTX GETS EXECUTE ACCOUNTS FROM TABLE EXACCT,
* FORMATS THEM INTO THE PRINT BUFFER, AND PRINTS THE LINE.
EACCTX   EQU      %
         LW,D4    EXTBL
         BEZ      *SR4
         LW,R4    EXTBL+1
         LW,R3    1,R4         GET FIRST ACCOUNT
         CW,R3    ='ALL '      IS DEFAULT SPECIFIED
         BNE      EACC10
         LW,R3    2,R4
         CW,R3    ='    '
         BE       *SR4
EACC10   EQU      %
         BAL,R5   WACC20
         TEXTC    '  EXECUTE='
*
* SUBROUTINE UACCTX GETS VEHICLE ACCOUNT FROM TABLE UNACCT,
* FORMATS THEM INTO THE PRINT BUFFER, AND PRINTS THE LINE.
UACCTX   EQU      %
         LW,D4    UNTBL
         BEZ      *SR4               NONE
         LW,R4    UNTBL+1
         MTB,1    SR4               SET UNDER FLAG
         BAL,R5   WACC20            AND PRINT EM
         TEXTC    '  VEHICLE='
         FIN
*
* SUBROUTINE WACCTX GETS WRITE ACCOUNTS FROM TABLE WRTACCT, FORMATS
* THEM IN THE PRINT BUFFER, AND PRINTS THE LINE.
WACCTX   LW,D4    WRTBL
         BEZ      *SR4
         LW,R4    WRTBL+1
         LW,R3    1,R4              GET FIRST ACCOUNT
         CW,R3    ='NONE'
         BNE      WACC10
         LW,R3    2,R4
         CW,R3    ='    '           IS DEFAULT SPECIFIED
         BE       *SR4              YES - EXIT
WACC10   BAL,R5   WACC20
         TEXTC    '  WRITE='
WACC20   STB,R0   R5                CLEAR HEADER COUNT
         LW,R1    R5                PUT OUT HEADER
         B        WACC45
WACC60   BAL,R1   WACC45            PUT , AFTER EACH
         TEXTC    ', '
WACC30   EQU      %
         SW,R1    R5                IF HEADER LAST GET IT TOO
         STB,R0   R5                IF NAME IS TOO LONG
         BNEZ     %+2
         STB,R2   R5
WACC40   LCI      2
         LM,R2    1,R4              GET ACCOUNT FROM TABLE
         ANLZ,R1  WACC40+1
         MTB,0    SR4               IF UNDER, ALREADY TEXTC
         BNEZ     WACC44
         LI,R1    IOBUF+22
         AW,R1    R7
         STB,R3   *R1               LAST BYTE TO TEMP BUFFER
         AI,R1    -2                BEG OF TEXTC
         SLD,R2   -8
         OR,R2    =X'08000000'      SET UP IN TEXTC FORMAT
         STD,R2   *R1
         LI,R2    ' '               STRIP BLANKS
         LB,R3    *R1
         CB,R2    *R1,R3
         BNE      %+2
         BDR,R3   %-2
         STB,R3   *R1
WACC44   MTB,1    R1                SET NAME FLAG
WACC45   RES
         LCI      4
         PSM,SR4  *R7
         AW,D3    RSSAVE,R7         GEN BYTE ADDR
         SCS,D3   -2                IF PROPER FORMAT
         BAL,SR4  UNPRINT           ENTER ACCOUNT IN BUFFER
         LCI      4
         PLM,SR4  *R7
         AW,D3    R2                ADJUST FOR THIS ONE
         MTB,0    R1                IS THIS NAME OR HEADER
         BE       WACC30            HEADER, GET NAME
         CI,D3    72                DONT RUN OFF THE LINE
         BG       WACC50
         AI,R4    2
         MTB,0    SR4               IF UNDER, 3 WORD ENTRIES
         BEZ      %+2
         AI,R4    1
         BDR,D4   WACC60            BR IF MORE ACCOUNTS
         B        *SR4
WACC50   EQU      %
         SW,D3    R2                SCRUB LAST ONE
         LB,R2    R5                AND HEADER IF THERE
         SW,D3    R2
         LW,R2    D3                SIZE
         LW,R1    RSSAVE,R7
         SLS,R1   -2
         PSW,SR4  *R7               SAVE RETURN
         BAL,SR4  LFILE
         LI,D3    0                 RESET SIZE
         PLW,SR4  *R7               RSTORE RETURN
         B        WACC20            PUTOUT A NEW HEADER
*
* BRANCH TABLE ORDERED BY VLP CODE
VLPTAB   BAL,SR4  FNAME             FILE NAME
         NOP                        ACCT
         NOP                        PASSWORD
         BAL,SR4  EDATE             EXPIRATION DATE
         BAL,SR4  RACCT             READ ACCT
         BAL,SR4  WACCT             WRITE ACCT
         NOP                        INSN
         NOP                        OUTSN
         NOP                        ORG
         BAL,SR4  CDATE             MODIFICATION DATE
         BAL,SR4  SYNON             SYNON
         NOP
         BAL,SR4  GRANULE           GRANULES
         BAL,SR4  MDATE             CREATION DATE
         BAL,SR4  ADATE             ACCESS DATE
         BAL,SR4  BDATE             BACKUP DATE
         DO       VERSION=2
         NOP
         NOP
         NOP
         BAL,SR4  EACCT        EXECUTE ACCOUNT.
         BAL,SR4  VACCT        VEHICLE ACCOUNT.
         NOP
         NOP
         NOP
         FIN
TDATE    TEXT     '  WILL EXPIRE'
         TEXT     '  CREATED  ON'
         TEXT     '  BACKED UP ON'
         TEXT     '  LAST ACCESS ON'
GRANTEXT TEXT     ' TOTAL GRANULES
'
FILEBUSY TEXT     ' **FILE BUSY**      '
INACCM   TEXT     ' *INACCESSIBLE* '
LSTTEXT  TEXT     ' FILES LISTED  
'
LISTHEAD TEXTC    'ORG    GRAN     REC    LAST MODIFIED    NAME'
MONTH    EQU      %-1
         TEXT     ' JAN'
         TEXT     ' FEB'
         TEXT     ' MAR'
         TEXT     ' APR'
         TEXT     ' MAY'
         TEXT     ' JUN'
         TEXT     ' JUL'
         TEXT     ' AUG'
         TEXT     ' SEP'
         TEXT     ' OCT'
         TEXT     ' NOV'
         TEXT     ' DEC'
ORGN     DATA     'CCKR'-'K'**8,'****','****','****'
         PAGE
LISTFT   EQU      %
         LI,R1    1
         CW,R1    DEVICE+1,R7       WAS ONLY ONE INSN SPECIFIED
         BE       LISTFT2           YES
         LI,R1    31
         BAL,SR4  ERROR             REPORT ERROR - MORE THAN ONE INSN
         B        RETURN
LISTFT2  LI,R1    0
         BAL,SR4  BLDCB             BUILD M:EI AND OPEN
         CI,D2    1
         BG       RETURN            ERROR ON OPEN - EXIT
         CAL1,1   FPTREW            REWIND
         CAL1,1   SPFPT             SPACE FORWARD ONE FILE
         CAL1,1   SETEIDCB          SET ERR AND ABN ADDRESSES
         CAL1,1   SKIPREC           BACK OVER HEADER RECORDS
         CAL1,1   SKIPREC
         CAL1,1   SKIPREC
         LI,R1    PRTBUF            ESTABLISH OUTPUT BUFFER ADR
         AW,R1    R7
         CAL1,1   RDACN             READ LABEL REC
         LW,R2    0,R1
         CW,R2    =':LBL'           LABEL REC
         BNE      LISTFT7           NO
         LW,R2    1,R1
         STW,R2   CMDBUF+13,R7      SAVE IT
         STW,R2   PRTBUF+2,R7       PUT INSN IN PRINT BUFFER
         LCI      2
         LM,R2    INSN
         STM,R2   PRTBUF,R7         SET UP PRINT LINE
         LI,R2    11                LINE LENGTH
         LI,R3    1                 BTD
         LI,R6    M:LO
         CAL1,1   FPTLFILE          PRINT INSN
         CAL1,1   RDACN             READ ACCT REC
         LW,R5    0,R1
         CW,R5    =':ACN'           IS REC ACCT REC
         BNE      LISTFT7           NO
         LCI      2
         LM,R5    1,R1
         STM,R5   CMDBUF+15,R7
         STM,R5   PRTBUF+2,R7       ENTER ACCT IN PRINT BUFFER
         LM,R5    ACCT
PRTBUFI7 RES
         STM,R5   PRTBUF,R7         SET UP PRINT LINE
         LI,R2    15                LINE LENGTH
         LI,R6    M:LO
         CAL1,1   FPTLFILE          PRINT ACCOUNT
         CAL1,1   FPTREW            REWIND THE TAPE
         LW,R2    CMDBUF+13,R7
         CW,R2    M:EISN
         BE       %+2
         CAL1,1   FPTREW1           REMOVE IF DIFFERENT SN
         BAL,SR4  CLOSEI
         MTW,-2   DEVICE,R7         CHANGE TO LT
         LI,R1    CMDBUF+CMDBUF+CMDBUF+CMDBUF+13*4
         STW,R1   DEVICE+2,R7       POINT TO SN
         MTW,2    FILE,R7           SET ACCOUNT ONLY
         AI,R1    7
         STW,R1   FILE+1,R7
         LW,R1    DOTS              TERMINATE STUFF
         STW,R1   CMDBUF+14,R7
         STW,R1   CMDBUF+17,R7
         B        LIST20            AND USE LIST LOGIC
DOTS     TEXT     '....'
*
LISTFT7  LB,R2    UNLABEL           UNLABELED TAPE
         LI,R1    UNLABEL
         LI,R3    1                 BTD
         LI,R6    M:LO              SET UP DCB
         CAL1,1   FPTLFILE          PRINT -UNLABELED TAPE-
         BAL,SR4  CLOSEI
         B        RETURN            EXIT
*
FTABN    LB,R2    SR3               GET ABN CODE
         CI,R2    7
         BE       *SR1              LOST DATA IS OK
         LI,R1    0
         B        LIST6             REPORT ERROR AND QUIT
SKIPREC  GEN,8,7,17      X'1D',0,M:EI
         DATA     X'80000010'
         DATA     1
SETEIDCB GEN,8,24 6,M:EI
         DATA     X'C0000000'
         DATA     FTABN
         DATA     FTABN
RDACN    GEN,8,7,17      X'10',0,M:EI
         DATA     X'F0000010'
         DATA     FTABN
         DATA     FTABN
         PZE      *R1
         DATA     24
INSN     TEXT     ' INSN = '
ACCT     TEXT     ' ACCT = '
UNLABEL  TEXTC    'UNLABELED TAPE'
         TITLE    'REM-REW'
REW      DSECT    1                 REWIND
         LCI      7
         PSM,R5   *R7               SAVE REGISTERS
         BAL,SR4  CLRARG            CLEAR ARGUMENT TABLE
         MTW,3    DEVICE,R7         DEFAULT FT
         LW,R1    TERM,R7
         CI,R1    '#'
         BE       %+3               SPECIAL FT FORM
         CI,R1    ' '
         BNE      REW7
         BAL,SR4  DEVTRAN           GET DEVICE CODE AND REEL NO
         LW,R1    DEVICE,R7
         CI,R1    4                 MUST BE LT,FT,AT OR DP
         BL       REWA              ERROR
         CI,R1    7
         BLE      REW1              OK
REWA     LI,R1    34                INVALID DEVICE SPECIFICATION
         B        REW2+1
REW1     RES
         CI,D2    1                 ERROR DETECTED
         BG       RETURN            YES
REW7     LW,R5    DEVICE+1,R7       GET # OF SNS
         CI,R5    1                 REWIND PERMITS ONLY ONE
         BLE      %+3
         CI,D1    6                 REMOVE MORE IS OK
         BNE      SPE5-1
         LW,R1    TERM,R7
         CI,R1    X'15'             ANOTHER REEL NO. FOLLOW
         BE       REW6              NO
         CI,R1    '('               OPTION FOLLOW
         BE       REWB              YES
         LW,R2    DEVICE,R7
         CI,R2    7                 ANS TAPE
         BNE      REW2              NO - ERROR
         CI,R1    '/'               DOES FILE NAME FOLLOW
         BE       REWC              YES, USE IT
         AI,R5    0                 NO, BETTER HAVE SN
         BEZ      REW2              NONE, ERROR
         B        REW6              GO ONE, USE IT
REWC     BAL,SR4  FILTRAN           GO GET FILE NAME
         B        REW6
REWB     EQU      %
         BAL,SR4  GETARG6           GET OPTION
         LW,R1    ARGBUFF,R7
         CW,R1    =X'02F7E340'      IS IT 7T
         BNE      REW3
         LW,R1    TERM,R7
         CI,R1    ')'               CORRECT DELIMITER
         BNE      REW6              NO - IGNORE OPTION
         LI,R1    3
         STW,R1   MODE+1,R7         SET MODE FOR 7T
         LW,R2    DEVICE,R7
         BEZ      REW2              TOO MANY RESOURCE TYPES
         CI,R2    7                 TEST IF ANS TAPE
         BE       REWE         BRANCH IF ANS TAPE.
         LI,R1    6            SET DEVICE CODE FOR FT.
         STW,R1   DEVICE,R7
         B        REW6
RINGT    TEXTC    'RING'
         RES      -1
REW3     CW,R1    RINGT
         BNE      REW6              NOT RING
         LI,R1    8                 RING, USE INOUT OPEN
         B        REW6+1
REWE     EQU      %
         BAL,SR4  GETARG6           GET NULL FIELD
         MTW,0    NCHAR,R7          IS FIELD NULL
         BNEZ     REW2              NO - SYNTAX ERROR
         LW,R2    TERM,R7
         CI,R2    '/'               DOES FILE NAME FOLLOW
         BE       REWC              YES
REW6     EQU      %
         LI,R1    0
         LW,R2    DEVICE,R7
         CI,R2    5
         BG       REW5              FT OR AT
         BE       REW8              DP
         MTW,2    DEVICE,R7         CHANGE LT TO FT
REW5     EQU      %
         CI,R2    7                 IF AT, USE OPNNXT
         BNE      %+4               UNLESS FILE SPECIFIED
         MTW,0    FILE,R7
         BNEZ     %+2
         AI,R1    4
         CI,D1    6                 IF REMOVE DO TEST OPN
         BNE      %+2
         OR,R1    =X'80000'
         BAL,SR4  BLDCB             GO BUILD INPUT DCB
         CI,D2    1                 ERROR DETECTED
         BG       RETURN            YES-RETURN
         AI,SR3   0
         BNEZ     REW9
         CI,D1    7                 CHECK COMMAND TYPE
         BL       REW4              REMOVE(6)
         BG       RETURN            MOUNT(2832)
         CAL1,1   FPTREW            NO-REWIND
         USECT    PLSECT
FPTREW   GEN,8,7,17      X'01',0,M:EI
         USECT    REW
         B        RETURN            RETURN
REW9     RES
         LB,R1    SR3
         CI,R1    2                 IF END OF ALL FILES, TRYOPNNXT ONCE
         BNE      REW10
         CI,D1    6                 BUT ONLY IF REMOVE
         BNE      REW10             OF ANS TAPE
         BAL,SR4  OPNNXT
         AI,SR3 0
         BEZ      REW4              WORKED
REW10    LI,R1    0
         BAL,SR4  ERROR
         B        RETURN
REW8     EQU      %
         DO       VERSION=1
         B        REWA
         ELSE
         CI,D1    6
         BNE      REWA              REW - ERROR
         MTW,0    DEVICE+1,R7
         BEZ      REW2              MUST HAVE SN FOR DP
         LI,R1    4                 OPEN NEXT, INPUT
         BAL,SR4  BLDCB
         LW,R1    =X'00200000'
         CW,R1    M:EI              WAS FILE OPENED
         BAZ      RETURN            NO - RELEASED BY OPEN
REW4     CAL1,1   FPTREW1
         B        RETURN
REW2     LI,R1    17                SYNTAX ERROR
         BAL,SR4  ERROR
         B        RETURN            EXIT
         USECT    PLSECT
FPTREW1  GEN,8,7,17      X'15',0,M:EI
         DATA     X'20'             REMOVE
         FIN
         TITLE    'WRITE END OF FILE'
WEOF     DSECT    1
         LCI      7
         PSM,R5   *R7
         LW,R1    TERM,R7
         CI,R1    X'15'             PARAMETERS PRESENT
         BNE      WEOF2             YES, GETEM
         LI,R1    M:EO              ASSUME EO
         MTW,0    TOSWT,R7
         BNEZ     WEOF1             GOOD GUESS
         LH,R1    M:EI+1            NO OUT, IS EI INOUT (SPE)
         CI,R1    8
         BAZ      WEOF3             NOTHING TO WRITE ON
         LI,R1    M:EI
WEOF1    RES
         CAL1,1   SETEOF            SET ERR/ABN IN DCB
         CAL1,1   FPTWEOF           WRITE AN EOF
         BAL,SR4  CLOSEI
         BAL,SR4  CLOSEO
         B        RETURN
FPTWEOF  GEN,8,24 X'82',1
SETEOF   GEN,8,24 X'86',1           SETDCB *R1
         DATA     X'C0000000',WEOFER,WEOFER
*
WEOF2    RES
         BAL,SR4  CLRARG
         MTW,3    DEVICE,R7         DEFAULT FT
         BAL,SR4  DEVTRAN
         LW,R2    DEVICE,R7
         CI,R2    6                 MUST BE FT,LP,CP OR PP
         BE       %+3
         CI,R2    9
         BL       REWA
         LI,R1    0                 BUILD OUTPUT DCB
         BAL,SR4  BLDCB
         CI,D2    2                 GIVE UP
         BGE      RETURN            YUP
         LI,R1    M:EO
         STW,R1   TOSWT,R7          SET DEVICE OUT THERE
         B        WEOF1
*
WEOF3    LI,R1    20                NO DEFINED OUTPUT DEVICE
         B        REW2+1
*
WEOFER   LI,R1    0                 IO ERROR
         B        REW2+1
         TITLE    'OPEN NEXT M:EI AND CHECK THAT NAME CHANGES'
OPNXFPT EQU CMDBUF+1
OPNNXT   DSECT    1
         LCI      2                 SAVE REGS
         PSM,SR1  *R7
         LI,SR1   X'100'
         CH,SR1   M:EI+23           IF NO FILE NAME NOW, MUST
         BE       OPNX9             ALREADY HAVE ERROR
         LW,SR1   =X'C0000400'      OPNNXT,ERR,ABN
         STW,SR1  OPNXFPT+1,R7
         LI,SR1   M:EI
         LI,SR2   X'7FFFF'          STUFF DCB ADDR, ZAP XFPT
         STS,SR1  OPNXFPT,R7
         LI,SR1   OPNX1             ERR,ABN ADDR
         STW,SR1  OPNXFPT+2,R7
         STW,SR1  OPNXFPT+3,R7
         LI,SR1   TLBLSIZE          SET TLABEL SIZE
         STB,SR1  TLABEL
         STW,R0   TLABEL+1          CLEAR RANDOM ID
         LI,SR3   0
         LI,SR2   OPNXFPT+5         SAVE CURRENT NAME IN DATA
         AW,SR2   R7
         SLS,SR2  2
         OR,SR2   =X'20000000'      MOVE 32 BYTES
         LI,SR1   BA(M:EI+23)
         MBS,SR1  0
         CAL1,1   OPNXFPT,R7        DO THE OPEN
         OR,SR4   =X'20000000'      SET GOOD RETURN IF OPEN
         B        OPNX9
OPNX1    AI,SR2   -32               BACK TO START OF FILE NAME
         LI,SR1   BA(M:EI+23)
         AW,SR2   =X'20000000'      COMPARE 32 BYTES
         CBS,SR1  0
         STCF     SR4
OPNX9    LB,SR1   SR3               SET CC=8 IF END OF ALL FILES
         CI,SR1   2
         BNE      %+2
         OR,SR4   =X'80000000'
         LCI      2
         PLM,SR1  *R7
         LC       SR4               SET CC
         B        *SR4
         TITLE    'SPACE AFTER LAST FILE'
SPE      DSECT    1
         LCI      7
         PSM,R5   *R7               SAVE REGISTERS
         BAL,SR4  CLRARG            CLEAN -ARGTBL-
         MTW,3    DEVICE,R7         DEFAULT FT
         BAL,SR4  DEVTRAN           GO-TRANSLATE DEVICE
         LW,R2    DEVICE,R7
         CI,R2    4                 LT SPECIFICATION
         BE       SPE1              YES
         LI,R1    34                ERROR-NOT LT SPECICATION
         CI,R2    7                 AT
         BE       SPE1
         CI,2     6                 OR FT
         BNE      SPE5
SPE1     LW,R1    DEVICE+1,R7
         CI,R1    1                 ONE REEL SPECIFIED
         BLE      SPE2              YES
         LI,R1    31                ERROR-ONE REEL MAY BE SPECIFIED
SPE5     EQU      %
         BAL,SR4  ERROR
         B        RETURN            RETURN
SPE2     CI,D2    1                 ANY ERRORS
         BG       RETURN            YES-RETURN
         LI,SR1   X'14'             GET READY TO CHECK ABN
         LW,R1    TERM,R7
         CI,R1    '('               DOES OPTION FOLLOW
         BNE      SPE7              NO
         BAL,SR4  GETARG6
         LW,R2    ARGBUFF,R7
         CW,R2    =X'02F7E340'      IS IT 7T
         BNE      SPE7              NO
         LW,R2    TERM,R7
         CI,R2    ')'               CORRECT TERMINATION
         BNE      SPE7              NO - IGNORE OPTION
         LI,R2    3
         STW,R2   MODE+1,R7         SET MODE FOR 7T
SPE7     EQU      %
         LI,R1    X'C'              INOUT-UPDATE,OPEN NEXT
         BAL,SR4  BLDCB
         LI,SR2   0                 INITIALIZE FILE COUNT
         CB,SR1   SR3               DID WE GET NO RING NOT AT BOT
         BNE      SPE8              NO
         CAL1,1   OPNIFT            YES, REWIND FIRST
         LI,SR1   -1                ONLY DO THIS ONCE
         CAL1,1   FPTREW
         BAL,SR4  CLOSEI
         B        SPE7
SPE8     LW,R2    M:EI              IF DEVICE
         CI,R2    1                 MUST USE SPF,READ LOOP
         BANZ     SPE4
SPE3     BAL,SR4  CLOSEI            GO-CLOSE THE FILE
         AI,SR2   1                 COUNT FILES SKIPPED
         BAL,SR4  OPNNXT            TRY TO OPEN NEXT FILE
         BCS,8    SPE6              GOT 02 ABN, ALL DONE
         BNE      SPE3              AT LEAST THE NAME CHANGED
SPEEX    LI,D2    4                 ABORT BATCH JOB IF FAILURE
         LI,R1    0                 GET READY TO DO IO ERROR
         BAL,SR4  ERROR
SPE6     RES
         LI,R5    SKIPTXT
         BAL,SR4  PRTNOF
         LI,R1    1
         CW,R1    M:EI              IF DEVICE NPO NAME
         BANZ     SPE61
         LCI      4
         LM,R1    LASTFN            PUT LAST FILE NAME TOO
         STM,R1   TLABEL
         STW,R2   TLABEL+4
         LI,D3    TLABEL+4
         LI,R1    M:EI+23
         BAL,SR4  UNPRINT
         AI,R2    17
         LI,R3    X'15'             ADD NEWLINE IF ONLINE
         STB,R3   TLABEL,R2
         LI,R6    M:LO
         LI,R1    TLABEL            BUFFER ADDRESS
         LB,R3    J:JIT             GET TYPE, SET BTD
         BEZ      %+3
         LI,R6    M:UC
         AI,R2    1
         CAL1,1   FPTLFILE
SPE61    LW,R1    TERM,R7
         CI,R1    X'15'             END OF COMMAND
         BE       RETURN            YES
         LI,R1    30
         B        SPE5
LASTFN   TEXT     'LAST FILE NAME ='
OPNIFT   GEN,8,24 20,M:EI           OPEN INPUT,DEVICE
         DATA     X'C1000003'
         DATA     SPR1,SPR1         ERROR, PRINT IT
         DATA     1,-1              INPUT, NO VPS
SPE4     LW,R2    =X'00200000'
         CW,R2    M:EI              IF NOT OPEN, PRINT IO ERROR
         BAZ      SPEEX
         CAL1,1   SKIPREC           SKIP BACK IN CASE AT END NOW
         CAL1,1   SPFPT             SKIP ONE FILE
         CAL1,1   SPRFPT            SKIP A RECORD
         AI,SR2   1
         B        %-2               DIDNT HIT MARK, MUST NOT BE DONE
SPE9     CAL1,1   SKIPREC           SKIP BACK OVER SECOND MARK
         B        SPE6              AND RETURN
         TITLE    'SPACE FILE'
SPF      DSECT    1                 SPACE FILE
         LCI      7
         PSM,R5   *R7               SAVE REGISTERS
         BAL,SR4  CLRARG            ZERO -ARGTBL-
         MTW,3    DEVICE,R7         FT DEFAULT
         BAL,SR4  DEVTRAN           GO-TRANSLATE DEVICE
         LW,R2    DEVICE,R7
         CI,R2    6                 FT
         BE       SPF1              YES
         LI,R1    34                ERROR-NOT FT SPECIFICATION
         B        SPE5
SPF1     LW,R1    DEVICE+1,R7
         CI,R1    1                 ONE REEL SPECIFIED
         BLE      SPF8              YES
         LI,R1    31                ERROR-ONE REEL MAY BE SPECIFIED
         B        SPE5
SPF8     LW,R2    TERM,R7
         CI,R2    ','
         BE       SPF2
         CI,R2    X'15'             IS COMMAND DONE
         BE       SPF2              YES
         CI,R2    '('               DOES OPTION FOLLOW
         BNE      SPF9              NO - BAD SYNTAX
         BAL,SR4  GETARG6
         LW,R2    ARGBUFF,R7
         CW,R2    =X'02F7E340'      IS IT 7T
         BNE      SPF9              NO - ERROR
         LW,R2    TERM,R7
         CI,R2    ')'               CORRECT TERMINATION
         BNE      SPF9              NO
         LI,R2    3
         STW,R2   MODE+1,R7         SET MODE CODE FOR 7T
         BAL,SR4  GETARG6
         MTW,0    NCHAR,R7
         BNEZ     SPF9              FIELD NOT NULL-ERROR
SPF2     EQU      %
         LI,R1    0                 OPEN IN INPUT MODE
         CI,D2    1                 ANY ERRORS IN SCAN
         BG       RETURN            YES - EXIT
         LW,SR4   CMBX,R7
         STW,SR4  WRTFPT,R7         SAVE CMBX
         BAL,SR4  BLDCB             GO OPEN M:EI
         CI,D2    1                 IF OPEN FAILED, QUIT
         BG       SPR1              AND PRINT MESSAGE
         LW,SR4   WRTFPT,R7
         STW,SR4  CMBX,R7      RESTORE CMBX.
         LCI      2
         LM,R1    SPFPT
         STM,R1   WRTFPT,R7         INITIALIZE MOVE FILE FPT
         LI,R1    0
         BAL,SR4  GETARG            GO-GET DIRECTION AND NO. OF FILES
         LI,R1    ARGBUF4+1         LOCATION OF DIRECTION AND NO. OF FIL
         LW,R2    NCHAR,R7          NO. OF CHARS IN ARGUMENT
         BAL,SR4  BCD2BIN           GO-CONVERT NO. OF FILES TO BINARY
         CI,R4    2                 OVERFLOW
         BNE      SPF3              NO
         LI,R1    10                BAD NUMMER
         BAL,SR4  ERROR
         B        SPF7
SPF3     CI,R4    1                 DIRECTION INDICATOR PRESENT
         BNE      SPF6              NO
         LB,R3    *R7,R1
         CI,R3    '-'               BACKWARD DIRECTION
         BE       SPF4              YES
         CI,R3    '+'               FORWARD DIRECTION
         BE       SPF5              YES
         LI,R1    37                ERROR-NOT A VALID DIRECTION INDICAT.
         BAL,SR4  ERROR
         B        SPF7
SPF4     LI,R3    X'10'
         STS,R3   WRTFPT+1,R7       SET BACKWARD DIRECTION
SPF5     AI,R1    1                 PASS OVER DIRECTION BYTE
         AI,R2    -1
         BAL,SR4  BCD2BIN           GO-CONVERT NO. OF FILES
         CI,R4    0                 NORMAL TERMINATION
         BE       SPF6              YES
         LI,R1    30                ERROR-INVALID TERMINATION
         BAL,SR4  ERROR
SPF6     CI,D1    8                 IS THIS SPF OR SPR
         BNE      SPR
         CAL1,1   WRTFPT,R7         MOVE THE TAPE A FILE
         BDR,R3   %-1
SPF7     BAL,SR4  CLOSEI            GO-CLOSE INPUT DCB
         B        RETURN            RETURN
SPF9     LI,R1    17
         B        SPE5
SPFPT    GEN,8,7,17      X'1C',0,M:EI
         DATA     0
SPR      LCI      2
         LM,1     SPRFPT
         OR,2     WRTFPT+1,R7       GET DIRECTION FLAG
         LI,R4    SPR1              AND ABN ADDR
         LCI      4
         STM,R1   WRTFPT,R7
         CAL1,1   WRTFPT,R7         DO IT
         B        SPF7              ALL DONE
SPR1     LI,R1    0
         B        SPE5              GOT AN ERROR
SPRFPT   GEN,8,7,17 X'1D',,M:EI
         DATA     X'C0000000'
         DATA     1,SPE9            COUNT AND ABN FOR SPF FT
         TITLE    'DELETEALL'
DELETEAL DSECT    1
         LCI      7
         PSM,R5   *R7               SAVE REGISTERS
         BAL,SR4  CLRARG            CLEAR ARG TABLE
         LW,R1    TERM,R7
         CI,R1    X'15'             TEST FOR END OF COMMAND
         BE       DEVRTN            YES - SIMPLE DELETEALL
         CI,R1    ','
         BE       DEVRTN            NULL FROM FIELD
         LI,R6    DEVRTN
DEVTEST  BAL,SR4  CLRARG            CLEAR ARG TABLE
         LW,R1    CMBX,R7
         STW,R1   SAVCMBX,R7        IND DEVICE CODE OPTIONAL
         BAL,SR4  DEVTRAN           TRANSLATE DEVICE
         STW,R0   SAVCMBX,R7
         LCI      3
         LM,R2    DEVICE,R7         SAVE DEVICE CODES
         STM,R2   SFARG
         CI,R2    3
         BE       0,R6              DC-EXIT
         CI,R2    5                 TEST IF DP
         BE       0,R6              YES-EXIT
         B        DELETE6           NO-ERROR
DEVRTN   LI,SR2   0                 INITIALIZE FILE COUNT
         STW,R7   2,R7              SET LIST NAMES FLAG
         LW,R1    TERM,R7
          CI,R1   X'15'             END OF COMMAND
         BE       DELALL3           YES
         LI,R1    -1
         STW,R1   COPYSK            ASSUME RANGE SPEC PRESENT
         BAL,SR4  REVIEW            GO PROCESS RANGE
         CI,D2    1
         BG       ALL9              ERROR - GO EXIT
DELALL3  EQU      %
         LI,R1    14                INOUT,NXTF,M:EI,FPARAM
         BAL,SR4  BLDCB
         LB,R1    SR3               ANY FILES TO DELETE
         CI,R1    2
         BE       LIST50            NO
         DO       VERSION=2
         LC       BOG
         BCR,4    DELALL2           BR. IF NOT INTERACTIVE. SKIP CONFIRMATION OF
*                                   DELETEALL COMMAND
         LI,D3    BA(TLABEL)        SET REGS FOR WACC20
         STW,D3   RSSAVE,R7
         LI,R4    FROMFILE-1
         LI,D3    0                 0 BTD
         LI,D4    1                 ONE THING
         BAL,SR4  DELETEM           DELETEALL FROMFILE
         LI,R4    M:EI+31
         BAL,SR4  DOTACCT           .ACCT
         LI,R4    TOFILE-1
         MTB,0    TOFILE
         BEZ      %+2
         BAL,SR4  TOM               TO TOFILE
         LW,R3    D3                GET DISP
         AI,R3    1                 GET TO HOLE
         LI,R4    '?'               ADD QUESTON MARK
         STB,R4   TLABEL,R3
         STB,R3   TLABEL
         CAL1,2   FPTALL            KEYIN THE QUEST
         LCI      2                 CHECK RESPONSE
         LM,R2    TLABEL
         CD,R2    YES%
         BE       %+4               GOOD ONE
         AI,R3    -X'80000'         TRY LIN FEED TOO
         CD,R2    YES%
         BNE      RETURN            NO-RETURN
         FIN
         STW,R0   BREAK             CLEAR BREAK
         USECT    PLSECT
FPTALL   DATA     X'4000000',X'F0000000',TLABEL,TLABEL,20,TLABEL
         BOUND    8
YES%     DATA     'YES'+5**24,'%TEA'+(13-'T')**16
DELETEM  MTB,1    SR4               TEXTC
         BAL,R5   WACC20
         TEXTC    'DELETEALL '
DOTACCT  BAL,R5   WACC20
         TEXTC    '.'
TOM      MTB,1    SR4               TEXTC
         BAL,R5   WACC20
         TEXTC    ' TO '
FPTSET   GEN,8,7,17      X'06',0,M:EI
         DATA     X'C0000000'
         DATA     ERRABN
         DATA     ERRABN
         USECT    DELETEAL
DELALL2  CAL1,1   FPTSET            SET ERR ABN ADDRS
         BAL,SR4  TESTFNC           TEST IF FILE IN RANGE
         B        ALL5              NO - SAVE FILE
         BDR,SR3  ERRABN            DIDNT GET IT OPEN
         CAL1,1   FPTDELET          RELEASE THE FILE
         BAL,R6   RANDCHK           TEST IF RANDOM FILE
ALL4     BAL,SR4  ALLC              COUNT FILE, LIST IT
ALL5     BAL,SR4  CLOSEI            CLOSE DCB IF OPEN
         LW,R1    BREAK             ARE WE TO STOP
         BNEZ     ALL9              YES
         MTW,0    TOFILE            ANY MORE FILES WANTED
         BLZ      ALL9              NO
         BAL,SR4  OPNNXT
         BCS,8    ALL9              ALL DONE
         BE       ALL10             DONT LOOP
         B        DELALL2           RELEASE IT
ERRABN   LB,R1    SR3
ALL8     CI,R1    8                 SYNONYM NAME
         BE       ALL5              YES-SKIP IT
         B        ALL4              NO TYPE MESSAGE
ALL10    RES
         LI,R1    0                 YES-REPORT ERROR
         BAL,SR4  ERROR
ALL9     LI,R5    DELTEXT           ADDR OF MESSAGE
         STH,R0   SR2               CLEAR SKIPPED COUNT
         B        LIST42            PRINT FILES/GRANULES
*
DELTEXT  TEXT     ' FILES DELETED 
'
RANDCHK  LI,R1    X'F0'
         AND,R1   M:EI+5            IS ORG RANDOM
         CI,R1    X'30'
         BNE      ADDGRAN           NO, JUST ACCUMULATE GRANULES
         LI,SR3   0
         CAL1,1   OPNTRY            TRY TO OPEN AGAIN
         PSW,SR4  *R7               FILE WAS NOT DELETED
         BAL,SR4  CLOSEI            GO CLOSE
         PLW,SR4  *R7
RAND1    EOR,SR3  03ABN             DID WE GET NO FILE
         CAL1,1   FPTSET            SET DELETEALL ERRABN
         MTW,0    DELETEF           REVIEW COMMAND
         BEZ      %+3               NO
         CAL1,1   FPTSET2           RESET ERR AND ABN ADR
         BDR,SR3  LIST28            AND TYPE MESSAGE
         BDR,SR3  0,R6              PRINT MESSAGE IF THERE IS ONE
ADDGRAN  LW,R1    M:EI+11           SEARCH FPARAM FOR SIZE CODE
         LI,SR1   255
         AND,SR1  *R1
         AW,R1    SR1               SKIP FILENAME ENTRY
         AI,R1    1
         LH,SR1   *R1
         CI,SR1   X'FF'             ARE WE DONE
         BANZ     0,R6              YES, THATS A BIT WIERD
         CI,SR1   X'D00'            IS THIS SIZE ENTRY
         BNE      ADDGRAN+1         NO
         LW,SR1   1,R1
         AWM,SR1  GRANCNT
         B        0,R6
         USECT    PLSECT
OPNTRY   GEN,8,24 X'14',M:EI
         DATA     X'C0000000'
         DATA     RAND1,RAND1
03ABN    GEN,8,24 3,M:EI
         TITLE    'DELETE'
DELETE   DSECT    1                 DELETE COMMAND
         LCI      7
         PSM,R5   *R7               SAVE REGISTERS
         LI,R5    0                 INITIALIZE SEVERITY LEVEL
         LI,SR2   0                 INITIALIZE FILE COUNT
         STW,R0   2,R7              RESET ACCESS FILE HEAD FLAG
         LW,R4    TERM,R7
         CI,R4    X'15'
         BNE      DELETE5
         LI,R1    17                ERROR - NO FILE NAME PRESENT
DELETE7  EQU      %
         BAL,SR4  ERROR
         B        RETURN
DELETE5  BAL,R6   DEVTEST
         LW,R1    TERM,R7
         CI,R1    X'15'
         BE       DELETE7-1         NO FILE NAME
DELETE3  EQU      %
         BAL,SR4  CLRARG            CLEAN OUT -ARGTBL-
         LCI      3
         LM,R1    SFARG             RESTORE DEVICE CODES
         STM,R1   DEVICE,R7
         BAL,SR4  FILTRAN           GO-CONVERT N.A.P
         CI,D2    1                 ANY ERRORS
         BG       DELETE2           YES
         MTW,0    NCHAR,R7
         BEZ      DELETE2           IGNORE NULL FIELD
DELETE1  LI,R1    10                INOUT,FPARAM
         BAL,SR4  BLDCB             GO-BUILD INPUT DCB
         CI,D2    1                 OPEN O.K.
         BG       DELETE2           NO
         CAL1,1   FPTDELET          RELEASE THE FILE
         LI,SR4   DELETE2
         BAL,R6   RANDCHK           TEST IF RANDOM FILE
         USECT    PLSECT
FPTDELET GEN,8,7,17      X'15',0,M:EI
         DATA     X'80000000'
         DATA     1                 RELEASE
         USECT    DELETE
         AI,SR2   1                 BUMP FILE COUNT
DELETE2  LW,R4    TERM,R7
         CW,D2    R5
         BLE      %+2
         LW,R5    D2                UPDATE SEVERITY LEVEL
         LW,R1    BREAK
         STW,R0   BREAK
         BNEZ     DELETE4
         CI,R4    X'15'             END OF COMMAND
         BE       DELETE4           YES
         LI,D2    0                 RESET SEVERITY FOR NEXT FILE
         CI,R4    ','
         BE       DELETE3           ANOTHER FID
         LW,D2    R5                SET SEVERITY LEVEL
         LI,R1    30                ERROR - IMPROPER TERMINATION
         BAL,SR4  ERROR
         B        ALL9
DELETE4  LW,D2    R5                SET SEVERITY LEVEL
         B        ALL9
DELETE6  LI,R1    34                INVALID DEVICE
         B        DELETE7
         END

