*                 CATALOG NO. 704902 - SIGMA 5/7 BPM M:CCISUBR
       CSECT       1
         SYSTEM   SIG7FDP
DEBUG    EQU      0
*
*
*        CCI  SUBROUTINES:
*                        DEVCK,         HEXCK,         OPLBTST,
*
*                        HEXBCD,        GETDECVAL,     DECCNV,
*
*                        WDTBLSRH,      GETDCBA,       TOPPAGE,
*
*                        EOCCSCAN,      GETACCN,       GETSN,
*
*                        LISTDATE,      GETHEXVAL,     BCDHEX,
*
*                        GETAVAL,       GETPASSW,      BINDECBCD
*
*                        GETLOC
*
*                       CHSTSHFT,     CALENDTE
*
*
         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      HEXCK,HEXBCD      902
         DEF      GETDECVAL,DECCNV,WDTBLSRH
         DEF      GETDCBA,TOPPAGE,EOCCSCAN
         DEF      GETACCN,GETSN,LISTDATE
         DEF      GETHEXVAL,BCDHEX,GETAVAL
         DEF      GETPASSW
         DEF      GETLOC,GETLOC1,GETLOC2,GETLOC3
         DEF      DCBCLS
         DEF      CHSTSHFT,CALENDTE
         DEF      GETVAL0,GETVAL4,GETACCN0,GETLOC20
         DEF      WAMR,RAMR
         DEF      INHYPHEN,EXHYPHEN
         REF      M:X1,PUTERCD,GETERCD
         SPACE    3
         REF      SYSID                                                 902
         REF      TSTACK
         REF      XFF
         REF      XFFFFFFFB
         REF      DSI
         REF      NXACTCHR,CHARSCAN,CHSTSCAN,DECSCAN,HEXSCAN
         REF     NAMSCAN
         REF      QUOTSCAN
           REF        Y002
         REF      FLAGS,CSL,PLB
         REF      COMERCD,DECERCD,VALERCD,HEXERCD,CHSTERCD
         REF      NAMERCD,RPERCD
         REF      Y4,Y1,Y04
         REF      Y2
         REF      ERRLFCK,LISTDCBT,LIST
         REF      X1FFFF                                                902
         REF      ANYSCAN,FLISTPPI
         REF      CHTBL
         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'
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      '-'
         SPACE    3
TEN15    DATA     10,15
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
**********************************************************************
*        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
**********************************************************************
*        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
**********************************************************************
*        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      %
         LI,SR3   COMERCD
         B        GETVAL3
GETVAL2  EQU      %
         LI,SR3   DECERCD
GETVAL3  EQU      %
         PULL     R1
         PULL     SR4
GETVAL4  EQU      %
         LCI      K8                SET CC1 = 1
BISR4    B        *SR4
*
GETVAL5  EQU      %
         LI,SR3   VALERCD
         B        GETVAL4
         PAGE
**********************************************************************
*        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
**********************************************************************
*        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
*        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
************************************************************************
*        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
**********************************************************************
*        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
*
*        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      %
         LI,SR3   NAMERCD           (SR3) = ILLEGAL NAME ERR CODE
         B        GETVAL4-1
         PAGE
*
*        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
         BNE      GETSN1
         B        COMEXIT1
         REF      COMEXIT1
         PAGE
*
*        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
         DEF      ONOFF
LSTDTCNT DATA     X'19404040'                                           902
IDM      TEXT     ' ID='                                                902
         PAGE
**********************************************************************
*        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
**********************************************************************
*        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
**********************************************************************
*        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
         B        GETVAL4-1
*
GETAVAL1 EQU      %
         LI,SR3   COMERCD
         B        GETAVAL3
*
GETAVAL2 EQU      GTHXVL1
GETAVAL3 EQU      GETVAL4-1
         PAGE
*        GETPASSW  GET FILE PASSWORD
*
GETPASSW EQU      %
         PUSH     SR4
         LW,R1    Y4
         STS,R1   FLAGS,R7          SET BLANK-OUT FLAG
         BAL,SR4  CHSTSCAN
         STCF     R4
         BCR,8    GETPASSW1
         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
*
*
*        DCBCLS  -  CLOSE  CCI  OUTPUT  DCB'S
*
*
*
*
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
*
*        GETLOC  -  GET RELATIVE OR ABSOLUTE HEXIDECIMAL LOCATION
*
*
*
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,8    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,8    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      %
         LI,SR3   NAMERCD
         B        GETLOC34
*
GETLOC32 EQU      %
         LI,SR3   RPERCD
*
GETLOC34 EQU      %
         PULL     R3
         PULL     R6
         B        GETLOC20
         PAGE
*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
*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
         LI,SR3   COMERCD
         B        CALERD+1
CALERD   EQU      %                 ERROR, ILLEGAL DECIMAL NUMBER
         LI,SR3   DECERCD
         BUMP     -2,D2
         B        CALERR
CALERV   EQU      %                 ERROR, ILLEGAL VALUE FOR DATE
         LI,SR3   VALERCD
         B        CALERR
DDDERV   EQU      %
         PULL     R0
         PULL     R1
         LI,SR3   VALERCD
CALERR   EQU      GETLOC20
         B        GETLOC20
         PAGE
* 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
*        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
         NOP
         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      %
         LI,SR3   PUTERCD           ERROR WRITING A/M RECORD
         B        WAMR10
*
SETEABN  EQU      %
         GEN,8,24 X'06',M:X1
         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:X1
         GEN,4,28 3,0
         GEN,1,31 1,SR2             BUFFER ADDRESS
         DATA     2048              BUFFER SIZE
         PAGE
*        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
         CAL1,1   RDAMR             READ A/M RECORD
         LI,SR3   0                 SET = 0, NO READ ERROR
RAMR10   EQU      %
         PULL     R2
         B        *SR4
RAMR15   EQU      %
         LI,SR3   GETERCD           ERROR READING A/M RECORD
         B        RAMR10
*
RDAMR    EQU      %
         GEN,8,24 X'2D',M:X1
         GEN,4,28 3,0
         GEN,1,31 1,SR2             BUFFER ADDRESS
         DATA     2048              BUFFER SIZE
         PAGE
*        INHYPHEN INCLUDE HYPHEN
*                 EXCLUDES HYPHEN AS A LEGAL ALPHANUMERIC CHARACTER AND
*                 INCLUDES HYPHEN AS A DELIMITER.
*        ENTER WITH
*                 (R7) = ADR OF PARAM LIST
*        CALL     BAL,SR4  INHYPHEN
*
*
INHYPHEN EQU      %
         PUSH     SR4
         MTB,1    *R7               MAKE HYPHEN A DELIMITER
         LI,SR4   0                 MAKE HYPHEN AN ILLEGAL ALPHANUMERIC
         LI,R1    KHYPEN            CHAR.
         STB,SR4  CHTBL,R1
         PULL     SR4
         B        *SR4
         PAGE
*        EXHYPHEN EXCLUDE HYPHEN
*                 INCLUDES HYPHEN AS A LEGAL ALPHANUMERIC CHARACTER AND
*                 EXCLUDES HYPHEN AS A DELIMITER.
*        ENTER WITH
*                 (R7) = ADR OF PARAM LIST
*        CALL     BAL,SR4  EXHYPHEN
*
*
EXHYPHEN EQU      %
         PUSH     SR4
         MTB,-1   *R7               ELIMINATE HYPHEN AS A DELIMITER
         LI,SR4   3                 MAKE HYPHEN A LEGAL ALPHANUMERIC
         LI,R1    KHYPEN            CHAR.
         STB,SR4  CHTBL,R1
         PULL     SR4
         B        *SR4
         END

