TITLE 'CHR'
R0       EQU   0         GENERAL REGISTER 0
R1       EQU   1         GENERAL REGISTER 1
R2       EQU   2         GENERAL REGISTER 2
R3       EQU   3         GENERAL REGISTER 3
R4       EQU   4         GENERAL REGISTER 4
R5       EQU   5         GENERAL REGISTER 5
R6       EQU   6         GENERAL REGISTER 6
R7       EQU   7         GENERAL REGISTER 7
R8       EQU   8         GENERAL REGISTER 8
R9       EQU   9         GENERAL REGISTER 9
R10      EQU   10        GENERAL REGISTER 10
R11      EQU   11        GENERAL REGISTER 11
R12      EQU   12        GENERAL REGISTER 12
R13      EQU   13        GENERAL REGISTER 13
R14      EQU   14        GENERAL REGISTER 14
R15      EQU   15        GENERAL REGISTER 15
         SPACE 2
CHR      CSECT
         SAVE  (14,12),,*               SAVE CALLER REGISTERS
         LR    R14,R13                  SAVE CALLER SAVE AREA
         CNOP  0,4
         BAL   R13,BEGIN-CHR(R15) BRANCH OVER SAVE AREA
         USING SAVEAREA,R13
SAVEAREA DS    18F                      SAVE AREA
VOLSER   DC    CL6' '
CCHHRX   DC    CL10'0'
CCHHR    DC    XL5'00'
GETCHR   CAMLST SEEK,CCHHR,VOLSER,READAREA
READAREA DS    140C
DSN      DC    C'DSN='
MSGDSN   DC    CL44' '
LDSN     EQU   *-DSN
ERR      DC    C'OBTAIN RETURNED '
RCX      DC    CL8' '
LERR     EQU   *-ERR
BADRC    DS    F
UNPKWK   DS    XL5'00'
HEXWK    DS    CL9
BEGIN    ST    R14,4(R13)               CHAIN SAVE AREAS
         ST    R13,8(R14)
         L     R15,0(,R1)                GET PARM
         LA    R8,8                      PARM ERROR 1
         LH    R3,0(R15)                 GET LENGTH
         LTR   R3,R3
         BZ    RETURN
         CH    R3,=H'16'                 WRONG SIZE?
         BNE   RETURN
         MVC   VOLSER(16),2(R15)         GET THE PARM
         LA    R8,12                     PARM ERROR 2
         LA    R15,CCHHRX                POINT TO INPUT PARM
         LA    R3,8                      SET GOOD ENUFF
         BAL   R6,PARMX
         ST    R5,CCHHR                  FIRST 4 BYTES
         LA    R15,CCHHRX+8              POINT TO INPUT PARM
         LA    R3,2                      SET GOOD ENUFF
         BAL   R6,PARMX
         STC   R5,CCHHR+4                LAST BYTE
         OBTAIN GETCHR                  READ DSCB AT CCHHR
         LTR   R8,R15                   DID IT WORK?
         BNZ   ERREXIT
         MVC   MSGDSN,READAREA          COPY DSN FROM FMT 1 DSCB
         CLI   MSGDSN,X'00'             DSN NOT PRESENT?
         BE    ERREXIT
         TPUT  DSN,LDSN
         B     RETURN
ERREXIT  ST    R8,BADRC
         LA    R2,BADRC
         BAL   R6,F2X
         MVC   RCX,HEXWK
         TPUT  ERR,LERR
RETURN   LR    R15,R8
         L     R13,4(R13)               RESTORE ORIGINAL SAVE AREA
         L     R14,12(R13)              RESTORE CALLER REGISTERS
         LM    R0,R12,20(R13)           RESTORE CALLER REGISTERS
         BR    R14                      RETURN TO CALLER
*** PROCESS HEX INPUT PARM
PARMX    SLR   R4,R4                     CLEAR A WORK REGISTER
         SLR   R5,R5                       AND ANOTHER
DOPARM   IC    R4,0(R15)                 GET A CHARACTER
         N     R4,=F'15'                 LOSE THE ZONE
         CLI   0(R15),C'0'               NUMERIC
         BNL   MVPSTC
         CLI   0(R15),C'F'               ALPAH
         BH    RETURN
         AH    R4,=H'9'                  1 GOES TO 10 ETC
MVPSTC   SLL   R5,4                      SHIFT BY NIBBLE
         ALR   R5,R4                     MOVE IN ANOTHER
         LA    R15,1(,R15)               GET NEXT BYTE
         BCT   R3,DOPARM
         BR    R6
*** CONVERT INPUT VALUE TO HEX
F2X      MVC   UNPKWK(4),0(R2)          COPY TO WORK AREA
         UNPK  HEXWK,UNPKWK             UNPACK IT
         SLR   R5,R5                    CLEAR FOR WORK
         LA    R3,7                     LOOP COUNTER
F2XCLI   LA    R4,HEXWK(R7)             GET NEXT CHARACTER
         CLI   0(R4),C'9'               IS IT OK?
         BNH   F2XNXT
         IC    R5,0(,R4)                PICK IT UP
         SH    R5,=H'57'                MAKE IT A-F
         STC   R5,0(,R4)                PUT IT BACK
F2XNXT   BCT   R3,F2XCLI                GO BACK
         BR    R6
         DROP  R13
         LTORG
         END   CHR