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