         TITLE 'MCT PRINT PROGRAM - REPORT GENERATOR'                   MCE00010
MCT410PA CSECT                                                          MCE00020
MCT410PA AMODE ANY                    (11.0)                            MCE00030
MCT410PA RMODE ANY                    (11.0)                            MCE00040
         USING *,R12                                                    MCE00050
         STM   R14,R12,12(R13)                                          MCE00060
         LR    R12,R15                                                  MCE00070
         LA    R2,SVREGS                                                MCE00080
         ST    R2,8(R13)                                                MCE00090
         ST    R13,4(R2)                                                MCE00100
         LR    R13,R2                                                   MCE00110
         B     ONWARD                 (3.0)                             MCE00120
         DC    C'MCT410PA'                                              MCE00130
*********************************************************************** MCE00140
ONWARD   LTR   R1,R1                  (3.0)                             MCE00150
         BZ    CLOSEPRT               (24.0)                            MCE00160
*                                                                       MCE00200
         MVC   VECTOR(112),0(R1)      (30.0)EXPECT UP TO 28 PTRS        MCE00170
         TM    PSW,1                  PRINTER OPEN?                     MCE00180
         BO    ONWARD2                (3.0)                             MCE00190
*                                                                       MCE00200
         BAL   R11,OPENPRT            (24.0)
*                                                                       MCE00200
*(240)         LA    R3,PRTDCB                                          MCE00200
*(240)         OPEN  ((R3),(OUTPUT))                                    MCE00210
*(240)         TM    48(R3),X'10'                                       MCE00220
*(240)         BZ    NOTOPEN                                            MCE00230
*(240)         OI    PSW,1                                              MCE00240
*                                                                       MCE00200
         L     R1,VDSC                                                  MCE00250
         TM    3(R1),1                1=OPEN DSCRP FILE                 MCE00260
         BZ    GDATE                                                    MCE00270
         XR    R1,R1                                                    MCE00280
         BAL   R11,CALLVS             (13.0)OPEN DSCRP FILE             MCE00290
         OI    PSW,2                  DSCRP FILE OPEN                   MCE00300
*********************************************************************** MCE00310
* CALL SUBROUTINE TO GET TODAYS DATE AND PUT IN SCHAR                   MCE00320
*********************************************************************** MCE00330
GDATE    LA    R9,SCHAR               (5.0)SUBROUTINE WILL FILL         MCE00340
         CALL  MCT410DT                                                 MCE00350
*                                                                       MCE00360
ONWARD2  L     R9,VBUFF                                                 MCE00370
         MVC   BUFDEF(78),0(R9)       (24.0)                            MCE00380
         MVI   PCNTL,C'1'             NEW PAGE                          MCE00390
         MVC   PAREA(23),HEAD1        (20.0)                            MCE00400
*********************************************************************** MCE00410
* PRINT THE APPROPRIATE MCT VERSION NUMBER BASED ON THE VERSION         MCE00420
* DETERMINED BY MCT..DC                                                 MCE00430
*********************************************************************** MCE00440
         L     R11,VERS               (4.0)MCT VERSION NUMBER           MCE00450
         MVI   PAREA+23,C'V'          (24.0)                            MCE00520
         MVC   PAREA+24(2),0(R11)     (24.0)PRINT VERSION USED          MCE00520
         MVI   PAREA+26,C'.'          (24.0)                            MCE00520
         MVC   PAREA+27(1),2(R11)     (24.0)PRINT VERSION USED          MCE00520
*********************************************************************** MCE00560
PPAGE    MVC   PAREA+56(4),=C'PAGE'   (7.0)                             MCE00570
         MVC   PAREA+60(6),PMSK       (7.0)                             MCE00580
         ED    PAREA+60(6),PAGENO     (7.0)                             MCE00590
         AP    PAGENO,P1              (3.0)                             MCE00600
         MVC   PAREA+45(10),SCHAR     (15.0)DATE                        MCE00610
         BAL   R11,PUT                                                  MCE00620
*                                                                       MCE00640
         MVI   PCNTL,C'0'             SKIP ONE LINE                     MCE00630
*********************************************************************** MCE00640
* IF ANY OPTIONAL INFORMATION IS TO BE PRINTED THE POINTERS WILL        MCE00650
* BEGIN IMMEDIATELY FOLLOWING THE DESCRIPTION FLAG                      MCE00660
*********************************************************************** MCE00670
         TM    VDSC,X'80'             IF HO BIT ON, THIS IS             MCE00680
         BO    NOOPT                  END OF LIST-NO OPTIONS            MCE00690
         LA    R4,VOPT                                                  MCE00700
         LA    R5,11                  (2.0)MAXIMUM OPTIONS              MCE00710
POPT     L     R9,0(R4)                                                 MCE00720
         MVC   PAREA(40),0(R9)        PRINT 'ASIS'                      MCE00730
         BAL   R11,PUT                                                  MCE00740
*                                                                       MCE00640
         TM    0(R4),X'80'            END OF LIST?                      MCE00750
         BO    NOOPT                                                    MCE00760
         AHI   R4,4                   NEXT POINTER                      MCE00770
         BCT   R5,POPT                (2.0)                             MCE00780
NOOPT    MVC   PAREA(9),=C'PROVIDER:' (2.0)                             MCE00790
         MVI   PCNTL,C'0'             (2.0)                             MCE00800
         L     R9,VPROV               (2.0)                             MCE00810
         LTR   R9,R9                  (2.0)                             MCE00820
         BZ    NOPROV                 (2.0)                             MCE00830
         MVC   PAREA+10(15),0(R9)     (24.0)                            MCE00840
         B     TPPS                   (2.0)                             MCE00850
NOPROV   MVC   PAREA+10(15),DDSC      (24.0)                            MCE00860
TPPS     L     R9,VPPS                (2.0)                             MCE00870
         LTR   R9,R9                  (2.0)                             MCE00880
         BZ    NOPPS                  (2.0)                             MCE00890
         CLI   0(R9),C'1'             (2.0)                             MCE00900
         BNE   TNP                    (2.0)                             MCE00910
         MVC   PAREA+27(5),PHD1       (24.0)                            MCE00920
         B     PPROV                  (2.0)                             MCE00930
TNP      CLI   0(R9),C'2'             (2.0)                             MCE00940
         BNE   NOPPS                  (2.0)                             MCE00950
         MVC   PAREA+27(9),PHD2       (24.0)                            MCE00960
         B     PPROV                  (2.0)                             MCE00970
NOPPS    MVC   PAREA+27(20),PHD3      (24.0)                            MCE00980
PPROV    BAL   R11,PUT                (2.0)                             MCE00990
*
         L     R9,VAGE                (2.0)AGE                          MCE01000
         MVC   PAREA(4),INVAGE2       (3.0)                             MCE01010
         TRT   0(3,R9),TRTAB                                            MCE01020
         BZ    EDAGE                                                    MCE01030
         MVC   PAREA+5(3),0(R9)       PRINT ASIS                        MCE01040
         BAL   R11,PUT                                                  MCE01050
         B     PLOS                                                     MCE01060
EDAGE    PACK  PWORK,0(3,R9)                                            MCE01070
         OI    PWORK+7,15                                               MCE01080
         MVC   PAREA+5(4),AMSK                                          MCE01090
         ED    PAREA+5(4),PWORK+6                                       MCE01100
         BAL   R11,PUT                                                  MCE01110
*
PLOS     DS    0H                     (30.0)
         L     R9,VLOS                (30.0)  LOS                       MCE01000
         MVC   PAREA(4),INVLOS        (30.0)                            MCE01010
         MVC   PAREA+5(5),0(R9)       (31.0)                            MCE01040
*31.0    MVC   PAREA+5(3),0(R9)       (30.0)                            MCE01040
         BAL   R11,PUT                (30.0)                            MCE01050
*
PSEX     L     R11,VSEX               (2.0)                             MCE01120
         XR    R9,R9                  (2.0)                             MCE01130
         CLI   BUFSEX+1,C'1'          (2.0)SEX INVALID?                 MCE01140
         BE    LA9                    (2.0)                             MCE01150
         IC    R9,0(R11)              (2.0)                             MCE01160
         SH    R9,H240                MAKE BINARY                       MCE01170
         MH    R9,H7                                                    MCE01180
LA9      LA    R9,SEXDSC(R9)                                            MCE01190
         MVC   PAREA(4),INVSEX2       (3.0)                             MCE01200
         MVC   PAREA+5(1),0(R11)      (2.0)PRINT SEX CODE FROM INPUT    MCE01210
         MVC   PAREA+7(7),0(R9)       (2.0)                             MCE01220
         BAL   R11,PUT                                                  MCE01230
*
         L     R11,VDST               (2.0)DSTAT                        MCE01240
         MVC   WDSTAT(2),0(R11)       (2.0)                             MCE01250
         CLI   WDSTAT,C' '            (3.0)                             MCE01260
         BNE   CLR9                   (3.0)                             MCE01270
         MVI   WDSTAT,C'0'            (3.0)                             MCE01280
CLR9     XR    R9,R9                                                    MCE01290
         CLI   BUFDST+1,C'0'          (18.0)VALID?                      MCE01300
         BNE   SET9                   (18.0)NO - PRINT UNKNOWN          MCE01310
         TRT   WDSTAT(2),TRTAB                                          MCE01320
         BNZ   SET9                                                     MCE01330
         PACK  PWORK,WDSTAT(2)                                          MCE01340
         CVB   R4,PWORK                                                 MCE01350
         STC   R4,PWORK                                                 MCE01360
         LA    R5,DSTAB               (24.1)DEFAULT TO FIRST TABLE
         L     R14,VDATE              (24.1)
         CLC   =C'20080401',0(R14)    (24.1)CHECK DATE
         JH    GETDESC                (24.1)
         AHI   R5,100                 (24.1)USE NEW TABLE
GETDESC  DS    0H                     (24.1)
         TR    PWORK(1),0(R5)         (24.1)TRANS TO CONTIG             MCE01370
         CLI   PWORK,X'FF'                                              MCE01380
         BE    SET9                                                     MCE01390
         IC    R9,PWORK                                                 MCE01400
         MH    R9,H45                 (31.0)EACH DSCRP 45 BYTES         MCE01410
*31.0    MH    R9,H15                 (13.0)EACH DSCRP 15 BYTES         MCE01410
*        MH    R9,H60                 (30.0)EACH DSCRP 60 BYTES         MCE01410
SET9     LA    R9,DDSC(R9)                                              MCE01420
         MVC   PAREA(17),INVDST2      (3.0)                             MCE01430
         MVC   PAREA+18(2),0(R11)     (2.0)PRINT DSTAT FROM INPUT       MCE01440
         MVC   PAREA+21(45),0(R9)     (31.0)                            MCE01450
*31.0    MVC   PAREA+21(15),0(R9)     (13.0)                            MCE01450
         BAL   R11,PUT                                                  MCE01460
*                                                                       MCE01510
         L     R9,VDATE               (4.0)                             MCE01470
         MVC   MCTDATE(8),0(R9)       (24.0)DISCH DATE
         MVC   PAREA(15),INVDTE2      (4.0)                             MCE01480
         MVC   PAREA+16(8),0(R9)      (4.0)PRINT DISCHARGE DATE AS IS   MCE01490
         BAL   R11,PUT                (4.0)                             MCE01500
*                                                                       MCE01510
         CLI   BUFEDFL+1,C'4'         (24.0)INVALID DISCH DATE?
         BE    TAS3                   (24.0)YES
*********************************************************************** MCE01510
* PROCESS DIAGNOSES                                                     MCE01510
*********************************************************************** MCE01510
PDIAGS   MVI   PCNTL,C'0'                                               MCE01520
         L     R3,VNDX                R3=NUMBER OF DX CODES             MCE01530
         L     R3,0(R3)                                                 MCE01540
         CH    R3,=H'26'              (23.0)INCREASED FROM 16           MCE01550
         BNH   SETVDX                 (3.0)                             MCE01560
         LA    R3,26                  (23.0)MAX DX ALLOWED              MCE01570
SETVDX   L     R4,VDX                 (3.0)R4->DX CODES                 MCE01580
         L     R5,VAFL                (24.0)ADXFLAG                     MCE01590
         MVC   PAREA(19),ADXHD        (3.0)PRINT ADMIT DX               MCE01620
         BAL   R11,PUT                (3.0)                             MCE01630
*                                                                       MCE01670
         MVI   ADXFLG,C'1'            (24.0)SAY THIS IS ADX
         BAL   R10,PRTDX              (3.0)                             MCE01640
         MVI   PAREA+8,C' '           (24.0)REMOVE POA IF ENTERED       MCE02510
*30.0    MVC   PAREA+39(1),0(R5)      (24.0)PRINT ADX ERROR FLAG
         MVC   PAREA+73(1),0(R5)      (30.0)PRINT ADX ERROR FLAG
         BAL   R11,PUT                (24.0)                            MCE01630
*                                                                       MCE01670
         AHI   R4,8                   (24.0)ADVANCE CODES TO PDX        MCE01660
         L     R5,VDFL                (24.0)START AT PDX FLAGS          MCE01670
         BCTR  R3,0                   (3.0)DECREMENT DX COUNT           MCE01680
         MVI   PCNTL,C'0'             (3.0)                             MCE01690
         MVC   PAREA(19),PDXHD        (24.0)PRINT PRINCIPAL DX          MCE01700
         BAL   R11,PUT                                                  MCE01710
*                                                                       MCE01670
         MVI   ADXFLG,C'0'            (24.0)NOT ADX
         BAL   R10,PRTDX                                                MCE01720
         BAL   R11,PUT                (24.0)                            MCE01630
         MVI   PCNTL,C'0'                                               MCE01740
         CH    R3,=H'1'               (3.0)NO SECONDARIES               MCE01750
         BE    NOSECX                                                   MCE01760
*
         SP    DCOUNT,DCOUNT          (23.0)
         LR    R10,R3                 (23.0)
         BCTR  R10,0                  (23.0)R10 = NUMBER SDX CODES
         LA    R11,8(R4)              (24.0)R11->FIRST SECONDARY
SDXLP    CLC   0(6,R11),BLANKS        (23.0)
         BE    SDXNXT                 (23.0)
         CLC   0(6,R11),CHAR0         (23.0)
         BE    SDXNXT                 (23.0)
         AP    DCOUNT,P1              (23.0)
SDXNXT   AHI   R11,8                  (24.0)NEXT DX CODE
         BCT   R10,SDXLP              (23.0)
*
         CP    DCOUNT,P0              (23.0)
         BE    NOSECX                 (23.0)
         MVC   PAREA(19),NOSDX+3      (23.0)
         CP    DCOUNT,P1              (23.0)
         BNE   B11                    (23.0)
*                                                                       MCE01770
ONEDX    MVI   PAREA+17,C'I'          (3.0)CHANGE TO SINGULAR           MCE01930
B11      BAL   R11,PUT                                                  MCE01940
         B     NDX                                                      MCE01950
DXLP     CLC   0(6,R4),BLANKS         (11.0)                            MCE01960
         BE    NDX                                                      MCE01970
         CLC   0(6,R4),CHAR0          (11.0)                            MCE01980
         BE    NDX                    (3.0)                             MCE01990
         MVI   ADXFLG,C'0'            (24.0)NOT ADX
         BAL   R10,PRTDX                                                MCE02000
         BAL   R11,PUT                (24.0)                            MCE01630
NDX      AHI   R4,8                   (24.0)NEXT DX CODE                MCE02020
*391
         AHI   R5,20                  (39.1)NEXT DXFLAG                 MCE02030
*391     AHI   R5,14                  (24.0)NEXT DXFLAG                 MCE02030
         BCT   R3,DXLP                                                  MCE02040
*********************************************************************** MCE01510
* PROCESS PROCEDURES                                                    MCE01510
*********************************************************************** MCE01510
LOADSG   MVI   PCNTL,C'0'                                               MCE02060
         L     R3,VNSG                NUMBER OF SURGERIES               MCE02070
         L     R3,0(R3)                                                 MCE02080
         LTR   R3,R3                                                    MCE02090
         BZ    NOSG                                                     MCE02100
         CH    R3,=H'25'              (23.0)INCREASED FROM 15           MCE02110
         BNH   SETVSG                 (3.0)                             MCE02120
         LA    R3,25                  (23.0)MAX SG ALLOWED              MCE02130
SETVSG   L     R4,VSG                 (3.0)R4->SG CODES                 MCE02140
         LR    R10,R3                 R10=NUMBER SG CODES               MCE02150
         LR    R11,R4                 R11->SG CODES                     MCE02180
         SP    DCOUNT,DCOUNT          (23.0)
*                                                                       MCE02170
SGCNT    CLC   0(7,R11),BLANKS        (23.0)
         BE    SGNXT                  (23.0)
         CLC   0(7,R11),CHAR0         (23.0)
         BE    SGNXT                  (23.0)
         AP    DCOUNT,P1              (23.0)
SGNXT    AHI   R11,7                  (24.0)
         BCT   R10,SGCNT              (23.0)
*
         CP    DCOUNT,P0              (23.0)COUNT=0?
         BE    NOSG                   (23.0)YES
         MVC   PAREA(10),NOPROCS+3    (23.0)                            MCE02240
         CP    DCOUNT,P1              (23.0)COUNT=1?
         BNE   BPT                    (23.0)NO
*
ONEPROC  MVI   PAREA+9,C' '           (3.0)YES,CHANGE TO SINGULAR       MCE02310
BPT      BAL   R11,PUT                                                  MCE02320
         L     R5,VSFL                R5->SG FLAGS                      MCE02230
SGLP     CLC   0(7,R4),BLANKS         (11.0)                            MCE02330
         BE    NSG                                                      MCE02340
         CLC   0(7,R4),CHAR0          (11.0)                            MCE02350
         BE    NSG                    (3.0)                             MCE02360
         BAL   R10,PRTSG                                                MCE02370
         BAL   R11,PUT                (24.0)                            MCE01630
NSG      AHI   R4,7                   (24.0)                            MCE02390
*391
         AHI   R5,20                  (39.1)NEXT SURGFLAG               MCE02400
*391     AHI   R5,17                  (30.0)NEXT SURGFLAG               MCE02400
*30.0    AHI   R5,16                  (25.0)NEXT SURGFLAG               MCE02400
         BCT   R3,SGLP                                                  MCE02410
         B     TESTD                                                    MCE02420
*********************************************************************** MCE02430
* SUBROUTINES                                                           MCE02440
*                                                                       MCE02450
* NOTE THAT EVEN THOUGH THE DX AND PROC FIELDS HAVE BEEN EXPANDED, WE   MCE02460
* STILL USE 5(DX) AND 4(PROC) FOR THE DESCRIPTION FILE KEY, BECAUSE     MCE02470
* THE DESCRIPTION FILE CONTAINS ONLY VALID CODES, AND THESE ARE STILL   MCE02480
* AT THE ORIGIN LENGTHS AS OF VERSION 11.0, NOT THE EXPANDED LENGTHS.   MCE02490
*
* UPDATE V30.0 I10. CODE EXPANDED TO 7 FROM 5(DX) AND 4(PROC)
*********************************************************************** MCE02500
PRTDX    MVI   PCNTL,C'0'             (2.0)                             MCE00800
         MVC   PAREA+1(8),0(R4)       (24.0)                            MCE02510
         CLI   0(R5),C'1'             (24.0)IS CODE INVALID?            MCE02520
         BNE   PRTDX2                 (24.0)NO                          MCE02530
         TM    PSW,2                  (24.0)DSCRP FILE OPEN?            MCE02560
         BZ    PRTDXERR               (24.0)NO                          MCE02570
         MVC   PAREA+10(14),NONE      (24.0)PRINT 'NO DESCRIPTION'      MCE02540
         B     PRTDXERR               (24.0)                            MCE02550
PRTDX2   TM    PSW,2                  (11.0)DSCRP FILE OPEN?            MCE02560
         BZ    PRTDXERR               (24.0)NO                          MCE02570
         MVI   RIBCODE,C'1'           (5.0)DIAGNOSIS KEY                MCE02580
*30.0    MVC   RIBCODE+1(5),0(R4)     (5.0)DIAGNOSIS CODE               MCE02590
         MVC   RIBCODE+1(7),0(R4)     (30.0)DIAGNOSIS CODE
*30.0DEL MVC   RIBCODE+6(2),=C'  '    (24.0)NO 6 OR 7 DIGIT YET (DX)    MCE02590
         BAL   R11,GETENG                                               MCE02600
PRTDXERR CLI   ADXFLG,C'1'            (24.0)ADX?
         BE    BR10                   (24.0)YES
*30.0    MVC   PAREA+39(14),0(R5)     (26.0)PRINT ERROR FLAGS
*39.1    MVC   PAREA+73(14),0(R5)     (30.0)PRINT ERROR FLAGS
         MVC   PAREA+73(20),0(R5)     (39.1)PRINT ERROR FLAGS
BR10     BR    R10                    (24.0)                            MCE02610
*********************************************************************** MCE02620
PRTSG    MVI   PCNTL,C'0'             (2.0)                             MCE00800
         MVC   PAREA+1(7),0(R4)       (11.0)                            MCE02630
         CLI   0(R5),C'1'             (24.0)IS CODE INVALID?            MCE02640
         BNE   PRTSG2                 (24.0)NO                          MCE02650
         TM    PSW,2                  (24.0)DSCRP FILE OPEN?            MCE02680
         BZ    PRTSGERR               (24.0)NO                          MCE02690
         MVC   PAREA+10(14),NONE      (24.0)PRINT 'NO DESCRIPTION'      MCE02660
         B     PRTSGERR               (24.0)                            MCE02670
PRTSG2   TM    PSW,2                  (11.0)DSCRP FILE OPEN?            MCE02680
         BZ    PRTSGERR               (24.0)NO                          MCE02690
         MVI   RIBCODE,C'2'           (5.0)PROCEDURE KEY                MCE02700
*30.0    MVC   RIBCODE+1(4),0(R4)     (5.0)PROCEDURE CODE               MCE02710
         MVC   RIBCODE+1(7),0(R4)     (30.0)PROCEDURE CODE              MCE02710
*30.0DEL MVC   RIBCODE+5(3),=C'   '   (24.0)NO 5,6 OR 7 DIGIT YET (SG)  MCE02720
         BAL   R11,GETENG                                               MCE02730
*391???
PRTSGERR MVC   PAREA+73(20),0(R5)     (39.1)PRINT ERROR FLAGS
*391PRTSGERR MVC   PAREA+73(17),0(R5)     (30.0)PRINT ERROR FLAGS
*PRTSGERR MVC   PAREA+39(16),0(R5)     (24.0)PRINT ERROR FLAGS
         BR    R10                                                      MCE02740
*********************************************************************** MCE02750
NOSECX   MVC   PAREA(22),NOSDX                                          MCE02760
         BAL   R11,PUT                                                  MCE02770
         B     LOADSG                                                   MCE02780
*********************************************************************** MCE02790
NOSG     MVC   PAREA(13),NOPROCS                                        MCE02800
         BAL   R11,PUT                                                  MCE02810
         B     TESTD                                                    MCE02820
*********************************************************************** MCE02830
PUT      L     R6,PDCBPTR             (24.0)
         PUT   (R6),PCNTL
*(24.01)PUT      PUT   PRTDCB,PCNTL                                     MCE02870
         MVI   PCNTL,C' '                                               MCE02880
         MVC   PAREA(132),PCNTL                                         MCE02890
         BR    R11                                                      MCE02900
*********************************************************************** MCE02910
GETENG   STM   R2,R4,SAVE                                               MCE02920
         LA    R1,4                   (5.0)                             MCE02930
         LA    R2,RIBCODE             (5.0)                             MCE02940
         CALL  MCT410VS               GET I9 DESCRIPTION                MCE02950
         CLI   0(R1),C'*'                                               MCE02960
         BE    WNONE                  (2.0)                             MCE02970
*********************************************************************** MCE02980
* AT THIS POINT, R1->DESCRIPTION                                        MCE02990
*********************************************************************** MCE03000
*30.0    MVC   PAREA+10(24),26(R1)    (24.0)ADJUST FOR NEW VSAM FORMAT  MCE03010
         MVC   PAREA+10(60),27(R1)    (30.0)ADJUST FOR NEW VSAM FORMAT  MCE03010
R234     LM    R2,R4,SAVE                                               MCE03020
         BR    R11                                                      MCE03080
*                                                                       MCE03090
WNONE    MVC   PAREA+10(14),NONE      (24.0)                            MCE03100
         B     R234                                                     MCE03110
*********************************************************************** MCE03460
* TEST FOR INVALID DISCHARGE STATUS, AGE, SEX AND/OR DISCHARGE DATE.    MCE03470
* IF ANY INVALID, DISPLAY MESSAGE.                                      MCE03480
*********************************************************************** MCE03490
TESTD    CLI   BUFDST+1,C'0'          (2.0)                             MCE03720
         BE    TAS                                                      MCE03730
         MVI   PCNTL,C'0'                                               MCE03740
         MVC   PAREA+10(24),INVDST                                      MCE03750
         BAL   R11,PUT                                                  MCE03760
TAS      CLI   BUFAGE+1,C'0'          (2.0)                             MCE03770
         BE    TAS2                   (2.0)                             MCE03780
         MVI   PCNTL,C'0'             (2.0)                             MCE03790
         MVC   PAREA+10(11),INVAGE    (2.0)                             MCE03800
         BAL   R11,PUT                (2.0)                             MCE03810
TAS2     CLI   BUFSEX+1,C'0'          (2.0)                             MCE03820
         BE    TAS3                   (4.0)BRANCH NOW TO TAS3           MCE03830
         MVI   PCNTL,C'0'             (2.0)                             MCE03840
         MVC   PAREA+10(11),INVSEX    (2.0)                             MCE03850
         BAL   R11,PUT                (2.0)                             MCE03860
TAS3     CLI   BUFEDFL+2,C'4'         (24.0)EDFLAG1 = 4 (INV DATE)      MCE03870
         BNE   EXIT                   (24.0)IF NOT INVALID, THEN EXIT   MCE03880
         MVI   PCNTL,C'0'             (4.0)                             MCE03890
         MVC   PAREA+10(22),INVDTE    (4.0)                             MCE03900
         BAL   R11,PUT                (4.0)                             MCE03910
         B     EXIT                                                     MCE03920
***********************************************************************
* OPEN PRINTER
***********************************************************************
OPENPRT  GETMAIN RU,LV=PRTEND2-PRTAREA,LOC=BELOW
         ST    R1,PDCBPTR             (24.0)
         USING PRTAREA,R1             (24.0)
         MVC   PRTDCB2,PRTDCB         (24.0)
         LA    R3,PRTDCB2             (24.0)
         DROP  R1                     (24.0)
         OPEN  ((R3),(OUTPUT)),MODE=31 (24.0)
         LTR   R15,R15                (24.0)TEST OPEN SUCCESS
         BNZ   NOTOPEN                (24.0)FAILED
         OI    PSW,1                  (24.0)
         BR    R11                    (24.0)
*********************************************************************** MCE03930
CLOSEPRT L     R3,PDCBPTR             (24.0)
         USING PRTDCB2,R3             (24.0)
         CLOSE ((R3)),MODE=31         (24.0)
         L     R1,PDCBPTR             (24.0)
         FREEMAIN RU,LV=PRTEND2-PRTAREA,A=(R1)
*                                                                       MCE03950
*(240)CLOSE    LA    R3,PRTDCB                                          MCE03940
*(240)         CLOSE ((R3))                                             MCE03950
*                                                                       MCE03950
         TM    PSW,2                  (24.0)DESCRIPTION FILE OPEN       MCE00180
         BZ    EXIT                   (24.0)NO                          MCE00190
         LA    R1,8                                                     MCE03960
         BAL   R11,CALLVS             (13.0)CLOSE VSAM FILE             MCE03970
*********************************************************************** MCE04050
EXIT     L     R13,4(R13)                                               MCE03980
         LM    R14,R12,12(R13)                                          MCE03990
         XR    R15,R15                                                  MCE04000
         BR    R14                                                      MCE04010
*                                                                       MCE04020
CALLVS   CALL  MCT410VS                                                 MCE04030
         BR    R11                    (13.0)                            MCE04040
*********************************************************************** MCE04050
NOTOPEN  ABEND 412                                                      MCE04060
*********************************************************************** MCE04070
PRTDCB   DCB   DSORG=PS,MACRF=PM,DDNAME=RPTFILE,EROPT=SKP               MCE04080
PRTEND   EQU   *                      (24.0)31-BIT
*                                                                       MCE04070
PWORK    DS    D                                                        MCE04090
SVREGS   DS    18F                                                      MCE04100
PDCBPTR  DS    A                      (24.0)31-BIT PRINT  DCB ADDRESS
DCOUNT   DC    PL8'0'                 (23.0)
*                                                                       MCE04110
VECTOR   DS   0F                                                        MCE04120
VDX      DS    F                                                        MCE04130
VNDX     DS    F                                                        MCE04140
VSG      DS    F                                                        MCE04150
VNSG     DS    F                                                        MCE04160
VAGE     DS    F                                                        MCE04170
VSEX     DS    F                                                        MCE04180
VDST     DS    F                                                        MCE04190
VPROV    DS    F                                                        MCE04240
VPPS     DS    F                                                        MCE04250
VLOS     DS    F                      30.0                              MCE04250
VDATE    DS    F                                                        MCE04260
VERS     DS    F                                                        MCE04200
VAFL     DS    F                      ADX FLAG                          MCE04210
VDFL     DS    F                      PDX/SDX FLAGS                     MCE04210
VSFL     DS    F                      PROC FLAGS                        MCE04220
VBUFF    DS    F                                                        MCE04230
VDSC     DS    F                                                        MCE04270
VOPT     DS    11F                                                      MCE04280
*********************************************************************** MCE04290
* PRINT COMMON AREA                                                     MCE04300
*********************************************************************** MCE04310
         LTORG                                                          MCE04330
         MCT410PR                                                       MCE04320
***********************************************************************
* PRINTER AREA DSECT
***********************************************************************
PRTAREA  DSECT                        (24.0)31-BIT
PRTDCB2  DS    CL(PRTEND-PRTDCB)      (24.0)31-BIT
PRTEND2  EQU   *                      (24.0)31-BIT
         END                                                            MCE04340
