         PROC  &CD,0,              OS/3 DM CARD SYSTEM                 XCDI00010
               &CMBND=,&CONTROL=,&INPT=,&LIST=,&MUXPER=,               XCDI00020
               &OUPT=,&SECT=YES                                         CDI00030
CDIO     NAME                                                           CDI00040
         GBL   &SDR$CD1                                                 CDI00050
         GBL   &DU$SA                   GBL TO PREVENT 2 SA$DSECT CALLS CDI00060
         LCL   &SFAC                                                    CDI00070
         LCL   &SIN,&SOU,&SCB                                           CDI00080
         LCL   &SLST,&SCNT                                              CDI00090
         LCL   &SMUX                                                    CDI00100
         DO    '&SDR$CD1'=''                                            CDI00110
&SDR$CD1 SET   0                                                        CDI00120
&SFAC    SET   0                                                        CDI00130
&SIN     SET   0                                                        CDI00140
&SCNT    SET   0                                                        CDI00150
&SOU     SET   0                                                        CDI00160
&SCB     SET   0                                                        CDI00170
&SLST    SET   0                                                        CDI00180
&SMUX    SET   0                                                        CDI00190
         DO    '&LIST'='YES'                                            CDI00200
&SLST    SET   1                        PRINT GEN FOR DSECTS            CDI00210
         ENDO                                                           CDI00220
         DO    ('&INPT'=''=0)++(('&OUPT'='')**('&CMBND'=''))            CDI00230
&SIN     SET   1                                                        CDI00240
&SFAC    SET   &SFAC+1                                                  CDI00250
         ENDO                                                           CDI00260
         SPACE 3                                                        CDI00270
         DO    '&SECT'='YES'=0                                          CDI00280
         DS    0H                                                       CDI00290
         ENDO                                                           CDI00300
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *  *  CDI00310
*                                                                    *  CDI00320
*   THE FOLLOWING PROGRAMS ARE THE SOLE PROPERTY OF SPERRY           *  CDI00330
*                                                                    *  CDI00340
* UNIVAC CONTAINING ITS PROPRIETARY, CONFIDENTIAL INFORMATION        *  CDI00350
*                                                                    *  CDI00360
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *  *  CDI00370
*                                                                       CDI00380
*                                                                       CDI00390
*        DATA MANAGEMENT CARD SYSTEM                                    CDI00400
*                                                                       CDI00410
*                                                                       CDI00420
         SPACE                                                          CDI00430
*#       N     'CARD SYSTEM COMMON ROUTINE'                             CDI00440
         SPACE                                                          CDI00450
         DO    '&INPT'=''=0                                             CDI00460
         DO    '&INPT'='YES'=0                                          CDI00470
         PNOTE *,'INPT SPECIFICATION MISSPELLED. ACCEPTED AS INPT=YES'  CDI00480
         ENDO                                                           CDI00490
         ENDO                                                           CDI00500
         DO    '&OUPT'=''=0                                             CDI00510
&SFAC    SET   &SFAC+2                                                  CDI00520
&SOU     SET   1                                                        CDI00530
         DO    '&OUPT'='YES'=0                                          CDI00540
         PNOTE *,'OUPT SPECIFICATION MISSPELLED. ACCEPTED AS OUPT=YES'  CDI00550
         ENDO                                                           CDI00560
         ENDO                                                           CDI00570
         DO    '&CONTROL'=''=0                                          CDI00580
         DO    ('&OUPT'='')**('&CMBND'='')                              CDI00590
         PNOTE *,'CONTROL SPECIFIED FOR INPT SYSTEM. IGNORED.'          CDI00600
         GOTO  .F1                                                      CDI00610
         ENDO                                                           CDI00620
&SFAC    SET   &SFAC+4                                                  CDI00630
&SCNT    SET   1                                                        CDI00640
&SMUX    SET   1                                                        CDI00650
         DO    '&CONTROL'='YES'=0                                       CDI00660
         PNOTE *,'CONTROL SPECIFICATION MISSPELLED. ACCEPTED AS CONTROLXCDI00670
               =YES'                                                    CDI00680
         ENDO                                                           CDI00690
         ENDO                                                           CDI00700
.F1      LABEL                                                          CDI00710
         DO    '&CMBND'=''=0                                            CDI00720
&SFAC    SET   &SFAC+8                                                  CDI00730
&SCB     SET   1                                                        CDI00740
         DO    '&CMBND'='YES'=0                                         CDI00750
         PNOTE *,'CMBND SPECIFICATION MISSPELLED. ACCEPTED AS CMBND=YESXCDI00760
               '                                                        CDI00770
         ENDO                                                           CDI00780
         ENDO                                                           CDI00790
         DO    '&MUXPER'=''=0                                           CDI00800
&SMUX    SET   1                                                        CDI00810
         DO    '&MUXPER'='YES'=0                                        CDI00820
         PNOTE *,'MUXPER SPECIFICATION MISSPELLED.'                     CDI00830
         PNOTE *,'ACCEPTED AS MUXPER=YES.'                              CDI00840
         ENDO                                                           CDI00850
         ENDO                                                           CDI00860
         DO    '&SECT'='YES'                                            CDI00870
DR$COM&SFAC  CSECT                                                      CDI00880
         ENDO                                                           CDI00890
         DO    '&SECT'='YES'=0                                          CDI00900
DR$COM&SFAC   EQU  *                                                    CDI00910
         ENTRY DR$COM&SFAC                                              CDI00920
         ENDO                                                           CDI00930
         DO    (&SFAC=1=0)**(&SFAC=2=0)**(&SFAC=8=0)**(&SFAC=12=0)      CDI00940
         DO    &SFAC**X'01'                                             CDI00950
DR$COM1  EQU   *                                                        CDI00960
         ENTRY DR$COM1                                                  CDI00970
         ENDO                                                           CDI00980
         DO    &SFAC**X'02'=X'02'                                       CDI00990
DR$COM2  EQU   *                                                        CDI01000
         ENTRY DR$COM2                                                  CDI01010
         ENDO                                                           CDI01020
         DO    (&SFAC**X'03'=X'03')**(&SFAC=3=0)                        CDI01030
DR$COM3  EQU   *                                                        CDI01040
         ENTRY DR$COM3                                                  CDI01050
         ENDO                                                           CDI01060
         DO    (&SFAC**X'06'=X'06')**(&SFAC=6=0)                        CDI01070
DR$COM6  EQU   *                                                        CDI01080
         ENTRY DR$COM6                                                  CDI01090
         ENDO                                                           CDI01100
         DO    (&SFAC**X'07'=X'07')**(&SFAC=7=0)                        CDI01110
DR$COM7  EQU   *                                                        CDI01120
         ENTRY DR$COM7                                                  CDI01130
         ENDO                                                           CDI01140
         DO    &SFAC**X'08'=X'08'                                       CDI01150
DR$COM8  EQU   *                                                        CDI01160
         ENTRY DR$COM8                                                  CDI01170
         ENDO                                                           CDI01180
         DO    &SFAC**X'0C'=X'0C'                                       CDI01190
DR$COM12 EQU   *                                                        CDI01200
         ENTRY DR$COM12                                                 CDI01210
         ENDO                                                           CDI01220
         ENDO                                                           CDI01230
         SPACE                                                          CDI01240
         USING *,15                                                     CDI01250
         USING DM$DSCT,1                                                CDI01260
         USING SA$DSECT,13                                              CDI01270
         SPACE                                                          CDI01280
         B     DR$C005                                                  CDI01290
         DC    XL3'4008F0'                                              CDI01300
         DC    AL1(&SFAC)                                               CDI01310
         DC    XL2'6701'                76/7/1
         EJECT                                                          CDI01330
*#       N     'STORE USER REGISTERS'                                   CDI01340
         SPACE                                                          CDI01350
DR$C005  EQU   *                                                        CDI01360
DR$C010  TSTBIT DR$B500,DC$CCB     . # D DR$C020 NO YES 'SAVAREA KEYWO# CDI01370
         BZ    DR$C020             . # RD SPECIFIED?'                   CDI01380
         ST    13,DR$SAVR          . # P 'STORE REG 13 IN DTF'          CDI01390
         L     13,DR$SAV           . # P 'SAVE AREA ADDR FR DTF TO R13' CDI01400
DR$C020  STM   14,12,12(13)        . # P 'SAVE USER''S REGISTERS'       CDI01410
         LA    12,DR$C080          . #.X P 'ADDR RETURN SUBRTN TO R12'  CDI01420
         ST    14,SA$R15                                                CDI01430
         MVI   DR$EFG,X'00'        . # P 'RESET ERROR FLAG BITS'        CDI01440
         SPACE                                                          CDI01450
*#       N     'CHECK FOR OPEN FILE'                                    CDI01460
         SPACE                                                          CDI01470
         TSTBIT  DR$B110,DC$CCB    . # D DR$C100 NO YES 'FILE OPEN?'    CDI01480
         BO    DR$C100                                                  CDI01490
DR$C040  MVI   DR$ERR,DR$E13       . # P 'FILE NOT OPEN CHAR TO DTF'    CDI01500
         SETBIT DR$EF60,DC$CCB     . # P 'SET INVALID IMP MACRO ERFLB'  CDI01510
         SPACE 3                                                        CDI01520
******************************                                          CDI01530
*# N 'ERROR SUBROUTINE'      *                                          CDI01540
******************************                                          CDI01550
DR$C050  EQU   *                   . # N                                CDI01560
         MVC   DR$EFG+1(1),DC$T         MOVE TRAFFIC BYTE TO ERR FLAG   CDI01570
         NI    DC$T,X'80'               RESET TRAFFIC BYTE ERROR FLAGS  CDI01580
         TSTBIT DR$B300,DC$CCB     . # D REF.AA1 NO YES 'USER ERROR RT# CDI01590
         BZ    DR$C070             . # N?'                              CDI01600
         TSTBIT DR$B500,DC$CCB     . # D DR$C060 NO YES 'SAVAREA SPEC?' CDI01610
         BZ    DR$C060                                                  CDI01620
         LM    14,12,12(13)        . # P 'RESTORE REG'                  CDI01630
         L     13,DR$SAVR          . # P 'RESTORE USERS R13'            CDI01640
         SVC   61                  . # B EXIT  'MSG TRANSIENT'          CDI01650
DR$C060  EQU   *                   . # N                                CDI01660
         LM    14,12,12(13)        . # P 'RESTORE USER REG'             CDI01670
         SVC   61                  . # B EXIT 'MSG TRANSIENT'           CDI01680
DR$C070  EQU   *                   . # N                                CDI01690
         LR    14,12                                                    CDI01700
         SVC   61                                                       CDI01710
*#REF.AA1   S  'MSG TRANSIENT'                                          CDI01720
         SPACE 3                                                        CDI01730
*************************                                               CDI01740
*#  N 'RETURN SUBRTN'   *                                               CDI01750
*************************                                               CDI01760
DR$C080  EQU   *                   . # N                                CDI01770
         TSTBIT DR$B500,DC$CCB     . # D DR$C090 NO YES 'SAVAREA SPEC?' CDI01780
         BZ    DR$C090                                                  CDI01790
         LM    14,12,12(13)        . # P 'RESTORE USER REG'             CDI01800
         L     13,DR$SAVR          . # P 'RESTORE USERS R13'            CDI01810
         BR    15                  . # B EXIT 'RETURN TO USER PROG'     CDI01820
DR$C090  EQU   *                   . # N                                CDI01830
         LM    14,12,12(13)        . # P 'RESTORE USER REG'             CDI01840
         BR    15                  . # B EXIT 'RETURN TO USER PROG'     CDI01850
         EJECT                                                          CDI01860
*#       N     'IMPERATIVE MACRO INTERPRETATION'                        CDI01870
         SPACE 2                                                        CDI01880
DR$C100  EQU   *                                                        CDI01890
         DO    &SOU                . # N 'OUPT DEPENDENT CODE'          CDI01900
         TSTBIT DR$B100,DC$CCB     . # D DR$C110 NO YES 'OUTPUT FILE'   CDI01910
         BZ    DR$C110                                                  CDI01920
         CLI   DR$REQS,X'20'       . # D REF.RC8 YES NO 'PUT ?'         CDI01930
         BE    DC$P000                                                  CDI01940
         DO    &SCNT               . # N 'CONTROL DEP CODE'             CDI01950
         CLI   DR$REQS,X'4A'       . # D REF.RC9 YES NO 'CNTRL ?'       CDI01960
         BE    DR$CN00                                                  CDI01970
         ENDO                      . # N 'END CONTROL DEP CODE'         CDI01980
DR$C110  EQU   *                   . # N                                CDI01990
         SPACE                                                          CDI02000
         ENDO                      . # N 'END OUPT DEP CODE'            CDI02010
         DO    &SIN                . # N 'INPT DEP CODE'                CDI02020
         TSTBIT DR$B170,DC$CCB     . # D DR$C120  NO YES 'INPUT FILE?'  CDI02030
         BZ    DR$C120                                                  CDI02040
         CLI   DR$REQS,X'10'       . # D REF.RC7 YES NO 'GET ?'         CDI02050
         BE    DR$G000                                                  CDI02060
DR$C120  EQU   *                   . # N                                CDI02070
         SPACE                                                          CDI02080
         ENDO                      . # N 'END INPT DEP CODE'            CDI02090
         DO    &SCB                . # N 'CMBND DEP CODE'               CDI02100
         TSTBIT DR$B160,DC$CCB     . # D DR$C130 NO YES 'COMBINED FILE' CDI02110
         BZ    DR$C130                                                  CDI02120
         CLI   DR$REQS,X'20'       . # D REF.RC11 YES NO 'PUT ?'        CDI02130
         BE    DQ$P000                                                  CDI02140
         CLI   DR$REQS,X'10'       . # D REF.RC10 YES NO  'GET ?'       CDI02150
         BE    DQ$G000                                                  CDI02160
         DO    &SCNT               . # N 'CONTROL DEP CODE'             CDI02170
         CLI   DR$REQS,X'4A'       . # D REF.RC9  YES NO  'CNTRL ?'     CDI02180
         BE    DR$CN00                                                  CDI02190
         ENDO                      . # N 'END CONTROL DEP CODE'         CDI02200
DR$C130  EQU   *                   . # N                                CDI02210
         SPACE                                                          CDI02220
         ENDO                      . # N 'END CMBND DEP CODE'           CDI02230
DR$C300  EQU   *                   . # N                                CDI02240
         MVI   DR$ERR,DR$E14       . # P 'INVALID IMPER MACRO ERR CD  # CDI02250
*#DTF'                                                                  CDI02260
         SETBIT DR$EF60,DC$CCB     . # P 'SET ERROR FLAG'               CDI02270
         B     DR$C050             . # B DR$C050  'ERROR RTN'           CDI02280
         DO    0                                                        CDI02290
*#REF.RC7 B DR$G000 'GET ROUTINE'                                       CDI02300
*#REF.RC8 B DR$P000 'PUT ROUTINE'                                       CDI02310
*#REF.RC9 B DR$CN00 'CONTROL ROUTINE'                                   CDI02320
*#REF.RC10 B DQ$G000 'CMBND GET RTN'                                    CDI02330
*#REF.RC11 B DQ$P000 'CMBND PUT RTN'                                    CDI02340
         ENDO                                                           CDI02350
         EJECT                                                          CDI02360
*        TRANSLATION, BUFFER SWAP, AND CCW SWAP SUBROUTINES             CDI02370
*                                                                       CDI02380
*              ALSO MOVE AND TRANSLATE INSTRUCTIONS USED WITH EX INSTR  CDI02390
         SPACE 2                                                        CDI02400
         DO    &SOU++&SCB               COMBINED AND OUTPUT FILES       CDI02410
DR$AE    EQU   *                        ASCII TO EBCDIC TRANSLATION     CDI02420
*                                       REG 2 IS USED TO STORE REG 1    CDI02430
*                                       NO OF BYTES IS IN REG 6         CDI02440
         TSTBIT DR$B580,DC$CCB          IF INHIBIT DM TRANSLATE BIT     CDI02450
         BOR   14                       IS SET RETURN INLINE            CDI02460
         LR    0,6                      BYTE COUNT TO R0                CDI02470
         LR    2,1                      STORE REG 1                     CDI02480
         LR    1,7                      DATA ADDR TO R1                 CDI02490
         AETRAN (1),(0)                 ASC TO EBCDIC TRANSLATION       CDI02500
         LR    1,2                      RESTORE R1                      CDI02510
         BR    14                                                       CDI02520
         SPACE 2                                                        CDI02530
DR$CE    EQU   *                        COMPRESSED CODE TO EBCDIC TRANS CDI02540
*                                       REG 2 IS USED TO STORE REG 1    CDI02550
*                                       REG 6 CONTAINS NO OF BYTES      CDI02560
         TSTBIT DR$B580,DC$CCB          IF INHIBIT DM TRANSLATE BIT     CDI02570
         BOR   14                       IS SET RETURN INLINE            CDI02580
         LR    0,6                                                      CDI02590
         LR    2,1                                                      CDI02600
         LR    1,7                                                      CDI02610
         DM$TCE (1),(0)                 COMP TO EBCDIC TRANS            CDI02620
         LR    1,2                                                      CDI02630
         BR    14                                                       CDI02640
*                                                                       CDI02650
*        OUTPUT MOVE INSTRUCTION                                        CDI02660
*                                                                       CDI02670
DR$OM    MVC   0(1,7),0(10)             FROM WORK AREA TO I/O AREA      CDI02680
         ENDO                                                           CDI02690
         DO    &SIN++&SCB               INPUT OR COMBINED               CDI02700
DR$EA    EQU   *                        EBCDIC TO ASCII TRANSLATION     CDI02710
         TSTBIT DR$B580,DC$CCB          IF INHIBIT DM TRANSLATION BIT   CDI02720
         BOR   14                       IS SET RETURN INLINE            CDI02730
         LR    0,6                                                      CDI02740
         LR    2,1                      SAVE CONT OF R1                 CDI02750
         LR    1,7                                                      CDI02760
         EATRAN (1),(0)                 EBCDIC TO ASCII TRANSLATION     CDI02770
         LR    1,2                                                      CDI02780
         BR    14                                                       CDI02790
         SPACE 2                                                        CDI02800
DR$EC    EQU   *                        EBCDIC TO COMPRESSED CODE TRANS CDI02810
         TSTBIT DR$B580,DC$CCB                                          CDI02820
         BOR   14                                                       CDI02830
         LR    0,6                                                      CDI02840
         LR    2,1                                                      CDI02850
         LR    1,7                                                      CDI02860
         DM$TEC  (1),(0)                EBCDIC TO COMP CDE TRANS        CDI02870
         LR    1,2                                                      CDI02880
         BR    14                                                       CDI02890
*                                                                       CDI02900
*        INPUT MOVE INSTRUCTION                                         CDI02910
*                                                                       CDI02920
DR$IM    MVC   0(1,10),0(7)             I/O AREA TO WORK AREA           CDI02930
         ENDO                                                           CDI02940
         DO    &SIN++&SOU               INPUT OR OUTPUT                 CDI02950
         SPACE 2                                                        CDI02960
*                                                                       CDI02970
*        BUFFER SWAP ROUTINE                                            CDI02980
*                                                                       CDI02990
DR$BS    XC    DR$CCW1+1(3),DR$BAS+1                                    CDI03000
         XC    DR$BAS+1(3),DR$CCW1+1                                    CDI03010
         EX    0,DR$BS                                                  CDI03020
         BR    14                                                       CDI03030
         ENDO                                                           CDI03040
         DO    &SOU                     OUTPUT                          CDI03050
         SPACE 2                                                        CDI03060
*                                                                       CDI03070
*        PUNCH RETRY CCW SWAP ROUTINE                                   CDI03080
*                                                                       CDI03090
DR$CWS   XC    DR$CCW1(8),DR$CCW2                                       CDI03100
         XC    DR$CCW2(8),DR$CCW1                                       CDI03110
         EX    0,DR$CWS                                                 CDI03120
         BR    4                        RETURN                          CDI03130
         ENDO                                                           CDI03140
         SPACE 2                                                        CDI03150
*                                                                       CDI03160
*        TRANSLATE INSTRUCTION FOR MODE=TRANS                           CDI03170
*                                                                       CDI03180
*              TRANSLATE TABLE ADDRESS IN REG 2                         CDI03190
*                                                                       CDI03200
DR$TR    TR    0(1,7),0(2)                                              CDI03210
         DO    &SIN++&SOU               INPUT AND OUTPUT                CDI03220
         SPACE 2                                                        CDI03230
DR$IR    EQU   *                        I/O REGISTER SUBROUTINE         CDI03240
         CLI   DR$IRG,68                IF  IOREG NOT 13                CDI03250
         BH    DR$IR05                  THEN                            CDI03260
         SR    2,2                                                      CDI03270
         IC    2,DR$IRG                                                 CDI03280
         LR    3,11                                                     CDI03290
         SR    3,9                                                      CDI03300
         ST    3,0(2,13)                I/O REG TO SAVE AREA            CDI03310
         BR    14                                                       CDI03320
DR$IR05  EQU   *                        ELSE                            CDI03330
         ST    3,DR$SAVR                I/O REG TO DTF                  CDI03340
         BR    14                                                       CDI03350
         ENDO                                                           CDI03360
         DO    &SCNT               . # N 'CONTROL DEP CODE'             CDI03370
         EJECT                                                          CDI03380
*                                                                       CDI03390
*        CONTROL ROUTINE                                                CDI03400
*                                                                       CDI03410
DR$CN00  EQU   *                   . # N                                CDI03420
         TSTBIT  DR$B200,DC$CCB                                         CDI03430
         BZ    DR$C300                  IF CONTROL SPECIFIED            CDI03440
         TSTBIT  DR$B650,DC$CCB                                         CDI03450
         BZ    DR$C300                  AND IF GET OR PUT ISSUED THEN   CDI03460
         TSTBIT DR$B510,DC$CCB     . # D DR$C080 YES NO 'OPTIONAL PROC# CDI03470
         BOR   12                  . # ESSING?'                         CDI03480
         DO    &SCB                                                     CDI03490
         TSTBIT  DR$B160,DC$CCB                                         CDI03500
         BZ    DR$CN005                 FOR CMBND FILES                 CDI03510
         SETBIT  DR$B230,DC$CCB         SET CNTRL MACRO ISSUED BIT      CDI03520
DR$CN005 EQU   *                                                        CDI03530
         ENDO                                                           CDI03540
         TSTBIT DR$B570,DC$CCB     . # D DR$C080 NO YES 'SELECTABLE ST# CDI03550
         BZR   12                  . # ACKER ?'                         CDI03560
         LTR   0,0                 . # D DR$CN010 NO YES 'SELECT STACK# CDI03570
         BZ    DR$CN010            . # ER ?'                            CDI03580
         SETBIT DR$B220,DC$CCB                                          CDI03590
         BR    12                  . # B DR$C080                        CDI03600
DR$CN010 EQU   *                   . # N                                CDI03610
         CLRBIT DR$B220,DC$CCB                                          CDI03620
         BR    12                  . # B DR$C080                        CDI03630
         ENDO                      . # N  'END CONTROL DEP CODE'        CDI03640
         DO    &SIN                                                     CDI03650
         EJECT                     * . # E                              CDI03660
*#       N     'INPUT FILE GET ROUTINE'                                 CDI03670
         SPACE 2                                                        CDI03680
DR$G000  EQU   *                                                        CDI03690
         LH    5,DR$RCS                 TRAN LENGTH - 1                 CDI03700
         LA    6,1(0,5)                 TRANS LENGTH                    CDI03710
         L     7,DR$CCW1                DATA ADDR TO R7                 CDI03730
         SR    9,9                      RLA                             CDI03740
         LR    10,0                     WORK ADDR TO R10                CDI03750
         LR    11,7                                                     CDI03760
         TSTBIT DR$B270,DC$CCB     . # D DR$G030 YES NO 'EOF SET?'      CDI03770
         BO    DR$G030                                                  CDI03780
         TSTBIT DR$B134,DC$CCB     . # D DR$G010 YES NO 'IOA2 AND/OR W# CDI03790
         BNZ   DR$G010             . # ORK SPECIFIED?'                  CDI03800
         TSTBIT  DR$B600,DC$CCB    . # D DR$G003 NO YES 'SKIP 1ST EXCP' CDI03805
         BZ    DR$G003
         CLRBIT  DR$B600,DC$CCB    . # P  'CLEAR SKIP 1ST EXCP BIT'
         B     DR$G010             . # B DR$G010
DR$G003  EQU   *                   . # N
DR$G005  EXCP  (1)                 . # I 'READ A CARD'                  CDI03810
DR$G010  WAIT  (1),DR$E000         . # D DR$E000 ERR OK 'WAIT'          CDI03820
         TSTBIT DR$B460,DC$CCB     . # D DR$G012 NO YES 'ASCII=YES SPE# CDI03830
         BZ    DR$G012             . # CIFIED?'                         CDI03840
         BAL   14,DR$EA                 EBCDIC TO ASCII TRANS SUBRTN    CDI03850
DR$G012  EQU   *                                                        CDI03860
DR$G013  TSTBIT DR$B340,DC$CCB     . # D DR$G015 NO YES 'MODE=CC?'      CDI03870
         BZ    DR$G015                                                  CDI03880
         BAL   14,DR$EC                 EBCDIC TO COMP CD TRANS SUBRTN  CDI03890
DR$G015  TSTBIT DR$B140,DC$CCB     . # D DR$G020 NO YES 'IOA2 SPECIFIE# CDI03900
         BZ    DR$G020             . # D?'                              CDI03910
         BAL   14,DR$BS                 SWAP BUFFERS                    CDI03920
DR$G020  EQU   *                   . # N                                CDI03930
         SR    2,2                                                      CDI03940
         IC    2,DR$EFDSP                                               CDI03950
         LA    3,DR$EFM                                                 CDI03960
         AR    3,2                                                      CDI03970
         CLC   0(4,7),0(3)         . # D DR$G040 NO YES 'TH IMAGE IN T# CDI03980
         BNE   DR$G040             . # OAREA A END OF FILE?'            CDI03990
DR$G030  SETBIT DR$B270,DC$CCB     . # P 'SET EOF BIT IN DTF'           CDI04000
         L     2,DR$EFA            . # P 'SET EOF RTN ADDR TO R15'      CDI04010
         ST    2,SA$R15                                                 CDI04020
         BR    12                  . # B DR$C080 'RETURN SUBRTN'        CDI04030
*# N 'BRANCH TO USER EOF RTN VIA RETURN SUBRTN'                         CDI04040
DR$G040  EQU   *                                                        CDI04050
         TSTBIT DR$B370,DC$CCB     . # D DR$G042 NO YES 'MODE=TRANS?'   CDI04060
         BZ    DR$G042                                                  CDI04070
         L     2,DR$ITB                                                 CDI04080
         EX    5,DR$TR                  TRANSLATE DATA                  CDI04090
DR$G042  TSTBIT DR$B130,DC$CCB     . # D DR$G050 NO YES 'WORK=YES SPEC# CDI04100
         BZ    DR$G050             . # IFIED?'                          CDI04110
         LH    2,DR$BKS                 MOVE LENGTH                     CDI04115
         BCTR  2,0
         EX    2,DR$IM                  MOVE DATA TO WORK AREA          CDI04120
         B     DR$G070             . # B DR$G070                        CDI04130
DR$G050  TSTBIT DR$B440,DC$CCB     . # D DR$G060 NO YES 'IORG SPECIFIE# CDI04140
         BZ    DR$G060             . # D?'                              CDI04150
         BAL   14,DR$IR                 I/O REGISTER SUBRTN             CDI04160
DR$G060  TSTBIT DR$B134,DC$CCB     . # D DR$G080 NO YES 'IOA2 AND/OR W# CDI04170
         BZ    DR$G080             . # ORK SPECIFIED?'                  CDI04180
DR$G070  EXCP  (1)                 . # I 'READ A CARD'                  CDI04190
DR$G080  BR    12                  . # B DR$C080 'RETUN SUBRTN'         CDI04200
******************************                                          CDI04210
*     ERROR PROCESSING       *                                          CDI04220
******************************                                          CDI04230
*# E                                                                    CDI04240
*# N 'ERROR PROCESSING'                                                 CDI04250
DR$E000  EQU   *                                                        CDI04260
         TSTBIT DR$CT20,DC$CCB     . # D DR$E010 NO YES 'UNIQUE UNIT E# CDI04280
         BZ    DR$E010             . # RROR OCCURRED?'                  CDI04290
         TSTBIT DR$B240,DC$CCB     . # D DR$G005 YES NO 'ACCEPT UNIQUE# CDI04300
         BO    DR$G005             . #  UNIT ERR-AUE=YES?'              CDI04310
         SETBIT DR$EF20,DC$CCB     . # P 'SET UNIQUE UNIT ERR FLG'      CDI04320
         MVI   DR$ERR,DR$E30            ERROR MESSAGE CODE              CDI04325
         B     DR$C050             . # B DR$C050  'ERROR RTN'           CDI04330
DR$E010  SETBIT DR$EF30,DC$CCB     . # P 'SET HARDWARE ERR FLG'         CDI04340
         MVI   DR$ERR,DR$E23            ERROR MESSAGE CODE              CDI04345
         B     DR$C050             . # B DR$C050  'ERROR RTN'           CDI04350
         ENDO                                                           CDI04360
         DO    &SIN++('&CMBND'=''=0)                                    CDI04370
*                                                                       CDI04380
*     END OF FILE CONSTANTS                                             CDI04390
*                                                                       CDI04400
DR$EFM   DC    XL4'0C001022'       . # N 'IMAGE MODE EOF MASK'          CDI04410
         DC    XL4'615C4040'       . # N 'TRANS MODE EOF MASK'          CDI04420
         DC    XL4'2F2A2020'       . # N 'ASCII MODE EOF MASK'          CDI04430
         DC    XL4'342A0000'       . # N 'CC MODE EOF MASK'             CDI04440
         ENDO                                                           CDI04450
         DO    '&OUPT'=''=0                                             CDI04460
         EJECT                     * . # E                              CDI04470
*# N 'CARD PUT ROUTINE'                                                 CDI04480
*                                                                       CDI04490
DC$P000  EQU   *                   . # N                                CDI04500
         DO    &SCNT                                                    CDI04510
         SETBIT  DR$B650,DC$CCB         SET GET/PUT ISSUED BIT          CDI04520
         ENDO                                                           CDI04530
         TSTBIT DR$B510,DC$CCB     . # D DR$C080 YES NO 'OPTIONAL PROC# CDI04540
         BOR   12                  . # ESSING ?'                        CDI04550
         LH    9,DR$RLA            . # P 'REC LENGTH ADJ TO R9'         CDI04560
         L     11,DR$CCW1               NEXT DATA ADDR TO R11           CDI04570
         LR    10,0                . # P 'WORKA ADDR TO R10'            CDI04580
         LA    8,DC$W000           . # P 'WAIT/CHECK ADDR TO R8'        CDI04590
         L     7,DR$BAS                 CURRENT DATA ADDR TO R7         CDI04600
         SR    6,6                 . # P 'CLEAR BLOCK SIZE REG'         CDI04610
         TSTBIT DR$RF50,DC$CCB     . # D DC$P040 YES NO 'RECFORM=FIXUN# CDI04620
         BO    DC$P040             . # B?'                              CDI04630
         TSTBIT DR$RF70,DC$CCB     . # D DC$P030 YES NO 'RECFORM=UNDEF# CDI04640
         BO    DC$P030             . # ?'                               CDI04650
*# E                                                                    CDI04660
*# N 'ENTRANCE FOR RECFORM =VARUNB'                                     CDI04670
*                                                                       CDI04680
DC$P010  TSTBIT DR$B130,DC$CCB     . # D DC$P020 YES NO 'WORK=YES?'     CDI04690
         BO    DC$P020                                                  CDI04700
         LR    2,7                                                      CDI04710
         SR    2,9                                                      CDI04720
         IC    6,1(,2)             . # P 'REC SIZE TO R6'               CDI04730
         B     DC$P050             . # B DC$P050                        CDI04740
DC$P020  EQU   *                   . # N                                CDI04750
         IC    6,1(,10)            . # P 'REC SIZE TO R6'               CDI04760
         B     DC$P050             . # B DC$P050                        CDI04770
*# N 'ENTRANCE FOR RECFORM=UNDEF'                                       CDI04780
         SPACE                                                          CDI04790
DC$P030  EQU   *                   . # N                                CDI04800
         CLI   DR$REC,68                IF RECSZ NOT 13 THEN            CDI04810
         BH    DC$P035                                                  CDI04820
         IC    6,DR$REC                                                 CDI04830
         L     6,0(6,13)                                                CDI04840
         B     DC$P050                                                  CDI04850
DC$P035  EQU   *                        ELSE                            CDI04860
         L     6,DR$SAVR                                                CDI04870
         B     DC$P050             . # B DC$P050                        CDI04880
         SPACE                                                          CDI04890
DC$P040  EQU   *                                                        CDI04900
         LH    6,DR$BKS                                                 CDI04910
DC$P050  EQU   *                                                        CDI04920
         SR    6,9                 . # P 'ADJUST REC LENGTH'            CDI04930
         CH    6,DR$BKS            . # D DC$P050A YES NO 'R6 .GT. BKS?' CDI04940
         BH    DC$P050A                                                 CDI04950
         LTR   6,6                 . # D DC$P051 NO YES 'RECSIZE IS MI# CDI04960
         BP    DC$P051             . # NUS OR ZERO?'                    CDI04970
DC$P050A EQU   *                   . # N                                CDI04980
         MVI   DR$ERR,DR$E17       . # P 'SET RECSIZE INVALID MSG CODE' CDI04990
         SETBIT DR$EF00,DC$CCB     . # P 'SET ERR FLAG'                 CDI05000
         B     DR$C050             . # B DR$C050  'ERROR RTN'           CDI05010
DC$P051  EQU   *                                                        CDI05020
         TSTBIT  DR$B134,DC$CCB    . # D DC$P051A NO YES 'IOA2 OR WORK' CDI05030
         BZ    DC$P051A                                                 CDI05040
         BALR  14,8                . # S DC$W000 'WAIT / CHECK RTN'     CDI05050
DC$P051A EQU   *                   . # N                                CDI05060
         STH   6,DR$CCW1+6         . # P 'STORE BYTE COUNT IN CCW1'     CDI05070
         LR    5,6                                                      CDI05080
         BCTR  5,0                                                      CDI05090
         TM    DR$CCW1+7,X'01'     . # D DC$P052 NO YES 'ODD NUMBER BK# CDI05100
         BZ    DC$P052             . # SZ?'                             CDI05110
         AI    DR$CCW1+6,1         . # P 'BYTE COUNT + 1'               CDI05120
         LR    4,7                                                      CDI05130
         AR    4,6                                                      CDI05140
         MVI   0(4),X'40'          . # P 'FILL BLANK TO TH LAST BYTE'   CDI05150
DC$P052  EQU   *                                                        CDI05160
         DO    '&CONTROL'=''=0                                          CDI05170
*# N 'CONTROL PROCESSING'                                               CDI05180
*# N 'CNTROL IS IGNORED ON 0605'                                        CDI05190
*                                                                       CDI05200
         TSTBIT  DR$B220,DC$CCB                                         CDI05210
         BZ    DC$P070                  IF CNTRL BIT SET THEN           CDI05220
         CLRBIT  DR$B220,DC$CCB         CLEAR CNTRL BIT                 CDI05230
         SETBIT  DR$CW190,DC$CCB        SET STACK SEL OP-CDE BIT        CDI05240
         B     DC$P080                                                  CDI05250
DC$P070  EQU   *                        ELSE CNTRL BIT NOT SET          CDI05260
         CLRBIT  DR$CW190,DC$CCB        CLEAR STACK SEL OP-CDE BIT      CDI05270
DC$P080  EQU   *                        ENDIF                           CDI05280
         ENDO                                                           CDI05290
DC$P110  TSTBIT DR$B130,DC$CCB     . # D DC$P120 NO YES 'WORKA=YES SPE# CDI05300
         BZ    DC$P120             . # CIFIED?'                         CDI05310
         EX    5,DR$OM             RECORD FROM WORK AREA TO I/O AREA    CDI05320
DC$P120  TSTBIT DR$B140,DC$CCB     . # D DC$P130 NO YES 'IOAREA2 SPECI# CDI05330
         BZ    DC$P130             . # FIED?'                           CDI05340
         BAL   14,DR$BS            SWAP BUFFERS                         CDI05350
DC$P130  TSTBIT (DR$B360++DR$B370),DC$CCB                               CDI05360
         BZ    DC$P190                  BR IF MODE NOT STD OR TRANS     CDI05370
*# N 'TRANSLATE DATA'                                                   CDI05380
         TSTBIT DR$B360,DC$CCB     . # D DC$P140 NO YES 'MODE=STD?'     CDI05390
         BZ    DC$P140                                                  CDI05400
         TSTBIT DR$B460,DC$CCB     . # D DC$P150 NO YES 'ASCII REQUEST# CDI05410
         BZ    DC$P150             . # ED?'                             CDI05420
         BAL   14,DR$AE            ASCII TO EBCDIC TRANSLATION          CDI05430
         B     DC$P150             . # B DC$P150                        CDI05440
DC$P140  EQU   *                                                        CDI05450
         L     2,DR$OTB                                                 CDI05460
         EX    5,DR$TR             EXECUTE TRANSLATE INSTRUCTION        CDI05470
DC$P150  EXCP  (1)                 . # I 'PUNCH A CARD'                 CDI05480
         TSTBIT DR$B440,DC$CCB     . # D DC$P160 NO YES 'IOREG SPECIFI# CDI05490
         BZ    DC$P160             . # ED?'                             CDI05500
         BAL   14,DR$IR            I/O REGISTER SUBRTN                  CDI05510
DC$P160  TSTBIT DR$B134,DC$CCB     . # D DC$P180 NO YES 'IOA2 AND/OR W# CDI05520
         BZ    DC$P180             . # ORK SPECIFIED?'                  CDI05530
DC$P170  BR    12                  . # B DR$C080 'RETURN SUBRTN'        CDI05540
DC$P180  EQU   *                                                        CDI05550
         BALR  14,8                . # S DC$W000 'WAIT/CHECK RTN'       CDI05560
         BR    12                  . # B DR$C080 'RETURN SUBRTN'        CDI05570
DC$P190  TSTBIT DR$B340,DC$CCB     . # D DC$P150 NO YES 'MOCE=CC?'      CDI05580
         BZ    DC$P150                                                  CDI05590
         BAL   14,DR$CE            . # S 'COMP CDE TO EBCDIC TRANS'     CDI05600
         B     DC$P150             . # B DC$P150                        CDI05610
         ENDO                                                           CDI05620
         DO    ('&OUPT'=''=0)++('&CMBND'=''=0)                          CDI05630
         EJECT                     * . # E                              CDI05640
*# N 'PUNCH WAIT/CHECK I/O MODULE'                                      CDI05650
*                                                                       CDI05660
         DC    0Y(0)                                                    CDI05670
DQ$W000  EQU   *                                                        CDI05680
DC$W000  WAIT  (1)                 . # I 'WAIT I/O'                     CDI05690
         TSTBIT  DR$CT10,DC$CCB    . # D DR$W040 YES NO 'UNREC ERROR?'  CDI05700
         BO    DR$W040                                                  CDI05710
         TSTBIT  DR$CT40,DC$CCB    . # D DR$W030 YES NO 'HOLE CNT ERR'  CDI05720
         BO    DR$W020                                                  CDI05730
         DO    &SOU**&SMUX              OUTPUT FILE AND MUX             CDI05740
         TSTBIT  DR$B400,DC$CCB    . # D EXIT NO YES  'CRDERR .EQ. RTY' CDI05750
         BZR   14                                                       CDI05760
         LH    2,DR$CW1B                                                CDI05770
         STH   2,DR$CW2B                STORE CCW1 BYTE COUNT IN CCW2   CDI05780
         BCTR  2,0                                                      CDI05790
         EX    2,DR$CBMV                MOVE DATA TO STORAGE AREA-DTF   CDI05800
         BR    14                                                       CDI05810
*              HOLE COUNT ERROR DETECTED                                CDI05820
DR$W020  EQU   *                                                        CDI05830
         TSTBIT  DR$B400,DC$CCB         CRDERR .EQ. RETRY?              CDI05840
         BZ    DR$W040                  NO  B  UNREC ERROR RTN          CDI05850
         BAL   2,DR$RT00           . # S DR$RT00  'HOLE COUNT ERROR RT' CDI05860
         TSTBIT  DR$B470,DC$CCB                                         CDI05870
         BOR   8                        IF RETRY NOT SUCCESSFUL THEN    CDI05880
*                                                                       CDI05890
*        RETRY NOT SUCCESSFUL OR UNRECOVERABLE ERROR                    CDI05900
*                                                                       CDI05910
         ENDO                                                           CDI05920
         DO    (&SOU**&SMUX)=0                                          CDI05930
         BR    14                       RETURN                          CDI05940
DR$W020  EQU   *                                                        CDI05950
         ENDO                                                           CDI05960
DR$W040  EQU   *                   . # N                                CDI05970
         DO    &SCB                                                     CDI05980
         TSTBIT  DR$B620,DC$CCB         VALIDITY CHECK ERROR            CDI05990
         BZ    DR$W050                                                  CDI06000
         SETBIT  DR$EF20,DC$CCB         UNIQUE UNIT ERR                 CDI06010
         MVI   DR$ERR,DR$E30            VALIDITY CHECK ERROR MSG        CDI06020
         B     DR$C050                  ERROR EXIT TO USER              CDI06030
         ENDO                                                           CDI06040
DR$W050  EQU   *                                                        CDI06050
         SETBIT  DR$EF30,DC$CCB         HARDWARE ERROR BIT              CDI06060
         MVI   DR$ERR,DR$E23            UNRECOVERABLE I/O ERROR MSG     CDI06070
         B     DR$C050                  ERROR EXIT TO USER              CDI06080
         DO    &SOU                                                     CDI06090
DR$CBMV  MVC   DR$SA(1),0(7)            MOVE DATA TO STORAGE AREA       CDI06100
         ENDO                                                           CDI06110
         ENDO                                                           CDI06120
         DO    &SOU**&SMUX                                              CDI06130
         EJECT                                                          CDI06140
*# E                                                                    CDI06150
*# N 'PUNCH HOLE COUNT ERROR RECOVERY'                                  CDI06160
*                                                                       CDI06170
DR$RT00  BAL   4,DR$CWS                 SWAP CCW1 TO CCW2               CDI06180
         LA    3,6                      RETRY COUNTER TO 6              CDI06190
DR$RT10  EQU   *                                                        CDI06200
         EXCP  (1)                      REPUNCH ERROR CARD              CDI06210
         WAIT  (1)                 . # O 'WAIT'                         CDI06220
         TSTBIT DR$CT40,DC$CCB     . # D DC$RT80 YES NO 'HOLE COUNT ER# CDI06230
         BO    DR$RT80             . #  ROR'                            CDI06240
         TSTBIT  DR$CT10,DC$CCB         UNRECOVERABLE ERROR             CDI06250
         BO    DR$RT50                                                  CDI06260
         BAL   4,DR$CWS                 SWAP CCW1 TO CCW2               CDI06270
         SETBIT  DR$CW180,DC$CCB        SET INHIBIT PIOCS TRANSLATION   CDI06280
         EXCP  (1)                      RE-PUNCH CARD AFTER ERROR CARD  CDI06290
         WAIT  (1)                      WAIT                            CDI06300
         TSTBIT  DR$B340,DC$CCB                                         CDI06310
         BO    DR$RT40                  IF MODE NOT CC THEN             CDI06320
         CLRBIT  DR$CW180,DC$CCB        CLEAR INHIBIT PIOCS TRANSLATION CDI06330
DR$RT40  EQU   *                                                        CDI06340
         SETBIT  DR$B470,DC$CCB         HOLE COUNT ERROR RECOVERED      CDI06350
         BR    2                        RETURN TO WAIT/CHECK RTN        CDI06360
         SPACE 2                                                        CDI06370
*        HOLE COUNT ERROR RECOVERY UNSUCCESSFUL                         CDI06380
         SPACE 2                                                        CDI06390
DR$RT50  EQU   *                                                        CDI06400
         BAL   4,DR$CWS            . # S DR$CWS  'SWAP CCW1/CCW2'       CDI06410
         CLRBIT  DR$B470,DC$CCB         RESET RETRY SUCCESSFUL BIT      CDI06420
         BR    2                        RETURN TO WAIT/CHECK RTN        CDI06430
         SPACE 2                                                        CDI06440
DR$RT80  EQU   *                                                        CDI06450
         BCT   3,DR$RT10                COUNT=0  IF NOT TRY AGAIN       CDI06460
         B     DR$RT50                  RETRY UNSUCCESSFUL              CDI06470
         ENDO                                                           CDI06480
         DO    '&CMBND'=''=0                                            CDI06490
         EJECT                     * . # E                              CDI06500
*# N 'CARD COMBINED GET RTN'                                            CDI06510
         SPACE                                                          CDI06520
DQ$G000  EQU   *                                                        CDI06530
         DO    &SCNT                                                    CDI06540
         BAL   14,DR$CBCN               CONTROL RTN                     CDI06550
         ENDO                                                           CDI06560
         TSTBIT  DR$B270,DC$CCB         EOF SET?                        CDI06570
         BO    DQ$G070                  IF NOT SET THEN                 CDI06580
         LR    10,0                     WORK AREA ADDRESS               CDI06590
         LA    8,DQ$W000           . # P 'WAIT/CHECK RTN ADDR TO R8'    CDI06600
         LH    6,DR$BKS                 BYTE COUNT                      CDI06610
         DO    &SMUX                                                    CDI06620
         TSTBIT DR$B520,DC$CCB                                          CDI06630
         BZ    DQ$G003                  IF 0604 PUNCH THEN              CDI06640
         L     7,DR$CCW1                DATA ADDRESS                    CDI06650
         B     DQ$G007                                                  CDI06660
DQ$G003  EQU   *                                                        CDI06670
         ENDO                                                           CDI06680
         L     7,DR$CW2R                DATA ADDRESS                    CDI06690
DQ$G007  EQU   *                                                        CDI06700
         LR    5,6                                                      CDI06710
         BCTR  5,0                      BYTE COUNT-1 TO R5              CDI06720
         BALR  14,8                     WAIT/CHECK                      CDI06730
         TSTBIT  DR$B520,DC$CCB                                         CDI06740
         BO    DQ$G010                  IF 0604 PUNCH BRANCH            CDI06750
         CLRBIT  DR$CW214,DC$CCB        CLEAR PUNCH BIT                 CDI06760
DQ$G010  TSTBIT DR$B130,DC$CCB     . # D DQ$G020 NO YES 'WORKA=YES?'    CDI06770
         BZ    DQ$G020                                                  CDI06780
         TSTBIT  DR$B430,DC$CCB    . # D DQ$G035 NO YES 'ORLP=YES'      CDI06790
         BO    DQ$G035                                                  CDI06800
DQ$G020  EQU   *                        . # N                           CDI06810
         TSTBIT  DR$B450,DC$CCB    . # D DQ$G035 NO YES 'PREV MAC GET?' CDI06820
         BZ    DQ$G035                                                  CDI06830
         DO    &SMUX                                                    CDI06840
         TSTBIT DR$B520,DC$CCB                                          CDI06850
         BO    DQ$G025                  IF 0604 PUNCH BRANCH            CDI06860
         ENDO                                                           CDI06870
         EXCP  (1)                 . # I 'READ A CARD'                  CDI06880
         DO    &SMUX                                                    CDI06890
         B     DQ$G030                                                  CDI06900
DQ$G025  EQU   *                                                        CDI06910
         BAL   11,DR$CBU                UNLOAD BUFFER                   CDI06920
         BALR  14,8                     WAIT/CHECK                      CDI06930
         BAL   11,DR$CBF                FEED CARD                       CDI06940
DQ$G030  EQU   *                                                        CDI06950
         ENDO                                                           CDI06960
         BALR  14,8                     WAIT/CHECK                      CDI06970
DQ$G035  EQU   *                                                        CDI06980
         EJECT                                                          CDI06990
*# E                                                                    CDI07000
*#       N     'TRANSLATION PROCESSING'                                 CDI07010
         SPACE                                                          CDI07020
         DO    &SMUX                                                    CDI07030
         TSTBIT DR$B520,DC$CCB          IF 0604 PUNCH THEN              CDI07040
         BZ    DQ$G037                                                  CDI07050
         BAL   14,DR$CE                 COMP CDE TO EBCDIC TRANS        CDI07060
DQ$G037  EQU   *                                                        CDI07070
         ENDO                                                           CDI07080
         TSTBIT DR$B460,DC$CCB     . # D DQ$G040 NO YES 'ASCII=YES?'    CDI07090
         BZ    DQ$G040                                                  CDI07100
         BAL   14,DR$EA                 EBCDIC TO ASCII TRANSLATION     CDI07110
DQ$G040  EQU   *                                                        CDI07120
DQ$G050  TSTBIT DR$B340,DC$CCB     . # D DQ$G060 NO YES 'MODE=CC'       CDI07130
         BZ    DQ$G060                                                  CDI07140
         BAL   14,DR$EC                 EBCDIC TO COMP CDE TRANSLATION  CDI07150
DQ$G060  EQU   *                                                        CDI07160
         SR    3,3                                                      CDI07170
         IC    3,DR$EFDSP                                               CDI07180
         LA    2,DR$EFM                                                 CDI07190
         AR    2,3                                                      CDI07200
         CLC   0(4,7),0(2)         . # D DQ$G080 NO YES 'TH IMAGE IN I# CDI07210
         BNE   DQ$G080             . # OAR1 A END OF FILE?'             CDI07220
DQ$G070  SETBIT DR$B270,DC$CCB     . # P 'SET EOF BIT'                  CDI07230
         L     2,DR$EFA            . # P 'USER EOF RTN TO R15'          CDI07240
         ST    2,SA$R15                                                 CDI07250
         SETBIT DR$B450,DC$CCB     . # P 'SET FORMER MACRO INDI - GET'  CDI07260
         BR    12                  . # B DR$C080 'RETURN SUBRTN'        CDI07270
DQ$G080  EQU   *                                                        CDI07280
         TSTBIT DR$B370,DC$CCB     . # D DQ$G082 NO YES 'MODE=TRANS?'   CDI07290
         BZ    DQ$G082                                                  CDI07300
         L     2,DR$ITB                                                 CDI07310
         EX    5,DR$TR                  TRANSLATE DATA                  CDI07320
DQ$G082  TSTBIT DR$B130,DC$CCB     . # D DQ$G090 NO YES 'WORKA=YES?'    CDI07330
         BZ    DQ$G090                                                  CDI07340
         EX    5,DR$IM                  MOVE DATA                       CDI07350
         TSTBIT DR$B430,DC$CCB     . # D DQ$G090 NO YES 'ORLP=YES?'     CDI07360
         BZ    DQ$G090                                                  CDI07370
         DO    &SMUX                                                    CDI07380
         TSTBIT  DR$B520,DC$CCB                                         CDI07390
         BO    DQ$G085                  IF 0604 PUNCH                   CDI07400
         ENDO                                                           CDI07410
         EXCP  (1)                 . # I 'READ A CARD'                  CDI07420
         DO    &SMUX                                                    CDI07430
         B     DQ$G090                                                  CDI07440
DQ$G085  EQU   *                                                        CDI07450
         BAL   11,DR$CBU                UNLOAD BUFFER                   CDI07460
         BALR  14,8                     WAIT/CHECK                      CDI07470
         BAL   11,DR$CBF                FEED CARD                       CDI07480
         ENDO                                                           CDI07490
DQ$G090  SETBIT DR$B450,DC$CCB     . # P 'SET FORMER MACRO IND - GET'   CDI07500
         BR    12                  . # B DR$C080 'RETURN SUBRTN'        CDI07510
         EJECT                     * . # E                              CDI07520
*# N 'CARD COMBINED PUT RTN'                                            CDI07530
         SPACE                                                          CDI07540
DQ$P000  EQU   *                                                        CDI07550
         DO    &SCNT                                                    CDI07560
         BAL   14,DR$CBCN               CNTRL PROCESSING                CDI07570
         ENDO                                                           CDI07580
         TSTBIT  DR$B510,DC$CCB                                         CDI07590
         BOR   12                       IF OPTIONAL PROCESSING RETURN   CDI07600
         LR    10,0                . # P 'WORKA TO R10'                 CDI07610
         LA    8,DQ$W000           . # P 'WAIT/CHECK RTN ADDR TO R8'    CDI07620
         L     7,DR$CCW2                DATA ADDR                       CDI07630
         LH    6,DR$OBS                 BYTE COUNT                      CDI07640
         LR    5,6                                                      CDI07650
         BCTR  5,0                      BYTE COUNT - 1                  CDI07660
         BALR  14,8                     WAIT/CHECK                      CDI07670
         TSTBIT  DR$B130,DC$CCB                                         CDI07680
         BZ    DQ$P015                  IF WORK AREA THEN               CDI07690
         EX    5,DR$OM                  MOVE DATA                       CDI07700
DQ$P015  EQU   *                                                        CDI07710
         TSTBIT  DR$B430,DC$CCB                                         CDI07720
         BZ    DQ$P040                  IF NOT ORLP BRANCH              CDI07730
         TSTBIT  DR$B130,DC$CCB                                         CDI07740
         BO    DQ$P040                  IF WORKA SPEC BRANCH            CDI07750
         TSTBIT  DR$B450,DC$CCB                                         CDI07760
         BZ    DQ$P040                  IF FORMER MACRO WAS PUT BRANCH  CDI07770
         DO    &SMUX                                                    CDI07780
         TSTBIT  DR$B520,DC$CCB                                         CDI07790
         BO    DQ$P020                  IF 0604 PUNCH                   CDI07800
         ENDO                                                           CDI07810
         CLRBIT  DR$CW214,DC$CCB        CLEAR PUNCH BIT                 CDI07820
         EXCP  (1)                      DUMMY READ (0605)               CDI07830
         DO    &SMUX                                                    CDI07840
         B     DQ$P030                                                  CDI07850
DQ$P020  EQU   *                                                        CDI07860
         BAL   11,DR$CBF                FEED CARD                       CDI07870
DQ$P030  EQU   *                                                        CDI07880
         ENDO                                                           CDI07890
         BALR  14,8                     WAIT/CHECK                      CDI07900
DQ$P040  EQU   *                                                        CDI07910
         DO    &SMUX                                                    CDI07920
         TSTBIT  DR$B520,DC$CCB                                         CDI07930
         BO    DQ$P045                  IF 0605 PUNCH THEN              CDI07940
         ENDO                                                           CDI07950
         SETBIT  DR$CW267,DC$CCB        SET 0605 OP-CDE TO READ PUNCH   CDI07960
DQ$P045  EQU   *                                                        CDI07970
         TSTBIT (DR$B360++DR$B370),DC$CCB                               CDI07980
         BZ    DQ$P055                  BR IF MODE NOT STD OR TRANS     CDI07990
         TSTBIT DR$B360,DC$CCB     . # D DQ$P050 NO YES 'MODE=STD?'     CDI08000
         BZ    DQ$P050                                                  CDI08010
         TSTBIT DR$B460,DC$CCB     . # D DQ$P060 NO YES 'ASCII=YES?'    CDI08020
         BZ    DQ$P060                                                  CDI08030
         BAL   14,DR$AE                 ASCII TO EBCDIC TRANSLATION     CDI08040
         B     DQ$P060             . # B DQ$P060                        CDI08050
DQ$P050  EQU   *                                                        CDI08060
         L     2,DR$OTB                                                 CDI08070
         EX    5,DR$TR                  TRANSLATE DATA                  CDI08080
         B     DQ$P060             . # B DQ$P060                        CDI08090
DQ$P055  EQU   *                                                        CDI08100
         TSTBIT  DR$B340,DC$CCB         . # D DQ$P065 NO YES 'MODE=CC?' CDI08110
         BZ    DQ$P065                                                  CDI08120
         BAL   14,DR$CE                 COMP CDE TO EBCDIC TRANSLATION  CDI08130
DQ$P060  EQU   *                                                        CDI08140
DQ$P065  EQU   *                                                        CDI08150
         DO    &SMUX                                                    CDI08160
         TSTBIT  DR$B520,DC$CCB                                         CDI08170
         BO    DQ$P073                  IF 0604 BRANCH                  CDI08180
         ENDO                                                           CDI08190
         EXCP  (1)                      READ AND PUNCH 0605             CDI08200
         DO    &SMUX                                                    CDI08210
         B     DQ$P075                                                  CDI08220
DQ$P073  EQU   *                                                        CDI08230
         BAL   11,DR$CBU                UNLOAD BUFFER                   CDI08240
         BALR  14,8                     WAIT/CHECK                      CDI08250
         BAL   11,DR$CBP                FEED AND PUNCH CARD             CDI08260
DQ$P075  EQU   *                                                        CDI08270
         ENDO                                                           CDI08280
         CLRBIT DR$B450,DC$CCB     . # P 'SET FORMER MACRO IND - PUT'   CDI08290
         TSTBIT DR$B130,DC$CCB     . # D DQ$P080 YES NO 'WORKA=YES?'    CDI08300
         BO    DQ$P080                                                  CDI08310
         BALR  14,8                     WAIT/CHECK                      CDI08320
DQ$P080  EQU   *                                                        CDI08330
         BR    12                       RETURN                          CDI08340
         DO    &SCNT                                                    CDI08350
         EJECT                                                          CDI08360
*        COMBINED FILE CONTROL ROUTINE                                  CDI08370
         SPACE 2                                                        CDI08380
DR$CBCN  EQU   *                                                        CDI08390
         SETBIT  DR$B650,DC$CCB         SET GET OR PUT ISSUED BIT       CDI08400
         TSTBIT  DR$B570,DC$CCB                                         CDI08410
         BZR   14                       IF SELECT STACKER THEN          CDI08420
         TSTBIT  DR$B230,DC$CCB                                         CDI08430
         BZ    DQ$S060                  IF A CNTRL MACRO ISSUED         CDI08440
         TSTBIT  DR$B680,DC$CCB                                         CDI08450
         BO    DQ$S005                  IF NOT ORLP W/ WORK THEN        CDI08460
         TSTBIT  DR$B450,DC$CCB                                         CDI08470
         BO    DQ$S020                  IF PREV MACRO IS PUT THEN       CDI08480
DQ$S005  EQU   *                                                        CDI08490
         TSTBIT  DR$B220,DC$CCB                                         CDI08500
         BZ    DQ$S010                  IF SELECT STACK SET             CDI08510
         SETBIT  DR$B640,DC$CCB         SET CNTRL SW 2                  CDI08520
         B     DQ$S050                                                  CDI08530
DQ$S010  EQU   *                                                        CDI08540
         CLRBIT  DR$B640,DC$CCB         CLEAR CNTRL SW 2                CDI08550
         B     DQ$S050                                                  CDI08560
DQ$S020  EQU   *                                                        CDI08570
         TSTBIT  DR$B220,DC$CCB                                         CDI08580
         BZ    DQ$S050                  IF CNTRL NOT SET BR             CDI08590
         TSTBIT  DR$B630,DC$CCB                                         CDI08600
         BO    DQ$S040                  IF CNTRL SW 1 SET BRANCH        CDI08610
         SETBIT  DR$B630,DC$CCB         SET CNTRL SW1                   CDI08620
         B     DQ$S050                                                  CDI08630
DQ$S040  EQU   *                                                        CDI08640
         SETBIT  DR$B640,DC$CCB         SET CNTRL SW 2                  CDI08650
DQ$S050  EQU   *                                                        CDI08660
         CLRBIT  DR$B223,DC$CCB         RESET CNTRL MACRO BITS          CDI08670
DQ$S060  EQU   *                                                        CDI08680
         BR    14                                                       CDI08690
         ENDO                                                           CDI08700
         DO    &SMUX                                                    CDI08710
         EJECT                                                          CDI08720
*        UNLOAD BUFFER RTN  0604                                        CDI08730
         SPACE                                                          CDI08740
DR$CBU   EQU   *                                                        CDI08750
         LA    2,DR$CCW1                                                CDI08760
         ST    2,DC$CCWA                CCW ADDR TO CCB                 CDI08770
         EXCP  (1)                                                      CDI08780
         BR    11                       RETURN                          CDI08790
         EJECT                                                          CDI08800
*        FEED CARD ROUTINE  0604                                        CDI08810
         SPACE                                                          CDI08820
DR$CBF   EQU   *                                                        CDI08830
         NI    DR$CW2C,X'0F'            CLEAR FEED AND PUNCH BITS       CDI08840
         OI    DR$CW2C,X'0B'            SET FEED CARD COMMAND CODE      CDI08850
         B     DR$CBEX                  B TO 0604 EXCP RTN              CDI08860
         SPACE 3                                                        CDI08870
*        FEED AND PUNCH ROUTINE  0604                                   CDI08880
         SPACE                                                          CDI08890
DR$CBP   EQU   *                                                        CDI08900
         NI    DR$CW2C,X'04'            RESET ALL EXCEPT BINARY BI      CDI08910
         OI    DR$CW2C,X'19'            SET FEED AND PUNCH BITS         CDI08920
         SETBIT  DR$B670,DC$CCB         TRANSLATE 0604 DATA             CDI08930
         B     DR$CBEX                  B TO 0604 EXCP RTN              CDI08940
         SPACE 3                                                        CDI08950
*        0604 EXCP ROUTINE                                              CDI08960
         SPACE                                                          CDI08970
DR$CBEX  EQU   *                                                        CDI08980
         LA    2,DR$CCW2                                                CDI08990
         ST    2,DC$CCWA                                                CDI09000
         TSTBIT  DR$B640,DC$CCB                                         CDI09010
         BZ    DR$U020                  IF CNTRL SW 2 SET THEN          CDI09020
         CLRBIT  DR$B640,DC$CCB                                         CDI09030
         SETBIT  DR$CW230,DC$CCB        SET STAVK SEL BIT               CDI09040
DR$U020  EQU   *                                                        CDI09050
         TSTBIT  DR$B670,DC$CCB                                         CDI09060
         BZ    DR$U035                  IF TRANSLATE DATA BIT SET THEN  CDI09070
         CLRBIT  DR$B670,DC$CCB         CLEAR TRANSLATE DATA BIT        CDI09080
         BAL   14,DR$EC                 EBCDIC TO COMPRESSED CDE TRANS  CDI09090
DR$U035  EQU   *                                                        CDI09100
         EXCP  (1)                                                      CDI09110
         TSTBIT  DR$B630,DC$CCB                                         CDI09120
         BZR   11                       IF CNTRL SW1 SET THEN           CDI09130
         SETBIT  DR$B640,DC$CCB                                         CDI09140
         CLRBIT  DR$B630,DC$CCB                                         CDI09150
         BR    11                       RETURN                          CDI09160
         ENDO                                                           CDI09170
         ENDO                                                           CDI09180
         DO    &SLST=0                                                  CDI09190
         PRINT NOGEN                                                    CDI09200
         ENDO                                                           CDI09210
         DO    '&DU$SA'=''                                              CDI09220
&DU$SA   SET   0                                                        CDI09230
         SA$DSECT                                                       CDI09240
         ENDO                                                           CDI09250
         DTFDM CD=YES                                                   CDI09260
         DO    &SLST=0                                                  CDI09270
         PRINT GEN                                                      CDI09280
         ENDO                                                           CDI09290
         DROP  1,13,15                                                  CDI09300
         DO    '&SECT'='YES'                                            CDI09310
         DO    '&SYSECT'=''=0                                           CDI09320
&SYSECT  CSECT                                                          CDI09330
         ENDO                                                           CDI09340
         ENDO                                                           CDI09350
         ENDO                                                           CDI09360
         END                                                            CDI09370
