         TITLE    'PCLUT - UTITILTY,DEV/FIL TRAN, FIX/GET/INT/TEXT ARG'
*
*        T E L E F I L E   P R O P R I E T A R Y   P R O D U C T
*
*        THIS DOCUMENT INCLUDES DATA AND INFORMATION CONSIDERED
*        PROPRIETARY TO TELEFILE COMPUTER PRODUCTS, INC.  REPRODUCTION,
*        DUPLICATION, DISCLOSURE OR DISSEMINATION, IN WHOLE OR IN PART,
*        TO OTHERS THAN REPRESENTATIVES OF THE UNITED STATES GOVERNMENT
*        SHALL NOT BE MADE WITHOUT PRIOR WRITTEN AUTHORIZATION OF
*        TELEFILE COMPUTER PRODUCTS, INC. NOTWITHSTANDING THE FORGOING,
*        USE OF THE DATA OR INFORMATION IN WHOLE OR IN PART FOR DESIGN,
*        PROCUREMENT OF MANUFACTURE IS STRICTLY FORBIDDEN.
*
*M*      UTILITY    MISC. ROUTINES FOR PCL
R0       EQU      0
R1       EQU      1
R2       EQU      2
R3       EQU      3
R4       EQU      4
R5       EQU      5
R6       EQU      6
R7       EQU      7
R8       EQU      8
R9       EQU      9
R10      EQU      10
R11      EQU      11
R12      EQU      12
R13      EQU      13
R14      EQU      14
R15      EQU      15
UTIL     DSECT    1
PLSECT   CSECT    1
         SYSTEM   SIG7
*
         DEF      BCD2BIN           XLATOR
         DEF      BIN2BCD           XLATOR
         DEF      CLOSEI            CLOSE DCB
         DEF      CLOSEO            CLOSE DCB
         DEF      HEX2BIN
         DEF      HEX2BCD           XLATOR
         DEF      MBS               DATA MOVER
         DEF      CLRARG            RESET ARGTBL
         DEF      REVARG            SWITCH ARGTBL/TOARG
         DEF      SIXBACK           XLATOR
         DEF      PRTNOF
         DEF      UNPRINT
         DEF      SIXPACK
*
         REF      M:EI,M:EO         DCBS
         REF      TOARG             OTHER ARGTBL
         REF      ARGTBL            PERIPHERAL DESCRIPTION
         REF      LCCHARS
         REF      LISTPOS           IF DOING NO UPSPACE STUFF, UPSPACE
         REF      LOSPACE           SEE LISTPOS
         REF      PRTBUF,J:JIT,M:UC,M:LO
         REF      BOG
         REF      M:EISN            EI SNS
         REF      INSER             INPUT CURRENT SERIAL#
         REF      M:EOSN            OUT SNS
         REF      OUTSER            CURRENT OUTPUT SERIAL#
         REF      CCTAB
         PAGE
*
*
*P*      NAME:    BCD2BIN
*P*
*P*      ENTRY:   HEX2BIN
*P*
*P*      PURPOSE: TO CONVERT A STRING OF EBCDIC DECIMAL(BCD2BIN)  OR
*P*               HEXADECIMAL(HEX2BIN) CHARACTERS
*P*               TO A BINARY VALUE.
*P*
*DO*
*P*
*
* INPUT
*        R1       BYTE INDEX OF ARGUMENT (USER STORAGE)
*        R2       NO. OF CHARACTERS IN ARGUMENT
* OUTPUT
*        R1       BYTE INDEX OF TERMINATING CHARACTER (USER STORAGE)
*        R2       NO OF UNCONVERTED CHARACTERS REMAINING IN ARGUMENT
*        R3       BINARY INTEGER
*        R4       TYPE OF RETURN (0-NORMAL,1-NON-NUMERIC,2-OVERFLOW)
*
*FIN*
*
         USECT    UTIL
HEX2BIN  LI,R4    100               FLAG FOR SWITCH
         LI,R1    ARGBUF4+1
         LW,R2    NCHAR,R7
         B        %+2
BCD2BIN  LI,R4    -100
         PSW,R5   *R7               SAVE R5
         LI,R5    0
         CI,R2    0                 TEST FOR NULL ARGUMENT
         BE       BCD2BIN4-1
*
BCD2BIN1 LB,R3    *R7,R1            GET NEXT CHARACTER
         CLM,R3   BCD2BIN5          TEST FOR NUMERIC (0-9)
         BCR,9    BCD2BIN2
         BIR,R4   %+3
         CLM,R3   HEX2BIN4          CHECK FOR A-F
         BCR,9    HEX2BIN1
         LI,R4    1                 FLAG NON-NUMERIC CHARACTER RETURN
         B        BCD2BIN4
*
HEX2BIN1 AI,R3    -'A'+10+'0'
BCD2BIN2 AI,R3    -'0'
         BIR,R4   BCD2BIN6
         LC       R5                CAN WE ADD ANOTHER CHAR
         BCS,15   HEX2BIN2          NO
         SLS,R5   4
         B        %+3
BCD2BIN6 MI,R5    10
         BDP      %+3
         AW,R5    R3                ADD CURRENT DIGIT
         BNOV     BCD2BIN3
HEX2BIN2 LI,R4    2                 FLAG OVERFLOW RETURN
         B        BCD2BIN4
*
BCD2BIN3 AI,R1    1                 TEST FOR END OF ARGUMENT
         BDR,R2   BCD2BIN1
         LI,R4    0                 FLAG NORMAL RETURN
*
BCD2BIN4 LW,R3    R5                STORE SUM
         PLW,R5   *R7               RESTORE REGISTERS
         CI,R4    1                 TEST RESULT FOR RETURN
         B        *R11
*
         BOUND    8
BCD2BIN5 DATA     X'F0',X'F9'
HEX2BIN4 DATA     'A','F'
         PAGE
*
*
*P*      NAME:    BIN2BCD
*P*
*P*      PURPOSE: TO CONVERT A BINARY VALUE TO AN EIGHT-CHARACTER
*P*               EBCDIC DECIMAL INTEGER WITH LEADING BLANKS.
*P*
*DO*
*P*
*
* INPUT
*        R1       POSITIVE BINARY INTEGER
* OUTPUT
*        R1       BINARY INTEGER / 100 000,000
*        R2,R3    BCD INTEGER (RIGHT JUSTIFIED, BLANK FILLED)
*        R4       NUMBER OF NON-BLANK CHARACTERS IN RESULT
*
*FIN*
*
BIN2BCD  PSW,R5   *R7               SAVE REGISTERS
*
         LW,R4    ='    '           INITIALIZE
         LW,R5    ='    '
         INT,R2   R1
         STH,R2   R3
         LI,R1    7
         B        BIN2BCD2
*
BIN2BCD1 CI,R3    0                 TEST FOR END OF INTEGER
         BE       BIN2BCD3
*
BIN2BCD2 LI,R2    0                 GET NEXT BCD INTEGER
         DW,R2    =10
         AI,R2    X'F0'
*
         STB,R2   R4,R1             STORE INTEGER
         AI,R1    -1
         BGE      BIN2BCD1
*
BIN2BCD3 LW,R2    R4                ORDER OUTPUT ARGUMENTS
         LCW,R4   R1
         AI,R4    7
         LW,R1    R3
         LW,R3    R5
*
         PLW,R5   *R7               RESTORE REGISTERS
         B        *R11
*
         PAGE
*
*P*      NAME:    CLOSEI
*P*
*P*      PURPOSE: TO CLOSE THE M:EI DCB IF IT IS OPEN.
*P*
*
*
CLOSEI   LW,R1    M:EI
         CW,R1    =X'00200000'
         BAZ      *R11
         CAL1,1   CLSEI
*
         USECT    PLSECT
CLSEI    GEN,8,7,17      X'15',0,M:EI
         DATA     0
*
         USECT    UTIL
         CI,R1    2                 ONLY REMEMBER FOR NON-FILES
         BAZ      *R11
         LW,R1    M:EISN-1          ANY SNS IN DCB
         CI,R1    X'FF00'
         BAZ      *R11
         LB,R1    M:EI+11           CURRENT VOLUME#
         BE       *R11
         LW,R1    M:EISN-1,R1
         STW,R1   INSER             SAVE SN FOR AUTO VOL ON OPEN
         B        *R11
         PAGE
*
*
*P*      NAME:    CLOSEO
*P*
*P*      PURPOSE: TO CLOSE THE M:EO DCB IF IT IS OPEN.
*P*
*
*
CLOSEO   LW,R1    M:EO
         CW,R1    =X'00200000'
         BAZ      *R11
         CAL1,1   CLSEO
*
         USECT    PLSECT
CLSEO    GEN,8,7,17      X'15',0,M:EO
         DATA     X'80000000'
         DATA     2                 SAVE
*
         USECT    UTIL
         CI,R1    2                 ONLY REMEMBER FOR NON-FILES
         BAZ      *R11
         LW,R1    M:EOSN-1          ANY SNS IN DCB
         CI,R1    X'FF00'
         BAZ      *R11
         LB,R1    M:EO+11           CURRENT VOLUME#
         BE       *R11
         LW,R1    M:EOSN-1,R1
         STW,R1   OUTSER            SAVE SN FOR AUTO VOL ON OPEN
         B        *R11
         PAGE
*
*
*P*      NAME:    CLRARG
*P*
*P*      PURPOSE: TO ZERO THE ARGUMENT TABLE ARGTBL.
*P*
*
*
CLRARG   LI,R1    16
         LW,R2    R7
         STW,R0   ARGTBL+15,R2      CLEAR FROM TOP DOWN
         AI,R2    -1                SO ENTRY AT +1 CAN CLEAR MORE
         BDR,R1   %-2
         MTW,3    DEVICE,R7         MAKE DC THE DEFAULT
         B        *R11              RETURN
         PAGE
*
*
*P*      NAME:    HEX2BCD
*P*
*P*      PURPOSE: TO CONVERT A WORD IN HEXADECIMAL TO A TWO-WORD BCD
*P*               EQUIVALENT.
*P*
*DO*
*P*
*
* INPUT
*        R1       HEXADECIMAL WORD (BINARY)
* OUTPUT
*        R2,R3    BCD EQUIVALENT OF HEX WORD
*
*
*FIN*
HEX2BCD  PSW,R5   *R7               SAVE REGISTERS
*
         LI,R5    7                 INITIALIZE
*
HEX2BCD1 LI,R4    X'F'              GET HEX DIGIT (BINARY)
         AND,R4   R1
         AI,R4    X'B7'             CALCULATE EBCDIC EQUIVALENT
         CI,R4    X'C0'
         BG       HEX2BCD2
         AI,R4    X'39'
*
HEX2BCD2 STB,R4   R2,R5             STORE EBCDIC VALUE
         SCS,R1   -4
         AI,R5    -1                TEST FOR END OF WORD
         BGE      HEX2BCD1
*
         PLW,R5   *R7               RESTORE REGISTERS
         B        *R11
         PAGE
*
*
*P*      NAME:    MBS
*P*
*P*      PURPOSE: TO MOVE A BYTE STRING OF ANY LENGTH.
*P*
*DO*
*P*
*
* INPUT
*        R1       NO. OF BYTES TO BE MOVED
*        R2       SOURCE BYTE INDEX
*        R3       DESTINATION BYTE INDEX
*
*
*FIN*
MBS      LB,R4    *R7,R2            MOVE BYTE STRING
         STB,R4   *R7,R3
         AI,R2    1
         AI,R3    1
         BDR,R1   MBS
         B        *R11
         PAGE
*
*
*P*      NAME:    REVARG
*P*
*P*      PURPOSE: TO BRING UP THE INPUT OR OUTPUT ARGUMENTS FOR ACCESS
*P*               BY EXCHANGING THE FIRST 15 WORDS OF ARGBUF AND TOARG.
*P*
*DO*
*P*
*
* INPUT
*        TOARG    OUTPUT ARGUMENT TABLE
*        ARGTBL   INPUT ARGUMENT TABLE
*
*
*FIN*
REVARG   LI,R1    16
         LW,R2    R7
KGCA%5   LW,R3    TOARG,R2          REVERSE TABLES
         LW,R4    ARGTBL,R2
         STW,R3   ARGTBL,R2
         STW,R4   TOARG,R2
         AI,R2    1
         BDR,R1   KGCA%5
         B        *R11              RETURN
         PAGE
*P*      NAME:    PRTNOF
*P*      PURPOSE: GENERATES A MESSAGE WITH UP TO 4
*P*               DECIMAL NUMBERS IN IT. THEY GET PUT
*P*               ON TOP OF % CHARS IN THE CALLER-SUPPLIED MESSAGE,
*P*      INPUT:   R8-R9   = INPUT HALFWORD NUMBERS..USED RIGHT TO LEFT
*P*               AND DESTROYED.
*P*               R5 = POINTER TO SKELETON MESSAGE (TEXT FORM)
*P*               R11 = RETURN
*P*               NO MESSAGE IS OUTPUT IF R9 IS ZERO
PRTNOF   CAL1,1   LONOVFC
         LW,R1    R9                NO. OF FILES
         BE       *R11              NONE, NO MESSAGE
         PSW,R11  *R7               SAVE RETURN
         PSW,R6   *R7
         ANLZ,R6  PRTBUFI7
         SLS,R6   2                 BA(OUTPUT BUFFER)
         SLS,R5   2                 BA(INPUT MESSAGE)
PRTN1    AI,R1    0                 ARE WE SKIPPING
         BE       %+2               YES
         AI,R6    1
PRTN2    LB,R2    0,R5              MOVE TEXT PART OF MESSAGE
         STB,R2   0,R6
         AI,R5    1
         CI,R2    X'15'             IS THIS END OF MESSAGE
         BLE      PRTN9             YES
         CI,R2    '%'               IS THIS PLACE FOR NEXT NUMBER
         BNE      PRTN1             NO
         LI,R1    X'FFFF'           GET NEXT ONE
         AND,R1   R9
         SLD,R8   -16               SHIFT FOR ITERATION
         BE       PRTN2             NOTHING HERE
         LB,R2    0,R5              IF DOUBLE % USE FULL WORD
         CI,R2    '%'
         BNE      KGC%5
         STH,R9   R1
         SCS,R1   16
         SLD,R8   -16
         AI,R5    1
KGC%5    BAL,R11  BIN2BCD           CONVERT TO BCD
         LCW,R4   R4
         LB,R1    R4,R4             MOVE INTO MESSAGE
         STB,R1   0,R6
         AI,R6    1
         BIR,R4   %-3
         B        PRTN2
*
PRTN9    ANLZ,R4  PRTBUFI7          BUFFER ADDRESS
         STB,R2   0,R6              REMOVE PUNCTIATION FROM
         AI,R6    -1                END OF MESSAGE
         LC       0,R6
         BCR,8    %-3
         SLS,R4   2                 GET SIZE OF MESSAGE
         SW,R6    R4
         SLS,R4   -2
         LI,R1    0
         XW,R1    LISTPOS
         BE       %+2
         CAL1,1   LOSPACE
         LI,R1    M:LO
         LC       BOG
         BCR,12   PRTNOF2           BRANCH IF BATCH
         CI,R12   5                 IS THIS A LIST
         BNE      PRTNOF1           NO
         LI,R3    X'6F00'           IS M:LO A TERMINAL TOO
         CW,R3    M:LO+1
         BAZ      PRTNOF1           YES
         CAL1,1   FPTDEL            PRINT MESSAGE ON LO
PRTNOF1  LI,R1    M:UC
         AI,R6    1
PRTNOF2  CAL1,1   FPTDEL            WRITE MESSAGE
*
         USECT    PLSECT
FPTDEL   GEN,8,7,17      X'91',0,R1
         DATA     X'34000010'
         PZE      *R4               BUFFER
         PZE      *R6               SIZE
         DATA     1                 BTD
PRTBUFI7 MTW,0    PRTBUF,R7         FOR ANLZ INSTRUCTION
LONOVFC  GEN,8,24 5,M:LO
         DATA     0
*
         USECT    UTIL
         PLW,R6   *R7
         PLW,R11  *R7               RESTORE LINK REGISTER
         B        *R11              RETURN
         PAGE
*
*
*P*      NAME:    UNPRINT
*P*
*P*      PURPOSE: TO TEST AN ARGUMENT FOR UNPRINTABLE CHARACTERS
*P*               AND, IF FOUND, ENTER ARGUMENT IN THE BUFFER AS A
*P*               HEXDECIMAL STRING INSTEAD OF A CHARACTER STRING.
*P*
*DO*
*P*
*
* INPUT
*        R1       POINTER TO ARGUMENT IN TEXTC FORMAT
*        R14      BUFFER POINTER
* OUTPUT
*        R2       NUMBER OF CHARACTERS MOVED TO BUFFER
*        R14      BUFFER POINTER (SAME AS ON ENTRY)
*
*
*FIN*
UNPRINT  LCI      6
         PSM,R3   *R7               SAVE REGISTERS
         LB,R3    *R1               GET ARGUMENT LENGTH
         BE       UNPX              NOTHING TO PRINT
         LW,R5    R14               GEN BYTE ADDRESS
         SCS,R5   2
         AW,R5    R3
UNP2     LB,R4    *R1,R3            MOVE ARGUMENT TO BUFFER
         STB,R4   0,R5
         AI,R5    -1
         LI,R2    1
         SCS,R2   0,R4
         SLS,R4   -5
         CW,R2    CCTAB,R4
         BAZ      UNP1              NOT PRINTABLE
         BDR,R3   UNP2
UNPX     LB,R2    *R1               NO. CHARS MOVED
UNP0     LCI      6
         PLM,R3   *R7
         B        *R11              EXIT
UNP1     LB,R3    *R1
         SLS,R3   1                 NO. OF HEX CHARS
         AI,R3    3                 TOTAL CHARS TO PRINT
         LW,R2    R3
         LW,R5    R14
         SCS,R5   2
         AW,R3    R5
         AI,R5    1
         LI,R4    'X'
         STB,R4   0,R5
         LI,R4    ''''
         AI,R5    1
         STB,R4   0,R5
         STB,R4   0,R3
         LB,R5    *R1               NO. CHARS IN ARGUMENT
UNP3     LI,R6    2
         LB,R4    *R1,R5            GET CHARACTER
UNP4     LI,R8    X'F'
         AND,R8   R4                GET HEX DIGIT
         AI,R8    X'B7'             CALCULATE EBCDIC EQUIVALENT
         CI,R8    X'C0'
         BG       %+2
         AI,R8    X'39'
         AI,R3    -1
         STB,R8   0,R3
         SLS,R4   -4
         BDR,R6   UNP4
         BDR,R5   UNP3
         B        UNP0
         PAGE
*
*
*P*      NAME:    SIXPACK
*P*
*P*      PURPOSE: TO HASH A SIX-CHARACTER ANS TAPE SERIAL NUMBER
*P*               INTO ONE WORD.  THIS ROUTINE IS USED ONLY IN CPV.
*P*
*P*
*DO*
*P*
*INPUT: R1 CONTAINS BYTE ADDRESS OF SERIAL NUMBER
*OUTPUT: R2 CONTAINS HASHED RESULT
*ENTRY:  BAL,R11 SIXPACK
*
*FIN*
SIXPACK  LCI      2
         PSM,R5   *R7
         LI,R5    0
         LI,R4    6
SIXPACK1 LB,R3    0,R1
         AI,R1    1
         SLS,R3   26
KGCB%5   SLD,R2   2
         SLS,R3   -28
         CI,R3    9                 CHECK FOR SPECIAL CHARACTER
         BLE      %+3
         SLS,R2   -2                CHANGE TO BLANK
         B        KGCB%5
         MI,R5    10
         AW,R5    R3
         BDR,R4   SIXPACK1
         SLS,R2   20
         OR,R2    R5
         LCI      2
         PLM,R5   *R7
         B        *R11
         PAGE
*
*P*      NAME: SIXBACK
*P*      PURPOSE: TO CONVERT SIXPACKED SERIAL# BACK TO EBCDIC.
*P*      CALL: R2 IS PACKED SN, R2-R3 IS RETURNED TEXT, BLANK PADDED
*P*               R11 IS LINK.
*
SIXBACK  LCI      7
         PSM,R4   *R7
         SLD,R2   -20
         SLS,R3   -12
         LW,R5    R3
         LW,R8    ='    '
         LI,R6    6
SIXBACK1 LI,R4    0
         DW,R4    =10
         SLD,R2   -2
         SLS,R3   -26
         OR,R3    R4
         BE       %+2
         AI,R3    X'80'
         AI,R3    X'40'
         SLD,R8   -8
         STB,R3   R8
         BDR,R6   SIXBACK1
         LD,R2    R8
         LCI      7
         PLM,R4   *R7
         B        *R11
         PAGE     'DEVTRAN'
DEVTRAN  DSECT    1
*
*P*      NAME:    DEVTRAN
*P*
*P*
*P*      PURPOSE: TO TRANSLATE A DEVICE SPECIFICATION OF A PCL
*P*               COMMAND.
*DO*
*P*
*
* INPUT
*        CMBX     COMMAND BUFFER INDEX OF NEXT ARGUMENT
*        TERM     TERMINATOR OF CURRENT ARGUMENT
* OUTPUT
*        DEVICE   +0    DEVICE ID CODE
*                 +1    NUMBER OF REEL NO.S
*                 +2    COMMAND BUFFER INDEX OF FIRST REEL NO.
*
*
*FIN*
         REF      ERROR
         REF      CMBX,TERM,DEVICE
         REF      FILE
         REF      ARGBUFF
         REF      MAXSN             UNUSED - KGC
         REF      OV:NMSZ,OH:NM
         REF      IN%ARG
         REF      OUT%ARG
         REF      ARGBUF4
         REF      NCHAR
         REF      MAXCMBX
         REF      LTSTCMBX
         REF      MODE
         REF      DEL%CT
*
         LCI      7                 SAVE REGISTERS
         PSM,R5   *R7
         LW,R6    TERM,R7
         LI,R1    17                NEVER SHOULD BE HERE FROM ( OR )
         CI,R6    '('
         BE       %+3
         CI,R6    ')'
         BNE      %+2
         BAL,R11  ERROR
         LI,R1    3                 SET FOR DC DEFAULT
         CI,R6    '.'               ACCOUNT WITHOUT DC
         BE       DEV2              YES, SET DC, GET ACCOUNT
         CI,R6    '/'               FILENAME WITHOUT DC
         BE       DEV2              YES, SET DC.
         CI,R6    ','               START OF RANGE
         BE       DEV2              YES
         LI,R1    6                 NOW FT DEFAULT
         CW,R1    DEVICE,R7         SN WITHOUT FT ONLY IF
         BNE      %+3               DEFAULT IS FT (NOT DC)
         CI,R6    '#'               IS IT SN WITHOUT FT
         BE       DEV2              YEP.
         CI,R6    '#'               IF # OR - DELIMITER,
         BE       %+2
         CI,R6    '-'               AND DEFAULT DC, IS PART OF FILE NAME
         BNE      %+2
         MTW,-1   CMBX,R7           SO USE IT THERE
         LW,R6    CMBX,R7
         LI,R1    6
         BAL,R11  GETARG            GET DEV  ARGUMENT
         LW,R1    =X'02000000'+DEVTBL   EDIT DEVICE CODE
         BAL,R11  FIXARG
DEV2     STW,R1   DEVICE,R7         STORE DEVICE ID CODE
         LW,R1    CMBX,R7           SAVE END FOR ERROR MESSAGES
         STW,R1   DEVICE+2,R7       FROM BLDCB
         STW,R0   DEVICE+1,R7       CLEAR SN COUNT
         B        ENDDEV
*
REELNO   LI,R1    X'40006'          SN ARGS..# - 'XX'
         BAL,R11  GETARG
         LW,R1    =X'3000104'
         LW,R2    DEVICE,R7
         CI,R2    7                 TEST IF ANS TAPE
         BNE      %+2               NO
         AI,R1    2                 MAX 6 CHAR FOR ANS
         BAL,R11  TEXTARG
         MTW,1    DEVICE+1,R7       COUNT IT
*
ENDDEV   LW,R1    TERM,R7           TEST FOR TERMINATION ON NO. SIGN
         CI,R1    '#'
         BE       REELNO            ANOTHER SERIAL NUMBER HERE
         CI,R1    '-'               DOES DEVICE TYPE FOLLOW?
         BNE      ENDDEV3K          NO
         LI,R1    6                 ARGUMENT DELIMITERS
         BAL,R11  GETARG
         LI,R2    0
         LW,R3    ARGBUFF,R7        GET ARGUMENT FROM BUFFER.
         SLD,R2   8                 ISOLATE LENGTH.
         AI,R2    -2
         BNE      ERR34
         SLS,R3   -16
         CI,R3    '7T'
         BNE      %+3               NOT 7T
         LI,R1    3
         STW,R1   MODE+1,R7         ENTER CODE FOR 7T IN ARGTBLE
         LI,R1    OUT%ARG           ASSUME OUT
         CI,R12   1
         BE       %+2               OUTPUT DEVICE.
         LI,R1    IN%ARG            INPUT
         STW,R3   *R1,R7
         B        ENDDEV3G
ERR34    LI,R1    34
         BAL,R11  ERROR
ENDDEV3G LW,R1    TERM,R7
ENDDEV3K CI,R1    X'4B'             TEST FOR TERMINATION ON PERIOD
         BNE      RETURN
         BAL,R11  FILTRAN           SCAN ACCT,PSWD
RETURN   LCI      7                 RESTORE REGISTERS
         PLM,R5   *R7
         CI,R2    1                 TEST RESULT OF INTARG CALL
         B        *R11
*
DEVTBL   DATA     11                DEVICE CODE TABLE
         TEXTC    'CR'
         TEXTC    'PR'
         TEXTC    'DC'
         TEXTC    'LT'
         TEXTC    'DP'
         TEXTC    'FT'
         TEXTC    'AT'
         TEXTC    'ME'
         TEXTC    'LP'
         TEXTC    'CP'
         TEXTC    'PP'
         PAGE     'FILTRAN'
FILTRAN  DSECT    1
*
*P*      NAME:    FILTRAN
*P*
*P*
*P*      PURPOSE: TO TRANSLATE THE NAME, ACCOUNT, AND PASSWORD FIELDS
*P*               OF A FILE ID IN A COMMAND.
*P*
*DO*
*P*
*
* INPUT
*        CMBX     COMMAND BUFFER INDEX OF NEXT ARGUMENT
*        TERM     TERMINATOR OF CURRENT ARGUMENT
* OUTPUT
*        FILE     +0    FIL ID COUNT (1-N,2-N,A,3-N,A,P)
*                 +1    COMMAND BUFFER INDEX OF FILE NAME
*
*
*FIN*
*
         LCI      7                 SAVE REGISTERS
         PSM,R5   *R7
         LI,R5    1                 INITIALIZE
         LW,R6    CMBX,R7
         CI,R11   RETURN            IF CALLED FROM DEVTRAN
         BNE      NEXTARG
         BDR,R6   NEXT2             AT THE '.', DONT GET FILE NAME
*
NEXTARG  LI,R1    12
         BAL,R11  GETARG            GET NEXT ARGUMENT
         CI,R13   1
         BG       NEXT2             ERROR REPORTED BY GETARG
         LW,R4    R5                SAVE PARAMETER COUNT
         LW,R3    DEVICE,R7
         CI,R3    7                 TEST IF ANS TAPE
         BNE      %+2               NO
         AI,R4    3                 SELECT 3RD EDIT TABLE
         LW,R1    EDITCNST-1,R4     EDIT FILE ID PARAMETER
         BAL,R11  TEXTARG
*
NEXT2    LW,R1    TERM,R7
         CI,R1    '.'               ACCT NO. OR PASS WORD PRESENT
         BNE      STORE
         LW,R3    DEVICE,R7         RESTORE DEVICE CODE.
         CI,R3    7                 IS DEVICE ANS TAPE
         BE       ERR7              YES-ERROR
         CI,R5    3                 CHECK FOR MAXIMUM PARAMETER COUNT
         BE       ERR7
         AI,R5    1                 INCREMENT PARAMETER COUNT
         B        NEXTARG
ERR7     LI,R1    7                 ERROR 07
         BAL,R11  ERROR
         B        NEXTARG
*
STORE    STW,R5   FILE,R7           STORE PARAMETER COUNT
         STW,R6   FILE+1,R7         STORE CMBX OF FILE NAME
         B        RETURN
*
EDITCNST DATA     X'0400011F'       NAME
         DATA     X'05000008'       ACCOUNT
         DATA     X'06000108'       PASSWORD
         DATA     X'04000111'       ANS NAME
         PAGE     'FIXARG'
*
*P*      NAME:    FIXARG
*P*
*P*      PURPOSE: TO LOOK UP AN ARGUMENT IN A TABLE AND RETURN WITH THE
*P*               INDEX OF THE ARGUMENT AS AN ID.
*P*
*DO*
*P*
*
* INPUT
*
*        R1       0-7    ERROR CODE DESIRED
*                 15-31  TABLE ADDRESS
*        ARGBUFF  ARGUMENT STORAGE BUFFER
*
* OUTPUT
*
*        R1       ARGUMENT ID CODE (INDEX)
*
*
*FIN*
*
FIXARG   DSECT    1
*
         LW,R2    R1                SAVE INPUT
         LW,R1    *R2               GET MAX. TABLE INDEX
*
         LW,R3    ARGBUFF,R7        SEARCH TABLE FOR MATCH
         CW,R3    *R2,R1
         BE       %+2
         BDR,R1   %-2
         CW,R2    =X'02000000'+DEVTBL  IS DEVICE BEING
         BNE      ERR               NO.
         MTB,-2   R3                MAKE HW TABLE LOOKUP VALUE
         BG       %+3               TWO CHARS MAX
         SLS,R3   8
         SAS,R3   -16
         MTB,0    J:JIT             IF ME IN BATCH
         BNE      FIXA1             FIX IT
         CI,R3    'ME'-X'10000'
         BNE      FIXA1
         CI,R12   1                 ME IS CR OR LP IN BATCH
         BNE      %+2
         LI,R1    9                 HAD TO BE EIGHT IF 'ME'
         LH,R3    GUDOPL-4,R1
         LB,R1    GUDDEV-2,R1
FIXA1    AI,R1    0                 IF WEVE GOT A CODE, JUST STORE TYPE
         BNE      ST%DCB
         LW,R1    TERM,R7           TEST IF TERM IS #.
         CI,R1    '#'
         BE       CK%DEVO           OR DASH, WHICH
         CI,R1    '-'               MAKES A FILE NAME
         BE       CK%DEVO           YES--DO NOT CHECK.
*                                   SYSTEM TABLE.
         LI,R1    OV:NMSZ           DEVICE IN SYSTEM TABLE.
CMP%NXT  CH,R3    OH:NM,R1
         BE       %+3
         BDR,R1   CMP%NXT
         B        CK%DEVO
         LI,R1    0
ST%DCB   CB,R3    TXTT              IF XT, ITS PROBABLY A TAPE
         BNE      %+2               AND ZERO IS THE RESOURCE TYPE
         LI,R3    0
         STH,R0   R3                CLEAR SIGN BITS
         CI,R12   1
         BE       ST%OUT
         STW,R3   IN%ARG,R7         SAVE INPUT ARGUMENT
         LI,R2    1                 TRY INPUT OPEN
         B        %+3
ST%OUT   LI,R2    2                 TRY OUTPUT OPEN
         STW,R3   OUT%ARG,R7
         AI,R1    0                 IF WEVE GOT A CODE, RETURN
         BNE      *R11
         CAL1,1   OPN%DEV
         CAL1,1   CLS%DEV
DEV%ABN  LI,R3    X'7F00'           GET DEVICE TYPE FROM DCB
         AND,R3   M:DEV+1
         LI,R1    9                 SET LP IF LISTING DEVICE
         CI,R3    X'4000'
         BANZ     *R11
         SLS,R3   -8
         LH,R3    OH:NM,R3
         LH,R1    DEVTYPES
         CH,R3    DEVTYPES,R1
         BE       %+2
         BDR,R1   %-2
         LB,R1    PCLTYPES,R1
         BNE      *R11
         CI,R3    X'FD5D6'          ANYTHING BUT NO DEVICE IS OK
         BE       CK%DEVO0
         LB,R1    DFDV,R2
         B        *R11
DFDV     DATA     X'20B00'          PR-INPUT, PP-OUTPUT
CK%DEVO0 LW,R2    =X'02000000'+DEVTBL RESTORE ERR CODE
CK%DEVO  LW,R1    DEVICE,R7         IF DEFAULT DC, DEVICE CODE
         CI,R1    3                 IS OPTIONAL
         BNE      ERR+2
         STW,R6   CMBX,R7           TREAT AS DC/ MISSING
         LI,R2    '/'
         STW,R2   TERM,R7
         LI,R3    0                 NO DEVTYPE FOR DEFAULT DC
         B        ST%DCB
TXTT     TEXT     'T'
GUDOPL   TEXT     'CRLP'
GUDDEV   DATA     X'1090000'
*
ERR      AI,R1    0
         BNE      *R11
         LB,R1    R2                SET GIVEN ERROR CODE
         BE       *R11
         PSW,R11  *R7               SAVE RETURN
         BAL,R11  ERROR
         LI,R1    0                 CLEAR ID CODE
         PLW,R11  *R7
         B        *R11
OPN%DEV  GEN,8,24 20,M:DEV
         DATA     X'1040000',X'80000002',X'80000003'
CLS%DEV  GEN,8,24 21,M:DEV
         DATA     0
DEVTYPES GEN,16,16 HA(PCLTYPES)-HA(%),'CR'
         TEXT     'PRDC9TDP7TMELPCPPP'
PCLTYPES DATA     X'10203'          CR,PR,DC
         DATA     X'6050608'        9T,DP,7T,ME
         DATA     X'90A0B00'        LP,CP,PP
M:DEV    DSECT    1
         DATA     X'8003',0,0,DEV%ABN,DEV%ABN
         DO1      17
         DATA     0
         PAGE     'GETARG'
*P*      NAME:    GETARG
*P*
*P*      PURPOSE: TO EXTRACT THE NEXT ARGUMENT FROM THE COMMAND BUFFER
*P*               AND PLACE IT IN TEXTC FORMAT IN THE ARGUMENT BUFFER.
*P*
*DO*
*P*
* GET ARGUMENT
*
* INPUT
*
*        CMBX     COMMAND BUFFER INDEX FOR CURRENT ARGUMENT
*        MAXCMBX  MAXIMUM COMMAND BUFFER INDEX
*
* OUTPUT
*
*        LTSTCMBX BUFFER INDEX OF START OF ARGUMENT
*        CMBX     COMMAND BUFFER INDEX FOR NEXT ARGUMENT
*        ARGBUFF  ARGUMENT BUFFER
*        TERM     TERMINATION CHARACTER
*        NCHAR    NUMBER OF CHARACTERS IN ARGUMENT BUFFER
*
*
*FIN*
GETARG   DSECT    1
         LCI      7                 SAVE REGISTERS
         PSM,R5   *R7
         LW,R15   R1                SET DELIMITER SET
         LW,R6    CMBX,R7           GET COMMAND BUFFER INDEX
         STW,R6   LTSTCMBX
         LI,R5    ARGBUF4+1         INITIALIZE -ARGBUF- INDEX
         LI,R8    0                 TURN OFF BLANK DELIMITER SWITCH
         LI,R9    0                 TURN OFF IGNORE CHARACTER SWITCH
         LI,R10   0                 TURN OFF CHAR STRING IND
         LI,R1    8
         LW,R2    ='    '
         LI,R3    ARGBUFF-1
         AW,R3    R7
         STW,R2   *R3,R1
         BDR,R1   %-1
P5       CW,R6    MAXCMBX,R7        TEST FOR MAXIMUM COMMAND INDEX
         BL       P10
P7       CI,R15   16                IF SCANNING CHAR STR,, MISSING QUOTE
         BAZ      %+3
         LI,R1    17
         BAL,R11  ERROR
         LI,R4    X'15'             SET END OF COMMAND
         B        RETURN2
*
P10      LB,R4    *R7,R6            GET NEXT CHARACTER
         AI,R6    1                 INCREMENT COMMAND BUFFER INDEX
         STW,R6   CMBX,R7           UPDATE CMBX FOR ERROR MESSAGE
         CI,R15   X'10'             ARE WE SCANNING A CHARACTER STR
         BANZ     P15               YES, NO BLANK TESTING
         CI,R4    X'15'
         BE       RETURN2           STOP ON CR IN BATCH
         CI,R4    X'0D'
         BE       P7
*
         CI,R4    X'40'             TEST FOR BLANK
         BNE      P11               SIGNIFICANT CHARACTER.
         CI,R12   3                 CHECK FOR DELETE COMMAND.
         BNE      P12               NOT DELETE.
         MTW,1    DEL%CT,R7         UPDATE DELETE BLANK COUNT.
         B        P12
P11      CI,R12   3                 CHECK IF DELETE COMMAND.
         BNE      P11A              NO
         LI,R1    0
         XW,R1    DEL%CT,R7         CHECK DELETE COMMAND FOR BLANKS.
         CI,R1    1
         BLE      P11A
         LI,R1    55
         BAL,R11  ERROR
         B        RETURN
P11A     CI,R4    X'05'             TEST FOR TAB CHARACTER
         BNE      P15
         LI,R4    X'40'             CHANGE TAB TO BLANK
P12      CI,R8    0                 TEST BLANK DELIMITER SWITCH
         BE       P5
         LI,R8    0                 TURN OFF BLANK DELIMITER SWITCH
         LI,R9    1                 TURN ON IGNORE CHARACTER SWITCH
         B        P5
*
P15      LW,R2    R4                GET DELIMITER FLAG FOR CHARACTER
         LI,R3    0
         SLD,R2   -5
         SLS,R3   -27
         AW,R2    R15               SELECT DELIMITER TABLE
         LW,R1    DELIMIT,R2
         SLS,R1   0,R3
         CI,R1    0                 TEST FOR DELIMITER
         BL       RETURN1
         CI,R9    0                 TEST IGNORE CHARACTER SWITCH
         BE       P20
P18      LI,R4    X'40'             SET DELIMITER TO BLANK
         AI,R6    -1                DECREMENT COMMAND BUFFER INDEX
         B        RETURN2
*
P19      AI,R6    1
P20      AI,R15   0                 IF R15 NEGATIVE, MUST HAVE DELIMITER
         BGE      P22
         LI,R1    17                NO CAN FIGURE OUT THIS ONE
         BAL,R11  ERROR
         LI,R15   6                 NOT TWICE
P22      CI,R5    ARGBUF4+32        TEST FOR MAX ARG SIZE
         BL       P25
         BG       P26               ERROR ALREADY REPORTED
         LI,R1    1                 SET ERROR FLAG (ERROR 01)
         BAL,R11  ERROR             ERROR 01
         B        P26
*
P25      LB,R8    *R7,R5            GET PREV BYTE IN CASE HEX CONVERT
         CI,R15   6
         BG       KGC0%4
         CLM,R4   LCCHARS           IF LOWER CASE, TRANSLATE
         BCS,9    %+2
         AI,R4    'A'-'a'
KGC0%4   STB,R4   *R7,R5            PACK CHARACTER IN ARGUMENT BUFFER
         CI,R15   22                ARE WE CONVERTING HEX
         BNE      P26               NO
         CLM,R4   BCD2BIN5          CHECK CHARACTER LEGALITY
         BCR,9    KGC1%4
         CLM,R4   HEX2BIN4
         BCS,9    P30               BADDIE
         AI,R4    10-'A'+'0'
KGC1%4   AI,R4    -'0'              MAKE BIN
         SLS,R8   4                 ADD TO PREVIOUS
         AW,R4    R8
         STB,R4   *R7,R5            STUFF IT IN
         CI,R8    X'F00'            WAS IT A FIRST HALF
         BANZ     %+2               YES, SKIP INCREMENT
P26      AI,R5    1                 INCREMENT CHARACTER COUNT
         LI,R8    1
         B        P5
*
P30      LI,R1    52
         BAL,R11  ERROR
         LI,R4    '0'               CHANGE TO '0'
         B        P25
*
RETURN1  CI,R4    X'7D'             IS DELIM A QUOTE
         BNE      RETURN2           NO
         CI,R15   6                 ARE WE SCANNING A FID
         BL       RETURN2           NO
         BE       P18               NO, STOP ONE BEFORE APOST
         CI,R5    ARGBUF4+1         HAVE WE STORED A CHARACTER
         BNE      RETURN3           YES
         CI,R15   16                ARE WE PAST INITIAL QUOTE
         BANZ     RETURN3           YES
         LI,R15   17                SET DELIM MODE TO SCAN FOR QUOTES
         B        P5
RETURN3  CI,R15   17                ARE WE SCANNING '--'
         BE       RETURN4           YES, CHECK '' IN STRING
         BG       RETURN5           END OF HEX STRING
         CI,R5    ARGBUF4+2         IS 2ND CHAR A QUOTE
         BNE      P18               NO, STOP PRE'
         LI,R1    ARGBUF4+1
         LB,R1    *R7,R1            GET FIRST CHAR
         CI,R1    'X'               IS IT AN X
         BNE      P18               NO, STOP PRE'
         LI,R15   22                SET DELIM MODE FOR HEX SCAN
         LI,R5    ARGBUF4+1         START OVER AGAIN
         MTB,-7   *R7,R5            MAKE RIGHT HALF BYTE 0
         B        P5
RETURN5  LB,R4    *R7,R5            DO WE HAVE HALF A CHARACTER
         CI,R4    ' '
         BE       RETURN6           NO
         SLS,R4   4
         STB,R4   *R7,R5
         AI,R5    1                 YES, ADD OTHER HALF=0
         B        RETURN6
RETURN4  CW,R6    MAXCMBX,R7        TEST FOR END OF COMMAND
         BL       %+3               NO
         LI,R4    X'15'             SET TERMINATOR
         B        RETURN2
         LB,R4    *R7,R6
         CI,R4    X'7D'             IS DOUBLE QUOTE IN CHAR STRING
         BE       P19               YES - STORE AND CONTINUE
RETURN6  LI,R15   X'80006'          SET DELIMITER NEXT FLAG
         B        P5                GO SCAN FOR DELIMITER
*
RETURN2  STW,R4   TERM,R7           SAVE DELIMITER
         STW,R6   CMBX,R7           SAVE COMMAND BUFFER INDEX
         AI,R5    -ARGBUF4-1        SAVE CHARACTER COUNT
         STW,R5   NCHAR,R7
         LI,R1    ARGBUF4
         STB,R5   *R7,R1
         LCI      7                 RESTORE REGISTERS
         PLM,R5   *R7
         B        *R11
*                   BLANK .(  );    / ,   #
DELIMIT  DATA     0,0,X'80140006',X'40100004',0,0,0,0
         DATA     X'80140006',X'C0100014',0,0,0,0
         DATA         X'80140006',X'40100004',0,0,0,0
         DATA     X'00000004',0,0,0,0
         DATA     X'00000004',0,0,0,0
         PAGE     'INTARG'
*P*      NAME:    INTARG
*P*
*P*      PURPOSE: TO CONVERT AN INTEGER ARGUMENT TO BINARY.  THE
*P*               CONVERTED INTEGER IS COMPARED WITH VALUE LIMITS
*P*               SUPPLIED BY THE CALLER.
*P*
*DO*
*P*
*
*
* INPUT
*
*        R1       MINIMUM INTEGER VALUE
*        R2       MAXIMUM INTEGER VALUE
*        ARGBUFF  ARGUMENT BUFFER
*        NCHAR    LENGTH OF CURRENT ARGUMENT
*
* OUTPUT
*
*        R1       INTEGER IN BINARY
*        R2       TYPE OF RETURN (0-NORMAL,1-INVALID,2-RANGE)
*
*FIN*
INTARG   DSECT    1
         LCI      7                 SAVE REGISTERS
         PSM,R5   *R7
         STW,R1   R6                SAVE RANGE VALUES
         STW,R2   R5
         LI,R1    ARGBUF4+1         CONVERT INTEGER TO BINARY
         LW,R2    NCHAR,R7
         BAL,R11  BCD2BIN
         LW,R1    R3                PUT RESULT IN R1
         LI,R2    0                 FLAG IF O.K.
         CI,R4    0                 TEST FOR VALID CONVERSION
         BE       RANGE
         LI,R2    1                 FLAG INVALID INTEGER
         B        RETURN
*
RANGE    LW,R4    R6                EDIT RANGE OF INTEGER
         CLR,R4   R3
         BCR,6    RETURN
         LI,R2    2                 FLAG RANGE ERROR
         B        RETURN
*
         PAGE     'TEXTARG'
*
*P*      NAME:    TEXTARG
*P*
*P*      PURPOSE: TO CHECK THE LENGTH OF THE ARGUMENT IN ARGBUFF TO
*P*               DETERMINE IF IT FALLS WITHIN THE LIMITS SUPPLIED BY
*P*               THE CALLER.
*P*
*DO*
*P*
*
* INPUT
*
*        R1       0-7    ERROR CODE DESIRED
*                 16-23  MIN. NO. OF CHARACTERS
*                 24-31  MAX. NO. OF CHARACTERS
*        ARGBUFF  ARGUMENT STORAGE BUFFER
*
*
*FIN*
TEXTARG  DSECT    1
         PSW,R11  *R7               SAVE RETURN  RESGISTER
         LI,R3    2                 GET MIN. VALUE
         LB,R2    R1,R3
         AI,R3    1                 GET MAX. VALUE
         LB,R3    R1,R3
         CLR,R2   NCHAR,R7          TEST NO. OF CHARACTERS
         BCR,6    %+3
         LB,R1    R1                SET GIVEN ERROR CODE
         BAL,R11  ERROR
         PLW,R11  *R7               RESTORE REGISTERS
         B        *R11
         END
