000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.           IPCAL08A.                                  00020000
000300*AUTHOR.               cms.                                       00030002
000400*REMARKS.              CMS.                                       00040002
000500****     FIRST IPF STARTED 01/01/2005 AND WILL RUN FOR 18MTHS     00050000
000600****     NEW IPF YEAR WILL START IN JULY OF ANY GIVEN YEAR        00060000
000700 DATE-COMPILED.                                                   00070000
000800 ENVIRONMENT DIVISION.                                            00080000
000900 CONFIGURATION SECTION.                                           00090000
001000 SOURCE-COMPUTER.            IBM-370.                             00100000
001100 OBJECT-COMPUTER.            IBM-370.                             00110000
001200 INPUT-OUTPUT  SECTION.                                           00120000
001300 FILE-CONTROL.                                                    00130000
001400                                                                  00140000
001500 DATA DIVISION.                                                   00150000
001600 FILE SECTION.                                                    00160000
001700                                                                  00170000
001800 WORKING-STORAGE SECTION.                                         00180000
001900 01  W-STORAGE-REF                  PIC X(46)  VALUE              00190000
002000     'IPCAL08A      - W O R K I N G   S T O R A G E'.             00200000
002100 01  CAL-VERSION                    PIC X(05)  VALUE 'C08.A'.     00210000
002200***************************************************************   00220000
002300***************************************************************   00230000
002400 01  SUB                     PIC 999   VALUE 0.                   00240000
002500 01  SUB2                    PIC 999   VALUE 0.                   00250000
002600 01  DAYS-UPTO-21            PIC 9(05) VALUE 0.                   00260000
002700 01  DAYS-OVER-21            PIC 9(05) VALUE 0.                   00270000
002800 01  DAYS-UPTO-9             PIC 9(05) VALUE 0.                   00280000
002900 01  DAYS-OVER-9             PIC 9(05) VALUE 0.                   00290000
003000 01  X1                      PIC 9(05)  COMP SYNC VALUE 0.        00300000
003100 01  X2                      PIC 9(05)  COMP SYNC VALUE 0.        00310000
003200 01  HOLDADJ                 PIC 9(02)V9(4)  COMP SYNC VALUE 0.   00320000
003300 01  WK-FED-PORTION          PIC 9(07)V9(2)  VALUE 0.             00330000
003400 01  WK-TEACH-PORTION        PIC 9(07)V9(2)  VALUE 0.             00340000
003500 01  WK-PER-DIEM-AMT         PIC 9(07)V9(2)  VALUE 0.             00350000
003600 01  WK-ADJ-PER-DIEM-STEP1   PIC 9(07)V9(2)  VALUE 0.             00360000
003700 01  WK-ADJ-PER-DIEM-STEP2   PIC 9(07)V9(2)  VALUE 0.             00370000
003800                                                                  00380000
003900******************************************************************00390000
004000***    INREC IS A SKEL OF FILE TO BE USED   FOR TESTING ONLY      00400000
004100*          OR IT IS THE CODE PASSED FROM PRICER                   00410000
004200***************************************************************   00420000
004300                                                                  00430000
004400 01  WK-COMORBIDITY-DATA.                                         00440000
004500     05  DDX.                                                     00450000
004600         10  DDXX         OCCURS 25 TIMES.                        00460001
004700             20 WK-DDXX1     PIC X.                               00470000
004800             20 WK-DDXX2     PIC X.                               00480000
004900             20 WK-DDXX3     PIC X.                               00490000
005000             20 WK-DDXX4     PIC X.                               00500000
005100             20 WK-DDXX5     PIC X.                               00510000
005200             20 WK-DDXX6     PIC X.                               00520000
005300             20 WK-DDXX7     PIC X.                               00530000
005400     05  SRG.                                                     00540000
005500         10  SRGX         PIC X(07)  OCCURS 25 TIMES.             00550001
005600                                                                  00560000
005700 01  OUT-DDXX-ZERO.                                               00570000
005800     05  OUT-Z-DDXX1          PIC X.                              00580000
005900     05  OUT-Z-DDXX2          PIC X.                              00590000
006000     05  OUT-Z-DDXX3          PIC X.                              00600000
006100     05  OUT-Z-DDXX4          PIC X.                              00610000
006200     05  OUT-Z-DDXX5          PIC X.                              00620000
006300     05  OUT-Z-DDXX6          PIC X.                              00630000
006400     05  OUT-Z-DDXX7          PIC X.                              00640000
006500*******************************************************           00650000
006600***************************************************************   00660000
006700***************************************************************   00670000
006800 01  DRG-FACTOR-TABLE.                                            00680000
006900     02  TB-DRG-DATA.                                             00690000
007000         10  FILLER      PIC X(07) VALUE '012 105'.               00700000
007100         10  FILLER      PIC X(07) VALUE '023 107'.               00710000
007200         10  FILLER      PIC X(07) VALUE '424 122'.               00720000
007300         10  FILLER      PIC X(07) VALUE '425 105'.               00730000
007400         10  FILLER      PIC X(07) VALUE '426 099'.               00740000
007500         10  FILLER      PIC X(07) VALUE '427 102'.               00750000
007600         10  FILLER      PIC X(07) VALUE '428 102'.               00760000
007700         10  FILLER      PIC X(07) VALUE '429 103'.               00770000
007800         10  FILLER      PIC X(07) VALUE '430 100'.               00780000
007900         10  FILLER      PIC X(07) VALUE '431 099'.               00790000
008000         10  FILLER      PIC X(07) VALUE '432 092'.               00800000
008100         10  FILLER      PIC X(07) VALUE '433 097'.               00810000
008200         10  FILLER      PIC X(07) VALUE '521 102'.               00820000
008300         10  FILLER      PIC X(07) VALUE '522 098'.               00830000
008400         10  FILLER      PIC X(07) VALUE '523 088'.               00840000
008500     02  TB-DRG-DATA2 REDEFINES TB-DRG-DATA OCCURS 15             00850000
008600             ASCENDING KEY IS TB-DRG-CODE                         00860000
008700             INDEXED BY DRGSUB.                                   00870000
008800          05  TB-DRG-CODE           PIC XXX.                      00880000
008900          05  TB-DRG-ADJUSTMENTS  OCCURS 1.                       00890000
009000              10  FILLER            PIC X.                        00900000
009100              10  TB-DRG-FACTOR     PIC 9V99.                     00910000
009200                                                                  00920000
009300***************************************************************   00930000
009400***************************************************************   00940000
009500 01  CODE-FIRST-TABLE.                                            00950000
009600     02  TB-FST-DATA.                                             00960000
009700         10  FILLER      PIC X(11) VALUE '2900    103'.           00970000
009800         10  FILLER      PIC X(11) VALUE '29010   103'.           00980000
009900         10  FILLER      PIC X(11) VALUE '29011   103'.           00990000
010000         10  FILLER      PIC X(11) VALUE '29012   103'.           01000000
010100         10  FILLER      PIC X(11) VALUE '29013   103'.           01010000
010200         10  FILLER      PIC X(11) VALUE '29020   103'.           01020000
010300         10  FILLER      PIC X(11) VALUE '29021   103'.           01030000
010400         10  FILLER      PIC X(11) VALUE '2903    103'.           01040000
010500         10  FILLER      PIC X(11) VALUE '29040   103'.           01050000
010600         10  FILLER      PIC X(11) VALUE '29041   103'.           01060000
010700         10  FILLER      PIC X(11) VALUE '29042   103'.           01070000
010800         10  FILLER      PIC X(11) VALUE '29043   103'.           01080000
010900         10  FILLER      PIC X(11) VALUE '2908    103'.           01090000
011000         10  FILLER      PIC X(11) VALUE '2909    103'.           01100000
011100         10  FILLER      PIC X(11) VALUE '2930    105'.           01110000
011200         10  FILLER      PIC X(11) VALUE '2931    105'.           01120000
011300         10  FILLER      PIC X(11) VALUE '29381   103'.           01130000
011400         10  FILLER      PIC X(11) VALUE '29382   103'.           01140000
011500         10  FILLER      PIC X(11) VALUE '29383   103'.           01150000
011600         10  FILLER      PIC X(11) VALUE '29384   103'.           01160000
011700         10  FILLER      PIC X(11) VALUE '29389   103'.           01170000
011800         10  FILLER      PIC X(11) VALUE '2939    105'.           01180000
011900         10  FILLER      PIC X(11) VALUE '2940    103'.           01190000
012000         10  FILLER      PIC X(11) VALUE '29410   103'.           01200000
012100         10  FILLER      PIC X(11) VALUE '29411   103'.           01210000
012200         10  FILLER      PIC X(11) VALUE '30789   102'.           01220000
012300     02  TB-FST-DATA2 REDEFINES TB-FST-DATA OCCURS 26             01230000
012400             ASCENDING KEY IS TB-FST-CODE                         01240000
012500             INDEXED BY FSTSUB.                                   01250000
012600          05  TB-FST-CODE           PIC X(07).                    01260000
012700          05  TB-FST-ADJUSTMENTS  OCCURS 1.                       01270000
012800              10  FILLER            PIC X.                        01280000
012900              10  TB-FST-FACTOR     PIC 9V99.                     01290000
013000                                                                  01300000
013100***************************************************************   01310000
013200***************************************************************   01320000
013300 01  DAY-ADJUSTMENTS.                                             01330000
013400     02  DAY-VALUES.                                              01340000
013500         10  DAY1        PIC XXX  VALUE '000'.                    01350000
013600         10  DAY2        PIC XXX  VALUE '112'.                    01360000
013700         10  DAY3        PIC XXX  VALUE '108'.                    01370000
013800         10  DAY4        PIC XXX  VALUE '105'.                    01380000
013900         10  DAY5        PIC XXX  VALUE '104'.                    01390000
014000         10  DAY6        PIC XXX  VALUE '102'.                    01400000
014100         10  DAY7        PIC XXX  VALUE '101'.                    01410000
014200         10  DAY8        PIC XXX  VALUE '101'.                    01420000
014300         10  DAY9        PIC XXX  VALUE '100'.                    01430000
014400         10  DAY10       PIC XXX  VALUE '100'.                    01440000
014500         10  DAY11       PIC XXX  VALUE '099'.                    01450000
014600         10  DAY12       PIC XXX  VALUE '099'.                    01460000
014700         10  DAY13       PIC XXX  VALUE '099'.                    01470000
014800         10  DAY14       PIC XXX  VALUE '099'.                    01480000
014900         10  DAY15       PIC XXX  VALUE '098'.                    01490000
015000         10  DAY16       PIC XXX  VALUE '097'.                    01500000
015100         10  DAY17       PIC XXX  VALUE '097'.                    01510000
015200         10  DAY18       PIC XXX  VALUE '096'.                    01520000
015300         10  DAY19       PIC XXX  VALUE '095'.                    01530000
015400         10  DAY20       PIC XXX  VALUE '095'.                    01540000
015500         10  DAY21       PIC XXX  VALUE '095'.                    01550000
015600         10  DAY21-OVER  PIC XXX  VALUE '092'.                    01560000
015700     02  DAY-VALUES2 REDEFINES DAY-VALUES OCCURS 22.              01570000
015800         10 DAY-VALUE2   PIC 9V99.                                01580000
015900                                                                  01590000
016000 LINKAGE SECTION.                                                 01600000
016100***************************************************************   01610000
016200*                 * * * * * * * * *                           *   01620000
016300                                                                  01630000
016400***************************************************************   01640000
016500*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *   01650000
016600*    AND PASSED BACK TO THE CALLING PROGRAM                   *   01660000
016700*            RETURN CODE VALUES (IPF-RTC)                     *   01670000
016800*                                                             *   01680000
016900*            IPF-RTC 00-49 = HOW THE BILL WAS PAID            *   01690000
017000*                                                             *   01700000
017100*                                                             *   01710000
017200*              00 = PAID NORMAL IPF PAYMENT                   *   01720000
017300*                                                             *   01730000
017400*              02 = PAID AS A COST-OUTLIER.                   *   01740000
017500*                                                             *   01750000
017600*                                                             *   01760000
017700*            IPF-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   01770000
017800*              51 = NO PROVIDER SPECIFIC INFO FOUND           *   01780000
017900*              52 = INVALID CBSA# IN PROVIDER FILE            *   01790000
018000*                   OR INVALID WAGE INDEX                     *   01800000
018100*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   01810000
018200*              54 = BILL-DRG INVALID                              01820000
018300*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   01830000
018400*                                      OR                     *   01840000
018500*                   DISCHARGE DATE < CBSA EFF START DATE      *   01850000
018600*                                      OR                     *   01860000
018700*                   DISCHARGE DATE > 20060630 START CBSA AND  *   01870000
018800*                 SELECTED PROV EFF DATE < 20060701 START CBSA*   01880000
018900*                   FOR PPS                                   *   01890000
019000*              56 = INVALID LENGTH OF STAY                    *   01900000
019100*              57 = INVALID AGE                               *   01910000
019200*              58 = INVALID PPS FED BLEND INDICATOR           *   01920000
019300*              98 = CANNOT PROCESS BILL OUTSIDE THIS VERSION  *   01930000
019400***************************************************************   01940000
019500*******************************************************           01950000
019600*    PASSED FROM IPDRV                                *           01960000
019700*******************************************************           01970000
019800 01  BILL-INPUT-DATA.                                             01980000
019900     05  BILL-IN-DATA.                                            01990000
020000         10  BILL-NPI-NUMBER.                                     02000000
020100             15  BILL-NPI            PIC X(08).                   02010000
020200             15  BILL-NPI-FILLER     PIC X(02).                   02020000
020300         10  BILL-PROVIDER-NO        PIC X(06).                   02030000
020400         10  BILL-HIC-NO             PIC X(12).                   02040000
020500         10  BILL-DISCHARGE-DATE.                                 02050000
020600             15  BILL-D-CC           PIC 9(02).                   02060000
020700             15  BILL-D-YY           PIC 9(02).                   02070000
020800             15  BILL-D-MM           PIC 9(02).                   02080000
020900             15  BILL-D-DD           PIC 9(02).                   02090000
021000         10  BILL-PATIENT-STATUS     PIC X(02).                   02100000
021100         10  BILL-AGE                PIC 9(03).                   02110000
021200         10  BILL-DRG                PIC 9(03).                   02120000
021300         10  BILL-LOS                PIC 9(05).                   02130000
021400         10  BILL-OUTL-OCCUR-IND     PIC X(01).                   02140000
021500         10  BILL-SRC-OF-ADMISSION   PIC X(01).                   02150000
021600         10  BILL-ECT-NO-OF-UNITS    PIC 9(03).                   02160000
021700         10  BILL-CHARGES-CLAIMED    PIC 9(07)V9(02).             02170000
021800         10  BILL-DIAG-PROC-DATA.                                 02180000
021900             15  BILL-OTHER-DIAG-DATA   OCCURS 25 TIMES.          02190001
022000                 20  BILL-DDXX-1ST     PIC X.                     02200000
022100                 20  FILLER            PIC X(06).                 02210000
022200             15  BILL-OTHER-PROC-DATA PIC x(07)  OCCURS 25 TIMES. 02220001
022201         10  BILL-PRIOR-DAYS         PIC 9(03).                   02220101
022300*******************************************************           02230000
022400*    PASSED AND RETURNED BY IPCAL                     *           02240000
022500*******************************************************           02250000
022600 01  IPF-DATA-VARIABLES.                                          02260000
022700         10  IPF-RTC                 PIC 9(02).                   02270000
022800         10  IPF-MSA-CBSA            PIC X(05).                   02280000
022900         10  IPF-MSA-CODE REDEFINES IPF-MSA-CBSA.                 02290000
023000             15  IPF-MSA             PIC X(04).                   02300000
023100             15  FILLER              PIC X.                       02310000
023200         10  IPF-CBSA-CODE REDEFINES IPF-MSA-CBSA.                02320000
023300             15  IPF-CBSA            PIC X(05).                   02330000
023400         10  IPF-WAGE-INDEX          PIC 9(02)V9(04).             02340000
023500         10  IPF-LABOR-SHARE         PIC 9(01)V9(05).             02350000
023600         10  IPF-NLABOR-SHARE        PIC 9(01)V9(05).             02360000
023700         10  IPF-COLA                PIC 9(01)V9(03).             02370000
023800         10  IPF-STD-FACTOR          PIC 9(01)V9(05).             02380000
023900         10  IPF-COMORB-FACTOR       PIC 9(01)V9(05).             02390000
024000         10  IPF-AGE-ADJ             PIC 9(01)V9(02).             02400000
024100         10  IPF-DRG-FACTOR          PIC 9(01)V9(02).             02410000
024200         10  IPF-GEO-RURAL-ADJ       PIC 9(01)V9(02).             02420000
024300         10  IPF-EMERG-ADJ           PIC 9(01)V9(02).             02430000
024400         10  IPF-TEACH-ADJ           PIC 9(01)V9(02).             02440000
024500         10  IPF-FED-PPS-BLEND-IND   PIC X.                       02450000
024600         10  IPF-CAL-VERSION         PIC X(05).                   02460000
024700         10  FILLER                  PIC X(12).                   02470000
024800                                                                  02480000
024900*******************************************************           02490000
025000*    PASSED AND RETURNED BY IPCAL                     *           02500000
025100*******************************************************           02510000
025200 01  IPF-ADDITIONAL-VARIABLES.                                    02520000
025300     02  IPF-MF-VARIABLES.                                        02530000
025400         10  IPF-100PCT-STOPLOS-AMT      PIC 9(07)V9(02).         02540000
025500         10  IPF-TOT-PAYMENT             PIC 9(07)V9(02).         02550000
025600         10  IPF-FED-PAYMENT             PIC 9(07)V9(02).         02560000
025700         10  IPF-FAC-PAYMENT             PIC 9(07)V9(02).         02570000
025800         10  IPF-ECT-PAYMENT             PIC 9(07)V9(02).         02580000
025900         10  IPF-OUTLIER-PAYMENT         PIC 9(07)V9(02).         02590000
026000         10  IPF-OUTL-COST               PIC 9(07)V9(02).         02600000
026100         10  IPF-OUTL-ADJ-COST           PIC 9(07)V9(02).         02610000
026200         10  IPF-OUTL-PER-DIEM-AMT       PIC 9(07)V9(02).         02620000
026300         10  IPF-OUTL-THRES-AMT          PIC 9(07)V9(02).         02630000
026400         10  IPF-OUTL-THRES-ADJ-AMT      PIC 9(07)V9(02).         02640000
026500         10  IPF-ADJUSTED-PER-DIEM-AMT   PIC 9(07)V9(02).         02650000
026600         10  IPF-WAGE-ADJ-AMT            PIC 9(07)V9(02).         02660000
026700         10  IPF-LABOR-BASE-AMT          PIC 9(07)V9(05).         02670000
026800         10  IPF-NLABOR-BASE-AMT         PIC 9(07)V9(05).         02680000
026900         10  IPF-OUTL-LABOR-BASE-AMT     PIC 9(07)V9(05).         02690000
027000         10  IPF-OUTL-NLABOR-BASE-AMT    PIC 9(07)V9(05).         02700000
027100         10  IPF-BUDGNUT-RATE-AMT        PIC 9(05)V9(02).         02710000
027200         10  IPF-ECT-RATE-AMT            PIC 9(05)V9(02).         02720000
027300         10  IPF-TEACH-PAYMENT           PIC 9(07)V9(02).         02730000
027400         10  FILLER                      PIC X(01).               02740000
027500      02 IPF-PC-VARIABLES.                                        02750000
027600         10  IPF-PC-DATA                 PIC X(44).               02760000
027700                                                                  02770000
027800 01  PRICER-OPT-VERS-SW.                                          02780000
027900     02  PRICER-OPTION-SW          PIC X(01).                     02790000
028000         88  VARIABLES                  VALUE 'S'.                02800000
028100         88  PROV-RECORD-PASSED         VALUE 'P'.                02810000
028200         88  ALL-TABLES-PASSED          VALUE 'B'.                02820000
028300         88  PC-PRICER                  VALUE 'C'.                02830000
028400     02  IPF-VERSIONS.                                            02840000
028500         10  IPDRV-VERSION         PIC X(05).                     02850000
028600                                                                  02860000
028700**************************************************************    02870000
028800*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BACK FROM *    02880000
028900*      THE IPCAL051 PROGRAM FOR PROCESSING                   *    02890000
029000**************************************************************    02900000
029100 01  PROV-NEW-HOLD.                                               02910000
029200     02  PROV-NEWREC-HOLD1.                                       02920000
029300         05  P-NEW-NPI10.                                         02930000
029400             10  P-NEW-NPI8             PIC X(08).                02940000
029500             10  P-NEW-NPI-FILLER       PIC X(02).                02950000
029600         05  P-NEW-PROVIDER-NO.                                   02960000
029700             88  P-NEW-DSH-ADJ-PROVIDERS                          02970000
029800                             VALUE '180049' '190044' '190144'     02980000
029900                                   '190191' '330047' '340085'     02990000
030000                                   '370016' '370149' '420043'.    03000000
030100             10  P-NEW-STATE            PIC 9(02).                03010000
030200             10  FILLER                 PIC X(04).                03020000
030300         05  P-NEW-DATE-DATA.                                     03030000
030400             10  P-NEW-EFF-DATE.                                  03040000
030500                 15  P-NEW-EFF-DT-CC    PIC 9(02).                03050000
030600                 15  P-NEW-EFF-DT-YY    PIC 9(02).                03060000
030700                 15  P-NEW-EFF-DT-MM    PIC 9(02).                03070000
030800                 15  P-NEW-EFF-DT-DD    PIC 9(02).                03080000
030900             10  P-NEW-FY-BEGIN-DATE.                             03090000
031000                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                03100000
031100                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                03110000
031200                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                03120000
031300                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                03130000
031400             10  P-NEW-REPORT-DATE.                               03140000
031500                 15  P-NEW-REPORT-DT-CC PIC 9(02).                03150000
031600                 15  P-NEW-REPORT-DT-YY PIC 9(02).                03160000
031700                 15  P-NEW-REPORT-DT-MM PIC 9(02).                03170000
031800                 15  P-NEW-REPORT-DT-DD PIC 9(02).                03180000
031900             10  P-NEW-TERMINATION-DATE.                          03190000
032000                 15  P-NEW-TERM-DT-CC   PIC 9(02).                03200000
032100                 15  P-NEW-TERM-DT-YY   PIC 9(02).                03210000
032200                 15  P-NEW-TERM-DT-MM   PIC 9(02).                03220000
032300                 15  P-NEW-TERM-DT-DD   PIC 9(02).                03230000
032400         05  P-NEW-WAIVER-CODE          PIC X(01).                03240000
032500             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              03250000
032600         05  P-NEW-INTER-NO             PIC 9(05).                03260000
032700         05  P-NEW-PROVIDER-TYPE        PIC X(02).                03270000
032800             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.      03280000
032900             88  P-N-REFERRAL-CENTER        VALUE '07' '11'       03290000
033000                                                  '15' '17'       03300000
033100                                                  '22'.           03310000
033200             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.           03320000
033300             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.           03330000
033400             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.           03340000
033500             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.           03350000
033600             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.      03360000
033700             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.           03370000
033800             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.      03380000
033900             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.           03390000
034000             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.           03400000
034100             88  P-N-EACH                   VALUE '21' '22'.      03410000
034200             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.           03420000
034300             88  P-N-NHCMQ-II-SNF           VALUE '32'.           03430000
034400             88  P-N-NHCMQ-III-SNF          VALUE '33'.           03440000
034500         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                03450000
034600             88  P-N-NEW-ENGLAND            VALUE  1.             03460000
034700             88  P-N-MIDDLE-ATLANTIC        VALUE  2.             03470000
034800             88  P-N-SOUTH-ATLANTIC         VALUE  3.             03480000
034900             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.             03490000
035000             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.             03500000
035100             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.             03510000
035200             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.             03520000
035300             88  P-N-MOUNTAIN               VALUE  8.             03530000
035400             88  P-N-PACIFIC                VALUE  9.             03540000
035500         05  P-NEW-CURRENT-DIV   REDEFINES                        03550000
035600                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         03560000
035700             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.          03570000
035800         05  P-NEW-MSA-DATA.                                      03580000
035900             10  P-NEW-CHG-CODE-INDEX       PIC X.                03590000
036000             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 03600000
036100             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   03610000
036200                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       03620000
036300             10  P-NEW-GEO REDEFINES                              03630000
036400                                 P-NEW-GEO-LOC-MSAX.              03640000
036500                 15  P-NEW-GEO-RURAL-1ST.                         03650000
036600                     20  P-NEW-GEO-RURAL  PIC XX.                 03660000
036700                         88  P-NEW-GEO-MSAX-RURAL VALUE '  '.     03670000
036800                 15  P-NEW-GEO-RURAL-2ND        PIC XX.           03680000
036900             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 03690000
037000             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 03700000
037100             10  P-NEW-STAND-AMT-LOC-MSA9                         03710000
037200       REDEFINES P-NEW-STAND-AMT-LOC-MSA.                         03720000
037300                 15  P-NEW-RURAL-1ST.                             03730000
037400                     20  P-NEW-STAND-RURAL  PIC XX.               03740000
037500                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    03750000
037600                 15  P-NEW-RURAL-2ND        PIC XX.               03760000
037700         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    03770000
037800                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.           03780000
037900                 88  P-NEW-SCH-YR82       VALUE   '82'.           03790000
038000                 88  P-NEW-SCH-YR87       VALUE   '87'.           03800000
038100         05  P-NEW-LUGAR                    PIC X.                03810000
038200         05  P-NEW-TEMP-RELIEF-IND          PIC X.                03820000
038300         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                03830000
038400         05  FILLER                         PIC X(05).            03840000
038500     02  PROV-NEWREC-HOLD2.                                       03850000
038600         05  P-NEW-VARIABLES.                                     03860000
038700             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        03870000
038800             10  P-NEW-COLA              PIC  9(01)V9(03).        03880000
038900             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        03890000
039000             10  P-NEW-BED-SIZE          PIC  9(05).              03900000
039100             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        03910000
039200             10  P-NEW-CMI               PIC  9(01)V9(04).        03920000
039300             10  P-NEW-SSI-RATIO         PIC  V9(04).             03930000
039400             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             03940000
039500             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              03950000
039600             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        03960000
039700             10  P-NEW-DSH-PERCENT       PIC  V9(04).             03970000
039800             10  P-NEW-FYE-DATE          PIC  X(08).              03980000
039900         05  P-NEW-CBSA-DATA.                                     03990000
040000             10  P-NEW-CBSA-SPEC-PAY-IND   PIC X.                 04000000
040100             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.                 04010000
040200             10  P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.  04020000
040300             10  P-NEW-CBSA-GEO-LOCX REDEFINES                    04030000
040400                 P-NEW-CBSA-GEO-LOC.                              04040000
040500                 15  P-NEW-CBSA-GEO-RURAL-1ST.                    04050000
040600                     20  P-NEW-CBSA-GEO-RURAL  PIC XXX.           04060000
040700                         88  P-NEW-CBSA-GEO-RURAL-CHECK           04070000
040800                             VALUE '   '.                         04080000
040900                 15  P-NEW-CBSA-GEO-RURAL-2ND PIC XX.             04090000
041000             10  P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.  04100000
041100             10  P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.  04110000
041200             10  P-NEW-CBSA-SPEC-WI        PIC 9(02)V9(04).       04120000
041300             10  P-NEW-CBSA-SPEC-WI-N  REDEFINES                  04130000
041400                 P-NEW-CBSA-SPEC-WI        PIC 9(06).             04140000
041500     02  PROV-NEWREC-HOLD3.                                       04150000
041600         05  P-NEW-PASS-AMT-DATA.                                 04160000
041700             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          04170000
041800             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          04180000
041900             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          04190000
042000             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          04200000
042100         05  P-NEW-CAPI-DATA.                                     04210000
042200             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 04220000
042300             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          04230000
042400             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          04240000
042500             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        04250000
042600             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             04260000
042700             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 04270000
042800             15  P-NEW-CAPI-IME            PIC 9V9999.            04280000
042900             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          04290000
043000         05  FILLER                        PIC X(22).             04300000
043100******************************************************************04310000
043200                                                                  04320000
043300 01  WAGE-INDEX-RECORD.                                           04330000
043400     05  W-CBSA              PIC 9(5).                            04340000
043500     05  W-SIZE              PIC X(01).                           04350000
043600         88  LARGE-URBAN       VALUE 'L'.                         04360000
043700         88  OTHER-URBAN       VALUE 'O'.                         04370000
043800         88  ALL-RURAL         VALUE 'R'.                         04380000
043900     05  W-CBSA-EFF-DATE     PIC 9(8).                            04390000
044000     05  FILLER              PIC X.                               04400000
044100     05  W-CBSA-WAGE-INDEX   PIC S9(02)V9(04).                    04410000
044200     05  FILLER              PIC S9(02)V9(04).                    04420000
044300                                                                  04430000
044400 PROCEDURE DIVISION  USING BILL-INPUT-DATA                        04440000
044500                           IPF-DATA-VARIABLES                     04450000
044600                           IPF-ADDITIONAL-VARIABLES               04460000
044700                           PRICER-OPT-VERS-SW                     04470000
044800                           PROV-NEW-HOLD                          04480000
044900                           WAGE-INDEX-RECORD.                     04490000
045000                                                                  04500000
045100***************************************************************   04510000
045200*    PROCESSING:                                              *   04520000
045300*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE        *   04530000
045400*        B. INITIALIZE IPCAL  HOLD VARIABLES.                 *   04540000
045500*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *   04550000
045600*           ATTEMPTING TO CALCULATE IPF. IF THIS BILL         *   04560000
045700*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   04570000
045800*           GOBACK.                                           *   04580000
045900*        D. ASSEMBLE PRICING COMPONENTS.                      *   04590000
046000*        E. CALCULATE THE PRICE.                              *   04600000
046100***************************************************************   04610000
046200                                                                  04620000
046300     PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT.                04630000
046400                                                                  04640000
046500     MOVE CAL-VERSION  TO  IPF-CAL-VERSION.                       04650000
046600                                                                  04660000
046700                                                                  04670000
046800     GOBACK.                                                      04680000
046900                                                                  04690000
047000 0200-MAINLINE-CONTROL.                                           04700000
047100                                                                  04710000
047200     PERFORM 1000-EDIT-THE-BILL-INFO.                             04720000
047300                                                                  04730000
047400     IF  IPF-RTC = 00                                             04740000
047500         PERFORM 2000-ASSEMBLE-PPS-VARIABLES THRU                 04750000
047600                 2000-EXIT                                        04760000
047700         PERFORM 3000-CALC-PAYMENT THRU                           04770000
047800                 3000-EXIT.                                       04780000
047900                                                                  04790000
048000                                                                  04800000
048100                                                                  04810000
048200 0200-EXIT.   EXIT.                                               04820000
048300                                                                  04830000
048400 1000-EDIT-THE-BILL-INFO.                                         04840000
048500***************************************************************   04850000
048600*    BILL DATA EDITS IF ANY FAIL SET IPF-RTC                  *   04860000
048700*    AND DO NOT ATTEMPT TO PRICE.                             *   04870000
048800***************************************************************   04880000
048900     MOVE SPACES TO WK-COMORBIDITY-DATA.                          04890000
049000                                                                  04900000
049100     IF  IPF-RTC = 00                                             04910000
049200         IF  P-NEW-WAIVER-STATE                                   04920000
049300             MOVE 53 TO IPF-RTC.                                  04930000
049400                                                                  04940000
049500     IF  IPF-RTC = 00                                             04950000
049600         IF  BILL-DRG < 001 OR > 579                              04960000
049700                           OR = 004 OR = 005                      04970000
049800                           OR = 107 OR = 109                      04980000
049900                           OR = 112 OR = 115                      04990000
050000                           OR = 116 OR = 209                      05000000
050100                           OR = 214 OR = 215                      05010000
050200                           OR = 221 OR = 222                      05020000
050300                           OR = 231 OR = 400                      05030000
050400                           OR = 434 OR = 435                      05040000
050500                           OR = 436 OR = 437                      05050000
050600                           OR = 438 OR = 456                      05060000
050700                           OR = 457 OR = 458                      05070000
050800                           OR = 459 OR = 460                      05080000
050900                           OR = 469 OR = 470                      05090000
051000                           OR = 472 OR = 474                      05100000
051100                           OR = 478 OR = 483                      05110000
051200                           OR = 514 OR = 516                      05120000
051300                           OR = 517 OR = 526                      05130000
051400                           OR = 527                               05140000
051500             MOVE 54 TO IPF-RTC.                                  05150000
051600                                                                  05160000
051700     IF IPF-RTC = 00                                              05170000
051800        IF  ((BILL-DISCHARGE-DATE < P-NEW-EFF-DATE) OR            05180000
051900             (BILL-DISCHARGE-DATE < W-CBSA-EFF-DATE))             05190000
052000              MOVE 55 TO IPF-RTC.                                 05200000
052100                                                                  05210000
052200     IF IPF-RTC = 00                                              05220000
052300         IF  BILL-LOS NOT NUMERIC OR                              05230000
052400             BILL-LOS = ZERO                                      05240000
052500             MOVE 56 TO IPF-RTC.                                  05250000
052600                                                                  05260000
052700     IF IPF-RTC = 00                                              05270000
052800         IF  BILL-AGE NOT NUMERIC OR                              05280000
052900             BILL-AGE = ZERO                                      05290000
053000             MOVE 57 TO IPF-RTC.                                  05300000
053100                                                                  05310000
053200     IF IPF-RTC = 00                                              05320000
053300         IF  P-NEW-FED-PPS-BLEND-IND NOT = 1 AND                  05330000
053400                                     NOT = 2 AND                  05340000
053500                                     NOT = 3 AND                  05350000
053600                                     NOT = 4                      05360000
053700             MOVE 58 TO IPF-RTC.                                  05370000
053800                                                                  05380000
053900 2000-ASSEMBLE-PPS-VARIABLES.                                     05390000
054000***************************************************************   05400000
054100*    THE APPROPRIATE SET OF THESE IPF VARIABLES ARE SELECTED  *   05410000
054200*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   05420000
054300*    OF THAT VARIABLE.                                        *   05430000
054400***************************************************************   05440000
054500     MOVE ALL '0'  TO IPF-MF-VARIABLES.                           05450000
054600                                                                  05460000
054700     MOVE 0614.99  TO IPF-BUDGNUT-RATE-AMT.                       05470000
054800     MOVE 0264.77  TO IPF-ECT-RATE-AMT.                           05480000
054900     MOVE 6488.00  TO IPF-OUTL-THRES-AMT.                         05490000
055000     MOVE 0.75788  TO IPF-LABOR-SHARE.                            05500000
055100     MOVE 0.24212  TO IPF-NLABOR-SHARE.                           05510000
055200     MOVE 0.82540  TO IPF-STD-FACTOR.                             05520000
055300     MOVE ZEROES   TO WK-FED-PORTION                              05530000
055400                      WK-TEACH-PORTION.                           05540000
055500                                                                  05550000
055600     IF  (P-NEW-STATE = 02 OR 12)                                 05560000
055700         MOVE P-NEW-COLA TO IPF-COLA                              05570000
055800     ELSE                                                         05580000
055900         MOVE 1.000 TO IPF-COLA.                                  05590000
056000                                                                  05600000
056100***************************************************************   05610000
056200***  GET THE DRG ADJUSTMENT FACTORES OR FIRST CODES               05620000
056300***  GET THE DRG ADJUSTMENT FACTORES OR FIRST CODES               05630000
056400                                                                  05640000
056500     PERFORM 2600-GET-DRG-FACTORS THRU 2600-EXIT.                 05650000
056600                                                                  05660000
056700     IF IPF-RTC = '60'                                            05670000
056800         MOVE '00' TO IPF-RTC                                     05680000
056900         PERFORM 2700-GET-FIRST-CODES THRU 2700-EXIT.             05690000
057000                                                                  05700000
057100                                                                  05710000
057200*******************************************************           05720000
057300***  GET THE COMORBIDITY FACTORS                                  05730000
057400***  GET THE COMORBIDITY FACTORS                                  05740000
057500                                                                  05750000
057600     PERFORM 3300-GET-COMORBIDITY THRU 3300-EXIT.                 05760000
057700                                                                  05770000
057800***************************************************************   05780000
057900***  GET THE WAGE-INDEX                                           05790000
058000***  GET THE WAGE-INDEX                                           05800000
058100                                                                  05810000
058200     MOVE W-CBSA-WAGE-INDEX TO IPF-WAGE-INDEX.                    05820000
058300                                                                  05830000
058400***************************************************************   05840000
058500***  GET THE AGE ADJUSTMENT                                       05850000
058600***  GET THE AGE ADJUSTMENT                                       05860000
058700                                                                  05870000
058800     IF BILL-AGE < 45                                             05880000
058900        MOVE 1.00 TO IPF-AGE-ADJ                                  05890000
059000        GO TO 2000-SKIP.                                          05900000
059100                                                                  05910000
059200     IF BILL-AGE < 50                                             05920000
059300        MOVE 1.01 TO IPF-AGE-ADJ                                  05930000
059400        GO TO 2000-SKIP.                                          05940000
059500                                                                  05950000
059600     IF BILL-AGE < 55                                             05960000
059700        MOVE 1.02 TO IPF-AGE-ADJ                                  05970000
059800        GO TO 2000-SKIP.                                          05980000
059900                                                                  05990000
060000     IF BILL-AGE < 60                                             06000000
060100        MOVE 1.04 TO IPF-AGE-ADJ                                  06010000
060200        GO TO 2000-SKIP.                                          06020000
060300                                                                  06030000
060400     IF BILL-AGE < 65                                             06040000
060500        MOVE 1.07 TO IPF-AGE-ADJ                                  06050000
060600        GO TO 2000-SKIP.                                          06060000
060700                                                                  06070000
060800     IF BILL-AGE < 70                                             06080000
060900        MOVE 1.10 TO IPF-AGE-ADJ                                  06090000
061000        GO TO 2000-SKIP.                                          06100000
061100                                                                  06110000
061200     IF BILL-AGE < 75                                             06120000
061300        MOVE 1.13 TO IPF-AGE-ADJ                                  06130000
061400        GO TO 2000-SKIP.                                          06140000
061500                                                                  06150000
061600     IF BILL-AGE < 80                                             06160000
061700        MOVE 1.15 TO IPF-AGE-ADJ                                  06170000
061800        GO TO 2000-SKIP.                                          06180000
061900                                                                  06190000
062000     MOVE 1.17 TO IPF-AGE-ADJ.                                    06200000
062100                                                                  06210000
062200 2000-SKIP.                                                       06220000
062300                                                                  06230000
062400***************************************************************   06240000
062500***  GET THE TEACHING ADJUSTMENT                                  06250000
062600***  GET THE TEACHING ADJUSTMENT                                  06260000
062700                                                                  06270000
062800     IF P-NEW-INTERN-RATIO NUMERIC                                06280000
062900        COMPUTE IPF-TEACH-ADJ ROUNDED =                           06290000
063000              ((1 + P-NEW-INTERN-RATIO) ** 0.5150)                06300000
063100     ELSE                                                         06310000
063200        MOVE 1.00 TO IPF-TEACH-ADJ.                               06320000
063300                                                                  06330000
063400***************************************************************   06340000
063500***  GET THE RURAL ADJUSTMENT                                     06350000
063600***  GET THE RURAL ADJUSTMENT                                     06360000
063700                                                                  06370000
063800     IF P-NEW-CBSA-GEO-RURAL-CHECK                                06380000
063900        MOVE 1.17 TO IPF-GEO-RURAL-ADJ                            06390000
064000     ELSE                                                         06400000
064100        MOVE 1.00 TO IPF-GEO-RURAL-ADJ.                           06410000
064200                                                                  06420000
064300***************************************************************   06430000
064400***  GET THE EMERGENCY ADJUSTMENT                                 06440000
064500***  GET THE EMERGENCY ADJUSTMENT                                 06450000
064600                                                                  06460000
064700     IF P-NEW-TEMP-RELIEF-IND = 'Y'                               06470000
064800        MOVE 1.31 TO IPF-EMERG-ADJ                                06480000
064900                     DAY-VALUE2 (1)                               06490000
065000     ELSE                                                         06500000
065100        MOVE 1.19 TO IPF-EMERG-ADJ                                06510000
065200                     DAY-VALUE2 (1).                              06520000
065300                                                                  06530000
065400***  CHECK FOR FACILITY W/O FULL SERVICE FROM CLAIM               06540000
065500     IF BILL-SRC-OF-ADMISSION = 'D'                               06550000
065600        MOVE 1.19 TO IPF-EMERG-ADJ                                06560000
065700                     DAY-VALUE2 (1).                              06570000
065800                                                                  06580000
065900                                                                  06590000
066000***************************************************************   06600000
066100***  GET THE ECT ADJUSTED PAYMENT                                 06610000
066200***  GET THE ECT ADJUSTED PAYMENT                                 06620000
066300                                                                  06630000
066400     COMPUTE IPF-ECT-PAYMENT ROUNDED =                            06640000
066500             (((IPF-ECT-RATE-AMT * IPF-LABOR-SHARE) *             06650000
066600                    W-CBSA-WAGE-INDEX)                            06660000
066700                           +                                      06670000
066800              ((IPF-ECT-RATE-AMT * IPF-NLABOR-SHARE) *            06680000
066900                       IPF-COLA)).                                06690000
067000                                                                  06700000
067100     COMPUTE IPF-ECT-PAYMENT ROUNDED =                            06710000
067200             IPF-ECT-PAYMENT * BILL-ECT-NO-OF-UNITS.              06720000
067300                                                                  06730000
067400 2000-EXIT.   EXIT.                                               06740000
067500                                                                  06750000
067600 2600-GET-DRG-FACTORS.                                            06760000
067700                                                                  06770000
067800     SET DRGSUB TO 1.                                             06780000
067900     SEARCH TB-DRG-DATA2 VARYING DRGSUB                           06790000
068000         AT END                                                   06800000
068100            MOVE '60' TO IPF-RTC                                  06810000
068200            GO TO 2600-EXIT                                       06820000
068300         WHEN TB-DRG-CODE (DRGSUB) = BILL-DRG                     06830000
068400            MOVE TB-DRG-FACTOR (DRGSUB, 1) TO IPF-DRG-FACTOR.     06840000
068500                                                                  06850000
068600 2600-EXIT.    EXIT.                                              06860000
068700                                                                  06870000
068800 2700-GET-FIRST-CODES.                                            06880000
068900                                                                  06890000
069000     SET FSTSUB TO 1.                                             06900000
069100     SEARCH TB-FST-DATA2 VARYING FSTSUB                           06910000
069200       AT END                                                     06920000
069300          MOVE 1.00 TO IPF-DRG-FACTOR                             06930000
069400          GO TO 2700-EXIT                                         06940000
069500       WHEN  TB-FST-CODE (FSTSUB) = BILL-OTHER-DIAG-DATA(1)       06950000
069600          MOVE TB-FST-FACTOR (FSTSUB, 1) TO IPF-DRG-FACTOR.       06960000
069700                                                                  06970000
069800                                                                  06980000
069900 2700-EXIT.    EXIT.                                              06990000
070000                                                                  07000000
070100 3000-CALC-PAYMENT.                                               07010000
070200***************************************************************   07020000
070300***  CALCULATE THE WAGE ADJ RATES                                 07030000
070400***  CALCULATE THE WAGE ADJ RATES                                 07040000
070500                                                                  07050000
070600     COMPUTE IPF-LABOR-BASE-AMT ROUNDED =                         07060000
070700                ((IPF-BUDGNUT-RATE-AMT * IPF-LABOR-SHARE) *       07070000
070800                     W-CBSA-WAGE-INDEX).                          07080000
070900                                                                  07090000
071000     COMPUTE IPF-NLABOR-BASE-AMT ROUNDED =                        07100000
071100                ((IPF-BUDGNUT-RATE-AMT * IPF-NLABOR-SHARE) *      07110000
071200                     IPF-COLA).                                   07120000
071300                                                                  07130000
071400     COMPUTE IPF-WAGE-ADJ-AMT ROUNDED =                           07140000
071500                (IPF-LABOR-BASE-AMT + IPF-NLABOR-BASE-AMT).       07150000
071600                                                                  07160000
071700***************************************************************   07170000
071800***  STEP 2                                                       07180000
071900***  CALCULATE ADJUSTED PER DIEM AMOUNT W/O TEACH-ADJ             07190000
072000***  CALCULATE ADJUSTED PER DIEM AMOUNT W/O TEACH-ADJ             07200000
072100                                                                  07210000
072200     COMPUTE WK-ADJ-PER-DIEM-STEP2 ROUNDED =                      07220000
072300          (IPF-COMORB-FACTOR *                                    07230000
072400           IPF-AGE-ADJ * IPF-DRG-FACTOR *                         07240000
072500           IPF-GEO-RURAL-ADJ)                                     07250000
072600                         *                                        07260000
072700                IPF-WAGE-ADJ-AMT.                                 07270000
072800                                                                  07280000
072900***************************************************************   07290000
073000***  STEP 4                                                       07300000
073100***  CALCULATE THE DAY LOS FOR TOTAL PAYMENT W/O  TEACH-ADJ       07310000
073200***  CALCULATE THE DAY LOS FOR TOTAL PAYMENT W/O  TEACH-ADJ       07320000
073300                                                                  07330000
073400     MOVE WK-ADJ-PER-DIEM-STEP2 TO IPF-ADJUSTED-PER-DIEM-AMT      07340000
073500                                   WK-PER-DIEM-AMT.               07350000
073600                                                                  07360000
073700     MOVE ZEROES TO DAYS-UPTO-21                                  07370000
073800                    DAYS-OVER-21                                  07380000
073900                    IPF-FED-PAYMENT.                              07390000
074000     MOVE 001    TO SUB                                           07400000
074100                    SUB2.                                         07410000
074200                                                                  07420000
074300     IF BILL-LOS > 21                                             07430000
074400        COMPUTE DAYS-OVER-21 = (BILL-LOS - 21)                    07440000
074500        MOVE 21 TO DAYS-UPTO-21                                   07450000
074600     ELSE                                                         07460000
074700        MOVE BILL-LOS TO DAYS-UPTO-21.                            07470000
074800                                                                  07480000
074900     PERFORM 3100-GET-EACH-DAY THRU 3100-EXIT  VARYING            07490000
075000             SUB FROM SUB2 BY 1 UNTIL                             07500000
075100             SUB > DAYS-UPTO-21.                                  07510000
075200                                                                  07520000
075300     IF BILL-LOS > 21                                             07530000
075400        COMPUTE IPF-FED-PAYMENT ROUNDED =                         07540000
075500                IPF-FED-PAYMENT +                                 07550000
075600       (DAYS-OVER-21 * (WK-PER-DIEM-AMT *                         07560000
075700                         DAY-VALUE2 (22))).                       07570000
075800                                                                  07580000
075900     MOVE IPF-FED-PAYMENT TO WK-FED-PORTION.                      07590000
076000                                                                  07600000
076100     MOVE ZEROES TO IPF-FED-PAYMENT.                              07610000
076200                                                                  07620000
076300***************************************************************   07630000
076400     IF IPF-TEACH-ADJ = 1.00                                      07640000
076500        MOVE ZEROES TO WK-ADJ-PER-DIEM-STEP1                      07650000
076600                       WK-TEACH-PORTION                           07660000
076700        GO TO 3000-BYPASS-TEACH.                                  07670000
076800                                                                  07680000
076900***************************************************************   07690000
077000***  STEP 1                                                       07700000
077100***  CALCULATE ADJUSTED PER DIEM AMOUNT WITH TEACHING-ADJ         07710000
077200***  CALCULATE ADJUSTED PER DIEM AMOUNT WITH TEACHING-ADJ         07720000
077300                                                                  07730000
077400     COMPUTE WK-ADJ-PER-DIEM-STEP1 ROUNDED =                      07740000
077500          (IPF-COMORB-FACTOR *                                    07750000
077600           IPF-AGE-ADJ * IPF-DRG-FACTOR *                         07760000
077700           IPF-TEACH-ADJ * IPF-GEO-RURAL-ADJ)                     07770000
077800                         *                                        07780000
077900                IPF-WAGE-ADJ-AMT.                                 07790000
078000                                                                  07800000
078100                                                                  07810000
078200***************************************************************   07820000
078300***  STEP 3                                                       07830000
078400     COMPUTE  WK-PER-DIEM-AMT ROUNDED =                           07840000
078500             WK-ADJ-PER-DIEM-STEP1 - WK-ADJ-PER-DIEM-STEP2.       07850000
078600                                                                  07860000
078700     MOVE WK-ADJ-PER-DIEM-STEP1 TO IPF-ADJUSTED-PER-DIEM-AMT.     07870000
078800                                                                  07880000
078900***************************************************************   07890000
079000***  STEP 5                                                       07900000
079100***  CALCULATE THE DAY LOS FOR TEACH ONLY                         07910000
079200***  CALCULATE THE DAY LOS FOR TEACH ONLY                         07920000
079300                                                                  07930000
079400     MOVE ZEROES TO DAYS-UPTO-21                                  07940000
079500                    DAYS-OVER-21                                  07950000
079600                    IPF-FED-PAYMENT.                              07960000
079700     MOVE 001    TO SUB                                           07970000
079800                    SUB2.                                         07980000
079900                                                                  07990000
080000     IF BILL-LOS > 21                                             08000000
080100        COMPUTE DAYS-OVER-21 = (BILL-LOS - 21)                    08010000
080200        MOVE 21 TO DAYS-UPTO-21                                   08020000
080300     ELSE                                                         08030000
080400        MOVE BILL-LOS TO DAYS-UPTO-21.                            08040000
080500                                                                  08050000
080600     PERFORM 3100-GET-EACH-DAY THRU 3100-EXIT  VARYING            08060000
080700             SUB FROM SUB2 BY 1 UNTIL                             08070000
080800             SUB > DAYS-UPTO-21.                                  08080000
080900                                                                  08090000
081000     IF BILL-LOS > 21                                             08100000
081100        COMPUTE IPF-FED-PAYMENT ROUNDED =                         08110000
081200                IPF-FED-PAYMENT +                                 08120000
081300       (DAYS-OVER-21 * (WK-PER-DIEM-AMT *                         08130000
081400                         DAY-VALUE2 (22))).                       08140000
081500                                                                  08150000
081600     MOVE IPF-FED-PAYMENT TO WK-TEACH-PORTION.                    08160000
081700                                                                  08170000
081800     MOVE ZEROES TO IPF-FED-PAYMENT.                              08180000
081900***************************************************************   08190000
082000 3000-BYPASS-TEACH.                                               08200000
082100***  STEP 6                                                       08210000
082200***  ADD FED AND TEACHING INPUT TO OULTLIER                       08220000
082300***  ADD FED AND TEACHING INPUT TO OULTLIER                       08230000
082400                                                                  08240000
082500     COMPUTE IPF-FED-PAYMENT ROUNDED =                            08250000
082600                      WK-FED-PORTION + WK-TEACH-PORTION.          08260000
082700                                                                  08270000
082800***************************************************************   08280000
082900***  CHECK FOR OUTLIER TO BE APPLIED                              08290000
083000***  CHECK FOR OUTLIER TO BE APPLIED                              08300000
083100                                                                  08310000
083200     IF ((BILL-PATIENT-STATUS = '30' AND                          08320000
083300          BILL-OUTL-OCCUR-IND  = 'Y')                             08330000
083400                     OR                                           08340000
083500         (BILL-PATIENT-STATUS NOT = '30'))                        08350000
083600          PERFORM 3050-GET-OULIER THRU 3050-EXIT.                 08360000
083700                                                                  08370000
083800***************************************************************   08380000
083900***  RETURN 100% PPS AMOUNT  FOR STOP LOSS PROVISION              08390000
084000***  RETURN 100% PPS AMOUNT  FOR STOP LOSS PROVISION              08400000
084100***  NOT BLENDED                                                  08410000
084200                                                                  08420000
084300      COMPUTE IPF-100PCT-STOPLOS-AMT ROUNDED =                    08430000
084400              WK-FED-PORTION + IPF-OUTLIER-PAYMENT +              08440000
084500              IPF-ECT-PAYMENT + WK-TEACH-PORTION.                 08450000
084600                                                                  08460000
084700***************************************************************   08470000
084800***  CHECK FOR FED PPS BLEND IND FOR FED AND FACILITY PCT         08480000
084900***  CHECK FOR FED PPS BLEND IND FOR FED AND FACILITY PCT         08490000
085000                                                                  08500000
085100     MOVE P-NEW-FED-PPS-BLEND-IND TO                              08510000
085200                                  IPF-FED-PPS-BLEND-IND.          08520000
085300                                                                  08530000
085400     IF P-NEW-FED-PPS-BLEND-IND = 1                               08540000
085500        COMPUTE IPF-FED-PAYMENT ROUNDED =                         08550000
085600                WK-FED-PORTION * .25                              08560000
085700        COMPUTE IPF-ECT-PAYMENT ROUNDED =                         08570000
085800                IPF-ECT-PAYMENT * .25                             08580000
085900        COMPUTE IPF-TEACH-PAYMENT ROUNDED =                       08590000
086000                WK-TEACH-PORTION * .25                            08600000
086100        COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                     08610000
086200                IPF-OUTLIER-PAYMENT * .25                         08620000
086300        COMPUTE IPF-FAC-PAYMENT ROUNDED =                         08630000
086400                P-NEW-FAC-SPEC-RATE * .75.                        08640000
086500                                                                  08650000
086600     IF P-NEW-FED-PPS-BLEND-IND = 2                               08660000
086700        COMPUTE IPF-FED-PAYMENT ROUNDED =                         08670000
086800                WK-FED-PORTION * .50                              08680000
086900        COMPUTE IPF-ECT-PAYMENT ROUNDED =                         08690000
087000                IPF-ECT-PAYMENT * .50                             08700000
087100        COMPUTE IPF-TEACH-PAYMENT ROUNDED =                       08710000
087200                WK-TEACH-PORTION * .50                            08720000
087300        COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                     08730000
087400                IPF-OUTLIER-PAYMENT * .50                         08740000
087500        COMPUTE IPF-FAC-PAYMENT ROUNDED =                         08750000
087600                P-NEW-FAC-SPEC-RATE * .50.                        08760000
087700                                                                  08770000
087800     IF P-NEW-FED-PPS-BLEND-IND = 3                               08780000
087900        COMPUTE IPF-FED-PAYMENT ROUNDED =                         08790000
088000                WK-FED-PORTION * .75                              08800000
088100        COMPUTE IPF-ECT-PAYMENT ROUNDED =                         08810000
088200                IPF-ECT-PAYMENT * .75                             08820000
088300        COMPUTE IPF-TEACH-PAYMENT ROUNDED =                       08830000
088400                WK-TEACH-PORTION * .75                            08840000
088500        COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                     08850000
088600                IPF-OUTLIER-PAYMENT * .75                         08860000
088700        COMPUTE IPF-FAC-PAYMENT ROUNDED =                         08870000
088800                P-NEW-FAC-SPEC-RATE * .25.                        08880000
088900                                                                  08890000
089000     IF P-NEW-FED-PPS-BLEND-IND = 4                               08900000
089100        COMPUTE IPF-FED-PAYMENT ROUNDED =                         08910000
089200                WK-FED-PORTION * 1.00                             08920000
089300        COMPUTE IPF-ECT-PAYMENT ROUNDED =                         08930000
089400                IPF-ECT-PAYMENT * 1.00                            08940000
089500        COMPUTE IPF-TEACH-PAYMENT ROUNDED =                       08950000
089600                WK-TEACH-PORTION * 1.00                           08960000
089700        COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                     08970000
089800                IPF-OUTLIER-PAYMENT * 1.00                        08980000
089900        COMPUTE IPF-FAC-PAYMENT ROUNDED =                         08990000
090000                P-NEW-FAC-SPEC-RATE * .0.                         09000000
090100                                                                  09010000
090200     COMPUTE IPF-TOT-PAYMENT ROUNDED =                            09020000
090300             IPF-FED-PAYMENT + IPF-FAC-PAYMENT +                  09030000
090400             IPF-ECT-PAYMENT + IPF-TEACH-PAYMENT +                09040000
090500             IPF-OUTLIER-PAYMENT.                                 09050000
090600                                                                  09060000
090700**  NOTE> IPF-FED-PAYMENT  AND IPF-TEACH-PAYMENT AND              09070000
090800**        IPF-ECT-PAYMENT  AND IPF-FAC-PAYMENT AND                09080000
090900**        IPF-OUTLIER-PAYMENT HAVE JUST BEEN BLENDED              09090000
091000**           AT THIS POINT IN THE PROGRAM LOGIC                   09100000
091100                                                                  09110000
091200 3000-EXIT.   EXIT.                                               09120000
091300                                                                  09130000
091400 3050-GET-OULIER.                                                 09140000
091500************************************                              09150000
091600***  CALCULATE THE OUTLIER PAYMENT                                09160000
091700***  CALCULATE THE OUTLIER PAYMENT                                09170000
091800                                                                  09180000
091900************************************                              09190000
092000** CALCULATE THE ADJUSTED FIXED                                   09200000
092100**    DOLLAR LOSS THRESHOLD                                       09210000
092200************************************                              09220000
092300                                                                  09230000
092400     COMPUTE IPF-OUTL-LABOR-BASE-AMT ROUNDED =                    09240000
092500                ((IPF-OUTL-THRES-AMT * IPF-LABOR-SHARE) *         09250000
092600                     W-CBSA-WAGE-INDEX).                          09260000
092700                                                                  09270000
092800     COMPUTE IPF-OUTL-NLABOR-BASE-AMT ROUNDED =                   09280000
092900                ((IPF-OUTL-THRES-AMT * IPF-NLABOR-SHARE) *        09290000
093000                     IPF-COLA).                                   09300000
093100                                                                  09310000
093200     COMPUTE IPF-OUTL-THRES-ADJ-AMT ROUNDED =                     09320000
093300           ((IPF-OUTL-LABOR-BASE-AMT +                            09330000
093400             IPF-OUTL-NLABOR-BASE-AMT) *                          09340000
093500             IPF-GEO-RURAL-ADJ *                                  09350000
093600             IPF-TEACH-ADJ) +                                     09360000
093700             IPF-FED-PAYMENT +                                    09370000
093800             IPF-ECT-PAYMENT.                                     09380000
093900                                                                  09390000
094000**  NOTE> IPF-FED-PAYMENT CONTAINS NO ECT OR OUTL PAYMENT         09400000
094100**           AT THIS POINT IN THE PROGRAM LOGIC                   09410000
094200                                                                  09420000
094300************************************                              09430000
094400** CALCULATE ELIGIBLE OUTLIER COSTS                               09440000
094500************************************                              09450000
094600                                                                  09460000
094700     COMPUTE IPF-OUTL-COST ROUNDED =                              09470000
094800             (BILL-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO).    09480000
094900                                                                  09490000
095000     MOVE '02' TO IPF-RTC.                                        09500000
095100                                                                  09510000
095200     IF IPF-OUTL-COST < IPF-OUTL-THRES-ADJ-AMT                    09520000
095300        MOVE '00' TO IPF-RTC                                      09530000
095400        MOVE ZEROES TO IPF-OUTLIER-PAYMENT                        09540000
095500        GO TO 3050-EXIT.                                          09550000
095600                                                                  09560000
095700     COMPUTE IPF-OUTL-ADJ-COST ROUNDED =                          09570000
095800             (IPF-OUTL-COST - IPF-OUTL-THRES-ADJ-AMT).            09580000
095900                                                                  09590000
096000     COMPUTE IPF-OUTL-PER-DIEM-AMT ROUNDED =                      09600000
096100            (IPF-OUTL-ADJ-COST / BILL-LOS).                       09610000
096200                                                                  09620000
096300     MOVE ZEROES TO DAYS-UPTO-9                                   09630000
096400                    DAYS-OVER-9.                                  09640000
096500                                                                  09650000
096600     IF BILL-LOS > 9                                              09660000
096700        COMPUTE DAYS-OVER-9 = (BILL-LOS - 9)                      09670000
096800        MOVE 9 TO DAYS-UPTO-9                                     09680000
096900     ELSE                                                         09690000
097000        MOVE BILL-LOS TO DAYS-UPTO-9.                             09700000
097100                                                                  09710000
097200     COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                        09720000
097300            (DAYS-UPTO-9 * (IPF-OUTL-PER-DIEM-AMT * .80)).        09730000
097400                                                                  09740000
097500     IF BILL-LOS > 9                                              09750000
097600        COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                     09760000
097700                IPF-OUTLIER-PAYMENT +                             09770000
097800       (DAYS-OVER-9 * (IPF-OUTL-PER-DIEM-AMT * .60)).             09780000
097900                                                                  09790000
098000     IF IPF-OUTLIER-PAYMENT = ZEROES                              09800000
098100        MOVE '00' TO IPF-RTC.                                     09810000
098200                                                                  09820000
098300 3050-EXIT.   EXIT.                                               09830000
098400 3100-GET-EACH-DAY.                                               09840000
098500                                                                  09850000
098600     COMPUTE IPF-FED-PAYMENT ROUNDED =                            09860000
098700             IPF-FED-PAYMENT + (WK-PER-DIEM-AMT *                 09870000
098800                                  DAY-VALUE2 (SUB)).              09880000
098900                                                                  09890000
099000 3100-EXIT.   EXIT.                                               09900000
099100                                                                  09910000
099200 3300-GET-COMORBIDITY.                                            09920000
099300                                                                  09930000
099400     MOVE BILL-DIAG-PROC-DATA TO WK-COMORBIDITY-DATA.             09940000
099500     MOVE 01.0000 TO HOLDADJ.                                     09950000
099600                                                                  09960000
099700     PERFORM 3400-ALTER-COMB-DATA THRU 3400-EXIT                  09970000
099800         VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                    09980001
099900                                                                  09990000
100000                                                                  10000000
100100     PERFORM CAT1-SEARCH THRU CAT1-SEARCH-EXIT                    10010000
100200       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10020001
100300                                                                  10030000
100400     PERFORM CAT2-SEARCH THRU CAT2-SEARCH-EXIT                    10040000
100500       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10050001
100600                                                                  10060000
100700     PERFORM CAT3-SEARCH-2 THRU CAT3-SEARCH-2-EXIT                10070000
100800       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10080001
100900                                                                  10090000
101000     PERFORM CAT4-SEARCH THRU CAT4-SEARCH-EXIT                    10100000
101100       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10110001
101200                                                                  10120000
101300     PERFORM CAT5-SEARCH-100105 THRU CAT5-SEARCH-100105-EXIT      10130000
101400              VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.               10140001
101500                                                                  10150000
101600     PERFORM CAT6-SEARCH-2 THRU CAT6-SEARCH-2-EXIT                10160000
101700       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25                       10170001
101800         AFTER X2 FROM 1 BY 1 UNTIL X2 > 25.                      10180001
101900                                                                  10190000
102000     PERFORM CAT7-SEARCH THRU CAT7-SEARCH-EXIT                    10200000
102100       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10210001
102200                                                                  10220000
102300     PERFORM CAT8-SEARCH THRU CAT8-SEARCH-EXIT                    10230000
102400       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10240001
102500                                                                  10250000
102600     PERFORM CAT9-SEARCH THRU CAT9-SEARCH-EXIT                    10260000
102700       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10270001
102800                                                                  10280000
102900     PERFORM CAT10-SEARCH THRU CAT10-SEARCH-EXIT                  10290000
103000       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10300001
103100                                                                  10310000
103200     PERFORM CAT11-SEARCH THRU CAT11-SEARCH-EXIT                  10320000
103300       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10330001
103400                                                                  10340000
103500     PERFORM CAT12-SEARCH THRU CAT12-SEARCH-EXIT                  10350000
103600       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10360001
103700                                                                  10370000
103800     PERFORM CAT13-SEARCH THRU CAT13-SEARCH-EXIT                  10380000
103900       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10390001
104000                                                                  10400000
104100     PERFORM CAT14-SEARCH-100105 THRU CAT14-SEARCH-100105-EXIT    10410000
104200          VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                   10420001
104300                                                                  10430000
104400     PERFORM CAT15-SEARCH THRU CAT15-SEARCH-EXIT                  10440000
104500       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10450001
104600                                                                  10460000
104700     PERFORM CAT16-SEARCH THRU CAT16-SEARCH-EXIT                  10470000
104800       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10480001
104900                                                                  10490000
105000     PERFORM CAT17-SEARCH THRU CAT17-SEARCH-EXIT                  10500000
105100       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10510001
105200                                                                  10520000
105300     MOVE HOLDADJ TO IPF-COMORB-FACTOR.                           10530000
105400                                                                  10540000
105500 3300-EXIT.   EXIT.                                               10550000
105600                                                                  10560000
105700 3400-ALTER-COMB-DATA.                                            10570000
105800*                                                                 10580000
105900     IF BILL-DDXX-1ST(X1) = 'V'                                   10590000
106000        GO TO 3400-EXIT                                           10600000
106100     ELSE                                                         10610000
106200        PERFORM 3500-ZERO-FILL-DDXX THRU 3500-EXIT.               10620000
106300                                                                  10630000
106400 3400-EXIT.    EXIT.                                              10640000
106500                                                                  10650000
106600 3500-ZERO-FILL-DDXX.                                             10660000
106700     MOVE SPACES TO OUT-DDXX-ZERO.                                10670000
106800     IF WK-DDXX7(X1) > SPACES                                     10680000
106900        GO TO 3500-EXIT                                           10690000
107000     ELSE                                                         10700000
107100     IF WK-DDXX6(X1) > SPACES                                     10710000
107200        MOVE WK-DDXX6(X1) TO OUT-Z-DDXX7                          10720000
107300        MOVE WK-DDXX5(X1) TO OUT-Z-DDXX6                          10730000
107400        MOVE WK-DDXX4(X1) TO OUT-Z-DDXX5                          10740000
107500        MOVE WK-DDXX3(X1) TO OUT-Z-DDXX4                          10750000
107600        MOVE WK-DDXX2(X1) TO OUT-Z-DDXX3                          10760000
107700        MOVE WK-DDXX1(X1) TO OUT-Z-DDXX2                          10770000
107800        MOVE SPACE        TO OUT-Z-DDXX1                          10780000
107900        MOVE OUT-DDXX-ZERO TO DDXX(X1)                            10790000
108000        GO TO 3500-EXIT                                           10800000
108100     ELSE                                                         10810000
108200     IF WK-DDXX5(X1) > SPACES                                     10820000
108300        MOVE WK-DDXX5(X1) TO OUT-Z-DDXX7                          10830000
108400        MOVE WK-DDXX4(X1) TO OUT-Z-DDXX6                          10840000
108500        MOVE WK-DDXX3(X1) TO OUT-Z-DDXX5                          10850000
108600        MOVE WK-DDXX2(X1) TO OUT-Z-DDXX4                          10860000
108700        MOVE WK-DDXX1(X1) TO OUT-Z-DDXX3                          10870000
108800        MOVE SPACE        TO OUT-Z-DDXX2                          10880000
108900                             OUT-Z-DDXX1                          10890000
109000        MOVE OUT-DDXX-ZERO TO DDXX(X1)                            10900000
109100        GO TO 3500-EXIT                                           10910000
109200     ELSE                                                         10920000
109300     IF WK-DDXX4(X1) > SPACES                                     10930000
109400        MOVE WK-DDXX4(X1) TO OUT-Z-DDXX7                          10940000
109500        MOVE WK-DDXX3(X1) TO OUT-Z-DDXX6                          10950000
109600        MOVE WK-DDXX2(X1) TO OUT-Z-DDXX5                          10960000
109700        MOVE WK-DDXX1(X1) TO OUT-Z-DDXX4                          10970000
109800        MOVE SPACE        TO OUT-Z-DDXX3                          10980000
109900                             OUT-Z-DDXX2                          10990000
110000                             OUT-Z-DDXX1                          11000000
110100        MOVE OUT-DDXX-ZERO TO DDXX(X1)                            11010000
110200        GO TO 3500-EXIT                                           11020000
110300     ELSE                                                         11030000
110400     IF WK-DDXX3(X1) > SPACES                                     11040000
110500        MOVE WK-DDXX3(X1) TO OUT-Z-DDXX7                          11050000
110600        MOVE WK-DDXX2(X1) TO OUT-Z-DDXX6                          11060000
110700        MOVE WK-DDXX1(X1) TO OUT-Z-DDXX5                          11070000
110800        MOVE SPACE        TO OUT-Z-DDXX4                          11080000
110900                             OUT-Z-DDXX3                          11090000
111000                             OUT-Z-DDXX2                          11100000
111100                             OUT-Z-DDXX1                          11110000
111200        MOVE OUT-DDXX-ZERO TO DDXX(X1)                            11120000
111300        GO TO 3500-EXIT                                           11130000
111400     ELSE                                                         11140000
111500     IF WK-DDXX2(X1) > SPACES                                     11150000
111600        MOVE WK-DDXX2(X1) TO OUT-Z-DDXX7                          11160000
111700        MOVE WK-DDXX1(X1) TO OUT-Z-DDXX6                          11170000
111800        MOVE SPACE        TO OUT-Z-DDXX5                          11180000
111900                             OUT-Z-DDXX4                          11190000
112000                             OUT-Z-DDXX3                          11200000
112100                             OUT-Z-DDXX2                          11210000
112200                             OUT-Z-DDXX1                          11220000
112300        MOVE OUT-DDXX-ZERO TO DDXX(X1)                            11230000
112400        GO TO 3500-EXIT                                           11240000
112500      ELSE                                                        11250000
112600        MOVE SPACES TO DDXX(X1).                                  11260000
112700 3500-EXIT.    EXIT.                                              11270000
112800                                                                  11280000
112900* DEVELOPMENTAL DISABILITIES                                      11290000
113000 CAT1-SEARCH.                                                     11300000
113100     IF  (DDXX (X1) = '    317' OR '   3180' OR '   3181' OR      11310000
113200                      '   3182' OR '    319')                     11320000
113300         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.04                 11330000
113400         MOVE 26 TO X1.                                           11340001
113500 CAT1-SEARCH-EXIT.   EXIT.                                        11350000
113600                                                                  11360000
113700*CONGULATION FACTOR DEFICITS                                      11370000
113800 CAT2-SEARCH.                                                     11380000
113900     IF  (DDXX (X1) = '   2860' OR '   2861' OR '   2862' OR      11390000
114000                      '   2863' OR '   2864')                     11400000
114100         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.13                 11410000
114200         MOVE 26 TO X1.                                           11420001
114300 CAT2-SEARCH-EXIT.   EXIT.                                        11430000
114400                                                                  11440000
114500*TRACHEOSTOMY                                                     11450000
114600 CAT3-SEARCH-2.                                                   11460000
114700      IF  (DDXX (X1) = '  51900' OR '  51901' OR '  51909' OR     11470000
114710                       '  51902' OR                               11471000
114720                       'V440')                                    11472000
114730          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.06                11473000
114740          MOVE 26 TO X1.                                          11474001
114750 CAT3-SEARCH-2-EXIT.   EXIT.                                      11475000
114760                                                                  11476000
114770*  RENAL FAILURE, ACUTE                                           11477000
114780 CAT4-SEARCH.                                                     11478000
114790      IF   (DDXX (X1) = '  63630' OR '  63631' OR '  63632' OR    11479000
114800                        '  63730' OR '  63731' OR '  63732' OR    11480000
114900                        '   6383' OR                              11490000
115000                        '   6393' OR '  66932' OR '  66934' OR    11500000
115100                        '   5845' OR '   5846' OR '   5847' OR    11510000
115200                        '   5848' OR '   5849' OR                 11520000
115300                        '   9585')                                11530000
115400          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.11                11540000
115500          MOVE 26 TO X1.                                          11550001
115600 CAT4-SEARCH-EXIT.   EXIT.                                        11560000
115700                                                                  11570000
115800* RENAL FAILURE, CHRONIC EFFECTIVE 10/01/2005                     11580000
115900 CAT5-SEARCH-100105.                                              11590000
116000      IF  (DDXX (X1) = '  40301' OR '  40311' OR '  40391' OR     11600000
116100                       '  40402' OR '  40412' OR                  11610000
116200                       '  40413' OR '  40492' OR '  40493' OR     11620000
116300                       '   5853' OR '   5854' OR                  11630000
116400                       '   5855' OR '   5856' OR                  11640000
116500                       '   5859' OR '    586' OR                  11650000
116600                       'V451'  OR 'V560'  OR                      11660000
116700                       'V561'  OR 'V562')                         11670000
116800          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.11                11680000
116900          MOVE 26 TO X1.                                          11690001
117000                                                                  11700000
117100 CAT5-SEARCH-100105-EXIT.   EXIT.                                 11710000
117200                                                                  11720000
117300* ONCOLOGY TREATMENT                                              11730000
117400 CAT6-SEARCH-2.                                                   11740000
117500     IF (((DDXX (X1) > '   1399' AND < '   1770')  OR             11750000
117600          (DDXX (X1) > '   1799' AND < '   1810')  OR             11760000
117700          (DDXX (X1) > '   1819' AND < '   1850')  OR             11770000
117800          (DDXX (X1) > '   1859' AND < '   1930')  OR             11780000
117900          (DDXX (X1) > '   1939' AND < '   1988')  OR             11790000
118000          (DDXX (X1) > '   2099' AND < '   2170')  OR             11800000
118100          (DDXX (X1) > '   2179' AND < '   2200')  OR             11810000
118200          (DDXX (X1) > '   2209' AND < '   2234')  OR             11820000
118300          (DDXX (X1) > '   2238' AND < '   2260')  OR             11830000
118400          (DDXX (X1) > '   2269' AND < '   2280')  OR             11840000
118500          (DDXX (X1) > '   2280' AND < '   2368')  OR             11850000
118600          (DDXX (X1) > '   2369' AND < '   2377')  OR             11860000
118700          (DDXX (X1) > '   2378' AND < '   2387')  OR             11870000
118800          (DDXX (X1) > '   2387' AND < '   2400')  OR             11880000
118900          (DDXX (X1) > '  19880' AND < '  19890')  OR             11890000
119000          (DDXX (X1) > '  19999' AND < '  20892')  OR             11900000
119100          (DDXX (X1) > '  22799' AND < '  22810')  OR             11910000
119200          (DDXX (X1) > '  23689' AND < '  23700')  OR             11920000
119300          (DDXX (X1) > '  23769' AND < '  23773')  OR             11930000
119400          (DDXX (X1) > '  23870' AND < '  23880')  OR             11940000
119500          (DDXX (X1) = '  22381' OR '  22389' OR                  11950000
119600                       '    179' OR '    181' OR '    185'  OR    11960000
119700                       '    193' OR '    217' OR '    220'  OR    11970000
119800                       '   1990' OR '   1991' OR                  11980000
119900                       '    226' or '  23873'))                   11990000
120000      AND                                                         12000000
120100          (SRGX (X2) = '9221' OR '9222' OR                        12010000
120200                       '9223' OR '9224' OR                        12020000
120300                       '9225' OR '9226' OR                        12030000
120400                       '9227' OR '9228' OR                        12040000
120500                       '9229' OR '9925'))                         12050000
120600         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.07                 12060000
120700         MOVE 26 TO X2                                            12070001
120800         MOVE 26 TO X1.                                           12080001
120900 CAT6-SEARCH-2-EXIT.   EXIT.                                      12090000
121000                                                                  12100000
121100* UNCONTROLLED DIABETES-MELLITUS W OR WO COMPLICTIONS             12110000
121200 CAT7-SEARCH.                                                     12120000
121300     IF  (DDXX (X1) = '  25002' OR '  25003' OR '  25012' OR      12130000
121400                      '  25013' OR '  25022' OR '  25023' OR      12140000
121500                      '  25032' OR '  25033' OR '  25042' OR      12150000
121600                      '  25043' OR '  25052' OR '  25053' OR      12160000
121700                      '  25062' OR '  25063' OR '  25072' OR      12170000
121800                      '  25073' OR '  25082' OR '  25083' OR      12180000
121900                      '  25092' OR '  25093')                     12190000
122000         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.05                 12200000
122100         MOVE 26 TO X1.                                           12210001
122200 CAT7-SEARCH-EXIT.   EXIT.                                        12220000
122300                                                                  12230000
122400* SEVERE PROTEIN CALORIE MALNUTRITION                             12240000
122500 CAT8-SEARCH.                                                     12250000
122600     IF  (DDXX (X1) = '    260' OR '    261' OR '    262')        12260000
122700         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.13                 12270000
122800         MOVE 26 TO X1.                                           12280001
122900 CAT8-SEARCH-EXIT.   EXIT.                                        12290000
123000                                                                  12300000
123100* EATING AND CONDUCT DISORDERS                                    12310000
123200 CAT9-SEARCH.                                                     12320000
123300     IF  (DDXX (X1) = '   3071' OR '  30750' OR '  31203' OR      12330000
123400                      '  31233' OR '  31234')                     12340000
123500         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.12                 12350000
123600         MOVE 26 TO X1.                                           12360001
123700 CAT9-SEARCH-EXIT.   EXIT.                                        12370000
123800                                                                  12380000
123900* INFECTIOUS DISEASE                                              12390000
124000 CAT10-SEARCH.                                                    12400000
124100     IF ((DDXX (X1) > '  00999' AND < '  01897') OR               12410000
124200         (DDXX (X1) > '   0199' AND < '   0240') OR               12420000
124300         (DDXX (X1) > '   0259' AND < '   0324') OR               12430000
124400         (DDXX (X1) > '   0328' AND < '   0342') OR               12440000
124500         (DDXX (X1) > '   0359' AND < '   0364') OR               12450000
124600         (DDXX (X1) > '   0387' AND < '   0404') OR               12460000
124700         (DDXX (X1) > '   0459' AND < '   0480') OR               12470000
124800         (DDXX (X1) > '   0489' AND < '   0531') OR               12480000
124900         (DDXX (X1) > '   0549' AND < '   0553') OR               12490000
125000         (DDXX (X1) > '   0567' AND < '   0580') OR               12500000
125100         (DDXX (X1) > '   0599' AND < '   0610') OR               12510000
125200         (DDXX (X1) > '   0619' AND < '   0640') OR               12520000
125300         (DDXX (X1) > '   0649' AND < '   0664') OR               12530000
125400         (DDXX (X1) > '   0719' AND < '   0724') OR               12540000
125500         (DDXX (X1) > '   0727' AND < '   0742') OR               12550000
125600         (DDXX (X1) > '   0759' AND < '   0771') OR               12560000
125700         (DDXX (X1) > '   0781' AND < '   0788') OR               12570000
125800         (DDXX (X1) > '  03280' AND < '  03290') OR               12580000
125900         (DDXX (X1) > '  03639' AND < '  03644') OR               12590000
126000         (DDXX (X1) > '  03680' AND < '  03690') OR               12600000
126100         (DDXX (X1) > '  03809' AND < '  03820') OR               12610000
126200         (DDXX (X1) > '  03839' AND < '  03850') OR               12620000
126300         (DDXX (X1) > '  04080' AND < '  04090') OR               12630000
126310         (DDXX (X1) > '  04099' AND < '  04111') OR               12631000
126320         (DDXX (X1) > '  04499' AND < '  04594') OR               12632000
126330         (DDXX (X1) > '  05309' AND < '  05320') OR               12633000
126340         (DDXX (X1) > '  05439' AND < '  05450') OR               12634000
126350         (DDXX (X1) > '  05570' AND < '  05580') OR               12635000
126360         (DDXX (X1) > '  05599' AND < '  05610') OR               12636000
126370         (DDXX (X1) > '  05670' AND < '  05680') OR               12637000
126380         (DDXX (X1) > '  06639' AND < '  06650') OR               12638000
126390         (DDXX (X1) > '  07019' AND < '  07060') OR               12639000
126400         (DDXX (X1) > '  07270' AND < '  07280') OR               12640000
126500         (DDXX (X1) > '  07419' AND < '  07424') OR               12650000
126600         (DDXX (X1) > '  07880' AND < '  07890') OR               12660000
126700         (DDXX (X1) > '  07949' AND < '  07960') OR               12670000
126800         (DDXX (X1) = '    042' OR '    024' OR '    025' OR      12680000
126900                      '    035' OR '    037' OR '    048' OR      12690000
127000                      '    061' OR '    064' OR '    071' OR      12700000
127100                      '   0382' OR '   0383' OR '   0558' OR      12710000
127200                      '   0559' OR '   0668' OR '   0669' OR      12720000
127300                      '   0700' OR '   0701' OR '   0706' OR      12730000
127400                      '  07070' OR '  07071' OR '   0709' OR      12740000
127500                      '   0743' OR '   0748' OR '    075' OR      12750000
127600                      '   0380'))                                 12760000
127700         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.07                 12770000
127800         MOVE 26 TO X1.                                           12780001
127900 CAT10-SEARCH-EXIT.   EXIT.                                       12790000
128000                                                                  12800000
128100* DRUG AND/OR ALCOHOL INDUCED MENTAL DISORDERS                    12810000
128200 CAT11-SEARCH.                                                    12820000
128300     IF  (DDXX (X1) = '   2910' OR '   2920' OR '  29212' OR      12830000
128400                      '   2922' OR '  30300' OR                   12840000
128500                      '  30400')                                  12850000
128600         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.03                 12860000
128700         MOVE 26 TO X1.                                           12870001
128800 CAT11-SEARCH-EXIT.   EXIT.                                       12880000
128900                                                                  12890000
129000* CARDIAC CONDITIONS                                              12900000
129100 CAT12-SEARCH.                                                    12910000
129200     IF  (DDXX (X1) = '   3910' OR '   3911' OR '   3912' OR      12920000
129300                      '  40201' OR '  40403' OR '   4160' OR      12930000
129400                      '   4210' OR '   4211' OR '   4219')        12940000
129500         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.11                 12950000
129600         MOVE 26 TO X1.                                           12960001
129700 CAT12-SEARCH-EXIT.   EXIT.                                       12970000
129800                                                                  12980000
129900* GANGRENE                                                        12990000
130000 CAT13-SEARCH.                                                    13000000
130100     IF  (DDXX (X1) = '  44024' OR '   7854')                     13010000
130200         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.10                 13020000
130300         MOVE 26 TO X1.                                           13030001
130400 CAT13-SEARCH-EXIT.   EXIT.                                       13040000
130500                                                                  13050000
130600* CHRONIC OBSTRUCTIVE PULMONARY DISEASE EFFECTIVE 10/01/2005      13060000
130700 CAT14-SEARCH-100105.                                             13070000
130800     IF  (DDXX (X1) = '  49121' OR '   4941' OR '   5100' OR      13080000
130900                      '  51883' OR '  51884' OR                   13090000
131000                      'V4611' OR 'V4612' OR                       13100000
131100                      'V4613' OR 'V4614')                         13110000
131200         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.12                 13120000
131300         MOVE 26 TO X1.                                           13130001
131400 CAT14-SEARCH-100105-EXIT.   EXIT.                                13140000
131500                                                                  13150000
131600* ARTIFICIAL OPENINGS - DIGESTIVE AND URINARY                     13160000
131700 CAT15-SEARCH.                                                    13170000
131800     IF  (DDXX (X1) = '  56960' OR '  56961' OR                   13180000
131900                      '  56962' OR '  56969' OR '   9975'  OR     13190000
132000                      'V441'  OR 'V442'  OR 'V443'  OR            13200000
132100                      'V444'  OR 'V4450' OR 'V4451' OR            13210000
132200                      'V4452' OR 'V4459' OR 'V446')               13220000
132300         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.08                 13230000
132400         MOVE 26 TO X1.                                           13240001
132500 CAT15-SEARCH-EXIT.   EXIT.                                       13250000
132600                                                                  13260000
132700* SEVERE MUSCLOSKELETAL AND CONNECTIVE TISSUE                     13270000
132800 CAT16-SEARCH.                                                    13280000
132900     IF  ((DDXX (X1) > '  72999' AND < '  73030') OR              13290000
133000          (DDXX (X1) = '   6960' OR '   7100'))                   13300000
133100         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.09                 13310000
133200         MOVE 26 TO X1.                                           13320001
133300 CAT16-SEARCH-EXIT.   EXIT.                                       13330000
133400                                                                  13340000
133500* POISONING                                                       13350000
133600 CAT17-SEARCH.                                                    13360000
133700     IF ((DDXX (X1) > '   9669'  AND < '   9700')  OR             13370000
133800         (DDXX (X1) > '   9799'  AND < '   9810')  OR             13380000
133900         (DDXX (X1) > '   9829'  AND < '   9840')  OR             13390000
134000         (DDXX (X1) > '   9889'  AND < '   9898')  OR             13400000
134100         (DDXX (X1) > '  96499'  AND < '  96510')  OR             13410000
134200         (DDXX (X1) = '   9654' OR '    986' OR '   9770'))       13420000
134300        COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.11                  13430000
134400        MOVE 26 TO X1.                                            13440001
134500 CAT17-SEARCH-EXIT.   EXIT.                                       13450000
134600***************************************************************   13460000
134700******       L A S T   S O U R C E   S T A T E M E N T    *****   13470000
