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