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