000010 IDENTIFICATION DIVISION.                                         00001000
000020 PROGRAM-ID.    IPCAL180.                                         00002000
000030*AUTHOR.        CMS.                                              00003000
000040*REMARKS.       CMS.                                              00004000
000050******************************************************************00005000
000060*  FIRST IPF STARTED 01/01/2005                                  *00006000
000070*  NEW IPF YEAR WILL START OCT 1ST                               *00007000
000080******************************************************************00008000
000090*  CHANGE IN THIS PROGRAM EFFECTIVE 10/01/2017 ARE:              *00009000
000100*  -- NO CODE FIRST TABLE UPDATE                                 *00010000
000101*  -- REMOVED THE RURAL PHASE OUT                                *00010100
000102*  -- UPDATED COMORB18 COPYBOOK                                 * 00010200
000103*                                                                *00010300
000104*  -- UPDATED RATES                                              *00010400
000105*     IF THE HOSP-QUAL-IND IS EQUAL TO '1'                       *00010500
000106*        MOVE 0771.35  TO IPF-BUDGNUT-RATE-AMT                   *00010600
000107*        MOVE 0332.08  TO IPF-ECT-RATE-AMT                       *00010700
000108*     ELSE                                                       *00010800
000109*        MOVE 0756.11  TO IPF-BUDGNUT-RATE-AMT                   *00010900
000110*        MOVE 0325.52  TO IPF-ECT-RATE-AMT                       *00011000
000120*     END-IF.                                                    *00012000
000130*     MOVE 11425.00 TO IPF-OUTL-THRES-AMT.                       *00013000
000140*     MOVE 0.75000  TO IPF-LABOR-SHARE.                          *00014000
000150*     MOVE 0.25000  TO IPF-NLABOR-SHARE.                         *00015000
000160*                                                                *00016000
000170******************************************************************00017000
000180 DATE-COMPILED.                                                   00018000
000190 ENVIRONMENT DIVISION.                                            00019000
000200 CONFIGURATION SECTION.                                           00020000
000300 SOURCE-COMPUTER.            IBM-370.                             00030000
000400 OBJECT-COMPUTER.            IBM-370.                             00040000
000500 INPUT-OUTPUT  SECTION.                                           00050000
000600 FILE-CONTROL.                                                    00060000
000700     EJECT                                                        00070000
000800 DATA DIVISION.                                                   00080000
000900 FILE SECTION.                                                    00090000
001000                                                                  00100000
001100 WORKING-STORAGE SECTION.                                         00110000
001200 01  W-STORAGE-REF                  PIC X(46)  VALUE              00120000
001300     'IPCAL180      - W O R K I N G   S T O R A G E'.             00130000
001400                                                                  00140000
001500 01  CAL-VERSION                    PIC X(05)  VALUE 'C18.0'.     00150000
001600 01  WS-IPF-GEO-RURAL-ADJ    PIC 9(01)V9(03).                     00160000
001700 01  SUB                     PIC 999   VALUE 0.                   00170000
001800 01  SUB2                    PIC 999   VALUE 0.                   00180000
001900 01  DAYS-UPTO-21            PIC 9(05) VALUE 0.                   00190000
002000 01  DAYS-OVER-21            PIC 9(05) VALUE 0.                   00200000
002100 01  DAYS-UPTO-9             PIC 9(05) VALUE 0.                   00210000
002200 01  DAYS-OVER-9             PIC 9(05) VALUE 0.                   00220000
002300 01  X1                      PIC 9(05)  COMP SYNC VALUE 0.        00230000
002400 01  X2                      PIC 9(05)  COMP SYNC VALUE 0.        00240000
002500 01  HOLDADJ                 PIC 9(02)V9(4)  COMP SYNC VALUE 0.   00250000
002600 01  WK-FED-PORTION          PIC 9(07)V9(2)  VALUE 0.             00260000
002700 01  WK-TEACH-PORTION        PIC 9(07)V9(2)  VALUE 0.             00270000
002800 01  WK-PER-DIEM-AMT         PIC 9(07)V9(2)  VALUE 0.             00280000
002900 01  WK-ADJ-PER-DIEM-STEP1   PIC 9(07)V9(2)  VALUE 0.             00290000
003000 01  WK-ADJ-PER-DIEM-STEP2   PIC 9(07)V9(2)  VALUE 0.             00300000
003100 01  WK-TOTAL-LOS            PIC 9(03) VALUE 0.                   00310000
003200 01  SW-CATS.                                                     00320000
003300     05 SW-STOP-CATS         PIC X     VALUE SPACE.               00330000
003400     05 SW-CAT1              PIC X     VALUE SPACE.               00340000
003500     05 SW-CAT2              PIC X     VALUE SPACE.               00350000
003600     05 SW-CAT3              PIC X     VALUE SPACE.               00360000
003700     05 SW-CAT4              PIC X     VALUE SPACE.               00370000
003800     05 SW-CAT5              PIC X     VALUE SPACE.               00380000
003900     05 SW-CAT6              PIC X     VALUE SPACE.               00390000
004000     05 SW-CAT6P             PIC X     VALUE SPACE.               00400000
004100     05 SW-CAT7              PIC X     VALUE SPACE.               00410000
004200     05 SW-CAT8              PIC X     VALUE SPACE.               00420000
004300     05 SW-CAT9              PIC X     VALUE SPACE.               00430000
004400     05 SW-CAT10             PIC X     VALUE SPACE.               00440000
004500     05 SW-CAT11             PIC X     VALUE SPACE.               00450000
004600     05 SW-CAT12             PIC X     VALUE SPACE.               00460000
004700     05 SW-CAT13             PIC X     VALUE SPACE.               00470000
004800     05 SW-CAT14             PIC X     VALUE SPACE.               00480000
004900     05 SW-CAT15             PIC X     VALUE SPACE.               00490000
005000     05 SW-CAT16             PIC X     VALUE SPACE.               00500000
005100     05 SW-CAT17             PIC X     VALUE SPACE.               00510000
005200                                                                  00520000
005300     EJECT                                                        00530000
005400***************************************************************   00540000
005500*    COMORBIDITY TABLES                                       *   00550000
005600***************************************************************   00560000
005700     COPY COMORB18.                                               00570000
005800     EJECT                                                        00580000
005900******************************************************************00590000
006000***    INREC IS A SKEL OF FILE TO BE USED   FOR TESTING ONLY      00600000
006100*          OR IT IS THE CODE PASSED FROM PRICER                   00610000
006200***************************************************************   00620000
006300                                                                  00630000
006400 01  WK-COMORBIDITY-DATA.                                         00640000
006500     05  DDX.                                                     00650000
006600         10  DDXX         OCCURS 25 TIMES.                        00660000
006700             20 WK-DDXX1     PIC X.                               00670000
006800             20 WK-DDXX2     PIC X.                               00680000
006900             20 WK-DDXX3     PIC X.                               00690000
007000             20 WK-DDXX4     PIC X.                               00700000
007100             20 WK-DDXX5     PIC X.                               00710000
007200             20 WK-DDXX6     PIC X.                               00720000
007300             20 WK-DDXX7     PIC X.                               00730000
007400     05  SRG.                                                     00740000
007500         10  SRGX         PIC X(07)  OCCURS 25 TIMES.             00750000
007600                                                                  00760000
007700*01  OUT-DDXX-ZERO.                                               00770000
007800*    05  OUT-Z-DDXX1          PIC X.                              00780000
007900*    05  OUT-Z-DDXX2          PIC X.                              00790000
008000*    05  OUT-Z-DDXX3          PIC X.                              00800000
008100*    05  OUT-Z-DDXX4          PIC X.                              00810000
008200*    05  OUT-Z-DDXX5          PIC X.                              00820000
008300*    05  OUT-Z-DDXX6          PIC X.                              00830000
008400*    05  OUT-Z-DDXX7          PIC X.                              00840000
008500                                                                  00850000
008600***************************************************************   00860000
008700 01  DRG-FACTOR-TABLE.                                            00870000
008800     02  TB-DRG-DATA.                                             00880000
008900         10  FILLER      PIC X(07) VALUE '056 105'.               00890000
009000         10  FILLER      PIC X(07) VALUE '057 105'.               00900000
009100         10  FILLER      PIC X(07) VALUE '080 107'.               00910000
009200         10  FILLER      PIC X(07) VALUE '081 107'.               00920000
009300         10  FILLER      PIC X(07) VALUE '876 122'.               00930000
009400         10  FILLER      PIC X(07) VALUE '880 105'.               00940000
009500         10  FILLER      PIC X(07) VALUE '881 099'.               00950000
009600         10  FILLER      PIC X(07) VALUE '882 102'.               00960000
009700         10  FILLER      PIC X(07) VALUE '883 102'.               00970000
009800         10  FILLER      PIC X(07) VALUE '884 103'.               00980000
009900         10  FILLER      PIC X(07) VALUE '885 100'.               00990000
010000         10  FILLER      PIC X(07) VALUE '886 099'.               01000000
010100         10  FILLER      PIC X(07) VALUE '887 092'.               01010000
010200         10  FILLER      PIC X(07) VALUE '894 097'.               01020000
010300         10  FILLER      PIC X(07) VALUE '895 102'.               01030000
010400         10  FILLER      PIC X(07) VALUE '896 088'.               01040000
010500         10  FILLER      PIC X(07) VALUE '897 088'.               01050000
010600     02  TB-DRG-DATA2 REDEFINES TB-DRG-DATA OCCURS 17             01060000
010700             ASCENDING KEY IS TB-DRG-CODE                         01070000
010800             INDEXED BY DRGSUB.                                   01080000
010900          05  TB-DRG-CODE           PIC XXX.                      01090000
011000          05  TB-DRG-ADJUSTMENTS  OCCURS 1.                       01100000
011100              10  FILLER            PIC X.                        01110000
011200              10  TB-DRG-FACTOR     PIC 9V99.                     01120000
011300                                                                  01130000
011400***************************************************************   01140000
011500* CHANGED VALUE FOR F068 FROM 105 TO 103                      *   01150000
011600***************************************************************   01160000
011700 01  CODE-FIRST-TABLE.                                            01170000
011800     02  TB-FST-DATA.                                             01180000
011900         10  FILLER      PIC X(11) VALUE 'F0150   103'.           01190000
012000         10  FILLER      PIC X(11) VALUE 'F0151   103'.           01200000
012100         10  FILLER      PIC X(11) VALUE 'F0280   103'.           01210000
012200         10  FILLER      PIC X(11) VALUE 'F0281   103'.           01220000
012300         10  FILLER      PIC X(11) VALUE 'F04     103'.           01230000
012400         10  FILLER      PIC X(11) VALUE 'F05     105'.           01240000
012500         10  FILLER      PIC X(11) VALUE 'F060    103'.           01250000
012600         10  FILLER      PIC X(11) VALUE 'F061    103'.           01260000
012700         10  FILLER      PIC X(11) VALUE 'F062    103'.           01270000
012800         10  FILLER      PIC X(11) VALUE 'F0630   103'.           01280000
012900         10  FILLER      PIC X(11) VALUE 'F0631   103'.           01290000
013000         10  FILLER      PIC X(11) VALUE 'F0632   103'.           01300000
013100         10  FILLER      PIC X(11) VALUE 'F0633   103'.           01310000
013200         10  FILLER      PIC X(11) VALUE 'F0634   103'.           01320000
013300         10  FILLER      PIC X(11) VALUE 'F064    103'.           01330000
013400         10  FILLER      PIC X(11) VALUE 'F068    103'.           01340000
013500         10  FILLER      PIC X(11) VALUE 'F4542   102'.           01350000
013600     02  TB-FST-DATA2 REDEFINES TB-FST-DATA OCCURS 17             01360000
013700             ASCENDING KEY IS TB-FST-CODE                         01370000
013800             INDEXED BY FSTSUB.                                   01380000
013900          05  TB-FST-CODE           PIC X(07).                    01390000
014000          05  TB-FST-ADJUSTMENTS  OCCURS 1.                       01400000
014100              10  FILLER            PIC X.                        01410000
014200              10  TB-FST-FACTOR     PIC 9V99.                     01420000
014300                                                                  01430000
014400***************************************************************   01440000
014500 01  DAY-ADJUSTMENTS.                                             01450000
014600     02  DAY-VALUES.                                              01460000
014700         10  DAY1        PIC XXX  VALUE '000'.                    01470000
014800         10  DAY2        PIC XXX  VALUE '112'.                    01480000
014900         10  DAY3        PIC XXX  VALUE '108'.                    01490000
015000         10  DAY4        PIC XXX  VALUE '105'.                    01500000
015100         10  DAY5        PIC XXX  VALUE '104'.                    01510000
015200         10  DAY6        PIC XXX  VALUE '102'.                    01520000
015300         10  DAY7        PIC XXX  VALUE '101'.                    01530000
015400         10  DAY8        PIC XXX  VALUE '101'.                    01540000
015500         10  DAY9        PIC XXX  VALUE '100'.                    01550000
015600         10  DAY10       PIC XXX  VALUE '100'.                    01560000
015700         10  DAY11       PIC XXX  VALUE '099'.                    01570000
015800         10  DAY12       PIC XXX  VALUE '099'.                    01580000
015900         10  DAY13       PIC XXX  VALUE '099'.                    01590000
016000         10  DAY14       PIC XXX  VALUE '099'.                    01600000
016100         10  DAY15       PIC XXX  VALUE '098'.                    01610000
016200         10  DAY16       PIC XXX  VALUE '097'.                    01620000
016300         10  DAY17       PIC XXX  VALUE '097'.                    01630000
016400         10  DAY18       PIC XXX  VALUE '096'.                    01640000
016500         10  DAY19       PIC XXX  VALUE '095'.                    01650000
016600         10  DAY20       PIC XXX  VALUE '095'.                    01660000
016700         10  DAY21       PIC XXX  VALUE '095'.                    01670000
016800         10  DAY21-OVER  PIC XXX  VALUE '092'.                    01680000
016900     02  DAY-VALUES2 REDEFINES DAY-VALUES OCCURS 22.              01690000
017000         10 DAY-VALUE2   PIC 9V99.                                01700000
017100     EJECT                                                        01710000
017200 LINKAGE SECTION.                                                 01720000
017300                                                                  01730000
017400***************************************************************   01740000
017500*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *   01750000
017600*    AND PASSED BACK TO THE CALLING PROGRAM                   *   01760000
017700*            RETURN CODE VALUES (IPF-RTC)                     *   01770000
017800*                                                             *   01780000
017900*            IPF-RTC 00-49 = HOW THE BILL WAS PAID            *   01790000
018000*                                                             *   01800000
018100*              00 = PAID NORMAL IPF PAYMENT                   *   01810000
018200*              02 = PAID AS A COST-OUTLIER                    *   01820000
018300*              03 = PRIOR DAYS BILL - VARIABLE PER DIEM       *   01830000
018400*              04 = COMBO OF '02' AND '03'                    *   01840000
018500*              60 = DRG NOT FOUND, CODES FIRST TABLE LOOK UP  *   01850000
018600*                                                             *   01860000
018700*                                                             *   01870000
018800*            IPF-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   01880000
018900*              51 = NO PROVIDER SPECIFIC INFO FOUND           *   01890000
019000*              52 = INVALID CBSA# IN PROVIDER FILE            *   01900000
019100*                   OR INVALID WAGE INDEX                     *   01910000
019200*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   01920000
019300*              54 = BILL-DRG INVALID                              01930000
019400*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   01940000
019500*                                      OR                     *   01950000
019600*                   DISCHARGE DATE < CBSA EFF START DATE      *   01960000
019700*                                      OR                     *   01970000
019800*                   DISCHARGE DATE > 20060630 START CBSA AND  *   01980000
019900*                 SELECTED PROV EFF DATE < 20060701 START CBSA*   01990000
020000*                   FOR PPS                                   *   02000000
020100*              56 = INVALID LENGTH OF STAY                    *   02010000
020200*              57 = INVALID AGE                               *   02020000
020300*              58 = INVALID PPS FED BLEND INDICATOR           *   02030000
020400*              98 = CANNOT PROCESS BILL OUTSIDE THIS VERSION  *   02040000
020500***************************************************************   02050000
020600*******************************************************           02060000
020700*    PASSED FROM IPDRV                                *           02070000
020800*******************************************************           02080000
020900 01  BILL-INPUT-DATA.                                             02090000
021000     05  BILL-IN-DATA.                                            02100000
021100         10  BILL-NPI-NUMBER.                                     02110000
021200             15  BILL-NPI            PIC X(08).                   02120000
021300             15  BILL-NPI-FILLER     PIC X(02).                   02130000
021400         10  BILL-PROVIDER-NO        PIC X(06).                   02140000
021500         10  BILL-HIC-NO             PIC X(12).                   02150000
021600         10  BILL-DISCHARGE-DATE.                                 02160000
021700             15  BILL-D-CC           PIC 9(02).                   02170000
021800             15  BILL-D-YY           PIC 9(02).                   02180000
021900             15  BILL-D-MM           PIC 9(02).                   02190000
022000             15  BILL-D-DD           PIC 9(02).                   02200000
022100         10  BILL-PATIENT-STATUS     PIC X(02).                   02210000
022200         10  BILL-AGE                PIC 9(03).                   02220000
022300         10  BILL-DRG                PIC 9(03).                   02230000
022400         10  BILL-LOS                PIC 9(05).                   02240000
022500         10  BILL-OUTL-OCCUR-IND     PIC X(01).                   02250000
022600         10  BILL-SRC-OF-ADMISSION   PIC X(01).                   02260000
022700         10  BILL-ECT-NO-OF-UNITS    PIC 9(03).                   02270000
022800         10  BILL-CHARGES-CLAIMED    PIC 9(07)V9(02).             02280000
022900         10  BILL-DIAG-PROC-DATA.                                 02290000
023000             15  BILL-OTHER-DIAG-DATA   OCCURS 25 TIMES.          02300000
023100                 20  BILL-DDXX-1ST     PIC X.                     02310000
023200                 20  FILLER            PIC X(06).                 02320000
023300             15  BILL-OTHER-PROC-DATA PIC X(07)  OCCURS 25 TIMES. 02330000
023400         10  BILL-PRIOR-DAYS         PIC 9(03).                   02340000
023500*******************************************************           02350000
023600*    PASSED AND RETURNED BY IPCAL                     *           02360000
023700*******************************************************           02370000
023800 01  IPF-DATA-VARIABLES.                                          02380000
023900         10  IPF-RTC                 PIC 9(02).                   02390000
024000         10  IPF-MSA-CBSA            PIC X(05).                   02400000
024100         10  IPF-MSA-CODE REDEFINES IPF-MSA-CBSA.                 02410000
024200             15  IPF-MSA             PIC X(04).                   02420000
024300             15  FILLER              PIC X.                       02430000
024400         10  IPF-CBSA-CODE REDEFINES IPF-MSA-CBSA.                02440000
024500             15  IPF-CBSA            PIC X(05).                   02450000
024600         10  IPF-WAGE-INDEX          PIC 9(02)V9(04).             02460000
024700         10  IPF-LABOR-SHARE         PIC 9(01)V9(05).             02470000
024800         10  IPF-NLABOR-SHARE        PIC 9(01)V9(05).             02480000
024900         10  IPF-COLA                PIC 9(01)V9(03).             02490000
025000         10  IPF-STD-FACTOR          PIC 9(01)V9(05).             02500000
025100         10  IPF-COMORB-FACTOR       PIC 9(01)V9(05).             02510000
025200         10  IPF-AGE-ADJ             PIC 9(01)V9(02).             02520000
025300         10  IPF-DRG-FACTOR          PIC 9(01)V9(02).             02530000
025400         10  IPF-GEO-RURAL-ADJ       PIC 9(01)V9(02).             02540000
025500         10  IPF-EMERG-ADJ           PIC 9(01)V9(02).             02550000
025600         10  IPF-TEACH-ADJ           PIC 9(01)V9(02).             02560000
025700         10  IPF-FED-PPS-BLEND-IND   PIC X.                       02570000
025800         10  IPF-CAL-VERSION         PIC X(05).                   02580000
025900         10  IPF-CSTCHG-RATIO        PIC 9(01)V9(03).             02590000
026000         10  FILLER                  PIC X(08).                   02600000
026100                                                                  02610000
026200*******************************************************           02620000
026300*    PASSED AND RETURNED BY IPCAL                     *           02630000
026400*******************************************************           02640000
026500 01  IPF-ADDITIONAL-VARIABLES.                                    02650000
026600     02  IPF-MF-VARIABLES.                                        02660000
026700         10  IPF-100PCT-STOPLOS-AMT      PIC 9(07)V9(02).         02670000
026800         10  IPF-TOT-PAYMENT             PIC 9(07)V9(02).         02680000
026900         10  IPF-FED-PAYMENT             PIC 9(07)V9(02).         02690000
027000         10  IPF-FAC-PAYMENT             PIC 9(07)V9(02).         02700000
027100         10  IPF-ECT-PAYMENT             PIC 9(07)V9(02).         02710000
027200         10  IPF-OUTLIER-PAYMENT         PIC 9(07)V9(02).         02720000
027300         10  IPF-OUTL-COST               PIC 9(07)V9(02).         02730000
027400         10  IPF-OUTL-ADJ-COST           PIC 9(07)V9(02).         02740000
027500         10  IPF-OUTL-PER-DIEM-AMT       PIC 9(07)V9(02).         02750000
027600         10  IPF-OUTL-THRES-AMT          PIC 9(07)V9(02).         02760000
027700         10  IPF-OUTL-THRES-ADJ-AMT      PIC 9(07)V9(02).         02770000
027800         10  IPF-ADJUSTED-PER-DIEM-AMT   PIC 9(07)V9(02).         02780000
027900         10  IPF-WAGE-ADJ-AMT            PIC 9(07)V9(02).         02790000
028000         10  IPF-LABOR-BASE-AMT          PIC 9(07)V9(05).         02800000
028100         10  IPF-NLABOR-BASE-AMT         PIC 9(07)V9(05).         02810000
028200         10  IPF-OUTL-LABOR-BASE-AMT     PIC 9(07)V9(05).         02820000
028300         10  IPF-OUTL-NLABOR-BASE-AMT    PIC 9(07)V9(05).         02830000
028400         10  IPF-BUDGNUT-RATE-AMT        PIC 9(05)V9(02).         02840000
028500         10  IPF-ECT-RATE-AMT            PIC 9(05)V9(02).         02850000
028600         10  IPF-TEACH-PAYMENT           PIC 9(07)V9(02).         02860000
028700         10  FILLER                      PIC X(01).               02870000
028800      02 IPF-PC-VARIABLES.                                        02880000
028900         10  IPF-PC-DATA                 PIC X(44).               02890000
029000                                                                  02900000
029100 01  PRICER-OPT-VERS-SW.                                          02910000
029200     02  PRICER-OPTION-SW          PIC X(01).                     02920000
029300         88  VARIABLES                  VALUE 'S'.                02930000
029400         88  PROV-RECORD-PASSED         VALUE 'P'.                02940000
029500         88  ALL-TABLES-PASSED          VALUE 'B'.                02950000
029600         88  PC-PRICER                  VALUE 'C'.                02960000
029700     02  IPF-VERSIONS.                                            02970000
029800         10  IPDRV-VERSION         PIC X(05).                     02980000
029900                                                                  02990000
030000**************************************************************    03000000
030100*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BACK FROM *    03010000
030200*      THE IPCAL056 PROGRAM FOR PROCESSING                   *    03020000
030300**************************************************************    03030000
030400 01  PROV-NEW-HOLD.                                               03040000
030500     02  PROV-NEWREC-HOLD1.                                       03050000
030600         05  P-NEW-NPI10.                                         03060000
030700             10  P-NEW-NPI8             PIC X(08).                03070000
030800             10  P-NEW-NPI-FILLER       PIC X(02).                03080000
030900         05  P-NEW-PROVIDER-NO.                                   03090000
031000             88  P-NEW-DSH-ADJ-PROVIDERS                          03100000
031100                             VALUE '180049' '190044' '190144'     03110000
031200                                   '190191' '330047' '340085'     03120000
031300                                   '370016' '370149' '420043'.    03130000
031400             10  P-NEW-STATE            PIC 9(02).                03140000
031500             10  FILLER                 PIC X(04).                03150000
031600         05  P-NEW-DATE-DATA.                                     03160000
031700             10  P-NEW-EFF-DATE.                                  03170000
031800                 15  P-NEW-EFF-DT-CC    PIC 9(02).                03180000
031900                 15  P-NEW-EFF-DT-YY    PIC 9(02).                03190000
032000                 15  P-NEW-EFF-DT-MM    PIC 9(02).                03200000
032100                 15  P-NEW-EFF-DT-DD    PIC 9(02).                03210000
032200             10  P-NEW-FY-BEGIN-DATE.                             03220000
032300                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                03230000
032400                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                03240000
032500                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                03250000
032600                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                03260000
032700             10  P-NEW-REPORT-DATE.                               03270000
032800                 15  P-NEW-REPORT-DT-CC PIC 9(02).                03280000
032900                 15  P-NEW-REPORT-DT-YY PIC 9(02).                03290000
033000                 15  P-NEW-REPORT-DT-MM PIC 9(02).                03300000
033100                 15  P-NEW-REPORT-DT-DD PIC 9(02).                03310000
033200             10  P-NEW-TERMINATION-DATE.                          03320000
033300                 15  P-NEW-TERM-DT-CC   PIC 9(02).                03330000
033400                 15  P-NEW-TERM-DT-YY   PIC 9(02).                03340000
033500                 15  P-NEW-TERM-DT-MM   PIC 9(02).                03350000
033600                 15  P-NEW-TERM-DT-DD   PIC 9(02).                03360000
033700         05  P-NEW-WAIVER-CODE          PIC X(01).                03370000
033800             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              03380000
033900         05  P-NEW-INTER-NO             PIC 9(05).                03390000
034000         05  P-NEW-PROVIDER-TYPE        PIC X(02).                03400000
034100             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.      03410000
034200             88  P-N-REFERRAL-CENTER        VALUE '07' '11'       03420000
034300                                                  '15' '17'       03430000
034400                                                  '22'.           03440000
034500             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.           03450000
034600             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.           03460000
034700             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.           03470000
034800             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.           03480000
034900             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.      03490000
035000             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.           03500000
035100             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.      03510000
035200             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.           03520000
035300             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.           03530000
035400             88  P-N-EACH                   VALUE '21' '22'.      03540000
035500             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.           03550000
035600             88  P-N-NHCMQ-II-SNF           VALUE '32'.           03560000
035700             88  P-N-NHCMQ-III-SNF          VALUE '33'.           03570000
035800         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                03580000
035900             88  P-N-NEW-ENGLAND            VALUE  1.             03590000
036000             88  P-N-MIDDLE-ATLANTIC        VALUE  2.             03600000
036100             88  P-N-SOUTH-ATLANTIC         VALUE  3.             03610000
036200             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.             03620000
036300             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.             03630000
036400             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.             03640000
036500             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.             03650000
036600             88  P-N-MOUNTAIN               VALUE  8.             03660000
036700             88  P-N-PACIFIC                VALUE  9.             03670000
036800         05  P-NEW-CURRENT-DIV   REDEFINES                        03680000
036900                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         03690000
037000             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.          03700000
037100         05  P-NEW-MSA-DATA.                                      03710000
037200             10  P-NEW-CHG-CODE-INDEX       PIC X.                03720000
037300             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 03730000
037400             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   03740000
037500                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       03750000
037600             10  P-NEW-GEO REDEFINES                              03760000
037700                                 P-NEW-GEO-LOC-MSAX.              03770000
037800                 15  P-NEW-GEO-RURAL-1ST.                         03780000
037900                     20  P-NEW-GEO-RURAL  PIC XX.                 03790000
038000                         88  P-NEW-GEO-MSAX-RURAL VALUE '  '.     03800000
038100                 15  P-NEW-GEO-RURAL-2ND        PIC XX.           03810000
038200             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 03820000
038300             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 03830000
038400             10  P-NEW-STAND-AMT-LOC-MSA9                         03840000
038500       REDEFINES P-NEW-STAND-AMT-LOC-MSA.                         03850000
038600                 15  P-NEW-RURAL-1ST.                             03860000
038700                     20  P-NEW-STAND-RURAL  PIC XX.               03870000
038800                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    03880000
038900                 15  P-NEW-RURAL-2ND        PIC XX.               03890000
039000         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    03900000
039100                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.           03910000
039200                 88  P-NEW-SCH-YR82       VALUE   '82'.           03920000
039300                 88  P-NEW-SCH-YR87       VALUE   '87'.           03930000
039400         05  P-NEW-LUGAR                    PIC X.                03940000
039500         05  P-NEW-TEMP-RELIEF-IND          PIC X.                03950000
039600         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                03960000
039700         05  FILLER                         PIC X(05).            03970000
039800     02  PROV-NEWREC-HOLD2.                                       03980000
039900         05  P-NEW-VARIABLES.                                     03990000
040000             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        04000000
040100             10  P-NEW-COLA              PIC  9(01)V9(03).        04010000
040200             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        04020000
040300             10  P-NEW-BED-SIZE          PIC  9(05).              04030000
040400             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        04040000
040500             10  P-NEW-CMI               PIC  9(01)V9(04).        04050000
040600             10  P-NEW-SSI-RATIO         PIC  V9(04).             04060000
040700             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             04070000
040800             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              04080000
040900             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        04090000
041000             10  P-NEW-DSH-PERCENT       PIC  V9(04).             04100000
041100             10  P-NEW-FYE-DATE          PIC  X(08).              04110000
041200         05  P-NEW-CBSA-DATA.                                     04120000
041300             10  P-NEW-CBSA-SPEC-PAY-IND   PIC X.                 04130000
041400             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.                 04140000
041500             10  P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.  04150000
041600             10  P-NEW-CBSA-GEO-LOCX REDEFINES                    04160000
041700                 P-NEW-CBSA-GEO-LOC.                              04170000
041800                 15  P-NEW-CBSA-GEO-RURAL-1ST.                    04180000
041900                     20  P-NEW-CBSA-GEO-RURAL  PIC XXX.           04190000
042000                         88  P-NEW-CBSA-GEO-RURAL-CHECK           04200000
042100                             VALUE '   '.                         04210000
042200                 15  P-NEW-CBSA-GEO-RURAL-2ND PIC XX.             04220000
042300             10  P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.  04230000
042400             10  P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.  04240000
042500             10  P-NEW-CBSA-SPEC-WI        PIC 9(02)V9(04).       04250000
042600             10  P-NEW-CBSA-SPEC-WI-N  REDEFINES                  04260000
042700                 P-NEW-CBSA-SPEC-WI        PIC 9(06).             04270000
042800     02  PROV-NEWREC-HOLD3.                                       04280000
042900         05  P-NEW-PASS-AMT-DATA.                                 04290000
043000             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          04300000
043100             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          04310000
043200             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          04320000
043300             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          04330000
043400         05  P-NEW-CAPI-DATA.                                     04340000
043500             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 04350000
043600             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          04360000
043700             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          04370000
043800             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        04380000
043900             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             04390000
044000             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 04400000
044100             15  P-NEW-CAPI-IME            PIC 9V9999.            04410000
044200             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          04420000
044300             15  P-VAL-BASED-PURCH-SCORE    PIC 9V999.            04430000
044400         05  FILLER                         PIC X(18).            04440000
044500******************************************************************04450000
044600                                                                  04460000
044700 01  WAGE-INDEX-RECORD.                                           04470000
044800     05  W-CBSA              PIC 9(5).                            04480000
044900     05  W-SIZE              PIC X(01).                           04490000
045000         88  LARGE-URBAN       VALUE 'L'.                         04500000
045100         88  OTHER-URBAN       VALUE 'O'.                         04510000
045200         88  ALL-RURAL         VALUE 'R'.                         04520000
045300     05  W-CBSA-EFF-DATE     PIC 9(8).                            04530000
045400     05  FILLER              PIC X.                               04540000
045500     05  W-CBSA-WAGE-INDEX   PIC S9(02)V9(04).                    04550000
045600     05  FILLER              PIC S9(02)V9(04).                    04560000
045700     EJECT                                                        04570000
045800 PROCEDURE DIVISION  USING BILL-INPUT-DATA                        04580000
045900                           IPF-DATA-VARIABLES                     04590000
046000                           IPF-ADDITIONAL-VARIABLES               04600000
046100                           PRICER-OPT-VERS-SW                     04610000
046200                           PROV-NEW-HOLD                          04620000
046300                           WAGE-INDEX-RECORD.                     04630000
046400                                                                  04640000
046500***************************************************************   04650000
046600*    PROCESSING:                                              *   04660000
046700*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE        *   04670000
046800*        B. INITIALIZE IPCAL  HOLD VARIABLES.                 *   04680000
046900*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *   04690000
047000*           ATTEMPTING TO CALCULATE IPF. IF THIS BILL         *   04700000
047100*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   04710000
047200*           GOBACK.                                           *   04720000
047300*        D. ASSEMBLE PRICING COMPONENTS.                      *   04730000
047400*        E. CALCULATE THE PRICE.                              *   04740000
047500***************************************************************   04750000
047600                                                                  04760000
047700     PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT.                04770000
047800                                                                  04780000
047900     MOVE CAL-VERSION  TO  IPF-CAL-VERSION.                       04790000
048000                                                                  04800000
048100     GOBACK.                                                      04810000
048200                                                                  04820000
048300 0200-MAINLINE-CONTROL.                                           04830000
048400                                                                  04840000
048500     PERFORM 1000-EDIT-THE-BILL-INFO.                             04850000
048600                                                                  04860000
048700     IF  IPF-RTC = 00                                             04870000
048800         PERFORM 2000-ASSEMBLE-PPS-VARIABLES THRU                 04880000
048900                 2000-EXIT                                        04890000
049000         PERFORM 3000-CALC-PAYMENT THRU                           04900000
049100                 3000-EXIT.                                       04910000
049200                                                                  04920000
049300 0200-EXIT.   EXIT.                                               04930000
049400                                                                  04940000
049500 1000-EDIT-THE-BILL-INFO.                                         04950000
049600***************************************************************   04960000
049700*    BILL DATA EDITS IF ANY FAIL SET IPF-RTC                  *   04970000
049800*    AND DO NOT ATTEMPT TO PRICE.                             *   04980000
049900***************************************************************   04990000
050000     MOVE SPACES TO WK-COMORBIDITY-DATA.                          05000000
050100                                                                  05010000
050200     IF  IPF-RTC = 00                                             05020000
050300         IF  P-NEW-WAIVER-STATE                                   05030000
050400             MOVE 53 TO IPF-RTC.                                  05040000
050500*-------------------------------------------------------------*   05050000
050600*    FOR FY2011, REMOVED 014 & 015 AND ADDED 009              *   05060000
050700*-------------------------------------------------------------*   05070000
050800     IF  IPF-RTC = 00                                             05080000
050900         IF  BILL-DRG < 001                                       05090000
051000                OR = 009          OR = 016 OR = 017               05100000
051100                OR = 018 OR = 019 OR = 043 OR = 044               05110000
051200                OR = 045 OR = 046 OR = 047 OR = 048               05120000
051300                OR = 049 OR = 050 OR = 051 OR = 104               05130000
051400                OR = 105 OR = 106 OR = 107 OR = 108               05140000
051500                OR = 109 OR = 110 OR = 111 OR = 112               05150000
051600                OR = 118 OR = 119 OR = 120 OR = 126               05160000
051700                OR = 127 OR = 128 OR = 140 OR = 141               05170000
051800                OR = 142 OR = 143 OR = 144 OR = 145               05180000
051900                OR = 160 OR = 161 OR = 162 OR = 169               05190000
052000                OR = 170 OR = 171 OR = 172 OR = 173               05200000
052100                OR = 174 OR = 209 OR = 210 OR = 211               05210000
052200                OR = 212 OR = 213 OR = 214 OR = 265               05220000
052300                OR = 266 OR = 267 OR = 268 OR = 269               05230000
052400                OR = 270 OR = 271 OR = 272 OR = 273               05240000
052500                OR = 274 OR = 275 OR = 276 OR = 277               05250000
052600                OR = 278 OR = 279 OR = 317 OR = 318               05260000
052700                OR = 319 OR = 320 OR = 321 OR = 322               05270000
052800                OR = 323 OR = 324 OR = 325 OR = 359               05280000
052900                OR = 360 OR = 361 OR = 362 OR = 363               05290000
053000                OR = 364 OR = 365 OR = 366 OR = 367               05300000
053100                OR = 396 OR = 397 OR = 398 OR = 399               05310000
053200                OR = 400 OR = 401 OR = 402 OR = 403               05320000
053300                OR = 404 OR = 426 OR = 427 OR = 428               05330000
053400                OR = 429 OR = 430 OR = 431 OR = 447               05340000
053500                OR = 448 OR = 449 OR = 450 OR = 451               05350000
053600                OR = 452 OR = 518 OR = 519 OR = 520               05360000
053700                OR = 521 OR = 522 OR = 523 OR = 524               05370000
053800                OR = 525 OR = 526 OR = 527 OR = 528               05380000
053900                OR = 529 OR = 530 OR = 531 OR = 532               05390000
054000                OR = 567 OR = 568 OR = 569 OR = 570               05400000
054100                OR = 571 OR = 572 OR = 586 OR = 587               05410000
054200                OR = 588 OR = 589 OR = 590 OR = 591               05420000
054300                OR = 608 OR = 609 OR = 610 OR = 611               05430000
054400                OR = 612 OR = 613 OR = 631 OR = 632               05440000
054500                OR = 633 OR = 634 OR = 635 OR = 636               05450000
054600                OR = 646 OR = 647 OR = 648 OR = 649               05460000
054700                OR = 650 OR = 651 OR = 676 OR = 677               05470000
054800                OR = 678 OR = 679 OR = 680 OR = 681               05480000
054900                OR = 701 OR = 702 OR = 703 OR = 704               05490000
055000                OR = 705 OR = 706 OR = 719 OR = 720               05500000
055100                OR = 721 OR = 731 OR = 732 OR = 733               05510000
055200                OR = 751 OR = 752 OR = 753 OR = 762               05520000
055300                OR = 763 OR = 764 OR = 771 OR = 772               05530000
055400                OR = 773 OR = 783 OR = 784 OR = 785               05540000
055500                OR = 786 OR = 787 OR = 788 OR = 796               05550000
055600                OR = 797 OR = 798 OR = 805 OR = 806               05560000
055700                OR = 807 OR = 817 OR = 818 OR = 819               05570000
055800                OR = 831 OR = 832 OR = 833 OR = 850               05580000
055900                OR = 851 OR = 852 OR = 859 OR = 860               05590000
056000                OR = 861 OR = 873 OR = 874 OR = 875               05600000
056100                OR = 877 OR = 878 OR = 879 OR = 891               05610000
056200                OR = 891 OR = 892 OR = 892 OR = 893               05620000
056300                OR = 893 OR = 898 OR = 899 OR = 900               05630000
056400                OR = 910 OR = 911 OR = 912 OR = 924               05640000
056500                OR = 925 OR = 926 OR = 930 OR = 931               05650000
056600                OR = 932 OR = 936 OR = 937 OR = 938               05660000
056700                OR = 942 OR = 943 OR = 944 OR = 952               05670000
056800                OR = 953 OR = 954 OR = 960 OR = 961               05680000
056900                OR = 962 OR = 966 OR = 967 OR = 968               05690000
057000                OR = 971 OR = 972 OR = 973 OR = 978               05700000
057100                OR = 979 OR = 980 OR = 990 OR = 991               05710000
057200                OR = 992 OR = 993 OR = 994 OR = 995               05720000
057300                OR = 996 OR = 997                                 05730000
057400             MOVE 54 TO IPF-RTC.                                  05740000
057500                                                                  05750000
057600     IF IPF-RTC = 00                                              05760000
057700        IF  ((BILL-DISCHARGE-DATE < P-NEW-EFF-DATE) OR            05770000
057800             (BILL-DISCHARGE-DATE < W-CBSA-EFF-DATE))             05780000
057900              MOVE 55 TO IPF-RTC.                                 05790000
058000                                                                  05800000
058100     IF IPF-RTC = 00                                              05810000
058200         IF  BILL-LOS NOT NUMERIC OR                              05820000
058300             BILL-LOS = ZERO                                      05830000
058400             MOVE 56 TO IPF-RTC.                                  05840000
058500                                                                  05850000
058600     IF IPF-RTC = 00                                              05860000
058700         IF  BILL-AGE NOT NUMERIC OR                              05870000
058800             BILL-AGE = ZERO                                      05880000
058810             MOVE 57 TO IPF-RTC.                                  05881000
058820                                                                  05882000
058830 2000-ASSEMBLE-PPS-VARIABLES.                                     05883000
058840***************************************************************   05884000
058850*    THE APPROPRIATE SET OF THESE IPF VARIABLES ARE SELECTED  *   05885000
058860*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   05886000
058870*    OF THAT VARIABLE.                                        *   05887000
058880*    3/31/2009 - THE STANDARDIZATION FACTOR WAS USED ONLY ONCE*   05888000
058881*    TO CORRECT WHERE A COMPUTER CODE INCORRECTLY ASSIGNED    *   05888100
058882*    NON-TEACHING STATUS TO MOST TEACHING FACILITIES.         *   05888200
058883*    IT HAS BEEN COMMENTED OUT AS IT IS NO LONGER NEEDED.     *   05888300
058884***************************************************************   05888400
058885     MOVE ALL '0'  TO IPF-MF-VARIABLES.                           05888500
058886                                                                  05888600
058887     IF P-NEW-CBSA-HOSP-QUAL-IND IS EQUAL TO '1'                  05888700
058888        MOVE 0771.35  TO IPF-BUDGNUT-RATE-AMT                     05888800
058889        MOVE 0332.08  TO IPF-ECT-RATE-AMT                         05888900
058890     ELSE                                                         05889000
058891        MOVE 0756.11  TO IPF-BUDGNUT-RATE-AMT                     05889100
058892        MOVE 0325.52  TO IPF-ECT-RATE-AMT                         05889200
058893     END-IF.                                                      05889300
058894                                                                  05889400
058895     MOVE 11425.00 TO IPF-OUTL-THRES-AMT.                         05889500
058896                                                                  05889600
058897     MOVE 0.75000  TO IPF-LABOR-SHARE.                            05889700
058898     MOVE 0.25000  TO IPF-NLABOR-SHARE.                           05889800
058899                                                                  05889900
058900*    MOVE 0.82540  TO IPF-STD-FACTOR.                             05890000
058901                                                                  05890100
058902     MOVE ZEROES   TO WK-FED-PORTION                              05890200
058903                      WK-TEACH-PORTION.                           05890300
058904                                                                  05890400
058905     IF P-NEW-STATE = 02 OR 12                                    05890500
058906         MOVE P-NEW-COLA TO IPF-COLA                              05890600
058907     ELSE                                                         05890700
058908         MOVE 1.000 TO IPF-COLA.                                  05890800
058909                                                                  05890900
058910***************************************************************   05891000
058911***  GET THE DRG ADJUSTMENT FACTORES OR FIRST CODES               05891100
058912***************************************************************   05891200
058913                                                                  05891300
058914     PERFORM 2600-GET-DRG-FACTORS THRU 2600-EXIT.                 05891400
058915                                                                  05891500
058916     IF IPF-RTC = '60'                                            05891600
058917         MOVE '00' TO IPF-RTC                                     05891700
058918         PERFORM 2700-GET-FIRST-CODES THRU 2700-EXIT.             05891800
058919                                                                  05891900
058920*******************************************************           05892000
058921***  GET THE COMORBIDITY FACTORS                                  05892100
058922***************************************************************   05892200
058923                                                                  05892300
058924     PERFORM 3300-GET-COMORBIDITY THRU 3300-EXIT.                 05892400
058925                                                                  05892500
058926***************************************************************   05892600
058927***  GET THE WAGE-INDEX                                           05892700
058928***************************************************************   05892800
058929                                                                  05892900
058930     MOVE W-CBSA-WAGE-INDEX TO IPF-WAGE-INDEX.                    05893000
058931                                                                  05893100
058932***************************************************************   05893200
058933***  GET THE AGE ADJUSTMENT                                       05893300
058934***************************************************************   05893400
058935                                                                  05893500
058936     IF BILL-AGE < 45                                             05893600
058937        MOVE 1.00 TO IPF-AGE-ADJ                                  05893700
058938        GO TO 2000-SKIP.                                          05893800
058939                                                                  05893900
058940     IF BILL-AGE < 50                                             05894000
058941        MOVE 1.01 TO IPF-AGE-ADJ                                  05894100
058942        GO TO 2000-SKIP.                                          05894200
058943                                                                  05894300
058944     IF BILL-AGE < 55                                             05894400
058945        MOVE 1.02 TO IPF-AGE-ADJ                                  05894500
058946        GO TO 2000-SKIP.                                          05894600
058947                                                                  05894700
058948     IF BILL-AGE < 60                                             05894800
058949        MOVE 1.04 TO IPF-AGE-ADJ                                  05894900
058950        GO TO 2000-SKIP.                                          05895000
058951                                                                  05895100
058952     IF BILL-AGE < 65                                             05895200
058953        MOVE 1.07 TO IPF-AGE-ADJ                                  05895300
058954        GO TO 2000-SKIP.                                          05895400
058955                                                                  05895500
058956     IF BILL-AGE < 70                                             05895600
058957        MOVE 1.10 TO IPF-AGE-ADJ                                  05895700
058958        GO TO 2000-SKIP.                                          05895800
058959                                                                  05895900
058960     IF BILL-AGE < 75                                             05896000
058961        MOVE 1.13 TO IPF-AGE-ADJ                                  05896100
058962        GO TO 2000-SKIP.                                          05896200
058963                                                                  05896300
058964     IF BILL-AGE < 80                                             05896400
058965        MOVE 1.15 TO IPF-AGE-ADJ                                  05896500
058966        GO TO 2000-SKIP.                                          05896600
058967                                                                  05896700
058968     MOVE 1.17 TO IPF-AGE-ADJ.                                    05896800
058969                                                                  05896900
058970 2000-SKIP.                                                       05897000
058971                                                                  05897100
058972***************************************************************   05897200
058973***  GET THE TEACHING ADJUSTMENT                                  05897300
058974***************************************************************   05897400
058975                                                                  05897500
058976     IF P-NEW-INTERN-RATIO NUMERIC                                05897600
058977        COMPUTE IPF-TEACH-ADJ ROUNDED =                           05897700
058978              ((1 + P-NEW-INTERN-RATIO) ** 0.5150)                05897800
058979     ELSE                                                         05897900
058980        MOVE 1.00 TO IPF-TEACH-ADJ.                               05898000
058981                                                                  05898100
058982***************************************************************   05898200
058983***  GET THE RURAL ADJUSTMENT                                     05898300
058984***************************************************************   05898400
058985                                                                  05898500
058986     PERFORM 2100-CHECK-RURAL-ADJ                                 05898600
058987        THRU 2100-EXIT.                                           05898700
058988                                                                  05898800
058989***************************************************************   05898900
058990***  GET THE EMERGENCY ADJUSTMENT                                 05899000
058991***************************************************************   05899100
058992                                                                  05899200
058993     IF P-NEW-TEMP-RELIEF-IND = 'Y'                               05899300
058994        MOVE 1.31 TO IPF-EMERG-ADJ                                05899400
058995                     DAY-VALUE2 (1)                               05899500
058996     ELSE                                                         05899600
058997        MOVE 1.19 TO IPF-EMERG-ADJ                                05899700
058998                     DAY-VALUE2 (1).                              05899800
058999                                                                  05899900
059000***  CHECK FOR FACILITY W/O FULL SERVICE FROM CLAIM               05900000
059001     IF BILL-SRC-OF-ADMISSION = 'D'                               05900100
059002        MOVE 1.19 TO IPF-EMERG-ADJ                                05900200
059003                     DAY-VALUE2 (1).                              05900300
059004                                                                  05900400
059005***************************************************************   05900500
059006***  GET THE ECT ADJUSTED PAYMENT                                 05900600
059007***************************************************************   05900700
059008                                                                  05900800
059009     COMPUTE IPF-ECT-PAYMENT ROUNDED =                            05900900
059010             (((IPF-ECT-RATE-AMT * IPF-LABOR-SHARE) *             05901000
059011                    W-CBSA-WAGE-INDEX)                            05901100
059012                           +                                      05901200
059013              ((IPF-ECT-RATE-AMT * IPF-NLABOR-SHARE) *            05901300
059014                       IPF-COLA)).                                05901400
059015                                                                  05901500
059016     COMPUTE IPF-ECT-PAYMENT ROUNDED =                            05901600
059017             IPF-ECT-PAYMENT * BILL-ECT-NO-OF-UNITS.              05901700
059018                                                                  05901800
059019 2000-EXIT.   EXIT.                                               05901900
059020                                                                  05902000
059030 2100-CHECK-RURAL-ADJ.                                            05903000
059031                                                                  05903100
059032     IF P-NEW-CBSA-GEO-RURAL-CHECK                                05903200
059033        MOVE 1.17 TO IPF-GEO-RURAL-ADJ                            05903300
059034        MOVE 1.17 TO WS-IPF-GEO-RURAL-ADJ                         05903400
059035     ELSE                                                         05903500
059036        MOVE 1.00 TO IPF-GEO-RURAL-ADJ                            05903600
059037        MOVE 1.00 TO WS-IPF-GEO-RURAL-ADJ.                        05903700
059038                                                                  05903800
059039 2100-EXIT.   EXIT.                                               05903900
059040                                                                  05904000
059041 2600-GET-DRG-FACTORS.                                            05904100
059042                                                                  05904200
059043     SET DRGSUB TO 1.                                             05904300
059044     SEARCH TB-DRG-DATA2 VARYING DRGSUB                           05904400
059045         AT END                                                   05904500
059046            MOVE '60' TO IPF-RTC                                  05904600
059047            GO TO 2600-EXIT                                       05904700
059048         WHEN TB-DRG-CODE (DRGSUB) = BILL-DRG                     05904800
059049            MOVE TB-DRG-FACTOR (DRGSUB, 1) TO IPF-DRG-FACTOR.     05904900
059050                                                                  05905000
059051 2600-EXIT.    EXIT.                                              05905100
059052                                                                  05905200
059053 2700-GET-FIRST-CODES.                                            05905300
059054                                                                  05905400
059055     SET FSTSUB TO 1.                                             05905500
059056     SEARCH TB-FST-DATA2 VARYING FSTSUB                           05905600
059057       AT END                                                     05905700
059058          MOVE 1.00 TO IPF-DRG-FACTOR                             05905800
059059          GO TO 2700-EXIT                                         05905900
059060       WHEN  TB-FST-CODE (FSTSUB) = BILL-OTHER-DIAG-DATA(1)       05906000
059061          MOVE TB-FST-FACTOR (FSTSUB, 1) TO IPF-DRG-FACTOR.       05906100
059062                                                                  05906200
059063 2700-EXIT.    EXIT.                                              05906300
059064                                                                  05906400
059065 3000-CALC-PAYMENT.                                               05906500
059066***************************************************************   05906600
059067***  CALCULATE THE WAGE ADJ RATES                                 05906700
059068***************************************************************   05906800
059069                                                                  05906900
059070     COMPUTE IPF-LABOR-BASE-AMT ROUNDED =                         05907000
059071                ((IPF-BUDGNUT-RATE-AMT * IPF-LABOR-SHARE) *       05907100
059072                     W-CBSA-WAGE-INDEX).                          05907200
059073                                                                  05907300
059074     COMPUTE IPF-NLABOR-BASE-AMT ROUNDED =                        05907400
059075                ((IPF-BUDGNUT-RATE-AMT * IPF-NLABOR-SHARE) *      05907500
059076                     IPF-COLA).                                   05907600
059077                                                                  05907700
059078     COMPUTE IPF-WAGE-ADJ-AMT ROUNDED =                           05907800
059079                (IPF-LABOR-BASE-AMT + IPF-NLABOR-BASE-AMT).       05907900
059080                                                                  05908000
059081***************************************************************   05908100
059082***  CALCULATE ADJUSTED PER DIEM AMOUNT W/O TEACH-ADJ             05908200
059083***************************************************************   05908300
059084                                                                  05908400
059085     COMPUTE WK-ADJ-PER-DIEM-STEP2 ROUNDED =                      05908500
059086          (IPF-COMORB-FACTOR *                                    05908600
059087           IPF-AGE-ADJ * IPF-DRG-FACTOR *                         05908700
059088           WS-IPF-GEO-RURAL-ADJ)                                  05908800
059089****       IPF-GEO-RURAL-ADJ)                                     05908900
059090                         *                                        05909000
059091                IPF-WAGE-ADJ-AMT.                                 05909100
059092                                                                  05909200
059093***************************************************************   05909300
059094***  CALCULATE THE DAY LOS FOR TOTAL PAYMENT W/O  TEACH-ADJ       05909400
059095***************************************************************   05909500
059096                                                                  05909600
059097     MOVE WK-ADJ-PER-DIEM-STEP2 TO IPF-ADJUSTED-PER-DIEM-AMT      05909700
059098                                   WK-PER-DIEM-AMT.               05909800
059099                                                                  05909900
059100     MOVE ZEROES TO DAYS-UPTO-21                                  05910000
059101                    DAYS-OVER-21                                  05910100
059102                    IPF-FED-PAYMENT.                              05910200
059103     MOVE 001    TO SUB                                           05910300
059104                    SUB2.                                         05910400
059105                                                                  05910500
059106     COMPUTE SUB2 = SUB2 + BILL-PRIOR-DAYS.                       05910600
059107     COMPUTE WK-TOTAL-LOS = BILL-LOS + BILL-PRIOR-DAYS.           05910700
059108                                                                  05910800
059109     IF WK-TOTAL-LOS > 21                                         05910900
059110        COMPUTE DAYS-OVER-21 = (WK-TOTAL-LOS - 21)                05911000
059111        MOVE 21 TO DAYS-UPTO-21                                   05911100
059112     ELSE                                                         05911200
059113        MOVE WK-TOTAL-LOS TO DAYS-UPTO-21.                        05911300
059114                                                                  05911400
059115     PERFORM 3100-GET-EACH-DAY THRU 3100-EXIT  VARYING            05911500
059116             SUB FROM SUB2 BY 1 UNTIL                             05911600
059117             SUB > DAYS-UPTO-21.                                  05911700
059118                                                                  05911800
059119     IF WK-TOTAL-LOS > 21                                         05911900
059120        IF BILL-LOS > 0                                           05912000
059121           IF DAYS-OVER-21 > BILL-LOS                             05912100
059122              MOVE BILL-LOS  TO DAYS-OVER-21                      05912200
059123           END-IF                                                 05912300
059124        END-IF                                                    05912400
059125        COMPUTE IPF-FED-PAYMENT ROUNDED =                         05912500
059126                IPF-FED-PAYMENT +                                 05912600
059127       (DAYS-OVER-21 * (WK-PER-DIEM-AMT *                         05912700
059128                         DAY-VALUE2 (22)))                        05912800
059129     END-IF.                                                      05912900
059130                                                                  05913000
059140     MOVE IPF-FED-PAYMENT TO WK-FED-PORTION.                      05914000
059150                                                                  05915000
059160     MOVE ZEROES TO IPF-FED-PAYMENT.                              05916000
059170                                                                  05917000
059180***************************************************************   05918000
059190     IF IPF-TEACH-ADJ = 1.00                                      05919000
059200        MOVE ZEROES TO WK-ADJ-PER-DIEM-STEP1                      05920000
059210                       WK-TEACH-PORTION                           05921000
059220        GO TO 3000-BYPASS-TEACH.                                  05922000
059230                                                                  05923000
059240***************************************************************   05924000
059250***  CALCULATE ADJUSTED PER DIEM AMOUNT WITH TEACHING-ADJ         05925000
059260***************************************************************   05926000
059270                                                                  05927000
059280     COMPUTE WK-ADJ-PER-DIEM-STEP1 ROUNDED =                      05928000
059290          (IPF-COMORB-FACTOR *                                    05929000
059300           IPF-AGE-ADJ * IPF-DRG-FACTOR *                         05930000
059310****       IPF-TEACH-ADJ * IPF-GEO-RURAL-ADJ)                     05931000
059320           IPF-TEACH-ADJ * WS-IPF-GEO-RURAL-ADJ)                  05932000
059330                         *                                        05933000
059340                IPF-WAGE-ADJ-AMT.                                 05934000
059350                                                                  05935000
059360***************************************************************   05936000
059370***  CALCULATE THE ADJUSTED PER DIEM AMOUNT                       05937000
059380***************************************************************   05938000
059390                                                                  05939000
059400     COMPUTE  WK-PER-DIEM-AMT ROUNDED =                           05940000
059410             WK-ADJ-PER-DIEM-STEP1 - WK-ADJ-PER-DIEM-STEP2.       05941000
059420                                                                  05942000
059430     MOVE WK-ADJ-PER-DIEM-STEP1 TO IPF-ADJUSTED-PER-DIEM-AMT.     05943000
059440                                                                  05944000
059450***************************************************************   05945000
059460***  CALCULATE THE DAY LOS FOR TEACH ONLY                         05946000
059470***************************************************************   05947000
059480                                                                  05948000
059490     MOVE ZEROES TO DAYS-UPTO-21                                  05949000
059500                    DAYS-OVER-21                                  05950000
059510                    IPF-FED-PAYMENT.                              05951000
059520                                                                  05952000
059530     MOVE 001    TO SUB                                           05953000
059540                    SUB2.                                         05954000
059550                                                                  05955000
059560     COMPUTE SUB2 = SUB2 + BILL-PRIOR-DAYS.                       05956000
059570     COMPUTE WK-TOTAL-LOS = BILL-LOS + BILL-PRIOR-DAYS.           05957000
059580                                                                  05958000
059590     IF WK-TOTAL-LOS > 21                                         05959000
059600        COMPUTE DAYS-OVER-21 = (WK-TOTAL-LOS - 21)                05960000
059610        MOVE 21 TO DAYS-UPTO-21                                   05961000
059620     ELSE                                                         05962000
059630        MOVE WK-TOTAL-LOS TO DAYS-UPTO-21.                        05963000
059640                                                                  05964000
059650     PERFORM 3100-GET-EACH-DAY THRU 3100-EXIT  VARYING            05965000
059660             SUB FROM SUB2 BY 1 UNTIL                             05966000
059670             SUB > DAYS-UPTO-21.                                  05967000
059680                                                                  05968000
059690     IF WK-TOTAL-LOS > 21                                         05969000
059700        IF BILL-LOS > 0                                           05970000
059710           IF DAYS-OVER-21 > BILL-LOS                             05971000
059720              MOVE BILL-LOS  TO DAYS-OVER-21                      05972000
059730           END-IF                                                 05973000
059740        END-IF                                                    05974000
059750        COMPUTE IPF-FED-PAYMENT ROUNDED =                         05975000
059760                IPF-FED-PAYMENT +                                 05976000
059770       (DAYS-OVER-21 * (WK-PER-DIEM-AMT *                         05977000
059780                         DAY-VALUE2 (22)))                        05978000
059790     END-IF.                                                      05979000
059800                                                                  05980000
059810     MOVE IPF-FED-PAYMENT TO WK-TEACH-PORTION.                    05981000
059820                                                                  05982000
059830     MOVE ZEROES TO IPF-FED-PAYMENT.                              05983000
059840                                                                  05984000
059850***************************************************************   05985000
059860***  ADD FED AND TEACHING INPUT TO OULTLIER                       05986000
059870***************************************************************   05987000
059880 3000-BYPASS-TEACH.                                               05988000
059890                                                                  05989000
059900     COMPUTE IPF-FED-PAYMENT ROUNDED =                            05990000
059910                      WK-FED-PORTION + WK-TEACH-PORTION.          05991000
059920                                                                  05992000
059930***************************************************************   05993000
059940***  CHECK FOR OUTLIER TO BE APPLIED                              05994000
059950***************************************************************   05995000
059960                                                                  05996000
059970     IF ((BILL-PATIENT-STATUS = '30' AND                          05997000
059980          BILL-OUTL-OCCUR-IND  = 'Y')                             05998000
059990                     OR                                           05999000
060000         (BILL-PATIENT-STATUS NOT = '30'))                        06000000
060010          PERFORM 3050-GET-OUTLIER THRU 3050-EXIT.                06001000
060020                                                                  06002000
060030***************************************************************   06003000
060040***  RETURN 100% PPS AMOUNT  FOR STOP LOSS PROVISION              06004000
060050***  NOT BLENDED                                                  06005000
060060***************************************************************   06006000
060070                                                                  06007000
060080      COMPUTE IPF-100PCT-STOPLOS-AMT ROUNDED =                    06008000
060090              WK-FED-PORTION + IPF-OUTLIER-PAYMENT +              06009000
060100              IPF-ECT-PAYMENT + WK-TEACH-PORTION.                 06010000
060200                                                                  06020000
060210     COMPUTE IPF-FED-PAYMENT ROUNDED =                            06021000
060220                WK-FED-PORTION * 1.00                             06022000
060230     COMPUTE IPF-ECT-PAYMENT ROUNDED =                            06023000
060240                IPF-ECT-PAYMENT * 1.00                            06024000
060250     COMPUTE IPF-TEACH-PAYMENT ROUNDED =                          06025000
060260                WK-TEACH-PORTION * 1.00                           06026000
060270     COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                        06027000
060280                IPF-OUTLIER-PAYMENT * 1.00                        06028000
060290      COMPUTE IPF-FAC-PAYMENT ROUNDED =                           06029000
060300                P-NEW-FAC-SPEC-RATE * .0.                         06030000
060310                                                                  06031000
060320     COMPUTE IPF-TOT-PAYMENT ROUNDED =                            06032000
060330             IPF-FED-PAYMENT + IPF-FAC-PAYMENT +                  06033000
060340             IPF-ECT-PAYMENT + IPF-TEACH-PAYMENT +                06034000
060350             IPF-OUTLIER-PAYMENT.                                 06035000
060360                                                                  06036000
060370     IF IPF-RTC = 00                                              06037000
060380        IF BILL-PRIOR-DAYS IS GREATER THAN 0                      06038000
060390           MOVE 03 TO IPF-RTC.                                    06039000
060400     IF IPF-RTC = 02                                              06040000
060410        IF BILL-PRIOR-DAYS IS GREATER THAN 0                      06041000
060420           MOVE 04 TO IPF-RTC.                                    06042000
060430                                                                  06043000
060440 3000-EXIT.   EXIT.                                               06044000
060450                                                                  06045000
060460************************************                              06046000
060470***  CALCULATE THE OUTLIER PAYMENT                                06047000
060480************************************                              06048000
060490 3050-GET-OUTLIER.                                                06049000
060500                                                                  06050000
060510************************************                              06051000
060520** CALCULATE THE ADJUSTED FIXED                                   06052000
060530**    DOLLAR LOSS THRESHOLD                                       06053000
060540************************************                              06054000
060550                                                                  06055000
060560     COMPUTE IPF-OUTL-LABOR-BASE-AMT ROUNDED =                    06056000
060570                ((IPF-OUTL-THRES-AMT * IPF-LABOR-SHARE) *         06057000
060580                     W-CBSA-WAGE-INDEX).                          06058000
060590                                                                  06059000
060600     COMPUTE IPF-OUTL-NLABOR-BASE-AMT ROUNDED =                   06060000
060610                ((IPF-OUTL-THRES-AMT * IPF-NLABOR-SHARE) *        06061000
060620                     IPF-COLA).                                   06062000
060630                                                                  06063000
060640     COMPUTE IPF-OUTL-THRES-ADJ-AMT ROUNDED =                     06064000
060650           ((IPF-OUTL-LABOR-BASE-AMT +                            06065000
060660             IPF-OUTL-NLABOR-BASE-AMT) *                          06066000
060670****         IPF-GEO-RURAL-ADJ *                                  06067000
060671             WS-IPF-GEO-RURAL-ADJ *                               06067100
060672             IPF-TEACH-ADJ) +                                     06067200
060673             IPF-FED-PAYMENT +                                    06067300
060674             IPF-ECT-PAYMENT.                                     06067400
060675                                                                  06067500
060676**  NOTE> IPF-FED-PAYMENT CONTAINS NO ECT OR OUTL PAYMENT         06067600
060677**           AT THIS POINT IN THE PROGRAM LOGIC                   06067700
060678                                                                  06067800
060679************************************                              06067900
060680** CALCULATE ELIGIBLE OUTLIER COSTS                               06068000
060690************************************                              06069000
060700                                                                  06070000
060710     MOVE P-NEW-OPER-CSTCHG-RATIO TO IPF-CSTCHG-RATIO.            06071000
060720     COMPUTE IPF-OUTL-COST ROUNDED =                              06072000
060730             (BILL-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO).    06073000
060740                                                                  06074000
060750     MOVE '02' TO IPF-RTC.                                        06075000
060760                                                                  06076000
060770     IF IPF-OUTL-COST < IPF-OUTL-THRES-ADJ-AMT                    06077000
060780        MOVE '00' TO IPF-RTC                                      06078000
060790        MOVE ZEROES TO IPF-OUTLIER-PAYMENT                        06079000
060800        GO TO 3050-EXIT.                                          06080000
060810                                                                  06081000
060820     COMPUTE IPF-OUTL-ADJ-COST ROUNDED =                          06082000
060830             (IPF-OUTL-COST - IPF-OUTL-THRES-ADJ-AMT).            06083000
060840                                                                  06084000
060850     COMPUTE IPF-OUTL-PER-DIEM-AMT ROUNDED =                      06085000
060860            (IPF-OUTL-ADJ-COST / BILL-LOS).                       06086000
060870                                                                  06087000
060880     MOVE ZEROES TO DAYS-UPTO-9                                   06088000
060890                    DAYS-OVER-9.                                  06089000
060900                                                                  06090000
060910     IF BILL-LOS > 9                                              06091000
060920        COMPUTE DAYS-OVER-9 = (BILL-LOS - 9)                      06092000
060930        MOVE 9 TO DAYS-UPTO-9                                     06093000
060940     ELSE                                                         06094000
060950        MOVE BILL-LOS TO DAYS-UPTO-9.                             06095000
060960                                                                  06096000
060970     COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                        06097000
060980            (DAYS-UPTO-9 * (IPF-OUTL-PER-DIEM-AMT * .80)).        06098000
060990                                                                  06099000
061000     IF BILL-LOS > 9                                              06100000
061010        COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                     06101000
061020                IPF-OUTLIER-PAYMENT +                             06102000
061030       (DAYS-OVER-9 * (IPF-OUTL-PER-DIEM-AMT * .60)).             06103000
061040                                                                  06104000
061050     IF IPF-OUTLIER-PAYMENT = ZEROES                              06105000
061060        MOVE '00' TO IPF-RTC.                                     06106000
061070                                                                  06107000
061080 3050-EXIT.   EXIT.                                               06108000
061090                                                                  06109000
061100 3100-GET-EACH-DAY.                                               06110000
061110                                                                  06111000
061120     COMPUTE IPF-FED-PAYMENT ROUNDED =                            06112000
061130             IPF-FED-PAYMENT + (WK-PER-DIEM-AMT *                 06113000
061140                                  DAY-VALUE2 (SUB)).              06114000
061150                                                                  06115000
061160 3100-EXIT.   EXIT.                                               06116000
061170                                                                  06117000
061180 3300-GET-COMORBIDITY.                                            06118000
061190                                                                  06119000
061200     INITIALIZE SW-CATS.                                          06120000
061210     MOVE BILL-DIAG-PROC-DATA TO WK-COMORBIDITY-DATA.             06121000
061220     MOVE 01.0000 TO HOLDADJ.                                     06122000
061230                                                                  06123000
061240     PERFORM 4000-CAT-SEARCH THRU 4000-EXIT                       06124000
061250       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25                       06125000
061260            OR SW-STOP-CATS = 'Y'.                                06126000
061270                                                                  06127000
061280     MOVE HOLDADJ TO IPF-COMORB-FACTOR.                           06128000
061290                                                                  06129000
061300 3300-EXIT.   EXIT.                                               06130000
061310     EJECT                                                        06131000
061320******************************************************************06132000
061330* EACH CATEGORY CAN ONLY BE HIT ONCE FOR EACH BILL               *06133000
061340******************************************************************06134000
061350 4000-CAT-SEARCH.                                                 06135000
061360                                                                  06136000
061370     IF DDXX (X1) = SPACES                                        06137000
061380         MOVE 'Y'    TO SW-STOP-CATS                              06138000
061390         GO TO 4000-EXIT.                                         06139000
061400                                                                  06140000
061410     PERFORM 4010-CAT1-SEARCH        THRU 4010-EXIT.              06141000
061420     PERFORM 4020-CAT2-SEARCH        THRU 4020-EXIT.              06142000
061430     PERFORM 4030-CAT3-SEARCH        THRU 4030-EXIT.              06143000
061440     PERFORM 4040-CAT4-SEARCH        THRU 4040-EXIT.              06144000
061450     PERFORM 4050-CAT5-SEARCH        THRU 4050-EXIT.              06145000
061460     PERFORM 4060-CAT6-SEARCH        THRU 4060-EXIT.              06146000
061470     PERFORM 4070-CAT7-SEARCH        THRU 4070-EXIT.              06147000
061480     PERFORM 4080-CAT8-SEARCH        THRU 4080-EXIT.              06148000
061490     PERFORM 4090-CAT9-SEARCH        THRU 4090-EXIT.              06149000
061500     PERFORM 4100-CAT10-SEARCH       THRU 4100-EXIT.              06150000
061510     PERFORM 4110-CAT11-SEARCH       THRU 4110-EXIT.              06151000
061520     PERFORM 4120-CAT12-SEARCH       THRU 4120-EXIT.              06152000
061530     PERFORM 4130-CAT13-SEARCH       THRU 4130-EXIT.              06153000
061540     PERFORM 4140-CAT14-SEARCH       THRU 4140-EXIT.              06154000
061550     PERFORM 4150-CAT15-SEARCH       THRU 4150-EXIT.              06155000
061560     PERFORM 4160-CAT16-SEARCH       THRU 4160-EXIT.              06156000
061570     PERFORM 4170-CAT17-SEARCH       THRU 4170-EXIT.              06157000
061580                                                                  06158000
061590 4000-EXIT.                                                       06159000
061600     EXIT.                                                        06160000
061610     EJECT                                                        06161000
061620***************************************************************   06162000
061630* DEVELOPMENTAL DISABILITIES                                  *   06163000
061640***************************************************************   06164000
061650 4010-CAT1-SEARCH.                                                06165000
061660                                                                  06166000
061670     IF SW-CAT1 = 'Y'                                             06167000
061680        GO TO 4010-EXIT.                                          06168000
061690                                                                  06169000
061700     SEARCH ALL CAT1-DATA                                         06170000
061710        AT END                                                    06171000
061720          GO TO 4010-EXIT                                         06172000
061730        WHEN                                                      06173000
061740          CAT1-CODE (IX-CAT1) = DDXX (X1)                         06174000
061750          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.04                06175000
061760          MOVE 'Y' TO SW-CAT1.                                    06176000
061770                                                                  06177000
061780 4010-EXIT.                                                       06178000
061790     EXIT.                                                        06179000
061800     EJECT                                                        06180000
061810***************************************************************   06181000
061820* COAGULATION FACTOR DEFICITS                                 *   06182000
061830***************************************************************   06183000
061840 4020-CAT2-SEARCH.                                                06184000
061850                                                                  06185000
061860     IF SW-CAT2 = 'Y'                                             06186000
061870        GO TO 4020-EXIT.                                          06187000
061880                                                                  06188000
061890     SEARCH ALL CAT2-DATA                                         06189000
061900        AT END                                                    06190000
061910          GO TO 4020-EXIT                                         06191000
061920        WHEN                                                      06192000
061930          CAT2-CODE (IX-CAT2) = DDXX (X1)                         06193000
061940          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.13                06194000
061950          MOVE 'Y' TO SW-CAT2.                                    06195000
061960                                                                  06196000
061970 4020-EXIT.                                                       06197000
061980     EXIT.                                                        06198000
061990     EJECT                                                        06199000
062000***************************************************************   06200000
062010* TRACHEOSTOMY                                                *   06201000
062020***************************************************************   06202000
062030 4030-CAT3-SEARCH.                                                06203000
062040                                                                  06204000
062050     IF SW-CAT3 = 'Y'                                             06205000
062060        GO TO 4030-EXIT.                                          06206000
062070                                                                  06207000
062080     SEARCH ALL CAT3-DATA                                         06208000
062090        AT END                                                    06209000
062100          GO TO 4030-EXIT                                         06210000
062110        WHEN                                                      06211000
062120          CAT3-CODE (IX-CAT3) = DDXX (X1)                         06212000
062130          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.06                06213000
062140          MOVE 'Y' TO SW-CAT3.                                    06214000
062150                                                                  06215000
062160 4030-EXIT.                                                       06216000
062170     EXIT.                                                        06217000
062180     EJECT                                                        06218000
062190***************************************************************   06219000
062200* RENAL FAILURE, ACUTE                                        *   06220000
062210***************************************************************   06221000
062220 4040-CAT4-SEARCH.                                                06222000
062230                                                                  06223000
062240     IF SW-CAT4 = 'Y'                                             06224000
062250        GO TO 4040-EXIT.                                          06225000
062260                                                                  06226000
062270     SEARCH ALL CAT4-DATA                                         06227000
062280        AT END                                                    06228000
062290          GO TO 4040-EXIT                                         06229000
062300        WHEN                                                      06230000
062310          CAT4-CODE (IX-CAT4) = DDXX (X1)                         06231000
062320          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.11                06232000
062330          MOVE 'Y' TO SW-CAT4.                                    06233000
062340                                                                  06234000
062350 4040-EXIT.                                                       06235000
062360     EXIT.                                                        06236000
062370     EJECT                                                        06237000
062380***************************************************************   06238000
062390* RENAL FAILURE, CHRONIC     EFFECTIVE 10/01/2005             *   06239000
062400***************************************************************   06240000
062410 4050-CAT5-SEARCH.                                                06241000
062420                                                                  06242000
062430     IF SW-CAT5 = 'Y'                                             06243000
062440        GO TO 4050-EXIT.                                          06244000
062450                                                                  06245000
062460     SEARCH ALL CAT5-DATA                                         06246000
062470        AT END                                                    06247000
062480          GO TO 4050-EXIT                                         06248000
062490        WHEN                                                      06249000
062500          CAT5-CODE (IX-CAT5) = DDXX (X1)                         06250000
062510          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.11                06251000
062520          MOVE 'Y' TO SW-CAT5.                                    06252000
062530                                                                  06253000
062540 4050-EXIT.                                                       06254000
062550     EXIT.                                                        06255000
062560     EJECT                                                        06256000
062570***************************************************************   06257000
062580* ONCOLOGY TREATMENT - DIAGNOSIS CODES                        *   06258000
062590***************************************************************   06259000
062600 4060-CAT6-SEARCH.                                                06260000
062610                                                                  06261000
062620     IF SW-CAT6 = 'Y'                                             06262000
062630        GO TO 4060-EXIT.                                          06263000
062640                                                                  06264000
062650     SEARCH ALL CAT6-DATA                                         06265000
062660        AT END                                                    06266000
062670          GO TO 4060-EXIT                                         06267000
062680        WHEN                                                      06268000
062690          CAT6-CODE (IX-CAT6) = DDXX (X1)                         06269000
062700          MOVE SPACE TO SW-CAT6P                                  06270000
062710          PERFORM 4065-CAT6P-SEARCH THRU 4065-EXIT                06271000
062720                  VARYING X2 FROM 1 BY 1 UNTIL X2 > 25            06272000
062730                  OR SW-CAT6P = 'Y'.                              06273000
062740                                                                  06274000
062750 4060-EXIT.                                                       06275000
062760     EXIT.                                                        06276000
062770     EJECT                                                        06277000
062780***************************************************************   06278000
062790* ONCOLOGY TREATMENT - PROCEDURE CODES                        *   06279000
062800***************************************************************   06280000
062810 4065-CAT6P-SEARCH.                                               06281000
062820                                                                  06282000
062830     SEARCH ALL CAT6P-DATA                                        06283000
062840        AT END                                                    06284000
062850          GO TO 4065-EXIT                                         06285000
062860        WHEN                                                      06286000
062870          CAT6P-CODE (IX-CAT6P) = SRGX (X2)                       06287000
062880          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.07                06288000
062890          MOVE 'Y' TO SW-CAT6                                     06289000
062900          MOVE 'Y' TO SW-CAT6P.                                   06290000
062910                                                                  06291000
062920 4065-EXIT.                                                       06292000
062930     EXIT.                                                        06293000
062940     EJECT                                                        06294000
062950***************************************************************   06295000
062960* UNCONTROLLED DIABETES-MELLITUS W OR WO COMPLICATIONS        *   06296000
062970***************************************************************   06297000
062980 4070-CAT7-SEARCH.                                                06298000
062990                                                                  06299000
063000     IF SW-CAT7 = 'Y'                                             06300000
063010        GO TO 4070-EXIT.                                          06301000
063020                                                                  06302000
063030     SEARCH ALL CAT7-DATA                                         06303000
063040        AT END                                                    06304000
063050          GO TO 4070-EXIT                                         06305000
063060        WHEN                                                      06306000
063070          CAT7-CODE (IX-CAT7) = DDXX (X1)                         06307000
063080          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.05                06308000
063090          MOVE 'Y' TO SW-CAT7.                                    06309000
063100                                                                  06310000
063110 4070-EXIT.                                                       06311000
063120     EXIT.                                                        06312000
063130     EJECT                                                        06313000
063140***************************************************************   06314000
063150* SEVERE PROTEIN CALORTIE MALNUTRITION                        *   06315000
063160***************************************************************   06316000
063170 4080-CAT8-SEARCH.                                                06317000
063180                                                                  06318000
063190     IF SW-CAT8 = 'Y'                                             06319000
063200        GO TO 4080-EXIT.                                          06320000
063210                                                                  06321000
063220     SEARCH ALL CAT8-DATA                                         06322000
063230        AT END                                                    06323000
063240          GO TO 4080-EXIT                                         06324000
063250        WHEN                                                      06325000
063260          CAT8-CODE (IX-CAT8) = DDXX (X1)                         06326000
063270          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.13                06327000
063280          MOVE 'Y' TO SW-CAT8.                                    06328000
063290                                                                  06329000
063300 4080-EXIT.                                                       06330000
063310     EXIT.                                                        06331000
063320     EJECT                                                        06332000
063330***************************************************************   06333000
063340* EATING AND CONDUCT DISORDERS                                *   06334000
063350***************************************************************   06335000
063360 4090-CAT9-SEARCH.                                                06336000
063370                                                                  06337000
063380     IF SW-CAT9 = 'Y'                                             06338000
063390        GO TO 4090-EXIT.                                          06339000
063400                                                                  06340000
063410     SEARCH ALL CAT9-DATA                                         06341000
063420        AT END                                                    06342000
063430          GO TO 4090-EXIT                                         06343000
063440        WHEN                                                      06344000
063450          CAT9-CODE (IX-CAT9) = DDXX (X1)                         06345000
063460          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.12                06346000
063470          MOVE 'Y' TO SW-CAT9.                                    06347000
063480                                                                  06348000
063490 4090-EXIT.                                                       06349000
063500     EXIT.                                                        06350000
063510     EJECT                                                        06351000
063520***************************************************************   06352000
063530* INFECTIOUS DISEASE                                          *   06353000
063540***************************************************************   06354000
063550 4100-CAT10-SEARCH.                                               06355000
063560                                                                  06356000
063570     IF SW-CAT10 = 'Y'                                            06357000
063580        GO TO 4100-EXIT.                                          06358000
063590                                                                  06359000
063600     SEARCH ALL CAT10-DATA                                        06360000
063610        AT END                                                    06361000
063620          GO TO 4100-EXIT                                         06362000
063630        WHEN                                                      06363000
063640          CAT10-CODE (IX-CAT10) = DDXX (X1)                       06364000
063650          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.07                06365000
063660          MOVE 'Y' TO SW-CAT10.                                   06366000
063670                                                                  06367000
063680 4100-EXIT.                                                       06368000
063690     EXIT.                                                        06369000
063700     EJECT                                                        06370000
063710***************************************************************   06371000
063720* DRUG AND/OR ALCOHOL INDUCED MENTAL DISORDERS                *   06372000
063730***************************************************************   06373000
063740 4110-CAT11-SEARCH.                                               06374000
063750                                                                  06375000
063760     IF SW-CAT11 = 'Y'                                            06376000
063770        GO TO 4110-EXIT.                                          06377000
063780                                                                  06378000
063790     SEARCH ALL CAT11-DATA                                        06379000
063800        AT END                                                    06380000
063810          GO TO 4110-EXIT                                         06381000
063820        WHEN                                                      06382000
063830          CAT11-CODE (IX-CAT11) = DDXX (X1)                       06383000
063840          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.03                06384000
063850          MOVE 'Y' TO SW-CAT11.                                   06385000
063860                                                                  06386000
063870 4110-EXIT.                                                       06387000
063880     EXIT.                                                        06388000
063890     EJECT                                                        06389000
063900***************************************************************   06390000
063910* CARDIAC CONDITIONS                                          *   06391000
063920***************************************************************   06392000
063930 4120-CAT12-SEARCH.                                               06393000
063940                                                                  06394000
063950     IF SW-CAT12 = 'Y'                                            06395000
063960        GO TO 4120-EXIT.                                          06396000
063970                                                                  06397000
063980     SEARCH ALL CAT12-DATA                                        06398000
063990        AT END                                                    06399000
064000          GO TO 4120-EXIT                                         06400000
064010        WHEN                                                      06401000
064020          CAT12-CODE (IX-CAT12) = DDXX (X1)                       06402000
064030          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.11                06403000
064040          MOVE 'Y' TO SW-CAT12.                                   06404000
064050                                                                  06405000
064060 4120-EXIT.                                                       06406000
064070     EXIT.                                                        06407000
064080     EJECT                                                        06408000
064090***************************************************************   06409000
064100* GANGRENE                                                    *   06410000
064110***************************************************************   06411000
064120 4130-CAT13-SEARCH.                                               06412000
064130                                                                  06413000
064140     IF SW-CAT13 = 'Y'                                            06414000
064150        GO TO 4130-EXIT.                                          06415000
064160                                                                  06416000
064170     SEARCH ALL CAT13-DATA                                        06417000
064180        AT END                                                    06418000
064190          GO TO 4130-EXIT                                         06419000
064200        WHEN                                                      06420000
064210          CAT13-CODE (IX-CAT13) = DDXX (X1)                       06421000
064220          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.10                06422000
064230          MOVE 'Y' TO SW-CAT13.                                   06423000
064240                                                                  06424000
064250 4130-EXIT.                                                       06425000
064260     EXIT.                                                        06426000
064270     EJECT                                                        06427000
064280***************************************************************   06428000
064290* CHRONIC OBSTRUCTIVE PULMONARY DISEASE - EFFECTIVE 10/01/2005*   06429000
064300***************************************************************   06430000
064310 4140-CAT14-SEARCH.                                               06431000
064320                                                                  06432000
064330     IF SW-CAT14 = 'Y'                                            06433000
064340        GO TO 4140-EXIT.                                          06434000
064350                                                                  06435000
064360     SEARCH ALL CAT14-DATA                                        06436000
064370        AT END                                                    06437000
064380          GO TO 4140-EXIT                                         06438000
064390        WHEN                                                      06439000
064400          CAT14-CODE (IX-CAT14) = DDXX (X1)                       06440000
064410          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.12                06441000
064420          MOVE 'Y' TO SW-CAT14.                                   06442000
064430                                                                  06443000
064440 4140-EXIT.                                                       06444000
064450     EXIT.                                                        06445000
064460     EJECT                                                        06446000
064470***************************************************************   06447000
064480* ARTIFICIAL OPENINGS - DIGESTIVE AND URINARY                 *   06448000
064490***************************************************************   06449000
064500 4150-CAT15-SEARCH.                                               06450000
064510                                                                  06451000
064520     IF SW-CAT15 = 'Y'                                            06452000
064530        GO TO 4150-EXIT.                                          06453000
064540                                                                  06454000
064550     SEARCH ALL CAT15-DATA                                        06455000
064560        AT END                                                    06456000
064570          GO TO 4150-EXIT                                         06457000
064580        WHEN                                                      06458000
064590          CAT15-CODE (IX-CAT15) = DDXX (X1)                       06459000
064600          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.08                06460000
064610          MOVE 'Y' TO SW-CAT15.                                   06461000
064620                                                                  06462000
064630 4150-EXIT.                                                       06463000
064640     EXIT.                                                        06464000
064650     EJECT                                                        06465000
064660***************************************************************   06466000
064670* SEVERE MUSCLOSKELETAL AND CONNECTIVE TISSUE                 *   06467000
064680***************************************************************   06468000
064690 4160-CAT16-SEARCH.                                               06469000
064700                                                                  06470000
064710     IF SW-CAT16 = 'Y'                                            06471000
064720        GO TO 4160-EXIT.                                          06472000
064730                                                                  06473000
064740     SEARCH ALL CAT16-DATA                                        06474000
064750        AT END                                                    06475000
064760          GO TO 4160-EXIT                                         06476000
064770        WHEN                                                      06477000
064780          CAT16-CODE (IX-CAT16) = DDXX (X1)                       06478000
064790          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.09                06479000
064800          MOVE 'Y' TO SW-CAT16.                                   06480000
064810                                                                  06481000
064820 4160-EXIT.                                                       06482000
064830     EXIT.                                                        06483000
064840     EJECT                                                        06484000
064850***************************************************************   06485000
064860* POISONING                                                   *   06486000
064870***************************************************************   06487000
064880 4170-CAT17-SEARCH.                                               06488000
064890                                                                  06489000
064900     IF SW-CAT17 = 'Y'                                            06490000
064910        GO TO 4170-EXIT.                                          06491000
064920                                                                  06492000
064930     SEARCH ALL CAT17-DATA                                        06493000
064940        AT END                                                    06494000
064950          GO TO 4170-EXIT                                         06495000
064960        WHEN                                                      06496000
064970          CAT17-CODE (IX-CAT17) = DDXX (X1)                       06497000
064980          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.11                06498000
064990          MOVE 'Y' TO SW-CAT17.                                   06499000
065000                                                                  06500000
065010 4170-EXIT.                                                       06501000
065020     EXIT.                                                        06502000
065030                                                                  06503000
065040***************************************************************   06504000
065050******       L A S T   S O U R C E   S T A T E M E N T    *****   06505000
065060***************************************************************   06506000
