*M*      SUBR     SUBR CONTAINS VARIOUS SUBROUTINES USED BY OTHER MODULES
***********************************************************************
*P*
*P*      NAME:    SUBR
*P*
*P*      PURPOSE: TO PERFORM GENERAL UTILITY FUNCTIONS FOR THE OTHER
*P*               MODULES
*P*
*P*      DESCRIPTION: SEE THE FUNCTION PREAMBLES FOR THE VARIOUS
*P*               SUBROUTINES
*P*
*P*      REFERENCE: BATCH PROCESSING REFERENCE MANUAL
*P*
       CSECT       1
         SYSTEM   SIG7FDP
         SYSTEM   BPM
DEBUG    EQU      0
         PAGE
*                 SYMBOLIC REGISTER DEF'S.
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
         PAGE
*                 CHANGE STACK POINTER AMOUNT SPEC. BY 1ST ARGUMENT.
*                 SECOND ARGUMENT SPEC. AVAILABLE REGISTER.
BUMP     CNAME
         PROC
LF       LI,AF(2) AF(1)
         MSP,AF(2)  TSTACK
         PEND
*                 PUSH OR PULL N WORDS SPECIFIED BY 1ST ARGU4ENT INTO
*                 REG'S STARTING AT 2ND ARGUMENT.
PUSH     CNAME    X'9',X'B'
PULL     CNAME    X'8',X'A'
         PROC
         DO       NUM(AF)=1
LF       GEN,1,7,4,3,17 0,NAME(1),AF(1),0,TSTACK
         ELSE
         DO       AF(1)=1
LF       GEN,1,7,4,3,17  0,NAME(1),AF(2),0,TSTACK
         ELSE
         DO       AF(1)=16
LF       LCI      0
         ELSE
LF       LCI      AF(1)
         FIN
         GEN,1,7,4,3,17  0,NAME(2),AF(2),0,TSTACK
         FIN
         FIN
         PEND
         PAGE
         DEF      ONOFF             FPT USED FOR WRITING ON/OFF MESSAGE
*,*                                 TO OC AND TIME, DATE, AND ID TO LL
*,*                                 DEVICE
         DEF      HEXCK             CONVERT EBCDIC CHARACTER TO HEXADECIMAL
         DEF      HEXBCD            CONVERT A HEXADECIMAL VALUE TO EBCDIC
         DEF      GETDECVAL         CONVERT VALUE FOLLOWING KEYWORD TO
*,*                                 BINARY
         DEF      DECCNV            CONVERT EBCDIC DECIMAL VALUE TO BINARY
         DEF      WDTBLSRH          SEARCH SPECIFIED WORD TABLE FOR
*,*                                 SPECIFIED WORD
         DEF      GETDCBA           GET DEVICE OR CFU ASSIGNMENT
         DEF      TOPPAGE           OUTPUT TOP OF FORM ON SPECIFIED DEVICE
         DEF      EOCCSCAN          SCAN TO END OF CONTROL COMMAND AND
*,*                                 LIST
         DEF      GETACCN           GET ACCOUNT FROM CONTROL COMMAND
         DEF      GETSN             GET TAPE SERIAL NUMBER FROM CONTROL
*,*                                 COMMAND
         DEF      LISTDATE          LIST DATE, TIME, ID ON SPECIFIED
*,*                                 DEVICES
         DEF      GETHEXVAL         GET BCD VALUE FROM CONTROL COMMAND AND
*,*                                 CONVERT TO HEXADECIMAL
         DEF      BCDHEX            CONVERT A STRING OF EBCDIC CHARACTERS
*,*                                 TO HEXADECIMAL
         DEF      GETAVAL           GET VALUE FROM CONTROL COMMAND AND
*,*                                 CONVERT TO HEXADECIMAL
         DEF      GETPASSW          GET PASSWORD FROM CONTROL COMMAND
         DEF      GETLOC            GET NEXT FIELD FROM CONTROL COMMAND
*,*                                 CONTAINING NAME
         DEF      GETLOC1           GET NEXT FIELD FROM CONTROL COMMAND
*,*                                 CONTAINING NAME AND RESOLUTION
         DEF      GETLOC2           GET NEXT FIELD FROM CONTROL COMMAND
*,*                                 CONTAINING NAME AND VALUE
         DEF      GETLOC3           GET NEXT FIELD FROM CONTROL COMMAND
*,*                                 CONTAINING NAME, RESOLUTION, VALUE
         DEF      DCBCLS            CLOSE OUTPUT DCBS IF OPEN
         DEF      CHSTSHFT          SHIFT SPECIFIED CHARACTER STRING AND
*,*                                 INSERT LENGTH IN BYTE 0
         DEF      CALENDTE          GET NEXT FIELD FROM CONTROL COMMAND
*,*                                 CONTAINING EXPIRATION DATE
         DEF      GETVAL0           RESET CONDITION CODES
         DEF      GETVAL4           SET CONDITION CODES=1 (CC1=1)
         DEF      GETACCN0          PULL REGISTER SR4, RESET CONDITION
*,*                                 CODES, AND RETURN ON SR4
         DEF      GETLOC20          PULL SR4 AND RETURN ON SR4
         DEF      WAMR              WRITE ASSIGN-MERGE RECORD
         DEF      RAMR              READ ASSIGN-MERGE RECORD
         DEF      OPNXS             OPEN COMMAND FILE AND SKIP TO RECORD
         DEF      WRCFM             WRITE COMMAND FILE MESSAGES
         DEF      CHKTERM           CHECK FOR LEGAL COMMAND TERMINATOR
         DEF      INDELIMS          INCLUDE HYPHEN AND PLUS AS DELIMITERS
*,*                                 AND MAKE THEM ILLEGAL ALPHANUMERIC
*,*                                 CHARACTERS
         DEF      EXDELIMS          EXCLUDE HYPHEN AND PLUS AS DELIMITERS
*,*                                 AND MAKE THEM LEGAL ALPHANUMERIC
*,*                                 CHARACTERS
         DEF      BINDCB            CONVERT HEXADECIMAL VALUE TO DECIMAL
*,*                                 -EBCDIC
         REF      M:EO              DCB USED IN READING/WRITING ASSIGN-
*,*                                 MERGE RECORD
         REF      PUTERCD           ERROR CODE CONSTANT
         REF      GETERCD           ERROR CODE CONSTANT
         REF      SYSID             EQU; INPUT-OFFSET INTO JIT FOR
*,*                                 OBTAINING SYSTEM ID
         REF      TSTACK            INPUT/OUTPUT-PRESERVE REGISTERS
         REF      XFF               CONSTANT
         REF      XFFFFFFFB         CONSTANT
         REF      DSI               EQU; INPUT-OFFSET INTO DCB FOR OBTAINING
*,*                                 DEVICE ASSIGNMENT
         REF      NXACTCHR          GET NEXT ACTIVE CHARACTER DURING
*,*                                 SEARCH FOR END OF CONTROL COMMAND
         REF      CHARSCAN          GET NEXT ACTIVE CHARACTER FROM CONTROL
*,*                                 COMMAND AND COMPARE
         REF      CHSTSCAN          GET NEXT FIELD FROM CONTROL COMMAND
         REF      DECSCAN           GET DECIMAL VALUE FROM CONTROL COMMAND
         REF      HEXSCAN           GET HEXADECIMAL VALUE FROM CONTROL
*,*                                 COMMAND
         REF      NAMSCAN           GET KEYWORDS AND LOCATION NAMES
*,*                                 FROM CONTROL COMMAND
         REF      QUOTSCAN          GET NEXT FIELD FROM CONTROL COMMAND
*,*                                 AND COMPARE
         REF      Y002              CONSTANT
         REF      FLAGS             EQU; OUTPUT-OFFSET INTO PARAMETER
*,*                                 TABLE FOR SETTING F1,F2,F3 FLAGS
         REF      CSL               EQU; INPUT-OFFSET INTOO PARAMETER TABLE
*,*                                 FOR OBTAINING LENGTH OF LAST
*,*                                 CHARACTER STRING SCANNED
         REF      PLB               EQU; INPUT-OFFSET INTO PARAMETER
*,*                                 TABLE CONTAINING MOST RECENT CHARACTER
*,*                                 STRING SCANNED
         REF      COMERCD           ERROR CODE CONSTANT
         REF      DECERCD           ERROR CODE CONSTANT
         REF      VALERCD           ERROR CODE CONSTANT
         REF      HEXERCD           ERROR CODE CONSTANT
         REF      CHSTERCD          ERROR CODE CONSTANT
         REF      NAMERCD           ERROR CODE CONSTANT
         REF      RPERCD            ERROR CODE CONSTANT
         REF      TERMERCD          ERROR CODE CONSTANT
         REF      Y4                CONSTANT
         REF      Y1                CONSTANT
         REF      Y04               CONSTANT
         REF      Y2                CONSTANT
         REF      ERRLFCK           CHECK FOR DEVICE DUPLICATION
         REF      LISTDCBT          INPUT-TABLE OF OUTPUT DCB ADDRESSES
*,*                                 USED FOR LISTING PURPOSES
         REF      LIST              LIST TIME, DATE AND JOB ID
         REF      ERRLIST           LIST ERROR MESSAGES
         REF      SERRLF            SET LIST FLAGS FOR SPECIFIED
*,*                                 DEVICES
         REF      X1FFFF            CONSTANT
         REF      ANYSCAN           SCAN CONTROL COMMAND FOR TAPE SERIAL
*,*                                 NUMBER
         REF      FLISTPPI          EQU; INPUT-OFFSET INTO OPEN PRIME
*,*                                 PLIST FOR DETERMINING IF ANS/NON-ANS
*,*                                 SERIAL NUMBER SPECIFIED
         REF      CHTBL             OUTPUT-INCLUDE THE HYPHEN IN THE LIST
*,*                                 OF LEGAL ALPHANUMERIC CHARACTERS
         REF      COMEXIT1          RESET BUFFER EMPTY FLAG IN PARAMETER
*,*                                 TABLE, RESET CONDITION CODES AND
*,*                                 RETURN ON SR4
         REF      AM:CNAME          INPUT; OBTAIN FILE NAME FROM A/M RECD
         REF      AM:CACCT          INPUT; OBTAIN ACCOUNT FROM A/M RECD
         REF      AM:CPASS          INPUT; OBTAIN PASSWORD FROM A/M RECD
         REF      AM:CREC           INPUT; OBTAIN RECORD FROM A/M RECD
         REF      OPNFD             DETERMINE IF COMMAND FILE EXISTS
         REF      F:CF              INPUT; DCB FOR OPENING COMMAND FILE
         REF      RDEXCD            ERROR CODE CONSTANT
         REF      FDEXM             ERROR MESSAGE
         REF      FBUSYM            ERROR MESSAGE
         REF      FADNDM            ERROR MESSAGE
         REF      ERRCODEM          INPUT; ERROR MESSAGE ADDRESS
         REF      FEXECM            ERROR MESSAGE ADDRESS
         PAGE
K0       EQU      0
K1       EQU      1
K2       EQU      2
K3       EQU      3
K4       EQU      4
K6       EQU      6
K7       EQU      7
K8       EQU      8
KA       EQU      X'A'
K10      EQU      X'10'
K18      EQU      X'18'
K39      EQU      X'39'
K40      EQU      X'40'
KB7      EQU      X'B7'
KC0      EQU      X'C0'
KC1      EQU      X'C1'
KF0      EQU      X'F0'
KFF      EQU      X'FF'
K201     EQU      X'201'
K1FFFF   EQU      X'1FFFF'
KN1      EQU      -1
KN3      EQU      -3
KNF0     EQU      -X'F0'
KCRET    EQU      X'15'
KEOB     EQU      X'26'
KCOMMA   EQU      ','
KHYPEN   EQU      '-'
KPLUS    EQU      '+'
KPERIOD  EQU      '.'
NFEBYTES EQU      29                NUMBER OF 'FILE EXECUTION' MESSAGE
*                                   BYTES TO MOVE
SFEBYTE  EQU      20                STARTING BYTE OF 'FILE EXECUTION'
*                                   MESSAGE TO MOVE
NFTBYTES EQU      31                NUMBER OF 'FILE TERMINATION'
*                                   MESSAGE BYTES TO MOVE
SFTBYTE  EQU      18                STARTING BYTE OF 'FILE EXECUTION'
*                                   MESSAGE TO MOVE
         SPACE    3
TEN15    DATA     10,15
GETPAGE  DATA     X'08000001'
FREEPAGE DATA     X'09000001'
NEVER    TEXTC    'NEVER'
BCZRO1   TEXT     '   0'
BCZRO2   TEXT     '  00'
EMONTH   TEXT     '  12'
EDAY     TEXT     '  31'
         CSECT    0
EXDDDFLG DATA     0                 FLAG USED IN CALENDTE
         CSECT    1
         PAGE
*F*
*F*      NAME:    HEXCK
*F*
*F*      PURPOSE: TO CONVERT AN EBCDIC CHARACTER TO HEXADECIMAL
*F*
**********************************************************************
*        HEXCK    HEX  CHECK                                         *
*                 CHECKS IF EBCDIC CHAR IS A LEGAL HEX CHAR. IF      *
*                 LEGAL,CONV. TO HEX                                 *
*        ENTER WITH                                                  *
*                 (R2) = HEX CHAR                                    *
*        EXIT WITH                                                   *
*                 (R2) = HEX DIGIT AND CC1 =0 IF LEGAL               *
*                 CC1 = 1 IF ILLEGAL                                 *
**********************************************************************
HEXCK    EQU      %
         AND,R2   XFF
         AI,R2    -KF0              CHK IF 0-9
         BL       HEXCK2            BRANCH IF NOT
         CI,R2    9
         BLE      HEXCK3            BRANCH IF 0-9
HEXCK1   EQU      %
         LCI      K8                SET CC1 =1 FOR ERROR
         B        *D4               EXIT
*
HEXCK2   EQU      %
         AI,R2    KF0+KA-KC1        CHK IF A-F
         CLM,R2   TEN15
         BCS,9    HEXCK1            BRANCH IF NOT
HEXCK3   EQU      %
         LCI      K0                SET CC1 = 0
         B        *D4
         PAGE
*F*
*F*      NAME:    HEXBCD
*F*
*F*      PURPOSE: TO CONVERT A HEXADECIMAL VALUE TO EBCDIC
*F*
**********************************************************************
*        HEXBCD    HEXIDECIMAL  TO  EBCDIC  CONVERSION               *
*        ENTER WITH                                                  *
*                 (D1) =  8  DIGIT  HEX NUMBER                       *
*        EXIT WITH                                                   *
*                 (D1-D2) =  8  CHAR EBCDIC  RESULT                  *
*        CALLING SEQUENCE                                            *
*        BAL,D4   HEXBCD                                             *
*                                                                    *
**********************************************************************
HEXBCD   EQU      %
         LI,D3    K8                SET COUNTER TO 8
HEXBCD1  EQU      %
         SLD,R0   K8
         LI,D2    K0
         SCD,D1   K4
         AI,D2    KB7
         CI,D2    KC0               CHK A-F
         BG       HEXBCD2           BRANCH IF YES
         AI,D2    K39               CONV TO F0-F9
HEXBCD2  EQU      %
         OR,R1    D2
         BDR,D3   HEXBCD1
         LD,D1    R0
         B        *D4               EXIT WITH RESULT IN  D1 AND D2
         PAGE
*F*
*F*      NAME:    GETDECVAL
*F*
*F*      PURPOSE: TO GET THE VALUE FOLLOWING THE KEYWORD AND CONVERT IT
*F*               TO BINARY
*F*
**********************************************************************
*        GETDECVAL- GET VALUE IN  CC  FOLLOWING KEYWORD.             *
*        CHECKS IF COMMA FOLLOWS KEYWORD FOLLOWED BY A LEGAL         *
*        DECIMAL VALUE.  CONVERTS VALUE TO BINARY AND CHECKS IF      *
*        LESS THAN  SPECIFIED  MAX  VALUE                            *
*        ENTER WITH                                                  *
*                 (R1) = MAX VALUE                                   *
*                 (R5) = JIT POINTER                                 *
*                 (R7) = PARAMETER LIST POINTER                      *
*                 (SR1) = CUR CHAR OR ZERO                           *
*        EXIT WITH                                                   *
*                 (R2) = VALUE IN BINARY                             *
*                 CC1 = 0, IF LEGAL VALUE LESS THAN MAX OBTAINED     *
*                 CC1 = 1,IF ERROR ENCOUNTERED IN TRYING TO OBTAIN   *
*                 (SR1) = ERROR CODE IF CC1 = 1             VALUE    *
**********************************************************************
GETDECVAL EQU     %
         PUSH     SR4
         PUSH     R1
         LI,SR2   KCOMMA            CHECK FOR COMMA FOLLOWING KEYWORD
         BAL,SR4  CHARSCAN
         BCS,8    GETVAL1           ERROR IF NOT
         BAL,SR4  DECSCAN           GET DECIMAL FIELD
         BCS,8    GETVAL2           ERROR IF NOT
         LW,R0    CSL,R7
         LW,R1    R7
         AI,R1    PLB
         BAL,SR4  DECCNV            CONVERT FROM EBCDIC DECIMAL TO BINAR
         BCS,8    GETVAL2
         PULL     R1
         PULL     SR4
         CW,R2    R1                CHECK IF < SPECIFIED VALUE
         BGE      GETVAL5
GETVAL0  RES      0
         LCI      K0
         B        *SR4
*
GETVAL1  EQU      %
*E*      MESSAGE: EXPECTED COMMA MISSING
         LI,SR3   COMERCD
         B        GETVAL3
GETVAL2  EQU      %
*E*      MESSAGE: ILLEGAL DECIMAL NUMBER
         LI,SR3   DECERCD
GETVAL3  EQU      %
         PULL     R1
         PULL     SR4
GETVAL4  EQU      %
         LCI      K8                SET CC1 = 1
BISR4    B        *SR4
*
GETVAL5  EQU      %
*E*      MESSAGE: ILLEGAL VALUE
         LI,SR3   VALERCD
         B        GETVAL4
         PAGE
*F*
*F*      NAME:    DECCNV
*F*
*F*      PURPOSE: TO CONVERT AN EBCDIC DECIMAL NUMBER TO BINARY
*F*
**********************************************************************
*        DECCNV   EBCDIC  DECIMAL TO BINARY CONVERSION               *
*        ENTER WITH                                                  *
*                 (R0) = NUMBER OF CHARACTERS                        *
*                 (R1) = WORD ADR OF 1ST CHAR                        *
*        EXIT WITH                                                   *
*                 (R2) = RESULT IF CORRECT AND CC1=0.                *
*                 CC1= 1 IF RESULT IN ERROR, I.E. GREATER THAN A     *
*                        31 BIT INTEGER                              *
**********************************************************************
DECCNV   EQU      %
         LI,R2    K0
         LI,R3    K0
DECCNV1  EQU      %
         LB,R4    *R1,R2            PICK DECIMAL BCD CHARACTER
         AI,R4    KNF0              REMOVE LEADING F
         MI,R3    KA                MULTIPLY RESULT BY 10
         BCS,4    DECCNV2           CHECK IF ILLEGAL RESULT
         AW,R3    R4
         AI,R2    K1
         BDR,R0   DECCNV1           CHECK IF DONE
         LW,R2    R3
         B        GETVAL0
*
DECCNV2  EQU      GETVAL4
         PAGE
*F*
*F*      NAME:    WDTBLSRH
*F*
*F*      PURPOSE: TO SEARCH A SPECIFIED WORD TABLE FOR A SPECIFIED WORD
*F*
**********************************************************************
*        WDTBLSRH -  WORD TABLE  SEARCH ROUTINE                      *
*        ENTER  WITH                                                 *
*                 (R1)= SEARCH ITEM                                  *
*                 (R2)= ADR OF WORD TABLE                            *
*                 (R3)= NO. OF ITEMS IN TABLE                        *
*                 (R4)= RETURN ADR IF SEARCH FAILS                   *
*        EXIT WITH                                                   *
*                 (R3)= POINTER TO ITEM IN TABLE IF SEARCH SUCCESS   *
**********************************************************************
WDTBLSRH EQU      %
         CW,R1    *R2,R3
         BE       BISR4             BRANCH ON HIT
         BDR,R3   WDTBLSRH
         B        0,R4              SRCH FAILED
         PAGE
*F*
*F*      NAME:    GETDCBA
*F*
*F*      PURPOSE: TO GET THE DEVICE OR CFU ASSIGNMENT FOR THE DCB
*F*
*        GETDCBA -GET DCB ASSIGNMENT
*                 GETS DEVICE OR CFU ASSIGNMENT POINTER
*        ENTER WITH
*        (R6) = DCB ADR
*        EXIT WITH
*        (R1) =  DCB ASSIGNMENT
*
GETDCBA  EQU      %
         LW,R1    Y002
         CW,R1    0,6
         BANZ     %+2               OPEN
         CAL1,1   GETDCBOPN
         LI,R1    X'F'
         AND,R1   0,R6
         CI,R1    X'1'
         BE      GETDCB1         FILE
         LI,R1    X'FF'                  -DCT
GETDCB2  AND,R1   DSI,R6
         B        *D4
GETDCB1  LI,R1    X'FFFF'
         B        GETDCB2
GETDCBOPN  DATA   X'94000006'
           DATA   0
*
         PAGE
*F*
*F*      NAME:    TOPPAGE
*F*
*F*      PURPOSE: TO OUTPUT A TOP OF FORM ON THE SPECIFIED DEVICE
*F*
************************************************************************
*        TOPPAGE   TOP OF PAGE  ROUTINE                                *
*        ENTER WITH                                                    *
*                 (R4) = DEVICEINDICATORS IN LOW 7 BITS(AL,PO,DO,LO,SL,*
*                 (R5) = JIT ADR                        LL,OC)         *
************************************************************************
TOPPAGE  EQU      %
         PUSH     7,R5
         BAL,SR4  ERRLFCK           CHECK FOR DEV DUPLICATION
         LI,R3    6
TOPPAGE2 EQU      %
         CI,R4    1
         BAZ      TOPPAGE4
         LW,R6    LISTDCBT+1,R3
         OR,R6    Y04
         CAL1,1   6
TOPPAGE4 EQU      %
         SLS,R4   -1
         BDR,R3   TOPPAGE2
         PULL     7,R5
         B        *SR4
         PAGE
*F*
*F*      NAME:    EOCCSCAN
*F*
*F*      PURPOSE: TO SCAN TO THE END OF A CONTROL COMMAND, SKIPPING
*F*               OVER ALL CONTINUATION RECORDS
*F*
**********************************************************************
*        EOCCSCAN -  END OF CONTROL COMMAND SCAN.                    *
*        SCANS TO THE END OF CC SKIPPING OVER ALL CONTINUATION       *
*        REORDS.                                                     *
*        ENTER WITH                                                  *
*                 (R7) = ADR OF  CC  PARM LIST                       *
*                 (SR1) = CUR  CHAR  OR ZERO                         *
*                                                                    *
**********************************************************************
EOCCSCAN EQU      %
         PUSH     SR4
EOCCSC1  RES      0
EOCCSCAN1 EQU     %
         CI,SR1   KEOB              CHECK IF EOB
         BE       EOCCSCAN2
         CI,SR1   KCRET             CHECK IF CARRIAGE RETURN
         BE       EOCCSCAN2
         CI,SR1   KFF               CHECK IF NEXT CONT. RECORD NOT
         BE       EOCCSCAN2                            OBTAINABLE
         LI,SR1   K0
         BAL,SR4  NXACTCHR
         B        EOCCSCAN1
         PAGE
*F*
*F*      NAME:    GETACCN
*F*
*F*      PURPOSE: TO GET THE NEXT FIELD FROM THE CONTROL COMMAND AND
*F*               CHECK IF IT IS A LEGAL ACCOUNT NUMBER
*F*
*
*        GET ACCOUNT NUMBER
*
GETACCN  EQU      %
         PUSH     SR4
         LI,R4    3                 CHK IF
         BAL,SR4  HEXSCAN+1           VALID ACCOUNT
         BCS,8    GETACCN1
         LW,R1    CSL,R7
         CI,R1    K8
         BG       GETACCN1
GETACCN0 RES      0
         PULL     SR4
         B        GETVAL0
*
GETACCN1 EQU      %
*E*      MESSAGE: ILLEGAL ALPHANUMERIC NAME
         LI,SR3   NAMERCD           (SR3) = ILLEGAL NAME ERR CODE
         B        GETVAL4-1
         PAGE
*F*
*F*      NAME:    GETSN
*F*
*F*      PURPOSE: TO GET THE NEXT FIELD FROM THE CONTROL COMMAND AND
*F*               CHECK IF IT IS A LEGAL TAPE SERIAL NUMBER
*F*
*
*        GET TAPE REEL SERIAL NUMBER
*
GETSN    EQU      %
         PUSH     SR4
         LI,SR4   7
         AND,SR4  FLISTPPI,R6
         CI,SR4   5
         BE       GETSN2
         BAL,SR4  NAMSCAN
         BCR,8    GETSN4
         LW,R1    Y2
         STS,R1   FLAGS,R7
         BAL,SR4  DECSCAN
         BCS,8    GETSN1
GETSN4   EQU      %
         LW,R1    CSL,R7
         CI,R1    K4
         BLE      GETACCN0
*
GETSN1   EQU      %
         PULL     SR4
         B        GETVAL5
*
GETSN2   EQU      %
         BAL,SR4  ANYSCAN
         LW,R1    CSL,R7
         CI,R1    6                 SERIAL NUMBERS ARE 6 CHARS FOR ANS
         BG       GETSN1
         B        COMEXIT1
         PAGE
*F*
*F*      NAME:    LISTDATE
*F*
*F*      PURPOSE: TO OBTAIN AND LIST THE DATE, TIME, AND JOB ID ON THE
*F*               LISTING DEVICE
*F*
*
*        LISTDATE LISTS DATE AND TIME ON SPECIFIED DEVICES
*
LISTDATE EQU      %
         PUSH     SR4
         BUMP     7,R1                                                  902
         LW,R2    TSTACK
         AI,R2    -6                                                    902
         LW,R3    R2
         AI,R3    1
         OR,R3    Y1
         CAL1,8   3
         LW,R3    LSTDTCNT
         STW,R3   0,R2
         PUSH     R2
         LI,4     2                 NO TYPE
         BAL,SR4  ERRLFCK
         LW,D1    SYSID,R5                                              902
         BAL,D4   HEXBCD                                                902
         PULL     R2
         STW,D2   6,R2                                                  902
         LW,D1    IDM                                                   902
         STW,D1   5,R2                                                  902
         LI,D4    3
         BAL,SR4  LIST
         LI,D1     ON
         CAL1,2   ONOFF
         BUMP     -7,R1                                                 902
         B        EOCCSCAN2
*
ON       TEXTC     ' ON'
ONOFF    RES      0                                                          902
ONLIST   GEN,8,24  X'02',0
         GEN,1,31  1,0
         PZE      *D1
LSTDTCNT DATA     X'19404040'                                           902
IDM      TEXT     ' ID='                                                902
         PAGE
*F*
*F*      NAME:    GETHEXVAL
*F*
*F*      PURPOSE: TO GET A HEXADECIMAL VALUE FROM A CONTROL COMMAND
*F*               AND CONVERT IT FROM EBCDIC TO HEXADECIMAL
*F*
**********************************************************************
*        GETHEXVAL  GETS HEXIDECIMAL VALUE FROM CONTROL COMMAND      *
*                 AND CONVERTS FROM BCD TO HEX                       *
*        ENTER WITH                                                  *
*                 (R7) = PARAM LIST ADR                              *
*                 (SR1) = CUR CHAR OR ZERO                           *
*        EXIT WITH                                                   *
*                 (D3) = HEX VALUE AND CC1=0 IF LEGAL HEX VALUE      *
*                 C1 = 1 AND (SR3) = ERROR CODE IF LEGAL VALUE NOT   *
*                         FOUND                                      *
**********************************************************************
GETHEXVAL EQU     %
         PUSH     SR4
         BAL,SR4  HEXSCAN           GET HEX FIELD
         BCS,8    GTHXVL1           CHECK IF LEGAL
         LW,R0    CSL,R7
         CI,R0    K8                CHK IF <= 8 CHAR
         BG       GTHXVL1
         LW,D1    PLB,R7
         LW,D2    PLB+1,R7
         LI,SR4   GETACCN0
*   FALL INTO BCDHEX
         PAGE
*F*
*F*      NAME:    BCDHEX
*F*
*F*      PURPOSE: TO CONVERT A STRING OF EBCDIC HEXADECIMAL CHARACTERS
*F*               TO HEXADECIMAL
**********************************************************************
*        BCDHEX CONVERTS UP TO 8 HEX-EBCDIC CHAR'S TO HEX DIGITS     *
*        ENTER WITH                                                  *
*                 (D1-D2) = BCD CHAR (LEFT JUSTIFIED AND BLANK       *
*                                   FILLED IF <8 CHAR)               *
*        EXIT WITH                                                   *
*                 (D3) = RESULT AND CC1=0 IF LEGAL                   *
*                 CC1= 1 IF RESULT ILLEGAL                           *
*                                                                    *
**********************************************************************
BCDHEX   EQU      %
         LI,D3    K0
         LI,R0    K8
BCDHEX1  EQU      %
         LB,R2    D1
         CI,R2    K40
         BE       BCDHEX2
         SLS,D3   4
         BAL,D4   HEXCK             CHECK AND CONVERT BCD CHAR
         BCS,8    BCDHEX3           CHECK IF LEGAL
         OR,D3    R2                MERGE NEXT HEX DIGIT
         SLD,D1   K8
         BDR,R0   BCDHEX1
BCDHEX2  EQU      GETVAL0
         B        GETVAL0
BCDHEX3  EQU      GETVAL4
         PAGE
*F*
*F*      NAME:    BINDCB
*F*
*F*      PURPOSE: TO CONVERT A BINARY VALUE TO A DECIMAL EBCDIC VALUE
*F*
*D*
*D*      NAME:    BINDCB
*D*
*D*      REGISTERS: R0,R1,D3,D4
*D*
*D*      CALL:    BAL,SR4  BINDCB
*D*
*D*      INPUT:   D1 = BINARY VALUE
*D*
*D*      OUTPUT:  D1,D2 = DECIMAL EBCDIC VALUE
*D*
*D*      DESCRIPTION: THE BINARY VALUE IN D1 IS CONVERTED TO A
*D*                   DECIMAL EBCDIC VALUE.
*D*
BINDCB   EQU      %
         LI,R1    7                 CHARACTER COUNT AND BYTE POINTER
         LW,D4    D1                GET NUMBER
BINDCB5  EQU      %
         LI,D3    0
         DW,D3    =10
         AI,D3    X'F0'             CONVERT REMAINDER TO EBCDIC AND
         STB,D3   D1,R1             PLACE INTO RESULT.
         AI,R1    -1
         BGEZ     BINDCB5
         B        *SR4
         PAGE
*F*
*F*      NAME:    GETAVAL
*F*
*F*      PURPOSE: TO GET THE NEXT FIELD FROM THE CONTROL COMMAND,
*F*               CHECK IF IT IS A LEGAL HEXADECIMAL ADDRESS, AND
*F*               CONVERT IT
*F*
**********************************************************************
*        GETAVAL  GET ADR VALUE FROM CC                              *
*        ENTER WITH                                                  *
*                 (R7) = PARAM LIST ADR                              *
*                 (SR1)= CUR CHAR OR ZERO                            *
*        EXIT WITH                                                   *
*                 (R2) = ADR VALUE AND CC1 =0 IF LEGAL VALUE.        *
*                 CC1 = 1 AND (SR3) = ERROR CODE IF LEGAL VALUE      *
*                 NOT OBTAINABLE                                     *
*                                                                    *
**********************************************************************
GETAVAL  EQU      %
         PUSH     SR4
         LI,SR2   KCOMMA
         BAL,SR4  CHARSCAN
         BCS,8    GETAVAL1
         B        GETAVAL11
GETAVAL10 EQU     %
         PUSH     SR4
GETAVAL11 EQU     %
         BAL,SR4  GETHEXVAL
         BCS,8    GETAVAL2
         STW,D3   R2
         CI,R2    K1FFFF
         BLE      GETACCN0
*
GTHXVL1  LI,SR3   HEXERCD
*E*      MESSAGE: ILLEGAL HEXADECIMAL NUMBER
         B        GETVAL4-1
*
GETAVAL1 EQU      %
*E*      MESSAGE: EXPECTED COMMA MISSING
         LI,SR3   COMERCD
         B        GETAVAL3
*
GETAVAL2 EQU      GTHXVL1
GETAVAL3 EQU      GETVAL4-1
         PAGE
*F*
*F*      NAME:    GETPASSW
*F*
*F*      PURPOSE: TO GET THE NEXT FIELD FROM THE CONTROL COMMAND AND
*F*               CHECK IF IT IS A LEGAL PASSWORD
*F
GETPASSW EQU      %
         PUSH     SR4
         LW,R1    Y4
         STS,R1   FLAGS,R7          SET BLANK-OUT FLAG
         BAL,SR4  CHSTSCAN
         STCF     R4
         BCR,8    GETPASSW1
*E*      MESSAGE: ILLEGAL CHARACTER STRING
         LI,SR3   CHSTERCD
GETPASSW1 EQU     %
         LI,R2    K0
         LW,R3    Y4
         STS,R2   FLAGS,R7          RESET BLANK-OUT FLAG
         PULL     SR4
         LC       R4
         B        *SR4
         PAGE
*F*
*F*      NAME:    DCBCLS
*F*
*F*      PURPOSE: TO CLOSE OUTPUT DCBS M:LL, M:LO, M:DO, M:PO, AND
*F*               M:AL IF THEY ARE OPEN
*F*
DCBCLS   EQU      %
         LI,R3    6
DCBCLS1  EQU      %
         LW,R2    LISTDCBT,R3
           LW,R1      0,R2
           CW,R1      Y002
           BAZ        DCBCLS2
         CAL1,1   CLSDCB
DCBCLS2    EQU        %
         BDR,R3   DCBCLS1
         B        *SR4
*
CLSDCB   EQU      %
         GEN,8,24 X'95',2
         DATA     X'80000000'
         DATA     2
         PAGE
*F*
*F*      NAME:    GETLOC
*F*
*F*      PURPOSE: TO GET THE NEXT FIELD ON THE CONTROL COMMAND AND
*F*               CHECK IF IT REPRESENTS A LEGAL RELATIVE OR
*F*               ABSOLUTE HEXADECIMAL LOCATION OF THE FORM
*F*               1. NAME
*F*               2. RES (NAME)
*F*               3. NAME +- HEX VALUE
*F*               4. RES (NAME) +- HEX VALUE
*F*               5. + HEX VALUE
GETLOC   EQU      %
         LI,R4    K2                SET FLAGS FOR NAME ONLY
         B        GETLOC4
GETLOC1  EQU      %
         LI,R4    K6                SET FLAGS FOR RES AND NAME
         B        GETLOC4
GETLOC2  EQU      %
         LI,R4    K3                SET FLAGS FOR NAME AND VALUE
         B        GETLOC4
GETLOC3  EQU      %
         LI,R4    K7                SET FLAGS FOR RES, NAME,AND VALUE
GETLOC4  EQU      %
         PUSH     SR4
         PUSH     R6
         LW,R6    R4                SAVE FLAGS IN R6
         PUSH     R3                (R3) = ADR OF NXT AVAIL LOC IN BUF
*
         LI,SR2   '+'
         BAL,SR4  CHARSCAN          CHECK FOR LEADING +
         BCS,8    GETLOC10          BRANCH IF ZERO
         CI,R6    K1                CHECK IF VALUE FLAG SET
         BAZ      GETLOC10          BRANCH IF NOT
         LW,R2    *TSTACK           NXT AVAIL LOC IN BUF
         LI,R3    K0
         STW,R3   0,R2              SET NAME = 0
         AI,R2    K1
         STW,R2   *TSTACK
GETLOC16 BAL,SR4  GETAVAL10         GET VALUE
         BCS,8    GETLOC34
         B        GETLOC18
*
GETLOC10 EQU      %
         BAL,SR4  NAMSCAN           GET NAME
         BCS,12   GETLOC30          BRANCH IF ILLEGAL NAME
         CI,R6    K4                CHECK RES FLAG SET
         BAZ      GETLOC11
         CI,SR1   '('               YES-CHECK IF CUR CHAR = )
         BNE      GETLOC11
         LW,R2    PLB,R7
         SLS,R2   -16
         LI,R3    K0
         CI,R2    'BA'              CHECK IF BA RES
         BE       GETLOC6
         LI,R3    K1
         CI,R2    'HA'              CHECK IF HA RES
         BE       GETLOC6
         LI,R3    K2
         CI,R2    'WA'              CHECK IF WA RES
         BE       GETLOC6
         LI,R3    K3
         CI,R2    'DA'              CHECK IF DA RES
         BNE      GETLOC30
GETLOC6  EQU      %
         LI,SR1   0
         B        GETLOC12
*
GETLOC11 EQU      %
         LI,R3    2                 SET RES = 2 = WORD RES.
         AND,R6   XFFFFFFFB         REST RES FLAG
         LW,R1    Y2
         STS,R1   FLAGS,R7          SET CHAR BUFFER FULL FLAG
GETLOC12 EQU      %
         STB,R3   R6                STORE RES IN HIGH BYTE OF R6
         BAL,SR4  NAMSCAN           GET NAME
         BCS,12   GETLOC30
         LW,R0    R7
         AI,R0    PLB
         LW,R1    CSL,R7
         LI,R2    K1
         BAL,SR4  CHSTSHFT          SHIFT NAME AND INSERT BYTE COUNT
         LW,R2    CSL,R7            CALCULATE
         AI,R2    4                    NO. OF  WORDS IN NAME
         SLS,R2   -2
         LW,R1    *TSTACK
         LW,R3    R7
         AI,R3    PLB
GETLOC14 EQU      %
         LW,R4    0,R3              MOVE
         STW,R4   0,R1                  NAME TO BUFFER
         AI,R3    K1
         AI,R1    K1
         BDR,R2   GETLOC14
         STW,R1   *TSTACK
         CI,R6    K4                CHECK IF RES PRESENT
         BAZ      GETLOC15
         LI,SR2   ')'               CHECK FOR RIGHT PAREN
         BAL,SR4  CHARSCAN
         BCS,8    GETLOC32
GETLOC15 EQU      %
         CI,R6    K1                CHECK IF VALUE FLAG SET
         BAZ      GETLOC21
         LI,SR2   '+'
         BAL,SR4  CHARSCAN          CHECK FOR + AFTER NAME
         BCR,8    GETLOC16
         LI,SR2   '-'
         BAL,SR4  CHARSCAN          CHECK FOR - AFTER NAME
         BCR,8    GETLOC17
         LI,R2    K0                SET VALUE
         B        GETLOC18
*
GETLOC17 EQU      %
         BAL,SR4  GETAVAL10         GET VALUE
         BCS,8    GETLOC34
         LCW,R2   R2                COMPLIMENT VALUE
GETLOC18 EQU      %
         PULL     R3
         STW,R2   0,R3
         AI,R3    K1
GETLOC19 EQU      %
         LB,R4    R6                MOVE RES TO R4
         PULL     R6
         MTW,1    *TSTACK
GETLOC20 EQU      %
         PULL     SR4
         B        *SR4
EOCCSCAN2 EQU     GETLOC20
*
GETLOC21 EQU      %
         PULL     R3
         B        GETLOC19
*
GETLOC30 EQU      %
*E*      MESSAGE: ILLEGAL ALPHANUMERIC NAME
         LI,SR3   NAMERCD
         B        GETLOC34
*
GETLOC32 EQU      %
*E*      MESSAGE: EXPECTED RIGHT PARENTHESIS MISSING
         LI,SR3   RPERCD
*
GETLOC34 EQU      %
         PULL     R3
         PULL     R6
         B        GETLOC20
         PAGE
*F*
*F*      NAME:    CHSTSHFT
*F*
*F*      PURPOSE: TO SHIFT A CHARACTER STRING A SPECIFIED NUMBER OF
*F*               BYTES TO THE RIGHT AND STORE THE CHARACTER LENGTH
*F*               IN BYTE ZERO
*F*
*CHSTSHFT SHIFTS CHARACTER STRING SPECIFIED NUMBER OF BYTES. ENTER WITH
*BUFFER ADDR IN R0, CHARACTER STRING LENGTH IN R1, DISPLACEMENT IN R2,
*AND RETURN ADDR IN SR4.
CHSTSHFT EQU      %
         LW,R4    R1
         AI,R1    KN1
         AW,R2    R1
CHSTS1   EQU      %
         LB,R3    *R0,R1
         STB,R3   *R0,R2
         AI,R2    KN1
         AI,R1    KN1
         BGEZ     CHSTS1
         STB,R4   *R0              STORE BYTE COUNT AS FIRST CHAR
         B        *SR4
         PAGE
*F*
*F*      NAME:    CALENDTE
*F*
*F*      PURPOSE: TO GET THE NEXT FIELD ON THE CONTROL COMMAND AND
*F*               DETERMINE IF IT IS A LEGAL EXPIRATION DATE
*F*
*CALENDTE TESTS LEGALITY OF SPECIFIED EXPIRE DATE IN CPL BUFFER AND
*STORES LEGAL DATE.  ENTER WITH CPL ADDR IN R7, DESTINATION ADDR IN R0,
*CURRENT DELIMETER IN SR1 AND RETURN ADDR IN SR4. NORMAL EXIT = (SR4)+1
*
*  THIS ROUTINE NOW UPDATED TO ACCOMODATE OPTION(IN ASSIGN CMND)
*  OF THE FORM:  (EXPIRE,MM,DD,YY)    I.E. DATE
*     OR          (EXPIRE,DDD)      I.E. DAYS
*
CALENDTE EQU      %
         PUSH     SR4
         LI,R1    KN1               SET MONTH INDICATOR
CALEN1   EQU      %
         PUSH     R1
         PUSH     R0
         LI,SR2   KCOMMA
         BAL,SR4  CHARSCAN
         BCS,8    CALERC
         LI,SR2   NEVER
         BAL,SR4  QUOTSCAN
         BCS,8    CALEN2            BRANCH IF NEVER NOT SPEDIFIED
         PULL     R0
         LCI      K2
         LM,R2    PLB,R7
         STM,R2   *R0               STORE DATE = NEVER
         BUMP     -1,D2
         B        CALEN8
CALEN2   EQU      %
         BAL,SR4  DECSCAN
         BCS,8    CALERD
         MTW,0    EXDDDFLG
         BCS,3    CALEN21           DATE OR DAYS ALREADY DETERMINED
*GET THE DELIMETER THAT FOLLOWS
*  IF COMMA, DATE OPTION; IF RIGHT PAREN., DAYS OPTION
         LI,SR2   ')'               IS IT A RIGHT PAREN.
         BAL,SR4  CHARSCAN
         BCR,8    %+3
         MTW,-1   EXDDDFLG          NO,IT IS A COMMA  (DATE:-1)
         B        CALEN21
         LI,SR1   ')'               WILL LATER BE SCANNED FOR AGAIN
         MTW,1    EXDDDFLG          YES, IT IS THE DAYS OPTION (DAYS:1)
         LW,R3    CSL,R7            GET BYTE COUNT FROM BUF INCPL
         LW,R2    PLB,R7            GET NO. OF DAYS FROM BUF
         CI,R3    K1                1 DIGIT?
         BNE      %+4
         SCS,R2   K8                SHIFT TO BYTE 3
         OR,R2    =X'F0F000'        SET TO RIGHT FORMAT
         B        DDDSTR
         CI,R3    K2                2 DIGITS?
         BNE      %+4
         SCS,R2   K10               SHIFT TO BYTE 2 AND 3
         OR,R2    =X'F00000'        SET TO RIGHT FORMAT
         B        DDDSTR
         CI,R3    K3                3 DIGITS?
         BNE      DDDERV            > 3 DIGITS ,NOT ACCEPTABLE
         SCS,R2   K18               SHIFT TO BYTE 1,2 AND 3
DDDSTR   STW,R2   *R0               NOW IN VLP IMAGE
         LI,R2    X'40'             FIRST BYTE HAS TO BE A BLANK
         STB,R2   *R0
         LI,R1    1
         LW,R2    =X'F0F04040'
         STW,R2   *R0,R1            2ND WD IN DATE VLP SET TO BLANKS
CALEN21  PULL     R0
         PULL     R1
         MTW,0    EXDDDFLG
         BCS,1    %+2               NEGATIVE,DATE OPTION
         B        CALEN8            DAY OPTION COMPLETED
         LW,R2    PLB,R7            GET MONTH OR DAY FROM BUF
         LW,R4    CSL,R7            GET BYTE COUNT FROM BUF
         BIR,R1   CALEN3
         CI,R4    K1
         BNE      CALEN3            BRANCH IF FIELD >1 BYTE
         SCS,R2   K8
         AI,R1    K1
         CW,R2    BCZRO1
         BE       CALERV            ERROR IF MONTH OR DAY = 0
         B        CALEN4
CALEN3   EQU      %
         CI,R4    K2
         BNE      CALERV            ERROR IF FIELD >2 BYTES
         SCS,R2   K10
         BIR,R1   CALEN7            BRANCH IF YEAR INDICATED
         CW,R2    BCZRO2
         BE       CALERV            ERROR IF MONTH OR DAY = 00
CALEN4   EQU      %
         BDR,R1   CALEN5            BRANCH IF DAY INDICATED
         CW,R2    EMONTH
         BG       CALERV            ERROR IF MONTH >12
         B        CALEN6
CALEN5   EQU      %
         CW,R2    EDAY
         BG       CALERV            ERROR IF DAY > 31
CALEN6   EQU      %
         STH,R2   *R0,R1            STORE MONTH OR DAY
         CI,R1    K1
         BNE      CALEN1
         LI,R1    KN3               SET YEAR INDICATOR
         B        CALEN1
CALEN7   EQU      %
         LI,R1    K1
         STW,R2   *R0,R1            STORE YEAR
* HAVE TO CHANGE POSSIBLE BLANKS TO EBCDIC ZEROS
         LW,R2    =X'F0F0F0F0'
         OR,R2    *R0
         STW,R2   *R0
         LI,R1    1
         LW,R2    =X'F0F0F0F0'
         OR,R2    *R0,R1
         STW,R2   *R0,R1
CALEN8   EQU      %                 NORMAL RETURN
         LI,R1    0
         STW,R1   EXDDDFLG          RESET
         PULL     SR4
         AI,SR4   K1
         B        *SR4
CALERC   EQU      %                 ERROR, MISSING COMMA
*E*      MESSAGE: EXPECTED COMMA MISSING
         LI,SR3   COMERCD
         B        CALERD+1
CALERD   EQU      %                 ERROR, ILLEGAL DECIMAL NUMBER
*E*      MESSAGE: ILLEGAL DECIMAL NUMBER
         LI,SR3   DECERCD
         BUMP     -2,D2
         B        CALERR
CALERV   EQU      %                 ERROR, ILLEGAL VALUE FOR DATE
*E*      MESSAGE: ILLEGAL VALUE
         LI,SR3   VALERCD
         B        CALERR
DDDERV   EQU      %
*E*      MESSAGE: ILLEGAL VALUE
         PULL     R0
         PULL     R1
         LI,SR3   VALERCD
CALERR   EQU      GETLOC20
         B        GETLOC20
         PAGE
*F*
*F*      NAME:    SIXPACK
*F*
*F*      PURPOSE: TO HASH A SIX CHARACTER SERIAL NUMBER INTO ONE WORD
*F*
* SIXPACK HASHES A SIX CHARACTER SERIAL # TO 1 WORD
* R1=BYTE ADDRESS OF SERAL #
* R2=RESULTS
* CALL BAL,SR4    SIXPACK
*
         DEF      SIXPACK
SIXPACK  EQU      %
         PUSH     3,R3
         LI,R5    0
         LI,R4    6
SIXPACK1 EQU      %
         LB,R3    0,R1
         AI,R1    1
         SLS,R3   26
         SLD,R2   2
         SLS,R3   -28
         MI,R5    10
         AW,R5    R3
         BDR,R4   SIXPACK1
         SLS,R2   20
         OR,R2    R5
         PULL     3,R3
         B        *SR4
         PAGE
*F*
*F*      NAME:    WAMR
*F*
*F*      PURPOSE: TO WRITE THE ASSIGN-MERGE RECORD
*F*
*        WAMR - WRITES THE ASSIGN MERGE RECORD.
*        ENTER WITH
*                 (SR2) = BUFFER ADDRESS
*        EXIT WITH
*                 (SR3) = 0 IF NO A/M WRITE ERROR
*                       = PUTERCD IF A/M WRITE ERROR
*        CALL     BAL,SR4  WAMR
*
*
WAMR     EQU      %
         PUSH     R2
         LI,R2    WAMR15            ERROR/ABNORMAL ADDRESS
         CAL1,1   SETEABN
         DO       DEBUG
         M:OPEN   M:EO,(FILE,'AMREC'),(OUT),(CONSEC)
         M:WRITE  M:EO,(BUF,*SR2),(SIZE,2048)
         M:CLOSE  M:EO,(SAVE)
         ELSE
         CAL1,1   WRAMR             WRITE A/M RECORD
         FIN
         LI,SR3   0                 SET = 0, NO WRITE ERROR
WAMR10   EQU      %
         PULL     R2
         B        *SR4
WAMR15   EQU      %
*E*      MESSAGE: ERROR WRITING A/M
*E*               AN ERROR OCCURRED IN WRITING THE ASSIGN-MERGE RECORD
         LI,SR3   PUTERCD           ERROR WRITING A/M RECORD
         B        WAMR10
*
SETEABN  EQU      %
         GEN,8,24 X'06',M:EO
         GEN,2,30 3,0
         GEN,1,31 1,R2              ERROR ADDRESS
         GEN,1,31 1,R2              ABNORMAL ADDRESS
*
WRAMR    EQU      %
         GEN,8,24 X'2E',M:EO
         GEN,4,28 3,0
         GEN,1,31 1,SR2             BUFFER ADDRESS
         DATA     2048              BUFFER SIZE
         PAGE
*F*
*F*      NAME:    RAMR
*F*
*F*      PURPOSE: TO READ THE ASSIGN-MERGE RECORD
*F*
*        RAMR - READS THE ASSIGN MERGE RECORD
*             - SEVEN READ ATTEMPTS ARE MADE BY RAMR CAL
*        ENTER WITH
*                 (SR2) = BUFFER ADDRESS
*        EXIT WITH
*                 (SR3) = 0 IF NO A/M READ ERROR
*                       = GETERCD IF A/M READ ERROR
*        CALL     BAL,SR4  RAMR
*
*
RAMR     EQU      %
         PUSH     R2
         LI,R2    RAMR15            ERROR/ABNORMAL ADDRESS
         CAL1,1   SETEABN
         DO       DEBUG
         M:OPEN   M:EO,(FILE,'AMREC'),(IN)
         M:READ   M:EO,(BUF,*SR2),(SIZE,2048)
         M:CLOSE  M:EO,(SAVE)
         ELSE
         CAL1,1   RDAMR             READ A/M RECORD
         FIN
         LI,SR3   0                 SET = 0, NO READ ERROR
RAMR10   EQU      %
         PULL     R2
         B        *SR4
RAMR15   EQU      %
*E*      MESSAGE: ERROR READING A/M
*E*               AN ERROR OCCURRED IN READING THE ASSIGN-MERGE RECORD
         LI,SR3   GETERCD           ERROR READING A/M RECORD
         B        RAMR10
*
RDAMR    EQU      %
         GEN,8,24 X'2D',M:EO
         GEN,4,28 3,0
         GEN,1,31 1,SR2             BUFFER ADDRESS
         DATA     2048              BUFFER SIZE
         PAGE
*F*
*F*      NAME:    INDELIMS
*F*
*F*      PURPOSE: TO INCLUDE THE HYPHEN AND PLUS AS DELIMITERS AND
*F*               EXCLUDE THEM FROM THE LIST OF LEGAL ALPHANUMERIC
*F*               CHARACTERS.
*F*
*D*
*D*      NAME:    INDELIMS
*D*
*D*      REGISTERS: R1
*D*
*D*      CALL:    BAL,SR4 INDELIMS
*D*
*D*      INPUT:   R7=ADDRESS OF PARAMETER LIST
*D*
*D*      OUTPUT:  CHARACTER TABLE SET TO 0 FOR PLUS AND HYPHEN
*D*               PARAMETER TABLE DELIMITER COUNT INCREASED
*D*
*D*      DESCRIPTION: THE DELIMITER COUNT IN THE PARAMETER TABLE IS
*D*                   INCREASED BY TWO SO THAT THE HYPHEN AND PLUS ARE
*D*                   ARE CONSIDERED DELIMITERS. THE HYPHEN AND PLUS ARE
*D*                   EXCLUDED FROM THE LIST OF LEGAL ALPHANUMERIC
*D*                   CHARACTERS.
*D*
INDELIMS EQU      %
         PUSH     SR4
         MTB,2    *R7               INCREASE DELIMITER COUNT
         LI,SR4   0
         LI,R1    KHYPEN            REMOVE HYPHEN FROM CHAR. TABLE
         STB,SR4  CHTBL,R1
         LI,R1    KPLUS
         STB,SR4  CHTBL,R1          REMOVE PLUS FROM CHAR. TABLE
         PULL     SR4
         B        *SR4
         PAGE
*F*
*F*      NAME:    EXDELIMS
*F*
*F*      PURPOSE: TO EXCLUDE THE HYPHEN AND PLUS AS DELIMITERS AND
*F*               INCLUDE THEM IN THE LIST OF LEGAL ALPHANUMERIC
*F*               CHARACTERS.
*F*
*D*      NAME:    EXDELIMS
*D*
*D*      REGISTERS: R1
*D*
*D*      CALL:    BAL,SR4 EXDELIMS
*D*
*D*      INPUT:   R7=ADDRESS OF PARAMETER LIST
*D*
*D*      OUTPUT:  CHARACTER TABLE SET TO 3(LEGAL CHARACTER) FOR PLUS
*D*                  AND HYPHEN
*D*                  PARAMETER TABLE DELIMITER COUNT DECREASED
*D*
*D*      DESCRIPTION: THE DELIMITER COUNT IN THE PARAMETER TABLE IS
*D*                   DECREASED BY TWO SO THAT THE HYPHEN AND PLUS ARE
*D*                   NOT CONSIDERED DELIMITERS. THE HYPHEN AND
*D*                   PLUS ARE INCLUDED IN THE LIST OF LEGAL ALPHANUMERIC
*D*                   CHARACTERS.
*D*
EXDELIMS EQU      %
         PUSH     SR4
         MTB,-2   *R7               DECREASE DELIMITER COUNT
         LI,SR4   3
         LI,R1    KHYPEN            INCLUDE HYPHEN IN CHAR. TABLE
         STB,SR4  CHTBL,R1
         LI,R1    KPLUS             INCLUDE PLUS IN CHAR. TABLE
         STB,SR4  CHTBL,R1
         PULL     SR4
         B        *SR4
         PAGE
*F*
*F*      NAME:    CHKTERM
*F*
*F*      PURPOSE: TO DETERMINE IF A CONTROL COMMAND WAS TERMINATED BY A
*F*               PERIOD, END OF BUFFER(X'26') OR CARRIAGE RETURN.
*D*
*D*      NAME:    CHKTERM
*D*
*D*      REGISTERS: SR3
*D*
*D*      CALL:    BAL,SR4  CHKTERM
*D*
*D*      INPUT:   SR1=LAST CHARACTER SCANNED
*D*
*D*      OUTPUT:  SR3=TERMERCD IF ILLEGAL TERMINATOR
*D*               CC=0 IF LEGAL TERMINATOR
*D*               CC=1 IF ILLEGAL TERMINATOR
*D*
*D*      DESCRIPTION: THE CHARACTER SPECIFIED IN SR1 IS COMPARED WITH
*D*               THE LEGAL CONTROL COMMAND TERMINATORS AND CC1 SET OR
*D*               RESET ACCORDINGLY.
*D*
CHKTERM  EQU      %
         CI,SR1   KPERIOD           IS IT A PERIOD
         BE       CHKTERM5
         CI,SR1   KEOB              IS IT END OF BUFFER
         BE       CHKTERM5
         CI,SR1   KCRET             IS IT C/R
         BE       CHKTERM5
         LI,SR3   TERMERCD
*E*      MESSAGE: EXPECTED TERMINATOR MISSING
*E*      DESCRIPTION: THE CONTROL COMMAND WAS NOT TERMINATED BY A PERIOD
*E*               , END OF BUFFER(X'26'), OR CARRIAGE RETURN.
         LCI      K8                SET CC1=1 FOR ERROR
         B        *SR4
CHKTERM5 EQU      %
         LCI      K0                SET CC1=0 O.K.
         B        *SR4
         PAGE
*F*
*F*      PURPOSE: TO OPEN THE COMMAND FILE USING THE F:CF DCB AND SKIP TO
*F*               THE RECORD SPECIFIED IN THE ASSIGN/MERGE RECORD.
*F*
*D*
*D*      NAME:    OPNXS
*D*
*D*      REGISTERS: R1,R2,R3,R4,D1,D2,D3,D4
*D*
*D*      CALL:    BAL,SR4 OPNXS
*D*
*D*      INPUT:   R6=ADDRESS OF ASSIGN/MERGE RECORD
*D*               D3=ERROR ADDRESS TO BE PUT IN DCB
*D*               D4=ABNORMAL ADDRESS TO BE PUT IN DCB
*D*
*D*      OUTPUT:  SR3=ERROR CODE IF FILE NOT OPENED NOR RECORD FOUND
*D*               SR3=0 IF FILE OPENED AND RECORD FOUND
*D*
*D*      DESCRIPTION: THE FILE SPECIFIED IN THE ASSIGN/MERGE RECORD IS
*D*               OPENED AND POSITIONED TO THE RECORD SPECIFIED IN THE
*D*               ASSIGN/MERGE RECORD.
*D*
OPNXS    EQU      %
         PUSH     SR4
         LI,R1    F:CF              DCB
         LI,R2    K201              SET MODE IN EXCLUSIVE
         LI,R3    1                 SET ORG=CONSEC
         LI,R4    AM:CNAME          SET FILE NAME ADDR
         AW,R4    R6
         LI,D1    AM:CACCT          SET ACCOUNT ADR
         AW,D1    R6
         LW,D2    AM:CPASS,R6       CHECK IF PASSWORD
         BEZ      OPNXS5
         LI,D2    AM:CPASS          SET PASSWORD ADDR
         AW,D2    R6
OPNXS5   EQU      %
         BAL,SR4  OPNFD             OPEN FILE
         CI,SR3   0                 CHECK IF FILE OPENED
         BNE      OPNXS20
         LW,D1    AM:CREC,R6
         M:PRECORD F:CF,(N,*D1),(ABN,OPNXS15),(FWD) DETERMINE EXISTENCE
         LI,D1    1
         M:PRECORD F:CF,(N,*D1),(ABN,OPNXS15),(REV) POSITION TO REC'D
         LI,SR3   0
         PULL     SR4
         B        *SR4              RETURN
OPNXS15  EQU      %
*E*      MESSAGE: SPECIFIED COMMAND FILE RECORD DOESN'T EXIST
         LI,SR3   RDEXCD            RECORD DOESN'T EXIST
         B        OPNXS50
OPNXS20  EQU      %
         CI,SR3   3
         BNE      OPNXS25
*E*      MESSAGE: COMMAND FILE DOESN'T EXIST
         LI,SR3   FDEXM
         B        OPNXS50
OPNXS25  EQU      %
         CI,SR3   X'14'
         BNE      OPNXS30
*E*      MESSAGE: COMMAND FILE IS BUSY
         LI,SR3   FBUSYM
         B        OPNXS50
OPNXS30  EQU      %
         PUSH     SR3               SAVE ERR/ABN TEMPORARILY
         LI,R4    X'12'
         BAL,SR4  SERRLF            SET LIST FLAGS
*E*      MESSAGE: COMMAND FILE ACCESS DENIED
         LI,SR3   FADNDM
         BAL,SR4  ERRLIST
         PULL     SR3
         LW,D1    SR3
         SLS,D1   24
         BAL,D4   HEXBCD
         LI,R1    HA(ERRCODEM)+7    STORE ERROR CODE IN MESSAGE
         STH,D2   0,R1
         LI,SR3   ERRCODEM
OPNXS50  EQU      %
         PULL     SR4
         B        *SR4
         PAGE
*F*
*F*      PURPOSE: TO OUTPUT COMMAND FILE EXECUTION INFORMATION MESSAGES
*F*               WHICH INCLUDE THE FILE NAME AND RECORD NUMBER.
*F*
*D*
*D*      NAME:    WRCFM
*D*
*D*      REGISTERS: R0,R2,R4,D1,D4
*D*
*D*      CALL:    BAL,SR4  WRCFM
*D*
*D*      INPUT:   R6=A/M ADDRESS
*D*               D2=ERROR MESSAGE ADDRESS
*D*
*D*      OUTPUT:  EXECUTE FILE INFORMATION MESSAGE
*D*
*D*      DESCRIPTION: THE FILE AND RECORD CONTAINED IN THE ASSIGN-MERGE
*D*               RECORD IS INSERTED INTO THE SPECIFIED MESSAGE AND
*D*               OUTPUT ON THE LL DEVICE.
*D*
WRCFM    EQU      %
         PUSH     SR4
         PUSH     SR1               SAVE LAST CHAR. SCANNED
         CAL1,8   GETPAGE           GET A BUFFER
         BCS,8    WRCFM25
         LB,R1    *D2               MOVE MESSAGE TO BUFFER
         LB,D1    *D2,R1
         STB,D1   *SR2,R1
         BDR,R1   %-2
*
         PUSH     D2
         LW,D1    AM:CREC,R6        CONVERT RECORD TO BCD
         BAL,SR4  BINDCB
         LI,R4    10
         STW,D2   *SR2,R4           STORE INTO MESSAGE
         LW,D2    SR2
*
         SLS,D2   2                 CREATE DESTINATION BYTE ADDR
         AI,D2    6
         LW,D1    R6                CREATE SOURCE BYTE ADDR
         AI,D1    AM:CNAME
         SLS,D1   2
         LI,R2    AM:CNAME          GENERATE BYTE COUNT
         SLS,R2   2
         LB,R0    *R6,R2
         STB,R0   D2
         MBS,D1   1                 MOVE FILE NAME TO MESSAGE
* ELIMINATE BLANKS AFTER FILE NAME
         PULL     D1                CREATE SOURCE BYTE ADDRESS
         CI,D1    FEXECM            IS IT 'FILE EXECUTED' MSGE
         BNE      WRCFM10           NOPE
         LI,R0    NFEBYTES          BYTES TO MOVE
         LI,R4    SFEBYTE           STARTING BYTE
         B        WRCFM15
WRCFM10  EQU      %
         LI,R0    NFTBYTES          OUTPUTTING 'FILE TERMINATED' MSGE.
         LI,R4    SFTBYTE           STARTING BYTE
WRCFM15  EQU      %
         LW,D1    SR2
         SLS,D1   2
         AW,D1    R4                DESTINATION ADDRESS
         STB,R0   D2                NUMBER OF BYTES TO MOVE
         MBS,D1   0
*
         LW,R3    D2                CALCULATE MESSAGE LENGTH
         LW,D2    SR2
         SLS,D2   2
         SW,R3    D2
         AI,R3    -1
         LW,R2    SR2               RESTORE MESSAGE ADDRESS
         LI,R4    2
         LI,D4    1
         BAL,SR4  LIST+1            OUTPUT MESSAGE
         CAL1,8   FREEPAGE
WRCFM25  EQU      %
         PULL     SR1
         PULL     SR4
         B        *SR4
         END

