000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.           IPCAL100.                                  00020001
000300*AUTHOR.               CMS.                                       00030006
000400*REMARKS.              CMS.                                       00040006
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     'IPCAL100      - W O R K I N G   S T O R A G E'.             00200003
002100 01  CAL-VERSION                    PIC X(05)  VALUE 'C10.0'.     00210002
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.                        00460005
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'.               00710001
007200         10  FILLER      PIC X(07) VALUE '080 107'.               00720001
007300         10  FILLER      PIC X(07) VALUE '081 107'.               00730001
007400         10  FILLER      PIC X(07) VALUE '876 122'.               00740001
007500         10  FILLER      PIC X(07) VALUE '880 105'.               00750001
007600         10  FILLER      PIC X(07) VALUE '881 099'.               00760001
007700         10  FILLER      PIC X(07) VALUE '882 102'.               00770001
007800         10  FILLER      PIC X(07) VALUE '883 102'.               00780001
007900         10  FILLER      PIC X(07) VALUE '884 103'.               00790001
008000         10  FILLER      PIC X(07) VALUE '885 100'.               00800001
008100         10  FILLER      PIC X(07) VALUE '886 099'.               00810001
008200         10  FILLER      PIC X(07) VALUE '887 092'.               00820001
008300         10  FILLER      PIC X(07) VALUE '894 097'.               00830001
008400         10  FILLER      PIC X(07) VALUE '895 102'.               00840001
008500         10  FILLER      PIC X(07) VALUE '896 088'.               00850001
008600         10  FILLER      PIC X(07) VALUE '897 088'.               00860001
008700     02  TB-DRG-DATA2 REDEFINES TB-DRG-DATA OCCURS 17             00870001
008800             ASCENDING KEY IS TB-DRG-CODE                         00880001
008900             INDEXED BY DRGSUB.                                   00890001
009000          05  TB-DRG-CODE           PIC XXX.                      00900001
009100          05  TB-DRG-ADJUSTMENTS  OCCURS 1.                       00910001
009200              10  FILLER            PIC X.                        00920001
009300              10  TB-DRG-FACTOR     PIC 9V99.                     00930001
009400                                                                  00940001
009500***************************************************************   00950001
009600***************************************************************   00960001
009700 01  CODE-FIRST-TABLE.                                            00970001
009800     02  TB-FST-DATA.                                             00980001
009900         10  FILLER      PIC X(11) VALUE '2900    103'.           00990001
010000         10  FILLER      PIC X(11) VALUE '29010   103'.           01000001
010100         10  FILLER      PIC X(11) VALUE '29011   103'.           01010001
010200         10  FILLER      PIC X(11) VALUE '29012   103'.           01020001
010300         10  FILLER      PIC X(11) VALUE '29013   103'.           01030001
010400         10  FILLER      PIC X(11) VALUE '29020   103'.           01040001
010500         10  FILLER      PIC X(11) VALUE '29021   103'.           01050001
010600         10  FILLER      PIC X(11) VALUE '2903    103'.           01060001
010700         10  FILLER      PIC X(11) VALUE '29040   103'.           01070001
010800         10  FILLER      PIC X(11) VALUE '29041   103'.           01080001
010900         10  FILLER      PIC X(11) VALUE '29042   103'.           01090001
011000         10  FILLER      PIC X(11) VALUE '29043   103'.           01100001
011100         10  FILLER      PIC X(11) VALUE '2908    103'.           01110001
011200         10  FILLER      PIC X(11) VALUE '2909    103'.           01120001
011300         10  FILLER      PIC X(11) VALUE '2930    105'.           01130001
011400         10  FILLER      PIC X(11) VALUE '2931    105'.           01140001
011500         10  FILLER      PIC X(11) VALUE '29381   103'.           01150001
011600         10  FILLER      PIC X(11) VALUE '29382   103'.           01160001
011700         10  FILLER      PIC X(11) VALUE '29383   103'.           01170001
011800         10  FILLER      PIC X(11) VALUE '29384   103'.           01180001
011900         10  FILLER      PIC X(11) VALUE '29389   103'.           01190001
012000         10  FILLER      PIC X(11) VALUE '2939    105'.           01200001
012100         10  FILLER      PIC X(11) VALUE '2940    103'.           01210001
012200         10  FILLER      PIC X(11) VALUE '29410   103'.           01220001
012300         10  FILLER      PIC X(11) VALUE '29411   103'.           01230001
012400         10  FILLER      PIC X(11) VALUE '30789   102'.           01240001
012500     02  TB-FST-DATA2 REDEFINES TB-FST-DATA OCCURS 26             01250001
012600             ASCENDING KEY IS TB-FST-CODE                         01260001
012700             INDEXED BY FSTSUB.                                   01270001
012800          05  TB-FST-CODE           PIC X(07).                    01280001
012900          05  TB-FST-ADJUSTMENTS  OCCURS 1.                       01290001
013000              10  FILLER            PIC X.                        01300001
013100              10  TB-FST-FACTOR     PIC 9V99.                     01310001
013200                                                                  01320001
013300***************************************************************   01330001
013400***************************************************************   01340001
013500 01  DAY-ADJUSTMENTS.                                             01350001
013600     02  DAY-VALUES.                                              01360001
013700         10  DAY1        PIC XXX  VALUE '000'.                    01370001
013800         10  DAY2        PIC XXX  VALUE '112'.                    01380001
013900         10  DAY3        PIC XXX  VALUE '108'.                    01390001
014000         10  DAY4        PIC XXX  VALUE '105'.                    01400001
014100         10  DAY5        PIC XXX  VALUE '104'.                    01410001
014200         10  DAY6        PIC XXX  VALUE '102'.                    01420001
014300         10  DAY7        PIC XXX  VALUE '101'.                    01430001
014400         10  DAY8        PIC XXX  VALUE '101'.                    01440001
014500         10  DAY9        PIC XXX  VALUE '100'.                    01450001
014600         10  DAY10       PIC XXX  VALUE '100'.                    01460001
014700         10  DAY11       PIC XXX  VALUE '099'.                    01470001
014800         10  DAY12       PIC XXX  VALUE '099'.                    01480001
014900         10  DAY13       PIC XXX  VALUE '099'.                    01490001
015000         10  DAY14       PIC XXX  VALUE '099'.                    01500001
015100         10  DAY15       PIC XXX  VALUE '098'.                    01510001
015200         10  DAY16       PIC XXX  VALUE '097'.                    01520001
015300         10  DAY17       PIC XXX  VALUE '097'.                    01530001
015400         10  DAY18       PIC XXX  VALUE '096'.                    01540001
015500         10  DAY19       PIC XXX  VALUE '095'.                    01550001
015600         10  DAY20       PIC XXX  VALUE '095'.                    01560001
015700         10  DAY21       PIC XXX  VALUE '095'.                    01570001
015800         10  DAY21-OVER  PIC XXX  VALUE '092'.                    01580001
015900     02  DAY-VALUES2 REDEFINES DAY-VALUES OCCURS 22.              01590001
016000         10 DAY-VALUE2   PIC 9V99.                                01600001
016100                                                                  01610001
016200 LINKAGE SECTION.                                                 01620001
016300***************************************************************   01630001
016400*                 * * * * * * * * *                           *   01640001
016500                                                                  01650001
016600***************************************************************   01660001
016700*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *   01670001
016800*    AND PASSED BACK TO THE CALLING PROGRAM                   *   01680001
016900*            RETURN CODE VALUES (IPF-RTC)                     *   01690001
017000*                                                             *   01700001
017100*            IPF-RTC 00-49 = HOW THE BILL WAS PAID            *   01710001
017200*                                                             *   01720001
017300*                                                             *   01730001
017400*              00 = PAID NORMAL IPF PAYMENT                   *   01740001
017500*                                                             *   01750001
017600*              02 = PAID AS A COST-OUTLIER.                   *   01760001
017700*                                                             *   01770001
017800*                                                             *   01780001
017900*            IPF-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   01790001
018000*              51 = NO PROVIDER SPECIFIC INFO FOUND           *   01800001
018100*              52 = INVALID CBSA# IN PROVIDER FILE            *   01810001
018200*                   OR INVALID WAGE INDEX                     *   01820001
018300*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   01830001
018400*              54 = BILL-DRG INVALID                              01840001
018500*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   01850001
018600*                                      OR                     *   01860001
018700*                   DISCHARGE DATE < CBSA EFF START DATE      *   01870001
018800*                                      OR                     *   01880001
018900*                   DISCHARGE DATE > 20060630 START CBSA AND  *   01890001
019000*                 SELECTED PROV EFF DATE < 20060701 START CBSA*   01900001
019100*                   FOR PPS                                   *   01910001
019200*              56 = INVALID LENGTH OF STAY                    *   01920001
019300*              57 = INVALID AGE                               *   01930001
019400*              58 = INVALID PPS FED BLEND INDICATOR           *   01940001
019500*              98 = CANNOT PROCESS BILL OUTSIDE THIS VERSION  *   01950001
019600***************************************************************   01960001
019700*******************************************************           01970001
019800*    PASSED FROM IPDRV                                *           01980001
019900*******************************************************           01990001
020000 01  BILL-INPUT-DATA.                                             02000001
020100     05  BILL-IN-DATA.                                            02010001
020200         10  BILL-NPI-NUMBER.                                     02020001
020300             15  BILL-NPI            PIC X(08).                   02030001
020400             15  BILL-NPI-FILLER     PIC X(02).                   02040001
020500         10  BILL-PROVIDER-NO        PIC X(06).                   02050001
020600         10  BILL-HIC-NO             PIC X(12).                   02060001
020700         10  BILL-DISCHARGE-DATE.                                 02070001
020800             15  BILL-D-CC           PIC 9(02).                   02080001
020900             15  BILL-D-YY           PIC 9(02).                   02090001
021000             15  BILL-D-MM           PIC 9(02).                   02100001
021100             15  BILL-D-DD           PIC 9(02).                   02110001
021200         10  BILL-PATIENT-STATUS     PIC X(02).                   02120001
021300         10  BILL-AGE                PIC 9(03).                   02130001
021400         10  BILL-DRG                PIC 9(03).                   02140001
021500         10  BILL-LOS                PIC 9(05).                   02150001
021600         10  BILL-OUTL-OCCUR-IND     PIC X(01).                   02160001
021700         10  BILL-SRC-OF-ADMISSION   PIC X(01).                   02170001
021800         10  BILL-ECT-NO-OF-UNITS    PIC 9(03).                   02180001
021900         10  BILL-CHARGES-CLAIMED    PIC 9(07)V9(02).             02190001
022000         10  BILL-DIAG-PROC-DATA.                                 02200001
022100             15  BILL-OTHER-DIAG-DATA   OCCURS 25 TIMES.          02210005
022200                 20  BILL-DDXX-1ST     PIC X.                     02220001
022300                 20  FILLER            PIC X(06).                 02230001
022400             15  BILL-OTHER-PROC-DATA PIC X(07)  OCCURS 25 TIMES. 02240005
022410         10  BILL-PRIOR-DAYS         PIC 9(03).                   02241005
022500*******************************************************           02250001
022600*    PASSED AND RETURNED BY IPCAL                     *           02260001
022700*******************************************************           02270001
022800 01  IPF-DATA-VARIABLES.                                          02280001
022900         10  IPF-RTC                 PIC 9(02).                   02290001
023000         10  IPF-MSA-CBSA            PIC X(05).                   02300001
023100         10  IPF-MSA-CODE REDEFINES IPF-MSA-CBSA.                 02310001
023200             15  IPF-MSA             PIC X(04).                   02320001
023300             15  FILLER              PIC X.                       02330001
023400         10  IPF-CBSA-CODE REDEFINES IPF-MSA-CBSA.                02340001
023500             15  IPF-CBSA            PIC X(05).                   02350001
023600         10  IPF-WAGE-INDEX          PIC 9(02)V9(04).             02360001
023700         10  IPF-LABOR-SHARE         PIC 9(01)V9(05).             02370001
023800         10  IPF-NLABOR-SHARE        PIC 9(01)V9(05).             02380001
023900         10  IPF-COLA                PIC 9(01)V9(03).             02390001
024000         10  IPF-STD-FACTOR          PIC 9(01)V9(05).             02400001
024100         10  IPF-COMORB-FACTOR       PIC 9(01)V9(05).             02410001
024200         10  IPF-AGE-ADJ             PIC 9(01)V9(02).             02420001
024300         10  IPF-DRG-FACTOR          PIC 9(01)V9(02).             02430001
024400         10  IPF-GEO-RURAL-ADJ       PIC 9(01)V9(02).             02440001
024500         10  IPF-EMERG-ADJ           PIC 9(01)V9(02).             02450001
024600         10  IPF-TEACH-ADJ           PIC 9(01)V9(02).             02460001
024700         10  IPF-FED-PPS-BLEND-IND   PIC X.                       02470001
024800         10  IPF-CAL-VERSION         PIC X(05).                   02480001
024900         10  FILLER                  PIC X(12).                   02490001
025000                                                                  02500001
025100*******************************************************           02510001
025200*    PASSED AND RETURNED BY IPCAL                     *           02520001
025300*******************************************************           02530001
025400 01  IPF-ADDITIONAL-VARIABLES.                                    02540001
025500     02  IPF-MF-VARIABLES.                                        02550001
025600         10  IPF-100PCT-STOPLOS-AMT      PIC 9(07)V9(02).         02560001
025700         10  IPF-TOT-PAYMENT             PIC 9(07)V9(02).         02570001
025800         10  IPF-FED-PAYMENT             PIC 9(07)V9(02).         02580001
025900         10  IPF-FAC-PAYMENT             PIC 9(07)V9(02).         02590001
026000         10  IPF-ECT-PAYMENT             PIC 9(07)V9(02).         02600001
026100         10  IPF-OUTLIER-PAYMENT         PIC 9(07)V9(02).         02610001
026200         10  IPF-OUTL-COST               PIC 9(07)V9(02).         02620001
026300         10  IPF-OUTL-ADJ-COST           PIC 9(07)V9(02).         02630001
026400         10  IPF-OUTL-PER-DIEM-AMT       PIC 9(07)V9(02).         02640001
026500         10  IPF-OUTL-THRES-AMT          PIC 9(07)V9(02).         02650001
026600         10  IPF-OUTL-THRES-ADJ-AMT      PIC 9(07)V9(02).         02660001
026700         10  IPF-ADJUSTED-PER-DIEM-AMT   PIC 9(07)V9(02).         02670001
026800         10  IPF-WAGE-ADJ-AMT            PIC 9(07)V9(02).         02680001
026900         10  IPF-LABOR-BASE-AMT          PIC 9(07)V9(05).         02690001
027000         10  IPF-NLABOR-BASE-AMT         PIC 9(07)V9(05).         02700001
027100         10  IPF-OUTL-LABOR-BASE-AMT     PIC 9(07)V9(05).         02710001
027200         10  IPF-OUTL-NLABOR-BASE-AMT    PIC 9(07)V9(05).         02720001
027300         10  IPF-BUDGNUT-RATE-AMT        PIC 9(05)V9(02).         02730001
027400         10  IPF-ECT-RATE-AMT            PIC 9(05)V9(02).         02740001
027500         10  IPF-TEACH-PAYMENT           PIC 9(07)V9(02).         02750001
027600         10  FILLER                      PIC X(01).               02760001
027700      02 IPF-PC-VARIABLES.                                        02770001
027800         10  IPF-PC-DATA                 PIC X(44).               02780001
027900                                                                  02790001
028000 01  PRICER-OPT-VERS-SW.                                          02800001
028100     02  PRICER-OPTION-SW          PIC X(01).                     02810001
028200         88  VARIABLES                  VALUE 'S'.                02820001
028300         88  PROV-RECORD-PASSED         VALUE 'P'.                02830001
028400         88  ALL-TABLES-PASSED          VALUE 'B'.                02840001
028500         88  PC-PRICER                  VALUE 'C'.                02850001
028600     02  IPF-VERSIONS.                                            02860001
028700         10  IPDRV-VERSION         PIC X(05).                     02870001
028800                                                                  02880001
028900**************************************************************    02890001
029000*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BACK FROM *    02900001
029100*      THE IPCAL056 PROGRAM FOR PROCESSING                   *    02910001
029200**************************************************************    02920001
029300 01  PROV-NEW-HOLD.                                               02930001
029400     02  PROV-NEWREC-HOLD1.                                       02940001
029500         05  P-NEW-NPI10.                                         02950001
029600             10  P-NEW-NPI8             PIC X(08).                02960001
029700             10  P-NEW-NPI-FILLER       PIC X(02).                02970001
029800         05  P-NEW-PROVIDER-NO.                                   02980001
029900             88  P-NEW-DSH-ADJ-PROVIDERS                          02990001
030000                             VALUE '180049' '190044' '190144'     03000001
030100                                   '190191' '330047' '340085'     03010001
030200                                   '370016' '370149' '420043'.    03020001
030300             10  P-NEW-STATE            PIC 9(02).                03030001
030400             10  FILLER                 PIC X(04).                03040001
030500         05  P-NEW-DATE-DATA.                                     03050001
030600             10  P-NEW-EFF-DATE.                                  03060001
030700                 15  P-NEW-EFF-DT-CC    PIC 9(02).                03070001
030800                 15  P-NEW-EFF-DT-YY    PIC 9(02).                03080001
030900                 15  P-NEW-EFF-DT-MM    PIC 9(02).                03090001
031000                 15  P-NEW-EFF-DT-DD    PIC 9(02).                03100001
031100             10  P-NEW-FY-BEGIN-DATE.                             03110001
031200                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                03120001
031300                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                03130001
031400                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                03140001
031500                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                03150001
031600             10  P-NEW-REPORT-DATE.                               03160001
031700                 15  P-NEW-REPORT-DT-CC PIC 9(02).                03170001
031800                 15  P-NEW-REPORT-DT-YY PIC 9(02).                03180001
031900                 15  P-NEW-REPORT-DT-MM PIC 9(02).                03190001
032000                 15  P-NEW-REPORT-DT-DD PIC 9(02).                03200001
032100             10  P-NEW-TERMINATION-DATE.                          03210001
032200                 15  P-NEW-TERM-DT-CC   PIC 9(02).                03220001
032300                 15  P-NEW-TERM-DT-YY   PIC 9(02).                03230001
032400                 15  P-NEW-TERM-DT-MM   PIC 9(02).                03240001
032500                 15  P-NEW-TERM-DT-DD   PIC 9(02).                03250001
032600         05  P-NEW-WAIVER-CODE          PIC X(01).                03260001
032700             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              03270001
032800         05  P-NEW-INTER-NO             PIC 9(05).                03280001
032900         05  P-NEW-PROVIDER-TYPE        PIC X(02).                03290001
033000             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.      03300001
033100             88  P-N-REFERRAL-CENTER        VALUE '07' '11'       03310001
033200                                                  '15' '17'       03320001
033300                                                  '22'.           03330001
033400             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.           03340001
033500             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.           03350001
033600             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.           03360001
033700             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.           03370001
033800             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.      03380001
033900             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.           03390001
034000             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.      03400001
034100             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.           03410001
034200             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.           03420001
034300             88  P-N-EACH                   VALUE '21' '22'.      03430001
034400             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.           03440001
034500             88  P-N-NHCMQ-II-SNF           VALUE '32'.           03450001
034600             88  P-N-NHCMQ-III-SNF          VALUE '33'.           03460001
034700         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                03470001
034800             88  P-N-NEW-ENGLAND            VALUE  1.             03480001
034900             88  P-N-MIDDLE-ATLANTIC        VALUE  2.             03490001
035000             88  P-N-SOUTH-ATLANTIC         VALUE  3.             03500001
035100             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.             03510001
035200             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.             03520001
035300             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.             03530001
035400             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.             03540001
035500             88  P-N-MOUNTAIN               VALUE  8.             03550001
035600             88  P-N-PACIFIC                VALUE  9.             03560001
035700         05  P-NEW-CURRENT-DIV   REDEFINES                        03570001
035800                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         03580001
035900             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.          03590001
036000         05  P-NEW-MSA-DATA.                                      03600001
036100             10  P-NEW-CHG-CODE-INDEX       PIC X.                03610001
036200             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 03620001
036300             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   03630001
036400                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       03640001
036500             10  P-NEW-GEO REDEFINES                              03650001
036600                                 P-NEW-GEO-LOC-MSAX.              03660001
036700                 15  P-NEW-GEO-RURAL-1ST.                         03670001
036800                     20  P-NEW-GEO-RURAL  PIC XX.                 03680001
036900                         88  P-NEW-GEO-MSAX-RURAL VALUE '  '.     03690001
037000                 15  P-NEW-GEO-RURAL-2ND        PIC XX.           03700001
037100             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 03710001
037200             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 03720001
037300             10  P-NEW-STAND-AMT-LOC-MSA9                         03730001
037400       REDEFINES P-NEW-STAND-AMT-LOC-MSA.                         03740001
037500                 15  P-NEW-RURAL-1ST.                             03750001
037600                     20  P-NEW-STAND-RURAL  PIC XX.               03760001
037700                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    03770001
037800                 15  P-NEW-RURAL-2ND        PIC XX.               03780001
037900         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    03790001
038000                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.           03800001
038100                 88  P-NEW-SCH-YR82       VALUE   '82'.           03810001
038200                 88  P-NEW-SCH-YR87       VALUE   '87'.           03820001
038300         05  P-NEW-LUGAR                    PIC X.                03830001
038400         05  P-NEW-TEMP-RELIEF-IND          PIC X.                03840001
038500         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                03850001
038600         05  FILLER                         PIC X(05).            03860001
038700     02  PROV-NEWREC-HOLD2.                                       03870001
038800         05  P-NEW-VARIABLES.                                     03880001
038900             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        03890001
039000             10  P-NEW-COLA              PIC  9(01)V9(03).        03900001
039100             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        03910001
039200             10  P-NEW-BED-SIZE          PIC  9(05).              03920001
039300             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        03930001
039400             10  P-NEW-CMI               PIC  9(01)V9(04).        03940001
039500             10  P-NEW-SSI-RATIO         PIC  V9(04).             03950001
039600             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             03960001
039700             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              03970001
039800             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        03980001
039900             10  P-NEW-DSH-PERCENT       PIC  V9(04).             03990001
040000             10  P-NEW-FYE-DATE          PIC  X(08).              04000001
040100         05  P-NEW-CBSA-DATA.                                     04010001
040200             10  P-NEW-CBSA-SPEC-PAY-IND   PIC X.                 04020001
040300             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.                 04030001
040400             10  P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.  04040001
040500             10  P-NEW-CBSA-GEO-LOCX REDEFINES                    04050001
040600                 P-NEW-CBSA-GEO-LOC.                              04060001
040700                 15  P-NEW-CBSA-GEO-RURAL-1ST.                    04070001
040800                     20  P-NEW-CBSA-GEO-RURAL  PIC XXX.           04080001
040900                         88  P-NEW-CBSA-GEO-RURAL-CHECK           04090001
041000                             VALUE '   '.                         04100001
041100                 15  P-NEW-CBSA-GEO-RURAL-2ND PIC XX.             04110001
041200             10  P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.  04120001
041300             10  P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.  04130001
041400             10  P-NEW-CBSA-SPEC-WI        PIC 9(02)V9(04).       04140001
041500             10  P-NEW-CBSA-SPEC-WI-N  REDEFINES                  04150001
041600                 P-NEW-CBSA-SPEC-WI        PIC 9(06).             04160001
041700     02  PROV-NEWREC-HOLD3.                                       04170001
041800         05  P-NEW-PASS-AMT-DATA.                                 04180001
041900             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          04190001
042000             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          04200001
042100             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          04210001
042200             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          04220001
042300         05  P-NEW-CAPI-DATA.                                     04230001
042400             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 04240001
042500             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          04250001
042600             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          04260001
042700             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        04270001
042800             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             04280001
042900             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 04290001
043000             15  P-NEW-CAPI-IME            PIC 9V9999.            04300001
043100             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          04310001
043200             15  P-VAL-BASED-PURCH-SCORE    PIC 9V999.            04320001
043300         05  FILLER                         PIC X(18).            04330001
043400******************************************************************04340001
043500                                                                  04350001
043600 01  WAGE-INDEX-RECORD.                                           04360001
043700     05  W-CBSA              PIC 9(5).                            04370001
043800     05  W-SIZE              PIC X(01).                           04380001
043900         88  LARGE-URBAN       VALUE 'L'.                         04390001
044000         88  OTHER-URBAN       VALUE 'O'.                         04400001
044100         88  ALL-RURAL         VALUE 'R'.                         04410001
044200     05  W-CBSA-EFF-DATE     PIC 9(8).                            04420001
044300     05  FILLER              PIC X.                               04430001
044400     05  W-CBSA-WAGE-INDEX   PIC S9(02)V9(04).                    04440001
044500     05  FILLER              PIC S9(02)V9(04).                    04450001
044600                                                                  04460001
044700 PROCEDURE DIVISION  USING BILL-INPUT-DATA                        04470001
044800                           IPF-DATA-VARIABLES                     04480001
044900                           IPF-ADDITIONAL-VARIABLES               04490001
045000                           PRICER-OPT-VERS-SW                     04500001
045100                           PROV-NEW-HOLD                          04510001
045200                           WAGE-INDEX-RECORD.                     04520001
045300                                                                  04530001
045400***************************************************************   04540001
045500*    PROCESSING:                                              *   04550001
045600*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE        *   04560001
045700*        B. INITIALIZE IPCAL  HOLD VARIABLES.                 *   04570001
045800*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *   04580001
045900*           ATTEMPTING TO CALCULATE IPF. IF THIS BILL         *   04590001
046000*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   04600001
046100*           GOBACK.                                           *   04610001
046200*        D. ASSEMBLE PRICING COMPONENTS.                      *   04620001
046300*        E. CALCULATE THE PRICE.                              *   04630001
046400***************************************************************   04640001
046500                                                                  04650001
046600     PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT.                04660001
046700                                                                  04670001
046800     MOVE CAL-VERSION  TO  IPF-CAL-VERSION.                       04680001
046900                                                                  04690001
047000                                                                  04700001
047100     GOBACK.                                                      04710001
047200                                                                  04720001
047300 0200-MAINLINE-CONTROL.                                           04730001
047400                                                                  04740001
047500     PERFORM 1000-EDIT-THE-BILL-INFO.                             04750001
047600                                                                  04760001
047700     IF  IPF-RTC = 00                                             04770001
047800         PERFORM 2000-ASSEMBLE-PPS-VARIABLES THRU                 04780001
047900                 2000-EXIT                                        04790001
048000         PERFORM 3000-CALC-PAYMENT THRU                           04800001
048100                 3000-EXIT.                                       04810001
048200                                                                  04820001
048300                                                                  04830001
048400                                                                  04840001
048500 0200-EXIT.   EXIT.                                               04850001
048600                                                                  04860001
048700 1000-EDIT-THE-BILL-INFO.                                         04870001
048800***************************************************************   04880001
048900*    BILL DATA EDITS IF ANY FAIL SET IPF-RTC                  *   04890001
049000*    AND DO NOT ATTEMPT TO PRICE.                             *   04900001
049100***************************************************************   04910001
049200     MOVE SPACES TO WK-COMORBIDITY-DATA.                          04920001
049300                                                                  04930001
049400     IF  IPF-RTC = 00                                             04940001
049500         IF  P-NEW-WAIVER-STATE                                   04950001
049600             MOVE 53 TO IPF-RTC.                                  04960001
049700                                                                  04970001
049800     IF  IPF-RTC = 00                                             04980001
049900         IF  BILL-DRG < 001                                       04990001
050000                OR = 014 OR = 015 OR = 016 OR = 017               05000001
050100                OR = 018 OR = 019 OR = 043 OR = 044               05010001
050200                OR = 045 OR = 046 OR = 047 OR = 048               05020001
050300                OR = 049 OR = 050 OR = 051 OR = 104               05030001
050400                OR = 105 OR = 106 OR = 107 OR = 108               05040001
050500                OR = 109 OR = 110 OR = 111 OR = 112               05050001
050600                OR = 118 OR = 119 OR = 120 OR = 126               05060001
050700                OR = 127 OR = 128 OR = 140 OR = 141               05070001
050800                OR = 142 OR = 143 OR = 144 OR = 145               05080001
050900                OR = 160 OR = 161 OR = 162 OR = 169               05090001
051000                OR = 170 OR = 171 OR = 172 OR = 173               05100001
051100                OR = 174 OR = 209 OR = 210 OR = 211               05110001
051200                OR = 212 OR = 213 OR = 214 OR = 265               05120001
051300                OR = 266 OR = 267 OR = 268 OR = 269               05130001
051400                OR = 270 OR = 271 OR = 272 OR = 273               05140001
051500                OR = 274 OR = 275 OR = 276 OR = 277               05150001
051600                OR = 278 OR = 279 OR = 317 OR = 318               05160001
051700                OR = 319 OR = 320 OR = 321 OR = 322               05170001
051800                OR = 323 OR = 324 OR = 325 OR = 359               05180001
051900                OR = 360 OR = 361 OR = 362 OR = 363               05190001
052000                OR = 364 OR = 365 OR = 366 OR = 367               05200001
052100                OR = 396 OR = 397 OR = 398 OR = 399               05210001
052200                OR = 400 OR = 401 OR = 402 OR = 403               05220001
052300                OR = 404 OR = 426 OR = 427 OR = 428               05230001
052400                OR = 429 OR = 430 OR = 431 OR = 447               05240001
052500                OR = 448 OR = 449 OR = 450 OR = 451               05250001
052600                OR = 452 OR = 518 OR = 519 OR = 520               05260001
052700                OR = 521 OR = 522 OR = 523 OR = 524               05270001
052800                OR = 525 OR = 526 OR = 527 OR = 528               05280001
052900                OR = 529 OR = 530 OR = 531 OR = 532               05290001
053000                OR = 567 OR = 568 OR = 569 OR = 570               05300001
053100                OR = 571 OR = 572 OR = 586 OR = 587               05310001
053200                OR = 588 OR = 589 OR = 590 OR = 591               05320001
053300                OR = 608 OR = 609 OR = 610 OR = 611               05330001
053400                OR = 612 OR = 613 OR = 631 OR = 632               05340001
053500                OR = 633 OR = 634 OR = 635 OR = 636               05350001
053600                OR = 646 OR = 647 OR = 648 OR = 649               05360001
053700                OR = 650 OR = 651 OR = 676 OR = 677               05370001
053800                OR = 678 OR = 679 OR = 680 OR = 681               05380001
053900                OR = 701 OR = 702 OR = 703 OR = 704               05390001
054000                OR = 705 OR = 706 OR = 719 OR = 720               05400001
054100                OR = 721 OR = 731 OR = 732 OR = 733               05410001
054200                OR = 751 OR = 752 OR = 753 OR = 762               05420001
054300                OR = 763 OR = 764 OR = 771 OR = 772               05430001
054400                OR = 773 OR = 783 OR = 784 OR = 785               05440001
054500                OR = 786 OR = 787 OR = 788 OR = 796               05450001
054600                OR = 797 OR = 798 OR = 805 OR = 806               05460001
054700                OR = 807 OR = 817 OR = 818 OR = 819               05470001
054800                OR = 831 OR = 832 OR = 833 OR = 850               05480001
054900                OR = 851 OR = 852 OR = 859 OR = 860               05490001
055000                OR = 861 OR = 873 OR = 874 OR = 875               05500001
055100                OR = 877 OR = 878 OR = 879 OR = 891               05510001
055200                OR = 891 OR = 892 OR = 892 OR = 893               05520001
055300                OR = 893 OR = 898 OR = 899 OR = 900               05530001
055400                OR = 910 OR = 911 OR = 912 OR = 924               05540001
055500                OR = 925 OR = 926 OR = 930 OR = 931               05550001
055600                OR = 932 OR = 936 OR = 937 OR = 938               05560001
055700                OR = 942 OR = 943 OR = 944 OR = 952               05570001
055800                OR = 953 OR = 954 OR = 960 OR = 961               05580001
055900                OR = 962 OR = 966 OR = 967 OR = 968               05590001
056000                OR = 971 OR = 972 OR = 973 OR = 978               05600001
056100                OR = 979 OR = 980 OR = 990 OR = 991               05610001
056200                OR = 992 OR = 993 OR = 994 OR = 995               05620001
056300                OR = 996 OR = 997                                 05630001
056400             MOVE 54 TO IPF-RTC.                                  05640001
056500                                                                  05650001
056600     IF IPF-RTC = 00                                              05660001
056700        IF  ((BILL-DISCHARGE-DATE < P-NEW-EFF-DATE) OR            05670001
056800             (BILL-DISCHARGE-DATE < W-CBSA-EFF-DATE))             05680001
056900              MOVE 55 TO IPF-RTC.                                 05690001
057000                                                                  05700001
057100     IF IPF-RTC = 00                                              05710001
057200         IF  BILL-LOS NOT NUMERIC OR                              05720001
057300             BILL-LOS = ZERO                                      05730001
057400             MOVE 56 TO IPF-RTC.                                  05740001
057500                                                                  05750001
057600     IF IPF-RTC = 00                                              05760001
057700         IF  BILL-AGE NOT NUMERIC OR                              05770001
057800             BILL-AGE = ZERO                                      05780001
057900             MOVE 57 TO IPF-RTC.                                  05790001
058000                                                                  05800001
058100     IF IPF-RTC = 00                                              05810001
058200         IF  P-NEW-FED-PPS-BLEND-IND NOT = 1 AND                  05820001
058300                                     NOT = 2 AND                  05830001
058400                                     NOT = 3 AND                  05840001
058500                                     NOT = 4                      05850001
058600             MOVE 58 TO IPF-RTC.                                  05860001
058700                                                                  05870001
058800 2000-ASSEMBLE-PPS-VARIABLES.                                     05880001
058900***************************************************************   05890001
059000*    THE APPROPRIATE SET OF THESE IPF VARIABLES ARE SELECTED  *   05900001
059100*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   05910001
059200*    OF THAT VARIABLE.                                        *   05920001
059300*    3/31/2009 - THE STANDARDIZATION FACTOR WAS USED ONLY ONCE*   05930001
059400*    TO CORRECT WHERE A COMPUTER CODE INCORRECTLY ASSIGNED    *   05940001
059500*    NON-TEACHING STATUS TO MOST TEACHING FACILITIES.         *   05950001
059600*    IT HAS BEEN COMMENTED OUT AS IT IS NO LONGER NEEDED.     *   05960001
059700***************************************************************   05970001
059800     MOVE ALL '0'  TO IPF-MF-VARIABLES.                           05980001
059900                                                                  05990001
060000     MOVE 0651.76  TO IPF-BUDGNUT-RATE-AMT.                       06000001
060100     MOVE 0280.60  TO IPF-ECT-RATE-AMT.                           06010001
060200     MOVE 6565.00  TO IPF-OUTL-THRES-AMT.                         06020001
060300     MOVE 0.75890  TO IPF-LABOR-SHARE.                            06030004
060400     MOVE 0.24110  TO IPF-NLABOR-SHARE.                           06040004
060500*    MOVE 0.82540  TO IPF-STD-FACTOR.                             06050001
060600     MOVE ZEROES   TO WK-FED-PORTION                              06060001
060700                      WK-TEACH-PORTION.                           06070001
060800                                                                  06080001
060900     IF  (P-NEW-STATE = 02 OR 12)                                 06090001
061000         MOVE P-NEW-COLA TO IPF-COLA                              06100001
061100     ELSE                                                         06110001
061200         MOVE 1.000 TO IPF-COLA.                                  06120001
061300                                                                  06130001
061400***************************************************************   06140001
061500***  GET THE DRG ADJUSTMENT FACTORES OR FIRST CODES               06150001
061600***  GET THE DRG ADJUSTMENT FACTORES OR FIRST CODES               06160001
061700                                                                  06170001
061800     PERFORM 2600-GET-DRG-FACTORS THRU 2600-EXIT.                 06180001
061900                                                                  06190001
062000     IF IPF-RTC = '60'                                            06200001
062100         MOVE '00' TO IPF-RTC                                     06210001
062200         PERFORM 2700-GET-FIRST-CODES THRU 2700-EXIT.             06220001
062300                                                                  06230001
062400                                                                  06240001
062500*******************************************************           06250001
062600***  GET THE COMORBIDITY FACTORS                                  06260001
062700***  GET THE COMORBIDITY FACTORS                                  06270001
062800                                                                  06280001
062900     PERFORM 3300-GET-COMORBIDITY THRU 3300-EXIT.                 06290001
063000                                                                  06300001
063100***************************************************************   06310001
063200***  GET THE WAGE-INDEX                                           06320001
063300***  GET THE WAGE-INDEX                                           06330001
063400                                                                  06340001
063500     MOVE W-CBSA-WAGE-INDEX TO IPF-WAGE-INDEX.                    06350001
063600                                                                  06360001
063700***************************************************************   06370001
063800***  GET THE AGE ADJUSTMENT                                       06380001
063900***  GET THE AGE ADJUSTMENT                                       06390001
064000                                                                  06400001
064100     IF BILL-AGE < 45                                             06410001
064200        MOVE 1.00 TO IPF-AGE-ADJ                                  06420001
064300        GO TO 2000-SKIP.                                          06430001
064400                                                                  06440001
064500     IF BILL-AGE < 50                                             06450001
064600        MOVE 1.01 TO IPF-AGE-ADJ                                  06460001
064700        GO TO 2000-SKIP.                                          06470001
064800                                                                  06480001
064900     IF BILL-AGE < 55                                             06490001
065000        MOVE 1.02 TO IPF-AGE-ADJ                                  06500001
065100        GO TO 2000-SKIP.                                          06510001
065200                                                                  06520001
065300     IF BILL-AGE < 60                                             06530001
065400        MOVE 1.04 TO IPF-AGE-ADJ                                  06540001
065500        GO TO 2000-SKIP.                                          06550001
065600                                                                  06560001
065700     IF BILL-AGE < 65                                             06570001
065800        MOVE 1.07 TO IPF-AGE-ADJ                                  06580001
065900        GO TO 2000-SKIP.                                          06590001
066000                                                                  06600001
066100     IF BILL-AGE < 70                                             06610001
066200        MOVE 1.10 TO IPF-AGE-ADJ                                  06620001
066300        GO TO 2000-SKIP.                                          06630001
066400                                                                  06640001
066500     IF BILL-AGE < 75                                             06650001
066600        MOVE 1.13 TO IPF-AGE-ADJ                                  06660001
066700        GO TO 2000-SKIP.                                          06670001
066800                                                                  06680001
066900     IF BILL-AGE < 80                                             06690001
067000        MOVE 1.15 TO IPF-AGE-ADJ                                  06700001
067100        GO TO 2000-SKIP.                                          06710001
067200                                                                  06720001
067300     MOVE 1.17 TO IPF-AGE-ADJ.                                    06730001
067400                                                                  06740001
067500 2000-SKIP.                                                       06750001
067600                                                                  06760001
067700***************************************************************   06770001
067800***  GET THE TEACHING ADJUSTMENT                                  06780001
067900***  GET THE TEACHING ADJUSTMENT                                  06790001
068000                                                                  06800001
068100     IF P-NEW-INTERN-RATIO NUMERIC                                06810001
068200        COMPUTE IPF-TEACH-ADJ ROUNDED =                           06820001
068300              ((1 + P-NEW-INTERN-RATIO) ** 0.5150)                06830001
068400     ELSE                                                         06840001
068500        MOVE 1.00 TO IPF-TEACH-ADJ.                               06850001
068600                                                                  06860001
068700***************************************************************   06870001
068800***  GET THE RURAL ADJUSTMENT                                     06880001
068900***  GET THE RURAL ADJUSTMENT                                     06890001
069000                                                                  06900001
069100     IF P-NEW-CBSA-GEO-RURAL-CHECK                                06910001
069200        MOVE 1.17 TO IPF-GEO-RURAL-ADJ                            06920001
069300     ELSE                                                         06930001
069400        MOVE 1.00 TO IPF-GEO-RURAL-ADJ.                           06940001
069500                                                                  06950001
069600***************************************************************   06960001
069700***  GET THE EMERGENCY ADJUSTMENT                                 06970001
069800***  GET THE EMERGENCY ADJUSTMENT                                 06980001
069900                                                                  06990001
070000     IF P-NEW-TEMP-RELIEF-IND = 'Y'                               07000001
070100        MOVE 1.31 TO IPF-EMERG-ADJ                                07010001
070200                     DAY-VALUE2 (1)                               07020001
070300     ELSE                                                         07030001
070400        MOVE 1.19 TO IPF-EMERG-ADJ                                07040001
070500                     DAY-VALUE2 (1).                              07050001
070600                                                                  07060001
070700***  CHECK FOR FACILITY W/O FULL SERVICE FROM CLAIM               07070001
070800     IF BILL-SRC-OF-ADMISSION = 'D'                               07080001
070900        MOVE 1.19 TO IPF-EMERG-ADJ                                07090001
071000                     DAY-VALUE2 (1).                              07100001
071100                                                                  07110001
071200                                                                  07120001
071300***************************************************************   07130001
071400***  GET THE ECT ADJUSTED PAYMENT                                 07140001
071500***  GET THE ECT ADJUSTED PAYMENT                                 07150001
071600                                                                  07160001
071700     COMPUTE IPF-ECT-PAYMENT ROUNDED =                            07170001
071800             (((IPF-ECT-RATE-AMT * IPF-LABOR-SHARE) *             07180001
071900                    W-CBSA-WAGE-INDEX)                            07190001
072000                           +                                      07200001
072100              ((IPF-ECT-RATE-AMT * IPF-NLABOR-SHARE) *            07210001
072200                       IPF-COLA)).                                07220001
072300                                                                  07230001
072400     COMPUTE IPF-ECT-PAYMENT ROUNDED =                            07240001
072500             IPF-ECT-PAYMENT * BILL-ECT-NO-OF-UNITS.              07250001
072600                                                                  07260001
072700 2000-EXIT.   EXIT.                                               07270001
072800                                                                  07280001
072900 2600-GET-DRG-FACTORS.                                            07290001
073000                                                                  07300001
073100     SET DRGSUB TO 1.                                             07310001
073200     SEARCH TB-DRG-DATA2 VARYING DRGSUB                           07320001
073300         AT END                                                   07330001
073400            MOVE '60' TO IPF-RTC                                  07340001
073500            GO TO 2600-EXIT                                       07350001
073600         WHEN TB-DRG-CODE (DRGSUB) = BILL-DRG                     07360001
073700            MOVE TB-DRG-FACTOR (DRGSUB, 1) TO IPF-DRG-FACTOR.     07370001
073800                                                                  07380001
073900 2600-EXIT.    EXIT.                                              07390001
074000                                                                  07400001
074100 2700-GET-FIRST-CODES.                                            07410001
074200                                                                  07420001
074300     SET FSTSUB TO 1.                                             07430001
074400     SEARCH TB-FST-DATA2 VARYING FSTSUB                           07440001
074500       AT END                                                     07450001
074600          MOVE 1.00 TO IPF-DRG-FACTOR                             07460001
074700          GO TO 2700-EXIT                                         07470001
074800       WHEN  TB-FST-CODE (FSTSUB) = BILL-OTHER-DIAG-DATA(1)       07480001
074900          MOVE TB-FST-FACTOR (FSTSUB, 1) TO IPF-DRG-FACTOR.       07490001
075000                                                                  07500001
075100                                                                  07510001
075200 2700-EXIT.    EXIT.                                              07520001
075300                                                                  07530001
075400 3000-CALC-PAYMENT.                                               07540001
075500***************************************************************   07550001
075600***  CALCULATE THE WAGE ADJ RATES                                 07560001
075700***  CALCULATE THE WAGE ADJ RATES                                 07570001
075800                                                                  07580001
075900     COMPUTE IPF-LABOR-BASE-AMT ROUNDED =                         07590001
076000                ((IPF-BUDGNUT-RATE-AMT * IPF-LABOR-SHARE) *       07600001
076100                     W-CBSA-WAGE-INDEX).                          07610001
076200                                                                  07620001
076300     COMPUTE IPF-NLABOR-BASE-AMT ROUNDED =                        07630001
076400                ((IPF-BUDGNUT-RATE-AMT * IPF-NLABOR-SHARE) *      07640001
076500                     IPF-COLA).                                   07650001
076600                                                                  07660001
076700     COMPUTE IPF-WAGE-ADJ-AMT ROUNDED =                           07670001
076800                (IPF-LABOR-BASE-AMT + IPF-NLABOR-BASE-AMT).       07680001
076900                                                                  07690001
077000***************************************************************   07700001
077100***  STEP 2                                                       07710001
077200***  CALCULATE ADJUSTED PER DIEM AMOUNT W/O TEACH-ADJ             07720001
077300***  CALCULATE ADJUSTED PER DIEM AMOUNT W/O TEACH-ADJ             07730001
077400                                                                  07740001
077500     COMPUTE WK-ADJ-PER-DIEM-STEP2 ROUNDED =                      07750001
077600          (IPF-COMORB-FACTOR *                                    07760001
077700           IPF-AGE-ADJ * IPF-DRG-FACTOR *                         07770001
077800           IPF-GEO-RURAL-ADJ)                                     07780001
077900                         *                                        07790001
078000                IPF-WAGE-ADJ-AMT.                                 07800001
078100                                                                  07810001
078200***************************************************************   07820001
078300***  STEP 4                                                       07830001
078400***  CALCULATE THE DAY LOS FOR TOTAL PAYMENT W/O  TEACH-ADJ       07840001
078500***  CALCULATE THE DAY LOS FOR TOTAL PAYMENT W/O  TEACH-ADJ       07850001
078600                                                                  07860001
078700     MOVE WK-ADJ-PER-DIEM-STEP2 TO IPF-ADJUSTED-PER-DIEM-AMT      07870001
078800                                   WK-PER-DIEM-AMT.               07880001
078900                                                                  07890001
079000     MOVE ZEROES TO DAYS-UPTO-21                                  07900001
079100                    DAYS-OVER-21                                  07910001
079200                    IPF-FED-PAYMENT.                              07920001
079300     MOVE 001    TO SUB                                           07930001
079400                    SUB2.                                         07940001
079500                                                                  07950001
079600     IF BILL-LOS > 21                                             07960001
079700        COMPUTE DAYS-OVER-21 = (BILL-LOS - 21)                    07970001
079800        MOVE 21 TO DAYS-UPTO-21                                   07980001
079900     ELSE                                                         07990001
080000        MOVE BILL-LOS TO DAYS-UPTO-21.                            08000001
080100                                                                  08010001
080200     PERFORM 3100-GET-EACH-DAY THRU 3100-EXIT  VARYING            08020001
080300             SUB FROM SUB2 BY 1 UNTIL                             08030001
080400             SUB > DAYS-UPTO-21.                                  08040001
080500                                                                  08050001
080600     IF BILL-LOS > 21                                             08060001
080700        COMPUTE IPF-FED-PAYMENT ROUNDED =                         08070001
080800                IPF-FED-PAYMENT +                                 08080001
080900       (DAYS-OVER-21 * (WK-PER-DIEM-AMT *                         08090001
081000                         DAY-VALUE2 (22))).                       08100001
081100                                                                  08110001
081200     MOVE IPF-FED-PAYMENT TO WK-FED-PORTION.                      08120001
081300                                                                  08130001
081400     MOVE ZEROES TO IPF-FED-PAYMENT.                              08140001
081500                                                                  08150001
081600***************************************************************   08160001
081700     IF IPF-TEACH-ADJ = 1.00                                      08170001
081800        MOVE ZEROES TO WK-ADJ-PER-DIEM-STEP1                      08180001
081900                       WK-TEACH-PORTION                           08190001
082000        GO TO 3000-BYPASS-TEACH.                                  08200001
082100                                                                  08210001
082200***************************************************************   08220001
082300***  STEP 1                                                       08230001
082400***  CALCULATE ADJUSTED PER DIEM AMOUNT WITH TEACHING-ADJ         08240001
082500***  CALCULATE ADJUSTED PER DIEM AMOUNT WITH TEACHING-ADJ         08250001
082600                                                                  08260001
082700     COMPUTE WK-ADJ-PER-DIEM-STEP1 ROUNDED =                      08270001
082800          (IPF-COMORB-FACTOR *                                    08280001
082900           IPF-AGE-ADJ * IPF-DRG-FACTOR *                         08290001
083000           IPF-TEACH-ADJ * IPF-GEO-RURAL-ADJ)                     08300001
083100                         *                                        08310001
083200                IPF-WAGE-ADJ-AMT.                                 08320001
083300                                                                  08330001
083400                                                                  08340001
083500***************************************************************   08350001
083600***  STEP 3                                                       08360001
083700     COMPUTE  WK-PER-DIEM-AMT ROUNDED =                           08370001
083800             WK-ADJ-PER-DIEM-STEP1 - WK-ADJ-PER-DIEM-STEP2.       08380001
083900                                                                  08390001
084000     MOVE WK-ADJ-PER-DIEM-STEP1 TO IPF-ADJUSTED-PER-DIEM-AMT.     08400001
084100                                                                  08410001
084200***************************************************************   08420001
084300***  STEP 5                                                       08430001
084400***  CALCULATE THE DAY LOS FOR TEACH ONLY                         08440001
084500***  CALCULATE THE DAY LOS FOR TEACH ONLY                         08450001
084600                                                                  08460001
084700     MOVE ZEROES TO DAYS-UPTO-21                                  08470001
084800                    DAYS-OVER-21                                  08480001
084900                    IPF-FED-PAYMENT.                              08490001
085000     MOVE 001    TO SUB                                           08500001
085100                    SUB2.                                         08510001
085200                                                                  08520001
085300     IF BILL-LOS > 21                                             08530001
085400        COMPUTE DAYS-OVER-21 = (BILL-LOS - 21)                    08540001
085500        MOVE 21 TO DAYS-UPTO-21                                   08550001
085600     ELSE                                                         08560001
085700        MOVE BILL-LOS TO DAYS-UPTO-21.                            08570001
085800                                                                  08580001
085900     PERFORM 3100-GET-EACH-DAY THRU 3100-EXIT  VARYING            08590001
086000             SUB FROM SUB2 BY 1 UNTIL                             08600001
086100             SUB > DAYS-UPTO-21.                                  08610001
086200                                                                  08620001
086300     IF BILL-LOS > 21                                             08630001
086400        COMPUTE IPF-FED-PAYMENT ROUNDED =                         08640001
086500                IPF-FED-PAYMENT +                                 08650001
086600       (DAYS-OVER-21 * (WK-PER-DIEM-AMT *                         08660001
086700                         DAY-VALUE2 (22))).                       08670001
086800                                                                  08680001
086900     MOVE IPF-FED-PAYMENT TO WK-TEACH-PORTION.                    08690001
087000                                                                  08700001
087100     MOVE ZEROES TO IPF-FED-PAYMENT.                              08710001
087200***************************************************************   08720001
087300 3000-BYPASS-TEACH.                                               08730001
087400***  STEP 6                                                       08740001
087500***  ADD FED AND TEACHING INPUT TO OULTLIER                       08750001
087600***  ADD FED AND TEACHING INPUT TO OULTLIER                       08760001
087700                                                                  08770001
087800     COMPUTE IPF-FED-PAYMENT ROUNDED =                            08780001
087900                      WK-FED-PORTION + WK-TEACH-PORTION.          08790001
088000                                                                  08800001
088100***************************************************************   08810001
088200***  CHECK FOR OUTLIER TO BE APPLIED                              08820001
088300***  CHECK FOR OUTLIER TO BE APPLIED                              08830001
088400                                                                  08840001
088500     IF ((BILL-PATIENT-STATUS = '30' AND                          08850001
088600          BILL-OUTL-OCCUR-IND  = 'Y')                             08860001
088700                     OR                                           08870001
088800         (BILL-PATIENT-STATUS NOT = '30'))                        08880001
088900          PERFORM 3050-GET-OULIER THRU 3050-EXIT.                 08890001
089000                                                                  08900001
089100***************************************************************   08910001
089200***  RETURN 100% PPS AMOUNT  FOR STOP LOSS PROVISION              08920001
089300***  RETURN 100% PPS AMOUNT  FOR STOP LOSS PROVISION              08930001
089400***  NOT BLENDED                                                  08940001
089500                                                                  08950001
089600      COMPUTE IPF-100PCT-STOPLOS-AMT ROUNDED =                    08960001
089700              WK-FED-PORTION + IPF-OUTLIER-PAYMENT +              08970001
089800              IPF-ECT-PAYMENT + WK-TEACH-PORTION.                 08980001
089900                                                                  08990001
090000***************************************************************   09000001
090100***  CHECK FOR FED PPS BLEND IND FOR FED AND FACILITY PCT         09010001
090200***  CHECK FOR FED PPS BLEND IND FOR FED AND FACILITY PCT         09020001
090300                                                                  09030001
090400     MOVE P-NEW-FED-PPS-BLEND-IND TO                              09040001
090500                                  IPF-FED-PPS-BLEND-IND.          09050001
090600                                                                  09060001
090700     IF P-NEW-FED-PPS-BLEND-IND = 1                               09070001
090800        COMPUTE IPF-FED-PAYMENT ROUNDED =                         09080001
090900                WK-FED-PORTION * .25                              09090001
091000        COMPUTE IPF-ECT-PAYMENT ROUNDED =                         09100001
091100                IPF-ECT-PAYMENT * .25                             09110001
091200        COMPUTE IPF-TEACH-PAYMENT ROUNDED =                       09120001
091300                WK-TEACH-PORTION * .25                            09130001
091400        COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                     09140001
091500                IPF-OUTLIER-PAYMENT * .25                         09150001
091600        COMPUTE IPF-FAC-PAYMENT ROUNDED =                         09160001
091700                P-NEW-FAC-SPEC-RATE * .75.                        09170001
091800                                                                  09180001
091900     IF P-NEW-FED-PPS-BLEND-IND = 2                               09190001
092000        COMPUTE IPF-FED-PAYMENT ROUNDED =                         09200001
092100                WK-FED-PORTION * .50                              09210001
092200        COMPUTE IPF-ECT-PAYMENT ROUNDED =                         09220001
092300                IPF-ECT-PAYMENT * .50                             09230001
092400        COMPUTE IPF-TEACH-PAYMENT ROUNDED =                       09240001
092500                WK-TEACH-PORTION * .50                            09250001
092600        COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                     09260001
092700                IPF-OUTLIER-PAYMENT * .50                         09270001
092800        COMPUTE IPF-FAC-PAYMENT ROUNDED =                         09280001
092900                P-NEW-FAC-SPEC-RATE * .50.                        09290001
093000                                                                  09300001
093100     IF P-NEW-FED-PPS-BLEND-IND = 3                               09310001
093200        COMPUTE IPF-FED-PAYMENT ROUNDED =                         09320001
093300                WK-FED-PORTION * .75                              09330001
093400        COMPUTE IPF-ECT-PAYMENT ROUNDED =                         09340001
093500                IPF-ECT-PAYMENT * .75                             09350001
093600        COMPUTE IPF-TEACH-PAYMENT ROUNDED =                       09360001
093700                WK-TEACH-PORTION * .75                            09370001
093800        COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                     09380001
093900                IPF-OUTLIER-PAYMENT * .75                         09390001
094000        COMPUTE IPF-FAC-PAYMENT ROUNDED =                         09400001
094100                P-NEW-FAC-SPEC-RATE * .25.                        09410001
094200                                                                  09420001
094300     IF P-NEW-FED-PPS-BLEND-IND = 4                               09430001
094400        COMPUTE IPF-FED-PAYMENT ROUNDED =                         09440001
094500                WK-FED-PORTION * 1.00                             09450001
094600        COMPUTE IPF-ECT-PAYMENT ROUNDED =                         09460001
094700                IPF-ECT-PAYMENT * 1.00                            09470001
094800        COMPUTE IPF-TEACH-PAYMENT ROUNDED =                       09480001
094900                WK-TEACH-PORTION * 1.00                           09490001
095000        COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                     09500001
095100                IPF-OUTLIER-PAYMENT * 1.00                        09510001
095200        COMPUTE IPF-FAC-PAYMENT ROUNDED =                         09520001
095300                P-NEW-FAC-SPEC-RATE * .0.                         09530001
095400                                                                  09540001
095500     COMPUTE IPF-TOT-PAYMENT ROUNDED =                            09550001
095600             IPF-FED-PAYMENT + IPF-FAC-PAYMENT +                  09560001
095700             IPF-ECT-PAYMENT + IPF-TEACH-PAYMENT +                09570001
095800             IPF-OUTLIER-PAYMENT.                                 09580001
095900                                                                  09590001
096000**  NOTE> IPF-FED-PAYMENT  AND IPF-TEACH-PAYMENT AND              09600001
096100**        IPF-ECT-PAYMENT  AND IPF-FAC-PAYMENT AND                09610001
096200**        IPF-OUTLIER-PAYMENT HAVE JUST BEEN BLENDED              09620001
096300**           AT THIS POINT IN THE PROGRAM LOGIC                   09630001
096400                                                                  09640001
096500 3000-EXIT.   EXIT.                                               09650001
096600                                                                  09660001
096700 3050-GET-OULIER.                                                 09670001
096800************************************                              09680001
096900***  CALCULATE THE OUTLIER PAYMENT                                09690001
097000***  CALCULATE THE OUTLIER PAYMENT                                09700001
097100                                                                  09710001
097200************************************                              09720001
097300** CALCULATE THE ADJUSTED FIXED                                   09730001
097400**    DOLLAR LOSS THRESHOLD                                       09740001
097500************************************                              09750001
097600                                                                  09760001
097700     COMPUTE IPF-OUTL-LABOR-BASE-AMT ROUNDED =                    09770001
097800                ((IPF-OUTL-THRES-AMT * IPF-LABOR-SHARE) *         09780001
097900                     W-CBSA-WAGE-INDEX).                          09790001
098000                                                                  09800001
098100     COMPUTE IPF-OUTL-NLABOR-BASE-AMT ROUNDED =                   09810001
098200                ((IPF-OUTL-THRES-AMT * IPF-NLABOR-SHARE) *        09820001
098300                     IPF-COLA).                                   09830001
098400                                                                  09840001
098500     COMPUTE IPF-OUTL-THRES-ADJ-AMT ROUNDED =                     09850001
098600           ((IPF-OUTL-LABOR-BASE-AMT +                            09860001
098700             IPF-OUTL-NLABOR-BASE-AMT) *                          09870001
098800             IPF-GEO-RURAL-ADJ *                                  09880001
098900             IPF-TEACH-ADJ) +                                     09890001
099000             IPF-FED-PAYMENT +                                    09900001
099100             IPF-ECT-PAYMENT.                                     09910001
099200                                                                  09920001
099300**  NOTE> IPF-FED-PAYMENT CONTAINS NO ECT OR OUTL PAYMENT         09930001
099400**           AT THIS POINT IN THE PROGRAM LOGIC                   09940001
099500                                                                  09950001
099600************************************                              09960001
099700** CALCULATE ELIGIBLE OUTLIER COSTS                               09970001
099800************************************                              09980001
099900                                                                  09990001
100000     COMPUTE IPF-OUTL-COST ROUNDED =                              10000001
100100             (BILL-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO).    10010001
100200                                                                  10020001
100300     MOVE '02' TO IPF-RTC.                                        10030001
100400                                                                  10040001
100500     IF IPF-OUTL-COST < IPF-OUTL-THRES-ADJ-AMT                    10050001
100600        MOVE '00' TO IPF-RTC                                      10060001
100700        MOVE ZEROES TO IPF-OUTLIER-PAYMENT                        10070001
100800        GO TO 3050-EXIT.                                          10080001
100900                                                                  10090001
101000     COMPUTE IPF-OUTL-ADJ-COST ROUNDED =                          10100001
101100             (IPF-OUTL-COST - IPF-OUTL-THRES-ADJ-AMT).            10110001
101200                                                                  10120001
101300     COMPUTE IPF-OUTL-PER-DIEM-AMT ROUNDED =                      10130001
101400            (IPF-OUTL-ADJ-COST / BILL-LOS).                       10140001
101500                                                                  10150001
101600     MOVE ZEROES TO DAYS-UPTO-9                                   10160001
101700                    DAYS-OVER-9.                                  10170001
101800                                                                  10180001
101900     IF BILL-LOS > 9                                              10190001
102000        COMPUTE DAYS-OVER-9 = (BILL-LOS - 9)                      10200001
102100        MOVE 9 TO DAYS-UPTO-9                                     10210001
102200     ELSE                                                         10220001
102300        MOVE BILL-LOS TO DAYS-UPTO-9.                             10230001
102400                                                                  10240001
102500     COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                        10250001
102600            (DAYS-UPTO-9 * (IPF-OUTL-PER-DIEM-AMT * .80)).        10260001
102700                                                                  10270001
102800     IF BILL-LOS > 9                                              10280001
102900        COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                     10290001
103000                IPF-OUTLIER-PAYMENT +                             10300001
103100       (DAYS-OVER-9 * (IPF-OUTL-PER-DIEM-AMT * .60)).             10310001
103200                                                                  10320001
103300     IF IPF-OUTLIER-PAYMENT = ZEROES                              10330001
103400        MOVE '00' TO IPF-RTC.                                     10340001
103500                                                                  10350001
103600 3050-EXIT.   EXIT.                                               10360001
103700 3100-GET-EACH-DAY.                                               10370001
103800                                                                  10380001
103900     COMPUTE IPF-FED-PAYMENT ROUNDED =                            10390001
104000             IPF-FED-PAYMENT + (WK-PER-DIEM-AMT *                 10400001
104100                                  DAY-VALUE2 (SUB)).              10410001
104200                                                                  10420001
104300 3100-EXIT.   EXIT.                                               10430001
104400                                                                  10440001
104500 3300-GET-COMORBIDITY.                                            10450001
104600                                                                  10460001
104700     MOVE BILL-DIAG-PROC-DATA TO WK-COMORBIDITY-DATA.             10470001
104800     MOVE 01.0000 TO HOLDADJ.                                     10480001
104900                                                                  10490001
105000     PERFORM 3400-ALTER-COMB-DATA THRU 3400-EXIT                  10500001
105100         VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                    10510005
105200                                                                  10520001
105300                                                                  10530001
105400     PERFORM CAT1-SEARCH THRU CAT1-SEARCH-EXIT                    10540001
105500       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10550005
105600                                                                  10560001
105700     PERFORM CAT2-SEARCH THRU CAT2-SEARCH-EXIT                    10570001
105800       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10580005
105900                                                                  10590001
106000     PERFORM CAT3-SEARCH-2 THRU CAT3-SEARCH-2-EXIT                10600001
106100       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10610005
106200                                                                  10620001
106300     PERFORM CAT4-SEARCH THRU CAT4-SEARCH-EXIT                    10630001
106400       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10640005
106500                                                                  10650001
106600     PERFORM CAT5-SEARCH-100105 THRU CAT5-SEARCH-100105-EXIT      10660001
106700              VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.               10670005
106800                                                                  10680001
106900     PERFORM CAT6-SEARCH-2 THRU CAT6-SEARCH-2-EXIT                10690001
107000       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25                       10700005
107100         AFTER X2 FROM 1 BY 1 UNTIL X2 > 25.                      10710005
107200                                                                  10720001
107300     PERFORM CAT7-SEARCH THRU CAT7-SEARCH-EXIT                    10730001
107400       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10740005
107500                                                                  10750001
107600     PERFORM CAT8-SEARCH THRU CAT8-SEARCH-EXIT                    10760001
107700       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10770005
107800                                                                  10780001
107900     PERFORM CAT9-SEARCH THRU CAT9-SEARCH-EXIT                    10790001
108000       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10800005
108100                                                                  10810001
108200     PERFORM CAT10-SEARCH THRU CAT10-SEARCH-EXIT                  10820001
108300       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10830005
108400                                                                  10840001
108500     PERFORM CAT11-SEARCH THRU CAT11-SEARCH-EXIT                  10850001
108600       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10860005
108700                                                                  10870001
108800     PERFORM CAT12-SEARCH THRU CAT12-SEARCH-EXIT                  10880001
108900       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10890005
109000                                                                  10900001
109100     PERFORM CAT13-SEARCH THRU CAT13-SEARCH-EXIT                  10910001
109200       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10920005
109300                                                                  10930001
109400     PERFORM CAT14-SEARCH-100105 THRU CAT14-SEARCH-100105-EXIT    10940001
109500          VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                   10950005
109600                                                                  10960001
109700     PERFORM CAT15-SEARCH THRU CAT15-SEARCH-EXIT                  10970001
109800       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10980005
109900                                                                  10990001
110000     PERFORM CAT16-SEARCH THRU CAT16-SEARCH-EXIT                  11000001
110100       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      11010005
110200                                                                  11020001
110300     PERFORM CAT17-SEARCH THRU CAT17-SEARCH-EXIT                  11030001
110400       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      11040005
110500                                                                  11050001
110600     MOVE HOLDADJ TO IPF-COMORB-FACTOR.                           11060001
110700                                                                  11070001
110800 3300-EXIT.   EXIT.                                               11080001
110900                                                                  11090001
111000 3400-ALTER-COMB-DATA.                                            11100001
111100*                                                                 11110001
111200     IF BILL-DDXX-1ST(X1) = 'V'                                   11120001
111300        GO TO 3400-EXIT                                           11130001
111400     ELSE                                                         11140001
111500        PERFORM 3500-ZERO-FILL-DDXX THRU 3500-EXIT.               11150001
111600                                                                  11160001
111700 3400-EXIT.    EXIT.                                              11170001
111800                                                                  11180001
111900 3500-ZERO-FILL-DDXX.                                             11190001
112000     MOVE SPACES TO OUT-DDXX-ZERO.                                11200001
112100     IF WK-DDXX7(X1) > SPACES                                     11210001
112200        GO TO 3500-EXIT                                           11220001
112300     ELSE                                                         11230001
112400     IF WK-DDXX6(X1) > SPACES                                     11240001
112500        MOVE WK-DDXX6(X1) TO OUT-Z-DDXX7                          11250001
112600        MOVE WK-DDXX5(X1) TO OUT-Z-DDXX6                          11260001
112700        MOVE WK-DDXX4(X1) TO OUT-Z-DDXX5                          11270001
112800        MOVE WK-DDXX3(X1) TO OUT-Z-DDXX4                          11280001
112900        MOVE WK-DDXX2(X1) TO OUT-Z-DDXX3                          11290001
113000        MOVE WK-DDXX1(X1) TO OUT-Z-DDXX2                          11300001
113100        MOVE SPACE        TO OUT-Z-DDXX1                          11310001
113200        MOVE OUT-DDXX-ZERO TO DDXX(X1)                            11320001
113300        GO TO 3500-EXIT                                           11330001
113400     ELSE                                                         11340001
113500     IF WK-DDXX5(X1) > SPACES                                     11350001
113600        MOVE WK-DDXX5(X1) TO OUT-Z-DDXX7                          11360001
113700        MOVE WK-DDXX4(X1) TO OUT-Z-DDXX6                          11370001
113800        MOVE WK-DDXX3(X1) TO OUT-Z-DDXX5                          11380001
113900        MOVE WK-DDXX2(X1) TO OUT-Z-DDXX4                          11390001
114000        MOVE WK-DDXX1(X1) TO OUT-Z-DDXX3                          11400001
114100        MOVE SPACE        TO OUT-Z-DDXX2                          11410001
114200                             OUT-Z-DDXX1                          11420001
114300        MOVE OUT-DDXX-ZERO TO DDXX(X1)                            11430001
114400        GO TO 3500-EXIT                                           11440001
114500     ELSE                                                         11450001
114600     IF WK-DDXX4(X1) > SPACES                                     11460001
114700        MOVE WK-DDXX4(X1) TO OUT-Z-DDXX7                          11470001
114800        MOVE WK-DDXX3(X1) TO OUT-Z-DDXX6                          11480001
114900        MOVE WK-DDXX2(X1) TO OUT-Z-DDXX5                          11490001
115000        MOVE WK-DDXX1(X1) TO OUT-Z-DDXX4                          11500001
115100        MOVE SPACE        TO OUT-Z-DDXX3                          11510001
115200                             OUT-Z-DDXX2                          11520001
115300                             OUT-Z-DDXX1                          11530001
115400        MOVE OUT-DDXX-ZERO TO DDXX(X1)                            11540001
115500        GO TO 3500-EXIT                                           11550001
115600     ELSE                                                         11560001
115700     IF WK-DDXX3(X1) > SPACES                                     11570001
115800        MOVE WK-DDXX3(X1) TO OUT-Z-DDXX7                          11580001
115900        MOVE WK-DDXX2(X1) TO OUT-Z-DDXX6                          11590001
116000        MOVE WK-DDXX1(X1) TO OUT-Z-DDXX5                          11600001
116100        MOVE SPACE        TO OUT-Z-DDXX4                          11610001
116200                             OUT-Z-DDXX3                          11620001
116300                             OUT-Z-DDXX2                          11630001
116400                             OUT-Z-DDXX1                          11640001
116500        MOVE OUT-DDXX-ZERO TO DDXX(X1)                            11650001
116600        GO TO 3500-EXIT                                           11660001
116700     ELSE                                                         11670001
116800     IF WK-DDXX2(X1) > SPACES                                     11680001
116900        MOVE WK-DDXX2(X1) TO OUT-Z-DDXX7                          11690001
117000        MOVE WK-DDXX1(X1) TO OUT-Z-DDXX6                          11700001
117100        MOVE SPACE        TO OUT-Z-DDXX5                          11710001
117200                             OUT-Z-DDXX4                          11720001
117300                             OUT-Z-DDXX3                          11730001
117400                             OUT-Z-DDXX2                          11740001
117500                             OUT-Z-DDXX1                          11750001
117600        MOVE OUT-DDXX-ZERO TO DDXX(X1)                            11760001
117700        GO TO 3500-EXIT                                           11770001
117800      ELSE                                                        11780001
117900        MOVE SPACES TO DDXX(X1).                                  11790001
118000 3500-EXIT.    EXIT.                                              11800001
118100                                                                  11810001
118200* DEVELOPMENTAL DISABILITIES                                      11820001
118300 CAT1-SEARCH.                                                     11830001
118400     IF  (DDXX (X1) = '    317' OR '   3180' OR '   3181' OR      11840001
118500                      '   3182' OR '    319')                     11850001
118600         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.04                 11860001
118700         MOVE 26 TO X1.                                           11870005
118800 CAT1-SEARCH-EXIT.   EXIT.                                        11880001
118900                                                                  11890001
119000*CONGULATION FACTOR DEFICITS                                      11900001
119100 CAT2-SEARCH.                                                     11910001
119200     IF  (DDXX (X1) = '   2860' OR '   2861' OR '   2862' OR      11920001
119300                      '   2863' OR '   2864')                     11930001
119400         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.13                 11940001
119500         MOVE 26 TO X1.                                           11950005
119600 CAT2-SEARCH-EXIT.   EXIT.                                        11960001
119700                                                                  11970001
119800*TRACHEOSTOMY                                                     11980001
119900 CAT3-SEARCH-2.                                                   11990001
120000      IF  (DDXX (X1) = '  51900' OR '  51901' OR '  51909' OR     12000001
120100                       '  51902' OR                               12010001
120200                       'V440')                                    12020001
120300          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.06                12030001
120400          MOVE 26 TO X1.                                          12040005
120500 CAT3-SEARCH-2-EXIT.   EXIT.                                      12050001
120600                                                                  12060001
120700*  RENAL FAILURE, ACUTE                                           12070001
120800 CAT4-SEARCH.                                                     12080001
120900      IF   (DDXX (X1) = '  63630' OR '  63631' OR '  63632' OR    12090001
121000                        '  63730' OR '  63731' OR '  63732' OR    12100001
121100                        '   6383' OR                              12110001
121200                        '   6393' OR '  66932' OR '  66934' OR    12120001
121300                        '   5845' OR '   5846' OR '   5847' OR    12130001
121400                        '   5848' OR '   5849' OR                 12140001
121500                        '   9585')                                12150001
121600          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.11                12160001
121700          MOVE 26 TO X1.                                          12170005
121800 CAT4-SEARCH-EXIT.   EXIT.                                        12180001
121900                                                                  12190001
122000* RENAL FAILURE, CHRONIC EFFECTIVE 10/01/2005                     12200001
122100 CAT5-SEARCH-100105.                                              12210001
122200      IF  (DDXX (X1) = '  40301' OR '  40311' OR '  40391' OR     12220001
122300                       '  40402' OR '  40412' OR                  12230001
122400                       '  40413' OR '  40492' OR '  40493' OR     12240001
122500                       '   5853' OR '   5854' OR                  12250001
122600                       '   5855' OR '   5856' OR                  12260001
122700                       '   5859' OR '    586' OR                  12270001
122800                       'V4511' OR 'V4512' OR                      12280001
122900                       'V560'  OR                                 12290001
123000                       'V561'  OR 'V562')                         12300001
123100          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.11                12310001
123200          MOVE 26 TO X1.                                          12320005
123300                                                                  12330001
123400 CAT5-SEARCH-100105-EXIT.   EXIT.                                 12340001
123500                                                                  12350001
123600* ONCOLOGY TREATMENT                                              12360001
123700 CAT6-SEARCH-2.                                                   12370001
123800     IF (((DDXX (X1) > '   1399' AND < '   1770')  OR             12380001
123900          (DDXX (X1) > '   1799' AND < '   1810')  OR             12390001
124000          (DDXX (X1) > '   1819' AND < '   1850')  OR             12400001
124100          (DDXX (X1) > '   1859' AND < '   1930')  OR             12410001
124200          (DDXX (X1) > '   1939' AND < '   1988')  OR             12420001
124300          (DDXX (X1) > '   2099' AND < '   2170')  OR             12430001
124400          (DDXX (X1) > '   2179' AND < '   2200')  OR             12440001
124500          (DDXX (X1) > '   2209' AND < '   2234')  OR             12450001
124600          (DDXX (X1) > '   2238' AND < '   2260')  OR             12460001
124700          (DDXX (X1) > '   2269' AND < '   2280')  OR             12470001
124800          (DDXX (X1) > '   2280' AND < '   2333')  OR             12480001
124900          (DDXX (X1) > '   2333' AND < '   2368')  OR             12490001
125000          (DDXX (X1) > '   2369' AND < '   2377')  OR             12500001
125100          (DDXX (X1) > '   2378' AND < '   2387')  OR             12510001
125200          (DDXX (X1) > '   2387' AND < '   2400')  OR             12520001
125300          (DDXX (X1) > '  19880' AND < '  19890')  OR             12530001
125400          (DDXX (X1) > '  19999' AND < '  20892')  OR             12540001
125500          (DDXX (X1) > '  20029' AND < '  20079')  OR             12550001
125600          (DDXX (X1) > '  20269' AND < '  20279')  OR             12560001
125700          (DDXX (X1) > '  22799' AND < '  22810')  OR             12570001
125800          (DDXX (X1) > '  23329' AND < '  23333')  OR             12580001
125900          (DDXX (X1) > '  23689' AND < '  23700')  OR             12590001
126000          (DDXX (X1) > '  23769' AND < '  23773')  OR             12600001
126100          (DDXX (X1) > '  23870' AND < '  23880')  OR             12610001
126200          (DDXX (X1) = '  22381' OR '  22389' OR '  23339' OR     12620001
126300                       '    179' OR '    181' OR '    185' OR     12630001
126400                       '    193' OR '    217' OR '    220' OR     12640001
126500                       '   1990' OR '   1991' OR                  12650001
126600                       '   1992' OR '  20302' OR '  20312' OR     12660001
126700                       '  20382' OR '  20402' OR                  12670001
126800                       '  20412' OR '  20422' OR '  20482' OR     12680001
126900                       '  20492' OR '  20502' OR '  20512' OR     12690001
127000                       '  20522' OR '  20532' OR                  12700001
127100                       '  20582' OR '  20592' OR '  20602' OR     12710001
127200                       '  20612' OR '  20622' OR '  20682' OR     12720001
127300                       '  20692' OR '  20702' OR                  12730001
127400                       '  20712' OR '  20722' OR '  20782' OR     12740001
127500                       '  20802' OR '  20812' OR '  20822' OR     12750001
127600                       '  20882' OR '  20892' OR                  12760001
127700                       '  20900' OR '  20901' OR '  20902' OR     12770001
127800                       '  20903' OR '  20910' OR '  20911' OR     12780001
127900                       '  20912' OR '  20913' OR                  12790001
128000                       '  20914' OR '  20915' OR '  20916' OR     12800001
128100                       '  20917' OR '  20920' OR '  20921' OR     12810001
128200                       '  20922' OR '  20923' OR                  12820001
128300                       '  20924' OR '  20925' OR '  20926' OR     12830001
128400                       '  20927' OR '  20929' OR '  20930' OR     12840001
128500                       '  20940' OR '  20941' OR                  12850001
128600                       '  20942' OR '  20943' OR '  20950' OR     12860001
128700                       '  20951' OR '  20952' OR '  20953' OR     12870001
128800                       '  20954' OR '  20955' OR                  12880001
128900                       '  20956' OR '  20957' OR '  20960' OR     12890001
129000                       '  20961' OR '  20962' OR '  20963' OR     12900001
129100                       '  20964' OR '  20965' OR                  12910001
129200                       '  20966' OR '  20967' OR '  20969' OR     12920001
129300                       '  23877' OR                               12930001
129400                       '    226' OR '  23873'))                   12940001
129500      AND                                                         12950001
129600          (SRGX (X2) = '9221' OR '9222' OR                        12960001
129700                       '9223' OR '9224' OR                        12970001
129800                       '9225' OR '9226' OR                        12980001
129900                       '9227' OR '9228' OR                        12990001
130000                       '9229' OR '9925'))                         13000001
130100         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.07                 13010001
130200         MOVE 7 TO X2                                             13020001
130300         MOVE 26 TO X1.                                           13030005
130400 CAT6-SEARCH-2-EXIT.   EXIT.                                      13040001
130500                                                                  13050001
130600* UNCONTROLLED DIABETES-MELLITUS W OR WO COMPLICTIONS             13060001
130700 CAT7-SEARCH.                                                     13070001
130800     IF  (DDXX (X1) = '  25002' OR '  25003' OR '  25012' OR      13080001
130900                      '  25013' OR '  25022' OR '  25023' OR      13090001
131000                      '  25032' OR '  25033' OR '  25042' OR      13100001
131100                      '  25043' OR '  25052' OR '  25053' OR      13110001
131200                      '  25062' OR '  25063' OR '  25072' OR      13120001
131300                      '  25073' OR '  25082' OR '  25083' OR      13130001
131400                      '  25092' OR '  25093')                     13140001
131500         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.05                 13150001
131600         MOVE 26 TO X1.                                           13160005
131700 CAT7-SEARCH-EXIT.   EXIT.                                        13170001
131800                                                                  13180001
131900* SEVERE PROTEIN CALORIE MALNUTRITION                             13190001
132000 CAT8-SEARCH.                                                     13200001
132100     IF  (DDXX (X1) = '    260' OR '    261' OR '    262')        13210001
132200         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.13                 13220001
132300         MOVE 26 TO X1.                                           13230005
132400 CAT8-SEARCH-EXIT.   EXIT.                                        13240001
132500                                                                  13250001
132600* EATING AND CONDUCT DISORDERS                                    13260001
132700 CAT9-SEARCH.                                                     13270001
132800     IF  (DDXX (X1) = '   3071' OR '  30750' OR '  31203' OR      13280001
132900                      '  31233' OR '  31234')                     13290001
133000         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.12                 13300001
133100         MOVE 26 TO X1.                                           13310005
133200 CAT9-SEARCH-EXIT.   EXIT.                                        13320001
133300                                                                  13330001
133400* INFECTIOUS DISEASE                                              13340001
133500 CAT10-SEARCH.                                                    13350001
133600     IF ((DDXX (X1) > '  00999' AND < '  01897') OR               13360001
133700         (DDXX (X1) > '   0199' AND < '   0240') OR               13370001
133800         (DDXX (X1) > '   0259' AND < '   0324') OR               13380001
133900         (DDXX (X1) > '   0328' AND < '   0342') OR               13390001
134000         (DDXX (X1) > '   0359' AND < '   0364') OR               13400001
134100         (DDXX (X1) > '   0387' AND < '   0404') OR               13410001
134200         (DDXX (X1) > '   0459' AND < '   0461') OR               13420001
134300         (DDXX (X1) > '   0461' AND < '   0480') OR               13430001
134400         (DDXX (X1) > '   0489' AND < '   0510') OR               13440001
134500         (DDXX (X1) > '   0510' AND < '   0531') OR               13450001
134600         (DDXX (X1) > '   0549' AND < '   0553') OR               13460001
134700         (DDXX (X1) > '   0567' AND < '   0580') OR               13470001
134800         (DDXX (X1) > '   0599' AND < '   0610') OR               13480001
134900         (DDXX (X1) > '   0619' AND < '   0640') OR               13490001
135000         (DDXX (X1) > '   0649' AND < '   0664') OR               13500001
135100         (DDXX (X1) > '   0719' AND < '   0724') OR               13510001
135200         (DDXX (X1) > '   0727' AND < '   0742') OR               13520001
135300         (DDXX (X1) > '   0759' AND < '   0771') OR               13530001
135400         (DDXX (X1) > '   0781' AND < '   0788') OR               13540001
135500         (DDXX (X1) > '  03280' AND < '  03290') OR               13550001
135600         (DDXX (X1) > '  03639' AND < '  03644') OR               13560001
135700         (DDXX (X1) > '  03680' AND < '  03690') OR               13570001
135800         (DDXX (X1) > '  03809' AND < '  03820') OR               13580001
135900         (DDXX (X1) > '  03839' AND < '  03850') OR               13590001
136000         (DDXX (X1) > '  04040' AND < '  04043') OR               13600001
136100         (DDXX (X1) > '  04080' AND < '  04090') OR               13610001
136200         (DDXX (X1) > '  04099' AND < '  04111') OR               13620001
136300         (DDXX (X1) > '  04499' AND < '  04594') OR               13630001
136400         (DDXX (X1) > '  05309' AND < '  05320') OR               13640001
136500         (DDXX (X1) > '  05439' AND < '  05450') OR               13650001
136600         (DDXX (X1) > '  05570' AND < '  05580') OR               13660001
136700         (DDXX (X1) > '  05599' AND < '  05610') OR               13670001
136800         (DDXX (X1) > '  05670' AND < '  05680') OR               13680001
136900         (DDXX (X1) > '  05809' AND < '  05813') OR               13690001
137000         (DDXX (X1) > '  05880' AND < '  05883') OR               13700001
137100         (DDXX (X1) > '  06639' AND < '  06650') OR               13710001
137200         (DDXX (X1) > '  07019' AND < '  07060') OR               13720001
137300         (DDXX (X1) > '  07270' AND < '  07280') OR               13730001
137400         (DDXX (X1) > '  07419' AND < '  07424') OR               13740001
137500         (DDXX (X1) > '  07880' AND < '  07890') OR               13750001
137600         (DDXX (X1) > '  07949' AND < '  07960') OR               13760001
137700         (DDXX (X1) = '    042' OR '    024' OR '    025' OR      13770001
137800                      '    035' OR '    037' OR '    048' OR      13780001
137900                      '    061' OR '    064' OR '    071' OR      13790001
138000                      '   0382' OR '   0383' OR '   0558' OR      13800001
138100                      '   0559' OR '   0668' OR '   0669' OR      13810001
138200                      '   0700' OR '   0701' OR '   0706' OR      13820001
138300                      '  07070' OR '  07071' OR '   0709' OR      13830001
138400                      '  05821' OR '  05829' OR '  05889' OR      13840001
138500                      '   0743' OR '   0748' OR '    075' OR      13850001
138600                      '  05900' OR '  03812' OR '  04611' OR      13860001
138700                      '  04619' OR '  04671' OR '  04672' OR      13870001
138800                      '  04679' OR '  05101' OR '  05102' OR      13880001
138900                      '  05901' OR '  05909' OR '  05910' OR      13890001
139000                      '  05911' OR '  05912' OR '  05919' OR      13900001
139100                      '  05920' OR '  05921' OR '  05922' OR      13910001
139200                      '   0598' OR '   0599' OR                   13920001
139300                      '   0380'))                                 13930001
139400         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.07                 13940001
139500         MOVE 26 TO X1.                                           13950005
139600 CAT10-SEARCH-EXIT.   EXIT.                                       13960001
139700                                                                  13970001
139800* DRUG AND/OR ALCOHOL INDUCED MENTAL DISORDERS                    13980001
139900 CAT11-SEARCH.                                                    13990001
140000     IF  (DDXX (X1) = '   2910' OR '   2920' OR '  29212' OR      14000001
140100                      '   2922' OR '  30300' OR                   14010001
140200                      '  30400')                                  14020001
140300         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.03                 14030001
140400         MOVE 26 TO X1.                                           14040005
140500 CAT11-SEARCH-EXIT.   EXIT.                                       14050001
140600                                                                  14060001
140700* CARDIAC CONDITIONS                                              14070001
140800 CAT12-SEARCH.                                                    14080001
140900     IF  (DDXX (X1) = '   3910' OR '   3911' OR '   3912' OR      14090001
141000                      '  40201' OR '  40403' OR '   4160' OR      14100001
141100                      '   4210' OR '   4211' OR '   4219')        14110001
141200         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.11                 14120001
141300         MOVE 26 TO X1.                                           14130005
141400 CAT12-SEARCH-EXIT.   EXIT.                                       14140001
141500                                                                  14150001
141600* GANGRENE                                                        14160001
141700 CAT13-SEARCH.                                                    14170001
141800     IF  (DDXX (X1) = '  44024' OR '   7854')                     14180001
141900         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.10                 14190001
142000         MOVE 26 TO X1.                                           14200005
142100 CAT13-SEARCH-EXIT.   EXIT.                                       14210001
142200                                                                  14220001
142300* CHRONIC OBSTRUCTIVE PULMONARY DISEASE EFFECTIVE 10/01/2005      14230001
142400 CAT14-SEARCH-100105.                                             14240001
142500     IF  (DDXX (X1) = '  49121' OR '   4941' OR '   5100' OR      14250001
142600                      '  51883' OR '  51884' OR                   14260001
142700                      'V4611' OR 'V4612' OR                       14270001
142800                      'V4613' OR 'V4614')                         14280001
142900         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.12                 14290001
143000         MOVE 26 TO X1.                                           14300005
143100 CAT14-SEARCH-100105-EXIT.   EXIT.                                14310001
143200                                                                  14320001
143300* ARTIFICIAL OPENINGS - DIGESTIVE AND URINARY                     14330001
143400 CAT15-SEARCH.                                                    14340001
143500     IF  (DDXX (X1) = '  56960' OR '  56961' OR                   14350001
143600                      '  56962' OR '  56969' OR '   9975'  OR     14360001
143700                      'V441'  OR 'V442'  OR 'V443'  OR            14370001
143800                      'V444'  OR 'V4450' OR 'V4451' OR            14380001
143900                      'V4452' OR 'V4459' OR 'V446')               14390001
144000         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.08                 14400001
144100         MOVE 26 TO X1.                                           14410005
144200 CAT15-SEARCH-EXIT.   EXIT.                                       14420001
144300                                                                  14430001
144400* SEVERE MUSCLOSKELETAL AND CONNECTIVE TISSUE                     14440001
144500 CAT16-SEARCH.                                                    14450001
144600     IF  ((DDXX (X1) > '  72999' AND < '  73030') OR              14460001
144700          (DDXX (X1) = '   6960' OR '   7100'))                   14470001
144800         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.09                 14480001
144900         MOVE 26 TO X1.                                           14490005
145000 CAT16-SEARCH-EXIT.   EXIT.                                       14500001
145100                                                                  14510001
145200* POISONING                                                       14520001
145300 CAT17-SEARCH.                                                    14530001
145400     IF ((DDXX (X1) > '   9669'  AND < '   9700')  OR             14540001
145500         (DDXX (X1) > '   9799'  AND < '   9810')  OR             14550001
145600         (DDXX (X1) > '   9829'  AND < '   9840')  OR             14560001
145700         (DDXX (X1) > '   9889'  AND < '   9898')  OR             14570001
145800         (DDXX (X1) > '  96499'  AND < '  96510')  OR             14580001
145900         (DDXX (X1) = '   9654' OR '    986' OR '   9770'))       14590001
146000        COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.11                  14600001
146100        MOVE 26 TO X1.                                            14610005
146200 CAT17-SEARCH-EXIT.   EXIT.                                       14620001
146300***************************************************************   14630001
146400******       L A S T   S O U R C E   S T A T E M E N T    *****   14640001
