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      5
NAME     EQU      8
         TITLE    'LIST'
         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      M:EO
         REF      BREAK
         REF      TOSWT
         DO1      VERSION=2
         REF      FPTPROMT
         REF      PRTNOF
         REF      SAVCMBX,PRTBUF
         REF      ARGBUFF,MODE,BIN2BCD
         REF      ATTRB,RDACCT,WRTACCT
         DO1      VERSION=2
         REF      UNACCT,EXACCT
         REF      IOERR
         REF      FILE
         REF      TRANSACT,#DELIM
         REF      OPNFPT
         REF      UNPRINT,SYNONYM
         REF      IOBUF
         REF      SYNFLAG
         REF      COBUSED
         REF      CMBXDIFF
         REF      EATTRB,DATETBL
         REF      COPYSK,FROMFILE,TOFILE,DELETEF
         REF      REVIEW
         REF      TLABEL
         REF      GRANCNT
         REF      TLBLSIZE
         REF      COPYPHY
         REF      LISTCMBX,LISTTERM
         REF      SFDEV
         REF      CMBXHLD
         DEF      TESTFNC
         DO1      VERSION=2
         DEF      REVRP,LIST26
         REF      SFARG
         REF      RSSAVE
         REF      IN%ARG,OUT%ARG
         REF      DEV%IN,DEV%OUT
         PAGE
         USECT    LIST
         LCI      7
         PSM,R5   *R7
         BAL,SR4  CLRARG            ZERO -ARGTBL-
         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   DEVICE,R7         INITIALIZE CODE FOR DC
         LW,R3    FROMFILE          IS THIS A REVIEW COMMAND
         BEZ      LIST25            NO
         LW,R2    SFDEV
         STW,R2   DEVICE,R7         SET DEVICE CODE FOR REVIEW
         LCI      2
         LM,R1    SFARG
         STM,R1   DEVICE+1,R7
         DO       VERSION=2
         MTW,0    J:JIT
         BGEZ     LIST20            BATCH MODE REVIEW
         CAL1,1   DELPRMT           DELETE PROMPT CHARACTER
         STW,R3   DELETEF           SET FLAG FOR ONLINE REVIEW
         STW,R0   2,R7              RESET HEADER FLAG
        FIN
         B        LIST20
LIST25   EQU      %
         LW,R2    TERM,R7
         CI,R2    X'15'             'LIST' ONLY
         BE       LIST20            YES
         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
         CW,R5    CMBX,R7           DEVICE CODE PRESENT
         BE       LIST9             NO - TREAT AS 'N.A.P'
         LW,R2    DEVICE,R7         VALID DEVICE
         BNEZ     %+2          PCL DEVICE.
         LW,R2    DEV%IN,R7    SYSTEM TABLE DEVICE.
         CI,R2    4                 LABLED TAPE
         BE       LIST4             YES
         CI,R2    3                 RAD
         BE       LIST2             YES
         CI,R2    5
         BE       LIST4             DP
         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
         CI,R5    X'15'             PROPER TERMINATION
         BE       LIST5             YES
LIST18   LI,R1    30                ERROR-IMPROPER TERMINATION
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.
         CW,R1    DEV%IN,R7    CHECK SYSTEM INPUT DEVICE.
         BE       LISTFT            FT
         PAGE
LIST20   LI,R1    4                 OPEN NEXT, INPUT
         DO       VERSION=2
         LW,R1    =X'80004'         TESTFILE, OPEN NEXT, INPUT
         MTW,0    DELETEF
         BNEZ     LIST23            ONLINE REVIEW
         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
         LI,SR3   0
         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
LIST24   EQU      %
         CAL1,1   FPTSET2           SET ERROR AND ABNORMAL ADDRESSES
         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
         USECT    LIST
LIST1    LI,D3    PRTBUF
         AW,D3    R7                BUFFER ADDRESS
         LI,R3    28
         LW,R2    ='    '
         STW,R2   *D3,R3            BLANK BUFFER
         BDR,R3   %-1
         STW,R2   *D3
         MTW,0    ATTRB,R7          ATTRIBUTES WANTED
         BNEZ     LISTATB           YES - GO LIST
         MTW,0    FROMFILE          REVIEW COMMAND
         BEZ      LIST17            NO
         BAL,SR4  TESTFN            TEST IF FILE WANTED
         B        LIST33            SKIP FILE
LIST17   LI,R1    M:EI+23
         BAL,SR4  UNPRINT           ENTER FILE NAME IN BUFFER
         LW,R1    D3
         LI,R6    M:LO
         DO       VERSION=2
         MTW,0    DELETEF           ONLINE REVIEW
         BEZ      LIST19            NO
         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 ABN 14
         LI,R4    X'40'
         AI,R2    1
         STB,R4   *R1,R2            SPACE AFTER FILE NAME
         LI,R6    M:UC
LIST19   EQU      %
        FIN
         LI,R3    1                 BTD
         CAL1,1   FPTLFILE
         DO       VERSION=2
         MTW,0    DELETEF           ONLINE REVIEW
         BEZ      LIST30            NO
         AI,R5    0                 ACCESS PROBLEM
         BNEZ     LIST26            YES - CONTINUE WITH LIST
REVRP    EQU      %
         CAL1,1   READFPT           READ REPLY
         LB,R1    DELETEF,R3        GET REPLY
         CI,R1    X'0D'
         BE       LIST30
         CI,R1    X'15'
         BE       LIST30            CONTINUE WITH LIST
         CI,R1    'D'               IS DELETE WANTED
         BNE      LIST26            NO
         LW,R1    M:EI
         CW,R1    =X'00200000'
         BANZ     %+2               FILE IS ALREADY OPEN
         CAL1,1   REVOPN            OPEN FILE
         CAL1,1   FPTDELET          RELEASE FILE
         BAL,R6   RANDCHK           TEST IF RANDOM FILE
         CAL1,1   WRTDEL            WRITE *DELETED*
LIST26   CAL1,1   WRTCR             WRITE CARRIAGE RETURN
        FIN
         USECT    PLSECT
FPTLFILE GEN,8,24 X'91',R6
         DATA     X'34000010'
         PZE      *R1               BUFFER
         PZE      *R2               COUNT
         PZE      *R3               BYTE DISPLACEMENT
         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
         LI,R5    0                 ZERO PASSWORD FLAG
         MTW,0    ATTRB,R7          WAS FID SPECIFIED
         BLEZ     LIST32            NO
         DO1      VERSION=2
         CAL1,1   OPENPR            REMOVE PASSWORD
         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    ','               ANOTHER FID
         BNE      LIST40            NO
         B        LIST9             YES - GO PROCESS
         DO       VERSION=2
LIST28   CAL1,1   WRTFB             WRITE 'FILE BUSY'
         CAL1,1   WRTCR             WRITE CR
         B        LIST30
         FIN
LIST32   EQU      %
         LW,R2    DEVICE,R7
         BNEZ     %+2          PCL DEVICE.
         LW,R2    DEV%IN,R7    SYSTEM INPUT DEVICE.
         CI,R2    4                 LISTING A TAPE
         BNE      LIST34            NO
         LI,R2    TLBLSIZE          PUT SIZE IN TLABEL BUFFER
         SLS,R2   24
         STW,R2   TLABEL
         STW,R0   TLABEL+1          RESET RANDOM FILE FLAG
LIST34   EQU      %
         DO       VERSION=2
         LW,R1    OPNFPT,R7
         CW,R1    =X'80000'         WAS TESTFILE OPEN DONE
         BAZ      %+3               NO
          CAL1,1  FPTNXT2           DO TESTFILE OPEN
         B        LIST1
         FIN
         CAL1,1   FPTNXT            OPEN NEXT FILE
         USECT    PLSECT
FPTNXT   GEN,8,7,17      X'14',0,M:EI
         DATA     X'00000400'
         DO       VERSION=2
FPTNXT2   GEN,8,7,17     X'14',4,M:EI
         DATA     X'400'
REVOPN   GEN,8,7,17      X'14',0,M:EI
         DATA     X'01000000'
         DATA     4                 INOUT
OPENPR   GEN,8,24 X'14',M:EI
         DATA     X'E000'
         DATA     0
         DATA     X'03010002'
         DATA     0,0
DELPRMT  DATA     X'2C000000'
READFPT  GEN,8,24 X'10',M:UC
         DATA     X'30000000'
         DATA     DELETEF
         DATA     1
WRTCR    GEN,8,24 X'11',M:UC
         DATA     X'34000010'
         DATA     REVMSG
         DATA     1
         DATA     0
RESETPR  GEN,8,16,8      X'2C',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
         FIN
         USECT    LIST
         B        LIST1             LIST THE FILE
         PAGE
TESTFN   EQU      %
TESTFNC  LB,R2    FROMFILE
         AI,R2    0                 WAS A FROM FILE SPECIFIED
         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
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
         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
TEST7    EQU      %
         AI,SR4   1
         B        TEST2
TEST3    AI,SR4   1
         B        *SR4              EXIT FOR FILE WANTED
TEST2    LW,R1    =X'80000000'      INDICATE END OF RANGE FOUND
         STS,R1   TOFILE
         B        *SR4
         PAGE
LIST8    BAL,SR4  GETARG            GET NEXT ARGUMENT
         LW,R1    ARGBUFF,R7
         CW,R1    =X'01C14040'      TEST IF 'A'
         BE       LIST10            YES
         CW,R1    =X'02C5C140'      TEST IF 'EA'
         BE       LIST16            YES
         LI,R2    3                 MODE CODE FOR 7T
         CW,R1    =X'02F7E340'
         BE       LIST12            7T
         LI,R2    4                 MODE CODE FOR 9T
         CW,R1    =X'02F9E340'
         BNE      LIST14
LIST12   LW,R1    DEVICE,R7
         BNEZ     %+2          PCL COMMAND.
         LW,R1    DEV%IN,R7    SYSTEM INPUT DEVICE.
         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      LIST15            NO - ERROR
         BAL,SR4  GETARG            GET DELIMITER ONLY
         MTW,0    NCHAR,R7          IS ARGUMENT NULL
         BNEZ     LIST18            NO - ERROR
         LW,R1    DEVICE,R7
         BNEZ     %+2          PCL COMMAND.
         LW,R1    DEV%IN,R7    SYSTEM INPUT DEVICE.
         CI,R1    6
         BE       LISTFT            FT
         LW,R2    TERM,R7
         STW,R2   LISTTERM          SAVE TERMINATOR
         LW,R1    CMBX,R7
         STW,R1   LISTCMBX          SAVE SCAN POINTER
         CI,R2    '/'               '/N.A.P' FOLLOW
         BNE      LIST5             NO
LIST9    BAL,SR4  FILTRAN           TRANSLATE FILE SPECIFICATION
         LI,R1    1
         STW,R1   ATTRB,R7          SET ATTRIBUTE FLAG FOR 1 FILE
         STW,R0   EATTRB            ZERO EXT ATTRIBUTE FLAG
         LW,R1    TERM,R7
         CI,R1    '('               OPTION FOLLOW
         BNE      LIST5             NO
         B        LIST8             YES - GO SCAN
LIST16   STW,R1   EATTRB            SET EXT ATTRIBUTE FLAG
LIST10   MTW,0    ATTRB,R7          WAS FID SPECIFIED
         BGZ      LIST11            YES
         LI,R2    -1
         STW,R2   ATTRB,R7          SET ATTRB FLAG FOR ALL FILES
         B        LIST11
LIST15   LI,R1    17                ERROR-DELIMITER OUT OF SYNTAX
         B        LIST6
LISTATB  AI,SR2   0                 IS THIS FIRST FILE
         BNEZ     LISTATB1          NO - SKIP HEADER
         LB,R2    LISTHEAD          LENGTH OF HEADER
         LI,R1    LISTHEAD          BUFFER ADR
         LI,R3    1                 BTD
         LI,R6    M:LO
         CAL1,1   FPTLFILE          PRINT ATTRIBUTE HEADER
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   RDACCT,R7         ZERO COUNT OF READ ACCTS
         STW,R0   WRTACCT,R7        ZERO COUNT OF WRITE ACCTS
         DO       VERSION=2
         STW,R0   EXACCT,R7         ZERO COUNT OF EXECUTE ACCTS
         STW,R0   UNACCT,R7         ZERO COUNT OF VEHICLE ACCTS
         FIN
         LI,R6    8
         STW,R0   DATETBL-1,R6      ZERO DATE TABLE
         BDR,R6   %-1
         LI,SR4   LISTATB2
ABN14T   EQU      %
         MTW,0    DELETEF
         BEZ      ABN14T1           NOT ONLINE REVIEW
         MTB,0    M:EI+X'4B'
         BEZ      %+3
         LI,R5    2                 FILE IS OPEN
         B        ABN14T1
         LI,D3    X'8000'
         CW,D3    M:EI+X'4B'
         BAZ      *SR4              NOT PASSWORDED
         LI,R5    1
ABN14T1  EQU      %
         CI,R5    0                 ACCESS PROBLEM
         BEZ      *SR4              NO
         LCI      2
         PSM,R1   *R7
         AI,R2    1
         SLS,R2   -2
         AW,R1    R2
         AI,R1    1                 COMPUTE BUFFER POINTER
         LI,D3    PASSMSG
         CI,R5    1                 PASSWORD OR ACCOUNT
         BE       %+2               YES
         LI,D3    FILEBUSY
         LCI      5
         LM,R2    *D3               MOVE MESSAGE TO BUFFER
         STM,R2   0,R1
         LCI      2
         PLM,R1   *R7
         AI,R2    23                TOTAL LINE LENGTH
         MTW,0    DELETEF           ONLINE REVIEW
         BEZ      LISTATB9          NO
         B        *SR4
LISTATB2 LW,D3    R2                SAVE LINE LENGTH
         LW,R2    DEVICE,R7
         BNEZ     %+2          PCL DEVICE.
         LW,R2    DEV%IN,R7    SYSTEM INPUT DEVICE.
         CI,R2    4            LABELED TAPE?
         BNE      %+4               NO
         LW,R3    TLABEL+1
         CW,R3    ='RFIL'           IS FILE RANDOM
         BE       LISTRAND          YES
         LI,R2    3
         LB,R3    M:EI+5,R2         GET ORG CODE
         SLS,R3   -4
         LB,R2    ORGN,R3
         LI,R4    ORG               GET BYTE DISPLACEMENT
         STB,R2   *R1,R4            'K' OR 'C' TO PRINT BUFFER
*
         LI,R4    1                 SET BYTE DISP REGS FOR VLP SEARCH
         LI,R2    2
         LI,R3    3
         LI,SR3   FPARAM            INITIALIZE POINTER TO VLP
         AW,SR3   R7
LISTATB3 LB,R5    *SR3              GET VLP CODE
         CI,R5    X'10'
         BLE      LIST%EX      CHECK PARAMETER.
         DO       VERSION=2
         CI,R5    X'14'        CHECK FOR EXECUTE OR VEHICLE.
         BL       LISTATB4     DONT WANT THIS ENTRY.
         FIN
         DO1      VERSION=1
         B        LISTATB4     THIS ENTRY NOT WANTED.
LIST%EX  EQU      %
         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 LW,R2    D3                RESTORE LINE LENGTH
LISTATB9 EQU      %
         LI,R6    M:LO
         LI,R3    1                 BTD
         CAL1,1   FPTLFILE          WRITE ATTRIBUTES
         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
         MTW,0    EATTRB            WAS 'EA' SPECIFIED
         BEZ      LIST30            NO
         BAL,SR4  DATELIST          GO LIST DATE ATTRIBUTES
         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        LISTATB6          GO PRINT LINE
ERRADD   LB,R1    SR3
         CI,R1    2                 END OF FILE DIRECTORY
         BE       LIST40
         LI,R2    X'100'
         CH,R2    M:EI+23           FILE NAME TO PRINT
         BE       LIST7             NO
         CI,R1    8                 SYNON
         BE       LIST41            YES
         CI,R1    X'14'             ACCESS PROBLEM
         BNE      LIST7             NO
         LI,R5    1                 SET PASSWORD FLAG
         LB,R1    SR3,R5            GET SUBCODE
         OR,R5    R1                1=PASSWORD, 3=FILE BUSY
LIST41   STW,R0   IOERR,7           SUPPRESS ERROR MESSAGE
         BAL,SR4  D2CHK             UPDATE ERR SEVERITY
         LW,R1    CMBX,R7
         AI,R1    -CMBXDIFF-1
         LI,R2    ' '               BLANK OUT ERROR POINTER
         STB,R2   *R7,R1
         AI,SR2   0                 IS THIS FIRST FILE
         BNEZ     LIST1             NO
         B        LIST24            GO PRINT FILE NAME
LIST7    EQU      %
         LI,R1    0                 NO-REPORT ERROR
         BAL,SR4  ERROR
         BAL,SR4  D2CHK             UPDATE ERR SEVERITY
         BAL,SR4  CLOSEI            CLOSE M:EI IF OPEN
         MTW,0    ATTRB,R7          WAS FID SPECIFIED
         BGZ      LIST31            YES
LIST40   LW,R1    TERM,R7
         CI,R1    '('
         BNE      %+2
         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    FROMFILE
         BNEZ     %+3               REVIEW COMMAND
         AI,SR2   0                 ANY FILES LISTED
         BEZ      RETURN            NO
         BAL,SR4  PRTNOF            PRINT 'NNN FILES LISTED'
         MTW,0    ATTRB,R7          ARE WE LISTING ATTR OF DIRECTORY
         BGEZ     RETURN            NO
         LW,SR2   GRANCNT           GET TOTAL GRANULES
         BEZ      RETURN
         LI,R5    GRANTEXT          ADDRESS OF MESSAGE
         BAL,SR4  PRTNOF            PRINT 'XXX TOTAL GRANULES'
RETURN   EQU      %
         DO       VERSION=2
         MTW,0    DELETEF
         BEZ      %+2               NOT REVIEW COMMAND
         CAL1,1   RESETPR           RESET PROMPT CHARACTER
         FIN
         LCI      7
         PLM,R5   *R7               RESTORE REGISTERS
         B        *SR4              RETURN
ERRADD2  LI,R1    0                 REPORT M:LO ERROR
         BAL,SR4  ERROR
         BAL,SR4  CLOSEI
         B        RETURN
LIST50   LB,R2    NOFILES           GET MESSAGE COUNT
         LI,R1    M:UC              SELECT BATCH OR ONLINE
         MTW,0    J:JIT
         BLZ      %+3
         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
'
         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
         AI,R1    DATE-2            PRINT BUFFER POSITION -2 WORDS
         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   *R1,R2            ENTER 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   *R1,R3            ENTER MONTH IN BUFFER
         AI,R1    1
         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   *R1,R3            ENTER YEAR IN BUFFER
         AI,R1    1-DATE            RESTORE BUFFER POINTER
         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+1           -WILL BE MODIFIED BY CDATE-
         CW,R5    ='NEVE'
         BE       DATEL4            EXP DATE IS NEVER
         BAL,SR4  CDATE             ENTER DATE IN LINE
DATEL5   EQU      %
         AI,R1    -1                BUFFER ADDRESS
         LI,R2    DATE*4+10         LENGTH
         LI,R3    1                 BTD
         LW,R5    R6                SAVE TDATE INDEX
         LI,R6    M:LO
         CAL1,1   FPTLFILE          PRINT LINE
         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
         AWM,R1   GRANCNT           UPDATE GRANULE COUNT
         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
         BNEZ     %+2          PCL DEVICE.
         LW,R5    DEV%IN,R7    SYSTEM INPUT DEVICE.
         CI,R5    5            TEST IF DP.
         BE       %+3          YES.
         CI,R5    3                 RAD FILE
         BNE      *SR4              NO - EXIT
         MTW,0    ATTRB,R7          WAS OPEN NEXT DONE
         BLZ      *SR4              YES - 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,SR3   SYNONYM,R7
         BEZ      *SR4              NO SYNON
         PSW,SR4  *R7
         LW,R1    ='  SY'
         STW,R1   PRTBUF+20,R7      MOVE ' SYNON= ' TO BUFFER
         STW,R1   PRTBUF+22,R7      PUT BLANK IN 1ST BYTE 3RD WORD
         LW,R1    ='NON='
         STW,R1   PRTBUF+21,R7
         LI,D3    PRTBUF+22         ADDR OF 3RD WORD OF BUFFER
         AW,D3    R7
         LW,R1    SR3               POINTER TO NAME
         AI,R1    1                 1ST WORD OF PARAMETER
         BAL,SR4  UNPRINT           MOVE NAME TO BUFFER
         LW,R1    D3                RESTORE R1
         AI,R2    9                 + 9 BYTES
         LI,R3    0                 BTD
         LI,R6    M:LO
         AI,R1    -2                BACK UP TO START OF BUFFER
         CAL1,1   FPTLFILE          PRINT 'SYNON=  XXX'
         PLW,SR4  *R7
         B        *SR4              RETURN
*
* SUBROUTINE RACCT GETS THE READ ACCOUNT FROM FPARAM AND ENTERS IT
* IN TABLE RDACCT.  A COUNT OF THE NUMBER OF READ ACCOUNTS IS
* MAINTAINED IN THE FIRST WORD OF THE TABLE.
RACCT    LB,R5    *SR3,R2           GET NO. OF SIGNIFICANT WORDS
         LW,R0    R5
         LW,SR1   ='    '
         STW,SR1  RDACCT+2,R7       BLANK 2ND WD OF 1ST ACCT
         AI,R0    1                IN CASE OF 1-WORD ENTRY
         SLS,R0   -1                COMPUTE NO. OF ACCTS
         STW,R0   RDACCT,R7
         LI,SR1   RDACCT
         AW,SR1   R7
         LW,R0    *SR3,R5           MOVE ACCT TO TABLE
         STW,R0   *SR1,R5
         BDR,R5   %-2
         LI,R0    0                 RESET R0
         B        *SR4              RETURN
*
* SUBROUTINE WACCT GETS THE WRITE ACCOUNT FROM FPARAM AND ENTERS IT
* IN TABLE WRTACCT.  A COUNT OF THE NUMBER OF WRITE ACCOUNTS IS
* MAINTAINED IN THE FIRST WORD OF THE TABLE.
WACCT    LB,R5    *SR3,R2           GET NO. OF SIGNIFICANT WORDS
         LW,R0    R5
         LW,R6    ='    '
         STW,R6   WRTACCT+2,R7      BLANK 2ND WD OF 1ST ACCT
         AI,R0    1                IN CASE OF 1-WORD ENTRY
         SLS,R0   -1                COMPUTE NO. OF ACCTS
         STW,R0   WRTACCT,R7
         LI,R6    WRTACCT
         AW,R6    R7
         LW,R0    *SR3,R5           MOVE ACCT TO TABLE
         STW,R0   *R6,R5
         BDR,R5   %-2
         LI,R0    0                 RESET R0
         B        *SR4              RETURN
         DO       VERSION=2
* SUBROUTINE EACCT GETS THE EXECUTE ACCOUNT FROM FPARAM AND
* ENTERS IT INTO TABLE EXACCT.  A COUNT OF THE NUMBER OF VEHICLE
* ACCOUNTS IS MAINTAINED IN THE FIRST WORD OF THE TABLE.
EACCT    EQU      %
         LB,R5    *SR3,R2      GET NO. OF SIGNIFICANT WORDS.
         LW,R0    R5
         LW,SR1   ='    '
         STW,SR1  EXACCT+2,R7  BLANK 2ND WD OF 1ST ACCT
         AI,R0    1            IN CASE OF 1-WORD ENTRY.
         SLS,R0   -1           COMPUTE NO. OF ACCTS
         STW,R0   EXACCT,R7
         LI,SR1   EXACCT
         AW,SR1   R7
         LW,R0    *SR3,R5      MOVE ACCT TO TABLE
         STW,R0   *SR1,R5
         BDR,R5   %-2
         LI,R0    0            RESET R0
         B        *SR4         RETURN
* SUBROUTINE VACCT GETS THE VEHICLE ACCOUNT FROM FPARAM AND
* ENTERS IT INTO TABLE UNACCT.  A COUNT OF THE NUMBER OF VEHICLE
* ACCOUNTS IS MAINTAINED IN THE FIRST WORD OF THE TABLE.
VACCT    EQU      %
         LB,R5    *SR3,R2      GET NO. OF SIGNIFICANT WORDS
         LW,R0    R5
         LW,SR1   ='    '
         STW,SR1  UNACCT+2,R7  BLANK 2ND WD OF 1ST ACCT.
         AI,R0    1            IN CASE OF 1-WORD ENTRY.
         SLS,R0   -1           COMPUTE NO. OF ACCTS
         STW,R0   UNACCT,R7
         LI,SR1   UNACCT
         AW,SR1   R7
         LW,R0    *SR3,R5      MOVE ACCT TO TABLE
         STW,R0   *SR1,R5
         BDR,R5   %-2
         LI,R0    0            RESET R0
         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    RDACCT,R7
         BEZ      *SR4              NO READ ACCOUNTS - EXIT
         LI,R4    RDACCT
         AW,R4    R7
         LW,R3    1,R4              GET FIRST ACCOUNT
         CW,R3    ='ALL '           IS DEFAULT SPECIFIED
         BNE      RACC10
         LW,R3    2,R4
         CW,R3    ='    '
         BE       *SR4              YES - EXIT
RACC10   EQU      %
         LW,R3    ='  RE'
         STW,R3   IOBUF,R7          SET UP 'READ=' IN BUFFER
         LW,R3    ='AD  '
         STW,R3   IOBUF+1,R7
         LW,R3    ='  = '
         STW,R3   IOBUF+2,R7
         B        WACC30            GO TO FORMAT ACCOUNTS
         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    EXACCT,R7
         BEZ      *SR4         NO EXECUTE ACCOUNTS - EXIT
         LI,R4    EXACCT
         AW,R4    R7
         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      %
         LW,R3    ='  EX'
         STW,R3   IOBUF,R7     SET UP 'EXECUTE=' IN BUFFER
         LW,R3    ='ECUT'
         STW,R3   IOBUF+1,R7
         LW,R3    ='E = '
         STW,R3   IOBUF+2,R7
         B        WACC30       GO TO FORMAT ACCOUNTS.
*
* SUBROUTINE UACCTX GETS VEHICLE ACCOUNT FROM TABLE UNACCT,
* FORMATS THEM INTO THE PRINT BUFFER, AND PRINTS THE LINE.
UACCTX   EQU      %
         LW,D4    UNACCT,R7
         BEZ      *SR4         NO VEHICLE ACCOUNT - EXIT.
         LI,R1    UNACCT
         AI,R1    1
         LB,R3    *R1
         BEZ      *SR4
UACC10   EQU      %
         LW,R3    ='  VE'
         STW,R3   IOBUF,R7     SET UP 'VEHICLE=' IN BUFFER
         LW,R3    ='HICL'
         STW,R3   IOBUF+1,R7
         LW,R3    ='E = '
         STW,R3   IOBUF+2,R7
         LI,D3    IOBUF+2
         AW,D3    R7           BUFFER ADDRESS +1
         LI,R3    40
         LW,R2    ='    '
         STW,R2   *D3,R3       BLANK OUTPUT BUFFER
         BDR,R3   %-1
         LI,R6    12
         AI,D3    -2
         LCI      4
         PSM,SR4  *R7
         SLS,R6   -2           COMPUTE WORD ADDRESS IN BUFFER
         AW,D3    R6
         BAL,SR4  UNPRINT      ENTER ACCOUNT IN BUFFER
         LCI      4
         PLM,SR4  *R7
         B        WACC50
         FIN
*
* SUBROUTINE WACCTX GETS WRITE ACCOUNTS FROM TABLE WRTACCT, FORMATS
* THEM IN THE PRINT BUFFER, AND PRINTS THE LINE.
WACCTX   LW,D4    WRTACCT,R7
         BEZ      *SR4              NO WRITE ACCOUNTS
         LI,R4    WRTACCT
         AW,R4    R7
         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   LW,R3    ='  WR'
         STW,R3   IOBUF,R7          SET UP 'WRITE=' IN BUFFER
         LW,R3    ='ITE '
         STW,R3   IOBUF+1,R7
         LW,R3    ='  = '
         STW,R3   IOBUF+2,R7
WACC30   EQU      %
         LI,D3    IOBUF+2
         AW,D3    R7                BUFFER ADDRESS +1
         LI,R3    40
         LW,R2    ='    '
         STW,R2   *D3,R3            BLANK OUTPUT BUFFER
         BDR,R3   %-1
         LI,R6    9
         AI,D3    -2
WACC40   LCI      2
         LM,R2    1,R4              GET ACCOUNT FROM TABLE
         LI,R1    IOBUF+52
         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
         LCI      4
         PSM,SR4  *R7
         AI,R6    3
         SLS,R6   -2                COMPUTE WORD ADDRESS IN BUFFER
         AW,D3    R6
         BAL,SR4  UNPRINT           ENTER ACCOUNT IN BUFFER
         LCI      4
         PLM,SR4  *R7
         SLS,R6   2
         AW,R6    R2                UPDATE BUFFER INDEX BY LNG OF ACCT
         LI,R1    ' '
         CB,R1    *D3,R6            SUPPRESS TRAILING BLANKS
         BNE      %+2
         BDR,R6   %-2
         AI,R6    1
         AI,R4    2
         BDR,D4   WACC60            BR IF MORE ACCOUNTS
WACC50   EQU      %
         LI,R3    0                 BTD
         LW,R1    D3                BUFFER
         LW,R2    R6                LENGTH
         LI,R6    M:LO
         CAL1,1   FPTLFILE          PRINT LINE
         B        *SR4              EXIT
WACC60   LI,R1    ','
         STB,R1   *D3,R6            ADD COMMA
         B        WACC40            GO GET NEXT ACCOUNT
*
* 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
'
PASSMSG  TEXT     '*RESTRICTED ACCESS*'
FILEBUSY TEXT     ' **FILE BUSY**      '
LSTTEXT  TEXT     ' FILES LISTED  
'
LISTHEAD TEXTC    'ORG    GRAN     REC     DATE    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'
         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
         LI,R4    OPNFPT-1
         AW,R4    R7
         LI,R2    OPNEIEND-OPNEINXT
         LW,R3    OPNEINXT-1,R2     INITIALIZE OPEN FPT
         STW,R3   *R4,R2
         BDR,R2   %-2
         LW,R2    1,R1
         DO1      VERSION=2
         STW,R2   OPNFPT+7,R7       PUT INSN IN FPT
         DO1      VERSION=1
         STW,R2   OPNFPT+6,R7      PUT INSN IN FPT--BPM
         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
         DO1      VERSION=2
         STM,R5   OPNFPT+9,R7       ENTER ACCT IN OPEN FPT.
         DO1      VERSION=1
         STM,R5   OPNFPT+8,R7      ENTER ACCT IN OPEN FPT--BPM
         STM,R5   PRTBUF+2,R7       ENTER ACCT IN PRINT BUFFER
         LM,R5    ACCT
         STM,R5   PRTBUF,R7         SET UP PRINT LINE
         LI,R2    15                LINE LENGTH
         LI,R6    M:LO
         CAL1,1   FPTLFILE          PRINT ACCOUNT
         CAL1,1   FPTREW1           REMOVE
*
LISTFT3  CAL1,1   OPNFPT,R7         OPEN NEXT FILE
LISTFT4  LW,D3    R1
         LI,R1    M:EI+23
         BAL,SR4  UNPRINT           PRINT FILE NAME
         LW,R1    D3
         LI,R3    1
         CAL1,1   FPTLFILE
         BAL,SR4  CLOSEI            CLOSE FILE
         LW,R1    D3                RESTORE BUFFER ADDRESS
         AI,SR2   1                 INCREMENT FILE COUNT
         MTW,0    BREAK             BREAK SET
         BEZ      LISTFT3           NO
         STW,R0   BREAK
         B        LIST40            YES - EXIT
*
LISTFT7  LB,R2    UNLABEL           UNLABELED TAPE
         LI,R1    UNLABEL
         LI,R3    1                 BTD
         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
*
ABNLIST  LB,R2    SR3
         CI,R2    2
         BE       LIST40            END OF DIRECTORY
         B        LISTFT4           CONTINUE
*
         USECT    PLSECT
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
         DO       VERSION=2
OPNEINXT GEN,8,7,17  X'14',1,M:EI
         DATA     X'0000044A'
         DATA     X'C1000000'
         FIN
         DO       VERSION=1
OPNEINXT GEN,8,7,17   X'14',0,M:EI
         DATA     X'C100044A'
         FIN
         DATA     ABNLIST
         DATA     ABNLIST
         DATA     4
         DATA     X'07000101'
         DATA     0
         DATA     X'02010202'
         DATA     0,0
OPNEIEND EQU      %
         USECT    LIST
INSN     TEXT     ' INSN = '
ACCT     TEXT     ' ACCT = '
UNLABEL  TEXTC    'UNLABELED TAPE'
         TITLE    'REM-REW'
REW      DSECT    1                 REWIND
         LCI      7
         PSM,R5   *R7               SAVE REGISTERS
         LI,R1    6
         STW,R1   #DELIM,R7         ENABLE # DELIMITER
         LI,R1    CMDBUF+CMDBUF+CMDBUF+CMDBUF
         STW,R1   CMBX,R7           BACK UP TO START OF COMMAND
         BAL,SR4  TRANSACT          GET COMMAND VERB AGAIN
         BAL,SR4  CLRARG            CLEAR ARGUMENT TABLE
         LI,R6    12
         STW,R6   DEVICE,R7         SET TO 'MT' OP LABEL
         LW,R1    TERM,R7
         CI,R1    '#'
         BE       REW3              NO DEVICE CODE PRESENT
         CI,R1    ' '
         BNE      REW7
         BAL,SR4  DEVTRAN           GET DEVICE CODE AND REEL NO
         LW,R1    DEVICE,R7
         BNEZ     %+2          PCL DEVICE.
         LW,R1    DEV%IN,R7    SYSTEM INPUT DEVICE.
         CI,R1    4                 MUST BE LT,FT,AT OR DP
         BL       REWA              ERROR
         CI,R1    7
         BLE      REW1+1            OK
REWA     LI,R1    34                INVALID DEVICE SPECIFICATION
         B        REW2+1
REW3     EQU      %
         LW,R6    CMBX,R7
         STW,R6   DEVICE+2,R7       CMBX OF FIRST REEL NO.
REW1     BAL,SR4  GETARG            READ REEL NO.
         STW,R0   #DELIM,R7         DISABLE # DELIMITER
         MTW,0    DEVICE+1,R7  IS REEL NUMBER PRESENT?
         BNEZ     REW11        YES.
         LW,R1    TERM,R7
         CI,R1    '/'
         BE       REWD         YES.
REW11    EQU      %
         CI,R1    7            CHECK FOR ANS TAPE.
         BNE      %+3          NOT ANS.
         LW,R1    =X'03000106'
         B        %+2
         LW,R1    =X'03000104'
         BAL,SR4  TEXTARG           GO-CHECK REEL NO.
         CI,D2    1                 ERROR DETECTED
         BG       RETURN            YES
         LI,R5    1
         STW,R5   DEVICE+1,R7       NO. OF REEL NUMBERS AT ONE
         LW,R1    TERM,R7
REW7     EQU      %
         CI,R1    X'15'             ANOTHER REEL NO. FOLLOW
         BE       REW6              NO
         CI,R1    '('               OPTION FOLLOW
         BE       REWB              YES
         CI,R1    '-'          CHECK FOR DASH.
         BE       REWB
REWD     EQU      %
         LW,R2    DEVICE,R7
         CI,R2    7                 ANS TAPE
         BNE      REW2              NO - ERROR
         CI,R1    '/'               DOES FILE NAME FOLLOW
         BNE      REW2              NO - ERROR
REWC     BAL,SR4  FILTRAN           GO GET FILE NAME
         B        REW6
REWB     EQU      %
         BAL,SR4  GETARG            GET OPTION
         LW,R1    ARGBUFF,R7
         CW,R1    =X'02F7E340'      IS IT 7T
         BNE      REW6              NO - IGNORE
         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
         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
REWE     EQU      %
         BAL,SR4  GETARG            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
         BNEZ     %+2          PCL COMMAND.
         LW,R2    DEV%IN,R7    SYSTEM INPUT DEVICE.
         CI,R2    5
         BG       REW5              FT OR AT
         BE       REW8              DP
         LI,R2    12                LT - SET CODE FOR MT
         STW,R2   DEVICE,R7
REW5     EQU      %
         BAL,SR4  BLDCB             GO BUILD INPUT DCB
         CI,D2    1                 ERROR DETECTED
         BG       RETURN            YES-RETURN
         CI,D1    6                 REMOVE
         BE       REW4              YES
         CAL1,1   FPTREW            NO-REWIND
         USECT    PLSECT
FPTREW   GEN,8,7,17      X'01',0,M:EI
         USECT    REW
         BAL,SR4  CLOSEI            GO-CLOSE M:EI
         B        RETURN            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
         BANZ     REW4              YES - GO RELEASE
ERRDP    LB,R1    SR3
         CI,R1    2
         BE       REW9              END OF DIRECTORY - ERROR
         LI,R2    X'100'
         CH,R2    M:EI+23           IS FILE NAME PRESENT
         BNE      %+4               YES - OK
         STW,SR3  IOERR,R7          I/O ERROR-REPORT AND QUIT
         LI,R1    0
         B        REW2+1
         CAL1,1   OPNDP             OPEN NEXT FILE
         B        REW4
         FIN
REW2     LI,R1    17                SYNTAX ERROR
         BAL,SR4  ERROR
         STW,R0   #DELIM,R7         DISABLE # DELIMITER
         B        RETURN            EXIT
REW4     CAL1,1   FPTREW1
         USECT    PLSECT
FPTREW1  GEN,8,7,17      X'15',0,M:EI
         DATA     X'20'             REMOVE
         DO       VERSION=2
OPNDP    GEN,8,24 X'14',M:EI
         DATA     X'C0000400'
         DATA     ERRDP
         DATA     ERRDP
         FIN
         USECT    REW
         B        RETURN            RETURN
         DO       VERSION=2
REW9     LI,R1    52                UNABLE TO DISMOUNT
         B        REW2+1
         FIN
         TITLE    'WRITE END OF FILE'
WEOF     DSECT    1
         LCI      7
         PSM,R5   *R7
         LW,R1    TERM,R7
         CI,R1    X'15'             PARAMETERS PRESENT
         BE       WEOF1             NO-O.K.
         LI,R1    30                ERROR-IMPROPER TERMINATION
         BAL,SR4  ERROR
WEOF1    MTW,0    TOSWT,R7
         BEZ      RETURN
         CAL1,1   FPTWEOF           WRITE AN EOF
         USECT    PLSECT
FPTWEOF  GEN,8,7,17      X'02',0,M:EO
         USECT    WEOF
         BAL,SR4  CLOSEO
         B        RETURN            RETURN
         TITLE    'SPACE AFTER LAST FILE'
SPE      DSECT    1
         LCI      7
         PSM,R5   *R7               SAVE REGISTERS
         BAL,SR4  CLRARG            CLEAN -ARGTBL-
         BAL,SR4  DEVTRAN           GO-TRANSLATE DEVICE
         LW,R2    DEVICE,R7
         BNEZ     %+2          PCL DEVICE.
         LW,R2    DEV%IN,R7    SYSTEM INPUT DEVICE.
         CI,R2    4                 LT SPECIFICATION
         BE       SPE1              YES
         LI,R1    34                ERROR-NOT LT SPECICATION
SPE8     LI,D2    4                 SET ABORT MODE
         B        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
         MTW,0    FILE,R7           IS ACCOUNT SPECIFIED
         BEZ      %+3               NO - OK
         LI,R1    40                ERROR - ACCT SPEC NOT VALID
         B        SPE8
         LW,R1    TERM,R7
         CI,R1    '('               DOES OPTION FOLLOW
         BNE      SPE7              NO
         BAL,SR4  GETARG            GET OPTION
         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
SPE4     LI,R2    X'100'
         CH,R2    M:EI+23           CROSS A FILE
         BNE      SPE3              YES
         LI,R1    0
         BAL,SR4  ERROR             REPORT I/O ERROR
         LI,D2    4                 SET ABORT MODE
         B        SPE6              QUIT
SPE3     BAL,SR4  CLOSEI            GO-CLOSE THE FILE
         CAL1,1   FPTSKIP           OPEN NEXT FILE
         USECT    PLSECT
FPTSKIP  GEN,8,7,17      X'14',0,M:EI
         DATA     X'C0000400'
         DATA     SPEABN
         DATA     SPEABN
         USECT    SPE
         B        SPE3              COUNT THE FILE
SPE6     LW,R1    TERM,R7
         CI,R1    X'15'             END OF COMMAND
         BE       RETURN            YES
         LI,R1    30
         B        SPE5
SPEABN   LB,R2    SR3
         CI,R2    2                 END OF ACCT.
         BNE      SPE4              NO-TEST FOR PASS WORD PROBLEM
         B        SPE6
         TITLE    'SPACE FILE'
SPF      DSECT    1                 SPACE FILE
         LCI      7
         PSM,R5   *R7               SAVE REGISTERS
         BAL,SR4  CLRARG            ZERO -ARGTBL-
         BAL,SR4  DEVTRAN           GO-TRANSLATE DEVICE
         LW,R2    DEVICE,R7
         BNEZ     %+2          PCL DEVICE.
         LW,R2    DEV%IN,R7    SYSTEM INPUT DEVICE.
         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    '('               DOES OPTION FOLLOW
         BNE      SPF9              NO - BAD SYNTAX
         BAL,SR4  GETARG            GET OPTION
         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  GETARG            GO SCAN NULL FIELD
         MTW,0    NCHAR,R7
         BNEZ     SPF9              FIELD NOT NULL-ERROR
SPF2     EQU      %
         LI,R1    12           CODE TO OPEN INPUT IN INOUT MODE.
         CI,D2    1                 ANY ERRORS IN SCAN
         BG       RETURN            YES - EXIT
         LW,SR4   CMBX,R7
         STW,SR4  CMBXHLD,R7   SAVE CMBX.
         BAL,SR4  BLDCB             GO OPEN M:EI
         LW,SR4   CMBXHLD,R7
         STW,SR4  CMBX,R7      RESTORE CMBX.
         CI,D2    1                 BLDCB ERROR
         BG       RETURN            YES-RETURN
         LCI      2
         LM,R1    SPFPT
         STM,R1   WRTFPT,R7         INITIALIZE MOVE FILE FPT
         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    36                ERROR-OVERFLOW ON NO. OF FILE CONV.
         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,R3    0                 DONE MOVING TAPE
         BE       SPF7              YES
         CAL1,1   WRTFPT,R7         MOVE THE TAPE A FILE
         AI,R3    -1                COUNT THIS MOVE
         B        SPF6
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
         TITLE    'DELETEALL'
DELETEAL DSECT    1
         LCI      7
         PSM,R5   *R7               SAVE REGISTERS
         BAL,SR4  CLRARG            CLEAR ARG TABLE
         LI,R1    3
         STW,R1   DEVICE,R7         INITIALIZE DEVICE TO DC
         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
         CI,R1    X'40'             IS DELIMITER A BLANK
         BNE      DELETE7-1         NO - BAD SYNTAX
         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    0            CHECK FOR SYSTEM DEVICE.
         BNE      CK%DC        NOT SYSTEM DEVICE
         LW,R2    DEV%IN,R7
         STW,R2   SFARG
CK%DC    EQU      %
         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,R0   2,R7              RESET HEADER 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      %
         DO       VERSION=2
         MTW,0    J:JIT             ONLINE
         BGEZ     DELALL1           NO-DONT CONFIRM
         CAL1,1   FPTALL            PRINT CONFIRM MESSAGE
         USECT    PLSECT
FPTALL   GEN,8,7,17      X'11',0,M:UC
         DATA     X'34000010'
         DATA     %+3
         DATA     11
         DATA     0
         TEXT     'DELETEALL?
'
         USECT    DELETEAL
         CAL1,1   FPTPRMT           SET PROMPT CHAR TO '.'
         LW,R1    R7
         AI,R1    CMDBUF
         LI,R6    M:UC
         CAL1,1   FPTCONSL          READ CONFIRMATION
         CAL1,1   FPTPROMT          RESET PROMPT CHAR TO '<'
         LW,R1    =C'YES%'
         CW,R1    CMDBUF,R7         CONFIRMATION RECEIVED
         BNE      RETURN            NO-RETURN
         FIN
DELALL1  EQU      %
         LI,R1    X'C'              INOUT,OPNXT,INPUT
         BAL,SR4  BLDCB             GO-BUILD INPUT DCB
         CAL1,1   FPTSET            SET ERR AND ABN ADDRESSES
         USECT    PLSECT
FPTSET   GEN,8,7,17      X'06',0,M:EI
         DATA     X'C0000000'
         DATA     ERRABN
         DATA     ERRABN
         USECT    DELETEAL
         LW,R1    =X'00200000'
         CW,R1    M:EI              ABLE TO OPEN USER ACCT.
         BANZ     DELALL2           YES-RELEASE IT
         LB,R1    SR3
         CI,R1    2                 ANY FILES PRESENT
         BE       LIST50            NO
         B        ALL8
DELALL2  MTW,0    FROMFILE
         BEZ      DELALL4           SIMPLE DELETEALL
         BAL,SR4  TESTFNC           TEST IF FILE IN RANGE
         B        DELALL5           NO - SAVE FILE
DELALL4  CAL1,1   FPTDELET          RELEASE THE FILE
         LI,SR4   ALL4
         BAL,R6   RANDCHK           TEST IF RANDOM FILE
         AI,SR2   1                 INCREMENT FILE COUNT
*
ALL4     LW,R1    BREAK
         BEZ      %+3               BREAK NOT SET
         MTW,1    BREAK             SET TO 2
         B        ALL9
         MTW,0    TOFILE            ANY MORE FILES WANTED
         BLZ      ALL9              NO
*
         CAL1,1   FPTFILE           OPEN NEXT FILE
         USECT    PLSECT
FPTFILE  GEN,8,7,17      X'14',0,M:EI
         DATA     X'00000400'
         USECT    DELETEAL
         B        DELALL2           RELEASE IT
ALL6     PLW,SR4  *R7
         B        ALL4
DELALL5  BAL,SR4  CLOSEI            CLOSE AND SAVE
         B        ALL4
ERRABN   LB,R1    SR3
         CI,R1    2                 END OF DIRECTORY
         BNE      ALL8              NO
ALL9     LI,R5    DELTEXT           ADDR OF MESSAGE
         BAL,SR4  PRTNOF            PRINT 'NNN FILES DELETED'
         B        RETURN
ALL8     CI,R1    8                 SYNONYM NAME
         BE       ALL4              YES-SKIP IT
         CI,R1    3
         BE       RAND1             RANDOM FILE WAS DELETED
ALL7     LI,R2    2
         LI,SR4   ALL4
         CI,R1    X'14'
         BNE      %+3
         MTB,0    M:EI+22,R2        PASSWORD PROBLEM
         BNEZ     ALL2              YES-PRINT 'CAN NOT ACCESS FILE'
         LI,R1    0                 YES-REPORT ERROR
         BAL,SR4  ERROR
         B        ALL9
*
ALL2     MTW,0    FROMFILE
         BEZ      ALL5              SIMPLE DELETEALL
         DO       VERSION=2
         MTW,0    DELETEF
         BNEZ     LIST28            REVIEW COMMAND
         FIN
         PSW,SR4  *R7
         BAL,SR4  TESTFNC           TEST IF FILE IN RANGE
         B        ALL6              NO - DON'T PRINT ANYTHING
         PLW,SR4  *R7
ALL5     MTW,0    2,R7              CANT ACCESS FILE HEAD PRINTED
         BNEZ     ALL3              YES
         LB,R2    TXCNTFIL          NO-PRINT IT
         STW,R2   2,R7              SET PRINTED
         LI,R3    M:UC              SELECT ONLINE OR BATCH
         MTW,0    J:JIT
         BLZ      %+3
         LI,R3    M:LO
         AI,R2    -1
         CAL1,1   FPTCNTFL          PRINT 'CAN NOT ACCESS FILE'
         USECT    PLSECT
FPTCNTFL GEN,8,7,17      X'91',0,R3
         DATA     X'34000010'
         DATA     TXCNTFIL
         PZE      *R2
         DATA     1
TXCNTFIL TEXTC    'CAN NOT ACCESS FILE
'
DELTEXT  TEXT     ' FILES DELETED 
'
FPTPRMT  GEN,8,16,8      X'2C',0,'.'
         USECT    DELETEAL
ALL3     LI,D3    FPARAM
         AW,D3    R7
         LI,R1    M:EI+23
         PSW,SR4  *R7
         BAL,SR4  UNPRINT           MOVE FILE NAME TO BUFFER
         PLW,SR4  *R7
         AI,R2    1
         LI,R3    X'15'
         STB,R3   *D3,R2            INSERT NL CHAR
         LI,R3    M:UC              SELECT BATCH OR ONLINE
         MTW,0    J:JIT
         BLZ      %+3
         LI,R3    M:LO
         AI,R2    -1                REMOVE NL CHAR GOING TO PRINTER
         CAL1,1   FPTNFILE          PRINT FILE NAME
         B        *SR4
RANDCHK  LI,R1    X'F0'
         AND,R1   M:EI+5            IS ORG RANDOM
         CI,R1    X'30'
         BNE      0,R6              NO - EXIT
         CAL1,1   FPTSET            SET ERR AND ABN ADDRESSES
         CAL1,1   OPNTRY            TRY TO OPEN AGAIN
         PSW,SR4  *R7               FILE WAS NOT DELETED
         BAL,SR4  CLOSEI            GO CLOSE
         PLW,SR4  *R7
         MTW,0    DELETEF           REVIEW COMMAND
         BEZ      ALL2              NO
         CAL1,1   FPTSET2           RESET ERR AND ABN ADR
         B        ALL2              GO PRINT MESSAGE
RAND1    EQU      %
         LI,D2    0                 FILE WAS DELETED
         STW,R0   IOERR,R7          ZERO ERROR FLAGS
         LW,R1    CMBX,R7
         AI,R1    -CMBXDIFF-1
         LI,R2    X'40'
         STB,R2   *R7,R1            REMOVE % POINTER
         MTW,0    DELETEF
         BEZ      0,R6              NOT REVIEW COMMAND
         CAL1,1   FPTSET2           RESET ERR AND ABN ADR
         B        0,R6
         USECT    PLSECT
OPNTRY   GEN,8,24 X'14',M:EI
         DATA     0
FPTNFILE GEN,8,7,17      X'91',0,R3
         DATA     X'34000010'
         PZE      *D3               BUFFER ADDRESS
         PZE      *R2               SIZE
         DATA     1
         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    8                 INOUT,INPUT
         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
         DO1      VERSION=2
         CAL1,1   OPENPR            REMOVE PASSWORD
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

