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