000100 IDENTIFICATION DIVISION.                                         00010004
000200 PROGRAM-ID.    IPCAL111.                                         00020004
000300*AUTHOR.        CMS.                                              00030007
000400*REMARKS.       CMS.                                              00040004
000410******************************************************************00041004
000420*  FIRST IPF STARTED 01/01/2005 AND WILL RUN FOR 18MTHS          *00042004
000430*  NEW IPF YEAR WILL START IN JULY OF ANY GIVEN YEAR             *00043004
000440******************************************************************00044004
000450*  CHANGE IN THIS PROGRAM ARE:                                   *00045004
000460*                                                                *00046004
000470*  ADDED CODES 23773 AND 23779 TO ONCOLOGY TREATMENT             *00047004
000480*                                                                *00048004
000490*  UPDATED DRG CODE EDIT                                         *00049004
000500******************************************************************00050004
000600 DATE-COMPILED.                                                   00060004
000700 ENVIRONMENT DIVISION.                                            00070004
000800 CONFIGURATION SECTION.                                           00080004
000900 SOURCE-COMPUTER.            IBM-370.                             00090004
001000 OBJECT-COMPUTER.            IBM-370.                             00100004
001100 INPUT-OUTPUT  SECTION.                                           00110004
001200 FILE-CONTROL.                                                    00120004
001300     EJECT                                                        00130004
001400 DATA DIVISION.                                                   00140004
001500 FILE SECTION.                                                    00150004
001600                                                                  00160004
001700 WORKING-STORAGE SECTION.                                         00170004
001800 01  W-STORAGE-REF                  PIC X(46)  VALUE              00180004
001900     'IPCAL111      - W O R K I N G   S T O R A G E'.             00190004
002000 01  CAL-VERSION                    PIC X(05)  VALUE 'C11.1'.     00200004
002100***************************************************************   00210004
002200 01  SUB                     PIC 999   VALUE 0.                   00220004
002300 01  SUB2                    PIC 999   VALUE 0.                   00230004
002400 01  DAYS-UPTO-21            PIC 9(05) VALUE 0.                   00240004
002500 01  DAYS-OVER-21            PIC 9(05) VALUE 0.                   00250004
002600 01  DAYS-UPTO-9             PIC 9(05) VALUE 0.                   00260004
002700 01  DAYS-OVER-9             PIC 9(05) VALUE 0.                   00270004
002800 01  X1                      PIC 9(05)  COMP SYNC VALUE 0.        00280004
002900 01  X2                      PIC 9(05)  COMP SYNC VALUE 0.        00290004
003000 01  HOLDADJ                 PIC 9(02)V9(4)  COMP SYNC VALUE 0.   00300004
003100 01  WK-FED-PORTION          PIC 9(07)V9(2)  VALUE 0.             00310004
003200 01  WK-TEACH-PORTION        PIC 9(07)V9(2)  VALUE 0.             00320004
003300 01  WK-PER-DIEM-AMT         PIC 9(07)V9(2)  VALUE 0.             00330004
003400 01  WK-ADJ-PER-DIEM-STEP1   PIC 9(07)V9(2)  VALUE 0.             00340004
003500 01  WK-ADJ-PER-DIEM-STEP2   PIC 9(07)V9(2)  VALUE 0.             00350004
003600                                                                  00360004
003700******************************************************************00370004
003800***    INREC IS A SKEL OF FILE TO BE USED   FOR TESTING ONLY      00380004
003900*          OR IT IS THE CODE PASSED FROM PRICER                   00390004
004000***************************************************************   00400004
004100                                                                  00410004
004200 01  WK-COMORBIDITY-DATA.                                         00420004
004300     05  DDX.                                                     00430004
004400         10  DDXX         OCCURS 25 TIMES.                        00440005
004500             20 WK-DDXX1     PIC X.                               00450004
004600             20 WK-DDXX2     PIC X.                               00460004
004700             20 WK-DDXX3     PIC X.                               00470004
004800             20 WK-DDXX4     PIC X.                               00480004
004900             20 WK-DDXX5     PIC X.                               00490004
005000             20 WK-DDXX6     PIC X.                               00500004
005100             20 WK-DDXX7     PIC X.                               00510004
005200     05  SRG.                                                     00520004
005300         10  SRGX         PIC X(07)  OCCURS 25 TIMES.             00530005
005400                                                                  00540004
005500 01  OUT-DDXX-ZERO.                                               00550004
005600     05  OUT-Z-DDXX1          PIC X.                              00560004
005700     05  OUT-Z-DDXX2          PIC X.                              00570004
005800     05  OUT-Z-DDXX3          PIC X.                              00580004
005900     05  OUT-Z-DDXX4          PIC X.                              00590004
006000     05  OUT-Z-DDXX5          PIC X.                              00600004
006100     05  OUT-Z-DDXX6          PIC X.                              00610004
006200     05  OUT-Z-DDXX7          PIC X.                              00620004
006300*******************************************************           00630004
006400***************************************************************   00640004
006500***************************************************************   00650004
006600 01  DRG-FACTOR-TABLE.                                            00660004
006700     02  TB-DRG-DATA.                                             00670004
006800         10  FILLER      PIC X(07) VALUE '056 105'.               00680004
006900         10  FILLER      PIC X(07) VALUE '057 105'.               00690004
007000         10  FILLER      PIC X(07) VALUE '080 107'.               00700004
007100         10  FILLER      PIC X(07) VALUE '081 107'.               00710004
007200         10  FILLER      PIC X(07) VALUE '876 122'.               00720004
007300         10  FILLER      PIC X(07) VALUE '880 105'.               00730004
007400         10  FILLER      PIC X(07) VALUE '881 099'.               00740004
007500         10  FILLER      PIC X(07) VALUE '882 102'.               00750004
007600         10  FILLER      PIC X(07) VALUE '883 102'.               00760004
007700         10  FILLER      PIC X(07) VALUE '884 103'.               00770004
007800         10  FILLER      PIC X(07) VALUE '885 100'.               00780004
007900         10  FILLER      PIC X(07) VALUE '886 099'.               00790004
008000         10  FILLER      PIC X(07) VALUE '887 092'.               00800004
008100         10  FILLER      PIC X(07) VALUE '894 097'.               00810004
008200         10  FILLER      PIC X(07) VALUE '895 102'.               00820004
008300         10  FILLER      PIC X(07) VALUE '896 088'.               00830004
008400         10  FILLER      PIC X(07) VALUE '897 088'.               00840004
008500     02  TB-DRG-DATA2 REDEFINES TB-DRG-DATA OCCURS 17             00850004
008600             ASCENDING KEY IS TB-DRG-CODE                         00860004
008700             INDEXED BY DRGSUB.                                   00870004
008800          05  TB-DRG-CODE           PIC XXX.                      00880004
008900          05  TB-DRG-ADJUSTMENTS  OCCURS 1.                       00890004
009000              10  FILLER            PIC X.                        00900004
009100              10  TB-DRG-FACTOR     PIC 9V99.                     00910004
009200                                                                  00920004
009300***************************************************************   00930004
009400***************************************************************   00940004
009500 01  CODE-FIRST-TABLE.                                            00950004
009600     02  TB-FST-DATA.                                             00960004
009700         10  FILLER      PIC X(11) VALUE '2900    103'.           00970004
009800         10  FILLER      PIC X(11) VALUE '29010   103'.           00980004
009900         10  FILLER      PIC X(11) VALUE '29011   103'.           00990004
010000         10  FILLER      PIC X(11) VALUE '29012   103'.           01000004
010100         10  FILLER      PIC X(11) VALUE '29013   103'.           01010004
010200         10  FILLER      PIC X(11) VALUE '29020   103'.           01020004
010300         10  FILLER      PIC X(11) VALUE '29021   103'.           01030004
010400         10  FILLER      PIC X(11) VALUE '2903    103'.           01040004
010500         10  FILLER      PIC X(11) VALUE '29040   103'.           01050004
010600         10  FILLER      PIC X(11) VALUE '29041   103'.           01060004
010700         10  FILLER      PIC X(11) VALUE '29042   103'.           01070004
010800         10  FILLER      PIC X(11) VALUE '29043   103'.           01080004
010900         10  FILLER      PIC X(11) VALUE '2908    103'.           01090004
011000         10  FILLER      PIC X(11) VALUE '2909    103'.           01100004
011100         10  FILLER      PIC X(11) VALUE '2930    105'.           01110004
011200         10  FILLER      PIC X(11) VALUE '2931    105'.           01120004
011300         10  FILLER      PIC X(11) VALUE '29381   103'.           01130004
011400         10  FILLER      PIC X(11) VALUE '29382   103'.           01140004
011500         10  FILLER      PIC X(11) VALUE '29383   103'.           01150004
011600         10  FILLER      PIC X(11) VALUE '29384   103'.           01160004
011700         10  FILLER      PIC X(11) VALUE '29389   103'.           01170004
011800         10  FILLER      PIC X(11) VALUE '2939    105'.           01180004
011900         10  FILLER      PIC X(11) VALUE '2940    103'.           01190004
012000         10  FILLER      PIC X(11) VALUE '29410   103'.           01200004
012100         10  FILLER      PIC X(11) VALUE '29411   103'.           01210004
012200         10  FILLER      PIC X(11) VALUE '30789   102'.           01220004
012300     02  TB-FST-DATA2 REDEFINES TB-FST-DATA OCCURS 26             01230004
012400             ASCENDING KEY IS TB-FST-CODE                         01240004
012500             INDEXED BY FSTSUB.                                   01250004
012600          05  TB-FST-CODE           PIC X(07).                    01260004
012700          05  TB-FST-ADJUSTMENTS  OCCURS 1.                       01270004
012800              10  FILLER            PIC X.                        01280004
012900              10  TB-FST-FACTOR     PIC 9V99.                     01290004
013000                                                                  01300004
013100***************************************************************   01310004
013200***************************************************************   01320004
013300 01  DAY-ADJUSTMENTS.                                             01330004
013400     02  DAY-VALUES.                                              01340004
013500         10  DAY1        PIC XXX  VALUE '000'.                    01350004
013600         10  DAY2        PIC XXX  VALUE '112'.                    01360004
013700         10  DAY3        PIC XXX  VALUE '108'.                    01370004
013800         10  DAY4        PIC XXX  VALUE '105'.                    01380004
013900         10  DAY5        PIC XXX  VALUE '104'.                    01390004
014000         10  DAY6        PIC XXX  VALUE '102'.                    01400004
014100         10  DAY7        PIC XXX  VALUE '101'.                    01410004
014200         10  DAY8        PIC XXX  VALUE '101'.                    01420004
014300         10  DAY9        PIC XXX  VALUE '100'.                    01430004
014400         10  DAY10       PIC XXX  VALUE '100'.                    01440004
014500         10  DAY11       PIC XXX  VALUE '099'.                    01450004
014600         10  DAY12       PIC XXX  VALUE '099'.                    01460004
014700         10  DAY13       PIC XXX  VALUE '099'.                    01470004
014800         10  DAY14       PIC XXX  VALUE '099'.                    01480004
014900         10  DAY15       PIC XXX  VALUE '098'.                    01490004
015000         10  DAY16       PIC XXX  VALUE '097'.                    01500004
015100         10  DAY17       PIC XXX  VALUE '097'.                    01510004
015200         10  DAY18       PIC XXX  VALUE '096'.                    01520004
015300         10  DAY19       PIC XXX  VALUE '095'.                    01530004
015400         10  DAY20       PIC XXX  VALUE '095'.                    01540004
015500         10  DAY21       PIC XXX  VALUE '095'.                    01550004
015600         10  DAY21-OVER  PIC XXX  VALUE '092'.                    01560004
015700     02  DAY-VALUES2 REDEFINES DAY-VALUES OCCURS 22.              01570004
015800         10 DAY-VALUE2   PIC 9V99.                                01580004
015900                                                                  01590004
016000 LINKAGE SECTION.                                                 01600004
016100***************************************************************   01610004
016200*                 * * * * * * * * *                           *   01620004
016300                                                                  01630004
016400***************************************************************   01640004
016500*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *   01650004
016600*    AND PASSED BACK TO THE CALLING PROGRAM                   *   01660004
016700*            RETURN CODE VALUES (IPF-RTC)                     *   01670004
016800*                                                             *   01680004
016900*            IPF-RTC 00-49 = HOW THE BILL WAS PAID            *   01690004
017000*                                                             *   01700004
017100*                                                             *   01710004
017200*              00 = PAID NORMAL IPF PAYMENT                   *   01720004
017300*                                                             *   01730004
017400*              02 = PAID AS A COST-OUTLIER.                   *   01740004
017500*                                                             *   01750004
017600*                                                             *   01760004
017700*            IPF-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   01770004
017800*              51 = NO PROVIDER SPECIFIC INFO FOUND           *   01780004
017900*              52 = INVALID CBSA# IN PROVIDER FILE            *   01790004
018000*                   OR INVALID WAGE INDEX                     *   01800004
018100*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   01810004
018200*              54 = BILL-DRG INVALID                              01820004
018300*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   01830004
018400*                                      OR                     *   01840004
018500*                   DISCHARGE DATE < CBSA EFF START DATE      *   01850004
018600*                                      OR                     *   01860004
018700*                   DISCHARGE DATE > 20060630 START CBSA AND  *   01870004
018800*                 SELECTED PROV EFF DATE < 20060701 START CBSA*   01880004
018900*                   FOR PPS                                   *   01890004
019000*              56 = INVALID LENGTH OF STAY                    *   01900004
019100*              57 = INVALID AGE                               *   01910004
019200*              58 = INVALID PPS FED BLEND INDICATOR           *   01920004
019300*              98 = CANNOT PROCESS BILL OUTSIDE THIS VERSION  *   01930004
019400***************************************************************   01940004
019500*******************************************************           01950004
019600*    PASSED FROM IPDRV                                *           01960004
019700*******************************************************           01970004
019800 01  BILL-INPUT-DATA.                                             01980004
019900     05  BILL-IN-DATA.                                            01990004
020000         10  BILL-NPI-NUMBER.                                     02000004
020100             15  BILL-NPI            PIC X(08).                   02010004
020200             15  BILL-NPI-FILLER     PIC X(02).                   02020004
020300         10  BILL-PROVIDER-NO        PIC X(06).                   02030004
020400         10  BILL-HIC-NO             PIC X(12).                   02040004
020500         10  BILL-DISCHARGE-DATE.                                 02050004
020600             15  BILL-D-CC           PIC 9(02).                   02060004
020700             15  BILL-D-YY           PIC 9(02).                   02070004
020800             15  BILL-D-MM           PIC 9(02).                   02080004
020900             15  BILL-D-DD           PIC 9(02).                   02090004
021000         10  BILL-PATIENT-STATUS     PIC X(02).                   02100004
021100         10  BILL-AGE                PIC 9(03).                   02110004
021200         10  BILL-DRG                PIC 9(03).                   02120004
021300         10  BILL-LOS                PIC 9(05).                   02130004
021400         10  BILL-OUTL-OCCUR-IND     PIC X(01).                   02140004
021500         10  BILL-SRC-OF-ADMISSION   PIC X(01).                   02150004
021600         10  BILL-ECT-NO-OF-UNITS    PIC 9(03).                   02160004
021700         10  BILL-CHARGES-CLAIMED    PIC 9(07)V9(02).             02170004
021800         10  BILL-DIAG-PROC-DATA.                                 02180004
021900             15  BILL-OTHER-DIAG-DATA   OCCURS 25 TIMES.          02190005
022000                 20  BILL-DDXX-1ST     PIC X.                     02200004
022100                 20  FILLER            PIC X(06).                 02210004
022200             15  BILL-OTHER-PROC-DATA PIC x(07)  OCCURS 25 TIMES. 02220005
022210         10  BILL-PRIOR-DAYS         PIC 9(03).                   02221005
022300*******************************************************           02230004
022400*    PASSED AND RETURNED BY IPCAL                     *           02240004
022500*******************************************************           02250004
022600 01  IPF-DATA-VARIABLES.                                          02260004
022700         10  IPF-RTC                 PIC 9(02).                   02270004
022800         10  IPF-MSA-CBSA            PIC X(05).                   02280004
022900         10  IPF-MSA-CODE REDEFINES IPF-MSA-CBSA.                 02290004
023000             15  IPF-MSA             PIC X(04).                   02300004
023100             15  FILLER              PIC X.                       02310004
023200         10  IPF-CBSA-CODE REDEFINES IPF-MSA-CBSA.                02320004
023300             15  IPF-CBSA            PIC X(05).                   02330004
023400         10  IPF-WAGE-INDEX          PIC 9(02)V9(04).             02340004
023500         10  IPF-LABOR-SHARE         PIC 9(01)V9(05).             02350004
023600         10  IPF-NLABOR-SHARE        PIC 9(01)V9(05).             02360004
023700         10  IPF-COLA                PIC 9(01)V9(03).             02370004
023800         10  IPF-STD-FACTOR          PIC 9(01)V9(05).             02380004
023900         10  IPF-COMORB-FACTOR       PIC 9(01)V9(05).             02390004
024000         10  IPF-AGE-ADJ             PIC 9(01)V9(02).             02400004
024100         10  IPF-DRG-FACTOR          PIC 9(01)V9(02).             02410004
024200         10  IPF-GEO-RURAL-ADJ       PIC 9(01)V9(02).             02420004
024300         10  IPF-EMERG-ADJ           PIC 9(01)V9(02).             02430004
024400         10  IPF-TEACH-ADJ           PIC 9(01)V9(02).             02440004
024500         10  IPF-FED-PPS-BLEND-IND   PIC X.                       02450004
024600         10  IPF-CAL-VERSION         PIC X(05).                   02460004
024700         10  FILLER                  PIC X(12).                   02470004
024800                                                                  02480004
024900*******************************************************           02490004
025000*    PASSED AND RETURNED BY IPCAL                     *           02500004
025100*******************************************************           02510004
025200 01  IPF-ADDITIONAL-VARIABLES.                                    02520004
025300     02  IPF-MF-VARIABLES.                                        02530004
025400         10  IPF-100PCT-STOPLOS-AMT      PIC 9(07)V9(02).         02540004
025500         10  IPF-TOT-PAYMENT             PIC 9(07)V9(02).         02550004
025600         10  IPF-FED-PAYMENT             PIC 9(07)V9(02).         02560004
025700         10  IPF-FAC-PAYMENT             PIC 9(07)V9(02).         02570004
025800         10  IPF-ECT-PAYMENT             PIC 9(07)V9(02).         02580004
025900         10  IPF-OUTLIER-PAYMENT         PIC 9(07)V9(02).         02590004
026000         10  IPF-OUTL-COST               PIC 9(07)V9(02).         02600004
026100         10  IPF-OUTL-ADJ-COST           PIC 9(07)V9(02).         02610004
026200         10  IPF-OUTL-PER-DIEM-AMT       PIC 9(07)V9(02).         02620004
026300         10  IPF-OUTL-THRES-AMT          PIC 9(07)V9(02).         02630004
026400         10  IPF-OUTL-THRES-ADJ-AMT      PIC 9(07)V9(02).         02640004
026500         10  IPF-ADJUSTED-PER-DIEM-AMT   PIC 9(07)V9(02).         02650004
026600         10  IPF-WAGE-ADJ-AMT            PIC 9(07)V9(02).         02660004
026700         10  IPF-LABOR-BASE-AMT          PIC 9(07)V9(05).         02670004
026800         10  IPF-NLABOR-BASE-AMT         PIC 9(07)V9(05).         02680004
026900         10  IPF-OUTL-LABOR-BASE-AMT     PIC 9(07)V9(05).         02690004
027000         10  IPF-OUTL-NLABOR-BASE-AMT    PIC 9(07)V9(05).         02700004
027100         10  IPF-BUDGNUT-RATE-AMT        PIC 9(05)V9(02).         02710004
027200         10  IPF-ECT-RATE-AMT            PIC 9(05)V9(02).         02720004
027300         10  IPF-TEACH-PAYMENT           PIC 9(07)V9(02).         02730004
027400         10  FILLER                      PIC X(01).               02740004
027500      02 IPF-PC-VARIABLES.                                        02750004
027600         10  IPF-PC-DATA                 PIC X(44).               02760004
027700                                                                  02770004
027800 01  PRICER-OPT-VERS-SW.                                          02780004
027900     02  PRICER-OPTION-SW          PIC X(01).                     02790004
028000         88  VARIABLES                  VALUE 'S'.                02800004
028100         88  PROV-RECORD-PASSED         VALUE 'P'.                02810004
028200         88  ALL-TABLES-PASSED          VALUE 'B'.                02820004
028300         88  PC-PRICER                  VALUE 'C'.                02830004
028400     02  IPF-VERSIONS.                                            02840004
028500         10  IPDRV-VERSION         PIC X(05).                     02850004
028600                                                                  02860004
028700**************************************************************    02870004
028800*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BACK FROM *    02880004
028900*      THE IPCAL056 PROGRAM FOR PROCESSING                   *    02890004
029000**************************************************************    02900004
029100 01  PROV-NEW-HOLD.                                               02910004
029200     02  PROV-NEWREC-HOLD1.                                       02920004
029300         05  P-NEW-NPI10.                                         02930004
029400             10  P-NEW-NPI8             PIC X(08).                02940004
029500             10  P-NEW-NPI-FILLER       PIC X(02).                02950004
029600         05  P-NEW-PROVIDER-NO.                                   02960004
029700             88  P-NEW-DSH-ADJ-PROVIDERS                          02970004
029800                             VALUE '180049' '190044' '190144'     02980004
029900                                   '190191' '330047' '340085'     02990004
030000                                   '370016' '370149' '420043'.    03000004
030100             10  P-NEW-STATE            PIC 9(02).                03010004
030200             10  FILLER                 PIC X(04).                03020004
030300         05  P-NEW-DATE-DATA.                                     03030004
030400             10  P-NEW-EFF-DATE.                                  03040004
030500                 15  P-NEW-EFF-DT-CC    PIC 9(02).                03050004
030600                 15  P-NEW-EFF-DT-YY    PIC 9(02).                03060004
030700                 15  P-NEW-EFF-DT-MM    PIC 9(02).                03070004
030800                 15  P-NEW-EFF-DT-DD    PIC 9(02).                03080004
030900             10  P-NEW-FY-BEGIN-DATE.                             03090004
031000                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                03100004
031100                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                03110004
031200                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                03120004
031300                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                03130004
031400             10  P-NEW-REPORT-DATE.                               03140004
031500                 15  P-NEW-REPORT-DT-CC PIC 9(02).                03150004
031600                 15  P-NEW-REPORT-DT-YY PIC 9(02).                03160004
031700                 15  P-NEW-REPORT-DT-MM PIC 9(02).                03170004
031800                 15  P-NEW-REPORT-DT-DD PIC 9(02).                03180004
031900             10  P-NEW-TERMINATION-DATE.                          03190004
032000                 15  P-NEW-TERM-DT-CC   PIC 9(02).                03200004
032100                 15  P-NEW-TERM-DT-YY   PIC 9(02).                03210004
032200                 15  P-NEW-TERM-DT-MM   PIC 9(02).                03220004
032300                 15  P-NEW-TERM-DT-DD   PIC 9(02).                03230004
032400         05  P-NEW-WAIVER-CODE          PIC X(01).                03240004
032500             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              03250004
032600         05  P-NEW-INTER-NO             PIC 9(05).                03260004
032700         05  P-NEW-PROVIDER-TYPE        PIC X(02).                03270004
032800             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.      03280004
032900             88  P-N-REFERRAL-CENTER        VALUE '07' '11'       03290004
033000                                                  '15' '17'       03300004
033100                                                  '22'.           03310004
033200             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.           03320004
033300             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.           03330004
033400             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.           03340004
033500             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.           03350004
033600             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.      03360004
033700             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.           03370004
033800             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.      03380004
033900             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.           03390004
034000             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.           03400004
034100             88  P-N-EACH                   VALUE '21' '22'.      03410004
034200             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.           03420004
034300             88  P-N-NHCMQ-II-SNF           VALUE '32'.           03430004
034400             88  P-N-NHCMQ-III-SNF          VALUE '33'.           03440004
034500         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                03450004
034600             88  P-N-NEW-ENGLAND            VALUE  1.             03460004
034700             88  P-N-MIDDLE-ATLANTIC        VALUE  2.             03470004
034800             88  P-N-SOUTH-ATLANTIC         VALUE  3.             03480004
034900             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.             03490004
035000             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.             03500004
035100             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.             03510004
035200             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.             03520004
035300             88  P-N-MOUNTAIN               VALUE  8.             03530004
035400             88  P-N-PACIFIC                VALUE  9.             03540004
035500         05  P-NEW-CURRENT-DIV   REDEFINES                        03550004
035600                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         03560004
035700             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.          03570004
035800         05  P-NEW-MSA-DATA.                                      03580004
035900             10  P-NEW-CHG-CODE-INDEX       PIC X.                03590004
036000             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 03600004
036100             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   03610004
036200                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       03620004
036300             10  P-NEW-GEO REDEFINES                              03630004
036400                                 P-NEW-GEO-LOC-MSAX.              03640004
036500                 15  P-NEW-GEO-RURAL-1ST.                         03650004
036600                     20  P-NEW-GEO-RURAL  PIC XX.                 03660004
036700                         88  P-NEW-GEO-MSAX-RURAL VALUE '  '.     03670004
036800                 15  P-NEW-GEO-RURAL-2ND        PIC XX.           03680004
036900             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 03690004
037000             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 03700004
037100             10  P-NEW-STAND-AMT-LOC-MSA9                         03710004
037200       REDEFINES P-NEW-STAND-AMT-LOC-MSA.                         03720004
037300                 15  P-NEW-RURAL-1ST.                             03730004
037400                     20  P-NEW-STAND-RURAL  PIC XX.               03740004
037500                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    03750004
037600                 15  P-NEW-RURAL-2ND        PIC XX.               03760004
037700         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    03770004
037800                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.           03780004
037900                 88  P-NEW-SCH-YR82       VALUE   '82'.           03790004
038000                 88  P-NEW-SCH-YR87       VALUE   '87'.           03800004
038100         05  P-NEW-LUGAR                    PIC X.                03810004
038200         05  P-NEW-TEMP-RELIEF-IND          PIC X.                03820004
038300         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                03830004
038400         05  FILLER                         PIC X(05).            03840004
038500     02  PROV-NEWREC-HOLD2.                                       03850004
038600         05  P-NEW-VARIABLES.                                     03860004
038700             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        03870004
038800             10  P-NEW-COLA              PIC  9(01)V9(03).        03880004
038900             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        03890004
039000             10  P-NEW-BED-SIZE          PIC  9(05).              03900004
039100             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        03910004
039200             10  P-NEW-CMI               PIC  9(01)V9(04).        03920004
039300             10  P-NEW-SSI-RATIO         PIC  V9(04).             03930004
039400             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             03940004
039500             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              03950004
039600             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        03960004
039700             10  P-NEW-DSH-PERCENT       PIC  V9(04).             03970004
039800             10  P-NEW-FYE-DATE          PIC  X(08).              03980004
039900         05  P-NEW-CBSA-DATA.                                     03990004
040000             10  P-NEW-CBSA-SPEC-PAY-IND   PIC X.                 04000004
040100             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.                 04010004
040200             10  P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.  04020004
040300             10  P-NEW-CBSA-GEO-LOCX REDEFINES                    04030004
040400                 P-NEW-CBSA-GEO-LOC.                              04040004
040500                 15  P-NEW-CBSA-GEO-RURAL-1ST.                    04050004
040600                     20  P-NEW-CBSA-GEO-RURAL  PIC XXX.           04060004
040700                         88  P-NEW-CBSA-GEO-RURAL-CHECK           04070004
040800                             VALUE '   '.                         04080004
040900                 15  P-NEW-CBSA-GEO-RURAL-2ND PIC XX.             04090004
041000             10  P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.  04100004
041100             10  P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.  04110004
041200             10  P-NEW-CBSA-SPEC-WI        PIC 9(02)V9(04).       04120004
041300             10  P-NEW-CBSA-SPEC-WI-N  REDEFINES                  04130004
041400                 P-NEW-CBSA-SPEC-WI        PIC 9(06).             04140004
041500     02  PROV-NEWREC-HOLD3.                                       04150004
041600         05  P-NEW-PASS-AMT-DATA.                                 04160004
041700             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          04170004
041800             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          04180004
041900             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          04190004
042000             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          04200004
042100         05  P-NEW-CAPI-DATA.                                     04210004
042200             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 04220004
042300             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          04230004
042400             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          04240004
042500             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        04250004
042600             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             04260004
042700             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 04270004
042800             15  P-NEW-CAPI-IME            PIC 9V9999.            04280004
042900             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          04290004
043000             15  P-VAL-BASED-PURCH-SCORE    PIC 9V999.            04300004
043100         05  FILLER                         PIC X(18).            04310004
043200******************************************************************04320004
043300                                                                  04330004
043400 01  WAGE-INDEX-RECORD.                                           04340004
043500     05  W-CBSA              PIC 9(5).                            04350004
043600     05  W-SIZE              PIC X(01).                           04360004
043700         88  LARGE-URBAN       VALUE 'L'.                         04370004
043800         88  OTHER-URBAN       VALUE 'O'.                         04380004
043900         88  ALL-RURAL         VALUE 'R'.                         04390004
044000     05  W-CBSA-EFF-DATE     PIC 9(8).                            04400004
044100     05  FILLER              PIC X.                               04410004
044200     05  W-CBSA-WAGE-INDEX   PIC S9(02)V9(04).                    04420004
044300     05  FILLER              PIC S9(02)V9(04).                    04430004
044400     EJECT                                                        04440004
044500 PROCEDURE DIVISION  USING BILL-INPUT-DATA                        04450004
044600                           IPF-DATA-VARIABLES                     04460004
044700                           IPF-ADDITIONAL-VARIABLES               04470004
044800                           PRICER-OPT-VERS-SW                     04480004
044900                           PROV-NEW-HOLD                          04490004
045000                           WAGE-INDEX-RECORD.                     04500004
045100                                                                  04510004
045200***************************************************************   04520004
045300*    PROCESSING:                                              *   04530004
045400*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE        *   04540004
045500*        B. INITIALIZE IPCAL  HOLD VARIABLES.                 *   04550004
045600*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *   04560004
045700*           ATTEMPTING TO CALCULATE IPF. IF THIS BILL         *   04570004
045800*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   04580004
045900*           GOBACK.                                           *   04590004
046000*        D. ASSEMBLE PRICING COMPONENTS.                      *   04600004
046100*        E. CALCULATE THE PRICE.                              *   04610004
046200***************************************************************   04620004
046300                                                                  04630004
046400     PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT.                04640004
046500                                                                  04650004
046600     MOVE CAL-VERSION  TO  IPF-CAL-VERSION.                       04660004
046700                                                                  04670004
046800     GOBACK.                                                      04680004
046900                                                                  04690004
047000 0200-MAINLINE-CONTROL.                                           04700004
047100                                                                  04710004
047200     PERFORM 1000-EDIT-THE-BILL-INFO.                             04720004
047300                                                                  04730004
047400     IF  IPF-RTC = 00                                             04740004
047500         PERFORM 2000-ASSEMBLE-PPS-VARIABLES THRU                 04750004
047600                 2000-EXIT                                        04760004
047700         PERFORM 3000-CALC-PAYMENT THRU                           04770004
047800                 3000-EXIT.                                       04780004
047900                                                                  04790004
048000                                                                  04800004
048100                                                                  04810004
048200 0200-EXIT.   EXIT.                                               04820004
048300                                                                  04830004
048400 1000-EDIT-THE-BILL-INFO.                                         04840004
048500***************************************************************   04850004
048600*    BILL DATA EDITS IF ANY FAIL SET IPF-RTC                  *   04860004
048700*    AND DO NOT ATTEMPT TO PRICE.                             *   04870004
048800***************************************************************   04880004
048900     MOVE SPACES TO WK-COMORBIDITY-DATA.                          04890004
049000                                                                  04900004
049100     IF  IPF-RTC = 00                                             04910004
049200         IF  P-NEW-WAIVER-STATE                                   04920004
049300             MOVE 53 TO IPF-RTC.                                  04930004
049400                                                                  04940004
049500*-------------------------------------------------------------*   04950004
049600*    FOR FY2011, REMOVED 014 & 015 AND ADDED 009              *   04960004
049700*-------------------------------------------------------------*   04970004
049800     IF  IPF-RTC = 00                                             04980004
049900         IF  BILL-DRG < 001                                       04990004
050000                OR = 009          OR = 016 OR = 017               05000004
050100                OR = 018 OR = 019 OR = 043 OR = 044               05010004
050200                OR = 045 OR = 046 OR = 047 OR = 048               05020004
050300                OR = 049 OR = 050 OR = 051 OR = 104               05030004
050400                OR = 105 OR = 106 OR = 107 OR = 108               05040004
050500                OR = 109 OR = 110 OR = 111 OR = 112               05050004
050600                OR = 118 OR = 119 OR = 120 OR = 126               05060004
050700                OR = 127 OR = 128 OR = 140 OR = 141               05070004
050800                OR = 142 OR = 143 OR = 144 OR = 145               05080004
050900                OR = 160 OR = 161 OR = 162 OR = 169               05090004
051000                OR = 170 OR = 171 OR = 172 OR = 173               05100004
051100                OR = 174 OR = 209 OR = 210 OR = 211               05110004
051200                OR = 212 OR = 213 OR = 214 OR = 265               05120004
051300                OR = 266 OR = 267 OR = 268 OR = 269               05130004
051400                OR = 270 OR = 271 OR = 272 OR = 273               05140004
051500                OR = 274 OR = 275 OR = 276 OR = 277               05150004
051600                OR = 278 OR = 279 OR = 317 OR = 318               05160004
051700                OR = 319 OR = 320 OR = 321 OR = 322               05170004
051800                OR = 323 OR = 324 OR = 325 OR = 359               05180004
051900                OR = 360 OR = 361 OR = 362 OR = 363               05190004
052000                OR = 364 OR = 365 OR = 366 OR = 367               05200004
052100                OR = 396 OR = 397 OR = 398 OR = 399               05210004
052200                OR = 400 OR = 401 OR = 402 OR = 403               05220004
052300                OR = 404 OR = 426 OR = 427 OR = 428               05230004
052400                OR = 429 OR = 430 OR = 431 OR = 447               05240004
052500                OR = 448 OR = 449 OR = 450 OR = 451               05250004
052600                OR = 452 OR = 518 OR = 519 OR = 520               05260004
052700                OR = 521 OR = 522 OR = 523 OR = 524               05270004
052800                OR = 525 OR = 526 OR = 527 OR = 528               05280004
052900                OR = 529 OR = 530 OR = 531 OR = 532               05290004
053000                OR = 567 OR = 568 OR = 569 OR = 570               05300004
053100                OR = 571 OR = 572 OR = 586 OR = 587               05310004
053200                OR = 588 OR = 589 OR = 590 OR = 591               05320004
053300                OR = 608 OR = 609 OR = 610 OR = 611               05330004
053400                OR = 612 OR = 613 OR = 631 OR = 632               05340004
053500                OR = 633 OR = 634 OR = 635 OR = 636               05350004
053600                OR = 646 OR = 647 OR = 648 OR = 649               05360004
053700                OR = 650 OR = 651 OR = 676 OR = 677               05370004
053800                OR = 678 OR = 679 OR = 680 OR = 681               05380004
053900                OR = 701 OR = 702 OR = 703 OR = 704               05390004
054000                OR = 705 OR = 706 OR = 719 OR = 720               05400004
054100                OR = 721 OR = 731 OR = 732 OR = 733               05410004
054200                OR = 751 OR = 752 OR = 753 OR = 762               05420004
054300                OR = 763 OR = 764 OR = 771 OR = 772               05430004
054400                OR = 773 OR = 783 OR = 784 OR = 785               05440004
054500                OR = 786 OR = 787 OR = 788 OR = 796               05450004
054600                OR = 797 OR = 798 OR = 805 OR = 806               05460004
054700                OR = 807 OR = 817 OR = 818 OR = 819               05470004
054800                OR = 831 OR = 832 OR = 833 OR = 850               05480004
054900                OR = 851 OR = 852 OR = 859 OR = 860               05490004
055000                OR = 861 OR = 873 OR = 874 OR = 875               05500004
055100                OR = 877 OR = 878 OR = 879 OR = 891               05510004
055200                OR = 891 OR = 892 OR = 892 OR = 893               05520004
055300                OR = 893 OR = 898 OR = 899 OR = 900               05530004
055400                OR = 910 OR = 911 OR = 912 OR = 924               05540004
055500                OR = 925 OR = 926 OR = 930 OR = 931               05550004
055600                OR = 932 OR = 936 OR = 937 OR = 938               05560004
055700                OR = 942 OR = 943 OR = 944 OR = 952               05570004
055800                OR = 953 OR = 954 OR = 960 OR = 961               05580004
055900                OR = 962 OR = 966 OR = 967 OR = 968               05590004
056000                OR = 971 OR = 972 OR = 973 OR = 978               05600004
056100                OR = 979 OR = 980 OR = 990 OR = 991               05610004
056200                OR = 992 OR = 993 OR = 994 OR = 995               05620004
056300                OR = 996 OR = 997                                 05630004
056400             MOVE 54 TO IPF-RTC.                                  05640004
056500                                                                  05650004
056600     IF IPF-RTC = 00                                              05660004
056700        IF  ((BILL-DISCHARGE-DATE < P-NEW-EFF-DATE) OR            05670004
056800             (BILL-DISCHARGE-DATE < W-CBSA-EFF-DATE))             05680004
056900              MOVE 55 TO IPF-RTC.                                 05690004
057000                                                                  05700004
057100     IF IPF-RTC = 00                                              05710004
057200         IF  BILL-LOS NOT NUMERIC OR                              05720004
057300             BILL-LOS = ZERO                                      05730004
057400             MOVE 56 TO IPF-RTC.                                  05740004
057500                                                                  05750004
057600     IF IPF-RTC = 00                                              05760004
057700         IF  BILL-AGE NOT NUMERIC OR                              05770004
057800             BILL-AGE = ZERO                                      05780004
057900             MOVE 57 TO IPF-RTC.                                  05790004
058000                                                                  05800004
058100     IF IPF-RTC = 00                                              05810004
058200         IF  P-NEW-FED-PPS-BLEND-IND NOT = 1 AND                  05820004
058300                                     NOT = 2 AND                  05830004
058400                                     NOT = 3 AND                  05840004
058500                                     NOT = 4                      05850004
058600             MOVE 58 TO IPF-RTC.                                  05860004
058700                                                                  05870004
058800 2000-ASSEMBLE-PPS-VARIABLES.                                     05880004
058900***************************************************************   05890004
059000*    THE APPROPRIATE SET OF THESE IPF VARIABLES ARE SELECTED  *   05900004
059100*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   05910004
059200*    OF THAT VARIABLE.                                        *   05920004
059300*    3/31/2009 - THE STANDARDIZATION FACTOR WAS USED ONLY ONCE*   05930004
059400*    TO CORRECT WHERE A COMPUTER CODE INCORRECTLY ASSIGNED    *   05940004
059500*    NON-TEACHING STATUS TO MOST TEACHING FACILITIES.         *   05950004
059600*    IT HAS BEEN COMMENTED OUT AS IT IS NO LONGER NEEDED.     *   05960004
059700***************************************************************   05970004
059800     MOVE ALL '0'  TO IPF-MF-VARIABLES.                           05980004
059801                                                                  05980104
059802     MOVE 0665.71  TO IPF-BUDGNUT-RATE-AMT.                       05980204
059803     MOVE 0286.60  TO IPF-ECT-RATE-AMT.                           05980304
059804     MOVE 6372.00  TO IPF-OUTL-THRES-AMT.                         05980404
059805     MOVE 0.75400  TO IPF-LABOR-SHARE.                            05980504
059806     MOVE 0.24600  TO IPF-NLABOR-SHARE.                           05980604
059807*    MOVE 0.82540  TO IPF-STD-FACTOR.                             05980704
059808                                                                  05980804
059809     MOVE ZEROES   TO WK-FED-PORTION                              05980904
059810                      WK-TEACH-PORTION.                           05981004
059820                                                                  05982004
059830     IF  (P-NEW-STATE = 02 OR 12)                                 05983004
059840         MOVE P-NEW-COLA TO IPF-COLA                              05984004
059850     ELSE                                                         05985004
059860         MOVE 1.000 TO IPF-COLA.                                  05986004
059870                                                                  05987004
059880***************************************************************   05988004
059890***  GET THE DRG ADJUSTMENT FACTORES OR FIRST CODES               05989004
059900***  GET THE DRG ADJUSTMENT FACTORES OR FIRST CODES               05990004
060000                                                                  06000004
060100     PERFORM 2600-GET-DRG-FACTORS THRU 2600-EXIT.                 06010004
060200                                                                  06020004
060300     IF IPF-RTC = '60'                                            06030004
060400         MOVE '00' TO IPF-RTC                                     06040004
060500         PERFORM 2700-GET-FIRST-CODES THRU 2700-EXIT.             06050004
060600                                                                  06060004
060700                                                                  06070004
060800*******************************************************           06080004
060900***  GET THE COMORBIDITY FACTORS                                  06090004
061000***  GET THE COMORBIDITY FACTORS                                  06100004
061100                                                                  06110004
061200     PERFORM 3300-GET-COMORBIDITY THRU 3300-EXIT.                 06120004
061300                                                                  06130004
061400***************************************************************   06140004
061500***  GET THE WAGE-INDEX                                           06150004
061600***  GET THE WAGE-INDEX                                           06160004
061700                                                                  06170004
061800     MOVE W-CBSA-WAGE-INDEX TO IPF-WAGE-INDEX.                    06180004
061900                                                                  06190004
062000***************************************************************   06200004
062100***  GET THE AGE ADJUSTMENT                                       06210004
062200***  GET THE AGE ADJUSTMENT                                       06220004
062300                                                                  06230004
062400     IF BILL-AGE < 45                                             06240004
062500        MOVE 1.00 TO IPF-AGE-ADJ                                  06250004
062600        GO TO 2000-SKIP.                                          06260004
062700                                                                  06270004
062800     IF BILL-AGE < 50                                             06280004
062900        MOVE 1.01 TO IPF-AGE-ADJ                                  06290004
063000        GO TO 2000-SKIP.                                          06300004
063100                                                                  06310004
063200     IF BILL-AGE < 55                                             06320004
063300        MOVE 1.02 TO IPF-AGE-ADJ                                  06330004
063400        GO TO 2000-SKIP.                                          06340004
063500                                                                  06350004
063600     IF BILL-AGE < 60                                             06360004
063700        MOVE 1.04 TO IPF-AGE-ADJ                                  06370004
063800        GO TO 2000-SKIP.                                          06380004
063900                                                                  06390004
064000     IF BILL-AGE < 65                                             06400004
064100        MOVE 1.07 TO IPF-AGE-ADJ                                  06410004
064200        GO TO 2000-SKIP.                                          06420004
064300                                                                  06430004
064400     IF BILL-AGE < 70                                             06440004
064500        MOVE 1.10 TO IPF-AGE-ADJ                                  06450004
064600        GO TO 2000-SKIP.                                          06460004
064700                                                                  06470004
064800     IF BILL-AGE < 75                                             06480004
064900        MOVE 1.13 TO IPF-AGE-ADJ                                  06490004
065000        GO TO 2000-SKIP.                                          06500004
065100                                                                  06510004
065200     IF BILL-AGE < 80                                             06520004
065300        MOVE 1.15 TO IPF-AGE-ADJ                                  06530004
065400        GO TO 2000-SKIP.                                          06540004
065500                                                                  06550004
065600     MOVE 1.17 TO IPF-AGE-ADJ.                                    06560004
065700                                                                  06570004
065800 2000-SKIP.                                                       06580004
065900                                                                  06590004
066000***************************************************************   06600004
066100***  GET THE TEACHING ADJUSTMENT                                  06610004
066200***  GET THE TEACHING ADJUSTMENT                                  06620004
066300                                                                  06630004
066400     IF P-NEW-INTERN-RATIO NUMERIC                                06640004
066500        COMPUTE IPF-TEACH-ADJ ROUNDED =                           06650004
066600              ((1 + P-NEW-INTERN-RATIO) ** 0.5150)                06660004
066700     ELSE                                                         06670004
066800        MOVE 1.00 TO IPF-TEACH-ADJ.                               06680004
066900                                                                  06690004
067000***************************************************************   06700004
067100***  GET THE RURAL ADJUSTMENT                                     06710004
067200***  GET THE RURAL ADJUSTMENT                                     06720004
067300                                                                  06730004
067400     IF P-NEW-CBSA-GEO-RURAL-CHECK                                06740004
067500        MOVE 1.17 TO IPF-GEO-RURAL-ADJ                            06750004
067600     ELSE                                                         06760004
067700        MOVE 1.00 TO IPF-GEO-RURAL-ADJ.                           06770004
067800                                                                  06780004
067900***************************************************************   06790004
068000***  GET THE EMERGENCY ADJUSTMENT                                 06800004
068100***  GET THE EMERGENCY ADJUSTMENT                                 06810004
068200                                                                  06820004
068300     IF P-NEW-TEMP-RELIEF-IND = 'Y'                               06830004
068400        MOVE 1.31 TO IPF-EMERG-ADJ                                06840004
068500                     DAY-VALUE2 (1)                               06850004
068600     ELSE                                                         06860004
068700        MOVE 1.19 TO IPF-EMERG-ADJ                                06870004
068800                     DAY-VALUE2 (1).                              06880004
068900                                                                  06890004
069000***  CHECK FOR FACILITY W/O FULL SERVICE FROM CLAIM               06900004
069100     IF BILL-SRC-OF-ADMISSION = 'D'                               06910004
069200        MOVE 1.19 TO IPF-EMERG-ADJ                                06920004
069300                     DAY-VALUE2 (1).                              06930004
069400                                                                  06940004
069500                                                                  06950004
069600***************************************************************   06960004
069700***  GET THE ECT ADJUSTED PAYMENT                                 06970004
069800***  GET THE ECT ADJUSTED PAYMENT                                 06980004
069900                                                                  06990004
070000     COMPUTE IPF-ECT-PAYMENT ROUNDED =                            07000004
070100             (((IPF-ECT-RATE-AMT * IPF-LABOR-SHARE) *             07010004
070200                    W-CBSA-WAGE-INDEX)                            07020004
070300                           +                                      07030004
070400              ((IPF-ECT-RATE-AMT * IPF-NLABOR-SHARE) *            07040004
070500                       IPF-COLA)).                                07050004
070600                                                                  07060004
070700     COMPUTE IPF-ECT-PAYMENT ROUNDED =                            07070004
070800             IPF-ECT-PAYMENT * BILL-ECT-NO-OF-UNITS.              07080004
070900                                                                  07090004
071000 2000-EXIT.   EXIT.                                               07100004
071100                                                                  07110004
071200 2600-GET-DRG-FACTORS.                                            07120004
071300                                                                  07130004
071400     SET DRGSUB TO 1.                                             07140004
071500     SEARCH TB-DRG-DATA2 VARYING DRGSUB                           07150004
071600         AT END                                                   07160004
071700            MOVE '60' TO IPF-RTC                                  07170004
071800            GO TO 2600-EXIT                                       07180004
071900         WHEN TB-DRG-CODE (DRGSUB) = BILL-DRG                     07190004
072000            MOVE TB-DRG-FACTOR (DRGSUB, 1) TO IPF-DRG-FACTOR.     07200004
072100                                                                  07210004
072200 2600-EXIT.    EXIT.                                              07220004
072300                                                                  07230004
072400 2700-GET-FIRST-CODES.                                            07240004
072500                                                                  07250004
072600     SET FSTSUB TO 1.                                             07260004
072700     SEARCH TB-FST-DATA2 VARYING FSTSUB                           07270004
072800       AT END                                                     07280004
072900          MOVE 1.00 TO IPF-DRG-FACTOR                             07290004
073000          GO TO 2700-EXIT                                         07300004
073100       WHEN  TB-FST-CODE (FSTSUB) = BILL-OTHER-DIAG-DATA(1)       07310004
073200          MOVE TB-FST-FACTOR (FSTSUB, 1) TO IPF-DRG-FACTOR.       07320004
073300                                                                  07330004
073400                                                                  07340004
073500 2700-EXIT.    EXIT.                                              07350004
073600                                                                  07360004
073700 3000-CALC-PAYMENT.                                               07370004
073800***************************************************************   07380004
073900***  CALCULATE THE WAGE ADJ RATES                                 07390004
074000***  CALCULATE THE WAGE ADJ RATES                                 07400004
074100                                                                  07410004
074200     COMPUTE IPF-LABOR-BASE-AMT ROUNDED =                         07420004
074300                ((IPF-BUDGNUT-RATE-AMT * IPF-LABOR-SHARE) *       07430004
074400                     W-CBSA-WAGE-INDEX).                          07440004
074500                                                                  07450004
074600     COMPUTE IPF-NLABOR-BASE-AMT ROUNDED =                        07460004
074700                ((IPF-BUDGNUT-RATE-AMT * IPF-NLABOR-SHARE) *      07470004
074800                     IPF-COLA).                                   07480004
074900                                                                  07490004
075000     COMPUTE IPF-WAGE-ADJ-AMT ROUNDED =                           07500004
075100                (IPF-LABOR-BASE-AMT + IPF-NLABOR-BASE-AMT).       07510004
075200                                                                  07520004
075300***************************************************************   07530004
075400***  STEP 2                                                       07540004
075500***  CALCULATE ADJUSTED PER DIEM AMOUNT W/O TEACH-ADJ             07550004
075600***  CALCULATE ADJUSTED PER DIEM AMOUNT W/O TEACH-ADJ             07560004
075700                                                                  07570004
075800     COMPUTE WK-ADJ-PER-DIEM-STEP2 ROUNDED =                      07580004
075900          (IPF-COMORB-FACTOR *                                    07590004
076000           IPF-AGE-ADJ * IPF-DRG-FACTOR *                         07600004
076100           IPF-GEO-RURAL-ADJ)                                     07610004
076200                         *                                        07620004
076300                IPF-WAGE-ADJ-AMT.                                 07630004
076400                                                                  07640004
076500***************************************************************   07650004
076600***  STEP 4                                                       07660004
076700***  CALCULATE THE DAY LOS FOR TOTAL PAYMENT W/O  TEACH-ADJ       07670004
076800***  CALCULATE THE DAY LOS FOR TOTAL PAYMENT W/O  TEACH-ADJ       07680004
076900                                                                  07690004
077000     MOVE WK-ADJ-PER-DIEM-STEP2 TO IPF-ADJUSTED-PER-DIEM-AMT      07700004
077100                                   WK-PER-DIEM-AMT.               07710004
077200                                                                  07720004
077300     MOVE ZEROES TO DAYS-UPTO-21                                  07730004
077400                    DAYS-OVER-21                                  07740004
077500                    IPF-FED-PAYMENT.                              07750004
077600     MOVE 001    TO SUB                                           07760004
077700                    SUB2.                                         07770004
077800                                                                  07780004
077900     IF BILL-LOS > 21                                             07790004
078000        COMPUTE DAYS-OVER-21 = (BILL-LOS - 21)                    07800004
078100        MOVE 21 TO DAYS-UPTO-21                                   07810004
078200     ELSE                                                         07820004
078300        MOVE BILL-LOS TO DAYS-UPTO-21.                            07830004
078400                                                                  07840004
078500     PERFORM 3100-GET-EACH-DAY THRU 3100-EXIT  VARYING            07850004
078600             SUB FROM SUB2 BY 1 UNTIL                             07860004
078700             SUB > DAYS-UPTO-21.                                  07870004
078800                                                                  07880004
078900     IF BILL-LOS > 21                                             07890004
079000        COMPUTE IPF-FED-PAYMENT ROUNDED =                         07900004
079100                IPF-FED-PAYMENT +                                 07910004
079200       (DAYS-OVER-21 * (WK-PER-DIEM-AMT *                         07920004
079300                         DAY-VALUE2 (22))).                       07930004
079400                                                                  07940004
079500     MOVE IPF-FED-PAYMENT TO WK-FED-PORTION.                      07950004
079600                                                                  07960004
079700     MOVE ZEROES TO IPF-FED-PAYMENT.                              07970004
079800                                                                  07980004
079900***************************************************************   07990004
080000     IF IPF-TEACH-ADJ = 1.00                                      08000004
080100        MOVE ZEROES TO WK-ADJ-PER-DIEM-STEP1                      08010004
080200                       WK-TEACH-PORTION                           08020004
080300        GO TO 3000-BYPASS-TEACH.                                  08030004
080400                                                                  08040004
080500***************************************************************   08050004
080600***  STEP 1                                                       08060004
080700***  CALCULATE ADJUSTED PER DIEM AMOUNT WITH TEACHING-ADJ         08070004
080800***  CALCULATE ADJUSTED PER DIEM AMOUNT WITH TEACHING-ADJ         08080004
080900                                                                  08090004
081000     COMPUTE WK-ADJ-PER-DIEM-STEP1 ROUNDED =                      08100004
081100          (IPF-COMORB-FACTOR *                                    08110004
081200           IPF-AGE-ADJ * IPF-DRG-FACTOR *                         08120004
081300           IPF-TEACH-ADJ * IPF-GEO-RURAL-ADJ)                     08130004
081400                         *                                        08140004
081500                IPF-WAGE-ADJ-AMT.                                 08150004
081600                                                                  08160004
081700                                                                  08170004
081800***************************************************************   08180004
081900***  STEP 3                                                       08190004
082000     COMPUTE  WK-PER-DIEM-AMT ROUNDED =                           08200004
082100             WK-ADJ-PER-DIEM-STEP1 - WK-ADJ-PER-DIEM-STEP2.       08210004
082200                                                                  08220004
082300     MOVE WK-ADJ-PER-DIEM-STEP1 TO IPF-ADJUSTED-PER-DIEM-AMT.     08230004
082400                                                                  08240004
082500***************************************************************   08250004
082600***  STEP 5                                                       08260004
082700***  CALCULATE THE DAY LOS FOR TEACH ONLY                         08270004
082800***  CALCULATE THE DAY LOS FOR TEACH ONLY                         08280004
082900                                                                  08290004
083000     MOVE ZEROES TO DAYS-UPTO-21                                  08300004
083100                    DAYS-OVER-21                                  08310004
083200                    IPF-FED-PAYMENT.                              08320004
083300     MOVE 001    TO SUB                                           08330004
083400                    SUB2.                                         08340004
083500                                                                  08350004
083600     IF BILL-LOS > 21                                             08360004
083700        COMPUTE DAYS-OVER-21 = (BILL-LOS - 21)                    08370004
083800        MOVE 21 TO DAYS-UPTO-21                                   08380004
083900     ELSE                                                         08390004
084000        MOVE BILL-LOS TO DAYS-UPTO-21.                            08400004
084100                                                                  08410004
084200     PERFORM 3100-GET-EACH-DAY THRU 3100-EXIT  VARYING            08420004
084300             SUB FROM SUB2 BY 1 UNTIL                             08430004
084400             SUB > DAYS-UPTO-21.                                  08440004
084500                                                                  08450004
084600     IF BILL-LOS > 21                                             08460004
084700        COMPUTE IPF-FED-PAYMENT ROUNDED =                         08470004
084800                IPF-FED-PAYMENT +                                 08480004
084900       (DAYS-OVER-21 * (WK-PER-DIEM-AMT *                         08490004
085000                         DAY-VALUE2 (22))).                       08500004
085100                                                                  08510004
085200     MOVE IPF-FED-PAYMENT TO WK-TEACH-PORTION.                    08520004
085300                                                                  08530004
085400     MOVE ZEROES TO IPF-FED-PAYMENT.                              08540004
085500***************************************************************   08550004
085600 3000-BYPASS-TEACH.                                               08560004
085700***  STEP 6                                                       08570004
085800***  ADD FED AND TEACHING INPUT TO OULTLIER                       08580004
085900***  ADD FED AND TEACHING INPUT TO OULTLIER                       08590004
086000                                                                  08600004
086100     COMPUTE IPF-FED-PAYMENT ROUNDED =                            08610004
086200                      WK-FED-PORTION + WK-TEACH-PORTION.          08620004
086300                                                                  08630004
086400***************************************************************   08640004
086500***  CHECK FOR OUTLIER TO BE APPLIED                              08650004
086600***  CHECK FOR OUTLIER TO BE APPLIED                              08660004
086700                                                                  08670004
086800     IF ((BILL-PATIENT-STATUS = '30' AND                          08680004
086900          BILL-OUTL-OCCUR-IND  = 'Y')                             08690004
087000                     OR                                           08700004
087100         (BILL-PATIENT-STATUS NOT = '30'))                        08710004
087200          PERFORM 3050-GET-OULIER THRU 3050-EXIT.                 08720004
087300                                                                  08730004
087400***************************************************************   08740004
087500***  RETURN 100% PPS AMOUNT  FOR STOP LOSS PROVISION              08750004
087600***  RETURN 100% PPS AMOUNT  FOR STOP LOSS PROVISION              08760004
087700***  NOT BLENDED                                                  08770004
087800                                                                  08780004
087900      COMPUTE IPF-100PCT-STOPLOS-AMT ROUNDED =                    08790004
088000              WK-FED-PORTION + IPF-OUTLIER-PAYMENT +              08800004
088100              IPF-ECT-PAYMENT + WK-TEACH-PORTION.                 08810004
088200                                                                  08820004
088300***************************************************************   08830004
088400***  CHECK FOR FED PPS BLEND IND FOR FED AND FACILITY PCT         08840004
088500***  CHECK FOR FED PPS BLEND IND FOR FED AND FACILITY PCT         08850004
088600                                                                  08860004
088700     MOVE P-NEW-FED-PPS-BLEND-IND TO                              08870004
088800                                  IPF-FED-PPS-BLEND-IND.          08880004
088900                                                                  08890004
089000     IF P-NEW-FED-PPS-BLEND-IND = 1                               08900004
089100        COMPUTE IPF-FED-PAYMENT ROUNDED =                         08910004
089200                WK-FED-PORTION * .25                              08920004
089300        COMPUTE IPF-ECT-PAYMENT ROUNDED =                         08930004
089400                IPF-ECT-PAYMENT * .25                             08940004
089500        COMPUTE IPF-TEACH-PAYMENT ROUNDED =                       08950004
089600                WK-TEACH-PORTION * .25                            08960004
089700        COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                     08970004
089800                IPF-OUTLIER-PAYMENT * .25                         08980004
089900        COMPUTE IPF-FAC-PAYMENT ROUNDED =                         08990004
090000                P-NEW-FAC-SPEC-RATE * .75.                        09000004
090100                                                                  09010004
090200     IF P-NEW-FED-PPS-BLEND-IND = 2                               09020004
090300        COMPUTE IPF-FED-PAYMENT ROUNDED =                         09030004
090400                WK-FED-PORTION * .50                              09040004
090500        COMPUTE IPF-ECT-PAYMENT ROUNDED =                         09050004
090600                IPF-ECT-PAYMENT * .50                             09060004
090700        COMPUTE IPF-TEACH-PAYMENT ROUNDED =                       09070004
090800                WK-TEACH-PORTION * .50                            09080004
090900        COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                     09090004
091000                IPF-OUTLIER-PAYMENT * .50                         09100004
091100        COMPUTE IPF-FAC-PAYMENT ROUNDED =                         09110004
091200                P-NEW-FAC-SPEC-RATE * .50.                        09120004
091300                                                                  09130004
091400     IF P-NEW-FED-PPS-BLEND-IND = 3                               09140004
091500        COMPUTE IPF-FED-PAYMENT ROUNDED =                         09150004
091600                WK-FED-PORTION * .75                              09160004
091700        COMPUTE IPF-ECT-PAYMENT ROUNDED =                         09170004
091800                IPF-ECT-PAYMENT * .75                             09180004
091900        COMPUTE IPF-TEACH-PAYMENT ROUNDED =                       09190004
092000                WK-TEACH-PORTION * .75                            09200004
092100        COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                     09210004
092200                IPF-OUTLIER-PAYMENT * .75                         09220004
092300        COMPUTE IPF-FAC-PAYMENT ROUNDED =                         09230004
092400                P-NEW-FAC-SPEC-RATE * .25.                        09240004
092500                                                                  09250004
092600     IF P-NEW-FED-PPS-BLEND-IND = 4                               09260004
092700        COMPUTE IPF-FED-PAYMENT ROUNDED =                         09270004
092800                WK-FED-PORTION * 1.00                             09280004
092900        COMPUTE IPF-ECT-PAYMENT ROUNDED =                         09290004
093000                IPF-ECT-PAYMENT * 1.00                            09300004
093100        COMPUTE IPF-TEACH-PAYMENT ROUNDED =                       09310004
093200                WK-TEACH-PORTION * 1.00                           09320004
093300        COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                     09330004
093400                IPF-OUTLIER-PAYMENT * 1.00                        09340004
093500        COMPUTE IPF-FAC-PAYMENT ROUNDED =                         09350004
093600                P-NEW-FAC-SPEC-RATE * .0.                         09360004
093700                                                                  09370004
093800     COMPUTE IPF-TOT-PAYMENT ROUNDED =                            09380004
093900             IPF-FED-PAYMENT + IPF-FAC-PAYMENT +                  09390004
094000             IPF-ECT-PAYMENT + IPF-TEACH-PAYMENT +                09400004
094100             IPF-OUTLIER-PAYMENT.                                 09410004
094200                                                                  09420004
094300**  NOTE> IPF-FED-PAYMENT  AND IPF-TEACH-PAYMENT AND              09430004
094400**        IPF-ECT-PAYMENT  AND IPF-FAC-PAYMENT AND                09440004
094500**        IPF-OUTLIER-PAYMENT HAVE JUST BEEN BLENDED              09450004
094600**           AT THIS POINT IN THE PROGRAM LOGIC                   09460004
094700                                                                  09470004
094800 3000-EXIT.   EXIT.                                               09480004
094900                                                                  09490004
095000 3050-GET-OULIER.                                                 09500004
095100************************************                              09510004
095200***  CALCULATE THE OUTLIER PAYMENT                                09520004
095300***  CALCULATE THE OUTLIER PAYMENT                                09530004
095400                                                                  09540004
095500************************************                              09550004
095600** CALCULATE THE ADJUSTED FIXED                                   09560004
095700**    DOLLAR LOSS THRESHOLD                                       09570004
095800************************************                              09580004
095900                                                                  09590004
096000     COMPUTE IPF-OUTL-LABOR-BASE-AMT ROUNDED =                    09600004
096100                ((IPF-OUTL-THRES-AMT * IPF-LABOR-SHARE) *         09610004
096200                     W-CBSA-WAGE-INDEX).                          09620004
096300                                                                  09630004
096400     COMPUTE IPF-OUTL-NLABOR-BASE-AMT ROUNDED =                   09640004
096500                ((IPF-OUTL-THRES-AMT * IPF-NLABOR-SHARE) *        09650004
096600                     IPF-COLA).                                   09660004
096700                                                                  09670004
096800     COMPUTE IPF-OUTL-THRES-ADJ-AMT ROUNDED =                     09680004
096900           ((IPF-OUTL-LABOR-BASE-AMT +                            09690004
097000             IPF-OUTL-NLABOR-BASE-AMT) *                          09700004
097100             IPF-GEO-RURAL-ADJ *                                  09710004
097200             IPF-TEACH-ADJ) +                                     09720004
097300             IPF-FED-PAYMENT +                                    09730004
097400             IPF-ECT-PAYMENT.                                     09740004
097500                                                                  09750004
097600**  NOTE> IPF-FED-PAYMENT CONTAINS NO ECT OR OUTL PAYMENT         09760004
097700**           AT THIS POINT IN THE PROGRAM LOGIC                   09770004
097800                                                                  09780004
097900************************************                              09790004
098000** CALCULATE ELIGIBLE OUTLIER COSTS                               09800004
098100************************************                              09810004
098200                                                                  09820004
098300     COMPUTE IPF-OUTL-COST ROUNDED =                              09830004
098400             (BILL-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO).    09840004
098500                                                                  09850004
098600     MOVE '02' TO IPF-RTC.                                        09860004
098700                                                                  09870004
098800     IF IPF-OUTL-COST < IPF-OUTL-THRES-ADJ-AMT                    09880004
098900        MOVE '00' TO IPF-RTC                                      09890004
099000        MOVE ZEROES TO IPF-OUTLIER-PAYMENT                        09900004
099100        GO TO 3050-EXIT.                                          09910004
099200                                                                  09920004
099300     COMPUTE IPF-OUTL-ADJ-COST ROUNDED =                          09930004
099400             (IPF-OUTL-COST - IPF-OUTL-THRES-ADJ-AMT).            09940004
099500                                                                  09950004
099600     COMPUTE IPF-OUTL-PER-DIEM-AMT ROUNDED =                      09960004
099700            (IPF-OUTL-ADJ-COST / BILL-LOS).                       09970004
099800                                                                  09980004
099900     MOVE ZEROES TO DAYS-UPTO-9                                   09990004
100000                    DAYS-OVER-9.                                  10000004
100100                                                                  10010004
100200     IF BILL-LOS > 9                                              10020004
100300        COMPUTE DAYS-OVER-9 = (BILL-LOS - 9)                      10030004
100400        MOVE 9 TO DAYS-UPTO-9                                     10040004
100500     ELSE                                                         10050004
100600        MOVE BILL-LOS TO DAYS-UPTO-9.                             10060004
100700                                                                  10070004
100800     COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                        10080004
100900            (DAYS-UPTO-9 * (IPF-OUTL-PER-DIEM-AMT * .80)).        10090004
101000                                                                  10100004
101100     IF BILL-LOS > 9                                              10110004
101200        COMPUTE IPF-OUTLIER-PAYMENT ROUNDED =                     10120004
101300                IPF-OUTLIER-PAYMENT +                             10130004
101400       (DAYS-OVER-9 * (IPF-OUTL-PER-DIEM-AMT * .60)).             10140004
101500                                                                  10150004
101600     IF IPF-OUTLIER-PAYMENT = ZEROES                              10160004
101700        MOVE '00' TO IPF-RTC.                                     10170004
101800                                                                  10180004
101900 3050-EXIT.   EXIT.                                               10190004
102000 3100-GET-EACH-DAY.                                               10200004
102100                                                                  10210004
102200     COMPUTE IPF-FED-PAYMENT ROUNDED =                            10220004
102300             IPF-FED-PAYMENT + (WK-PER-DIEM-AMT *                 10230004
102400                                  DAY-VALUE2 (SUB)).              10240004
102500                                                                  10250004
102600 3100-EXIT.   EXIT.                                               10260004
102700                                                                  10270004
102800 3300-GET-COMORBIDITY.                                            10280004
102900                                                                  10290004
103000     MOVE BILL-DIAG-PROC-DATA TO WK-COMORBIDITY-DATA.             10300004
103100     MOVE 01.0000 TO HOLDADJ.                                     10310004
103200                                                                  10320004
103300     PERFORM 3400-ALTER-COMB-DATA THRU 3400-EXIT                  10330004
103400         VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                    10340005
103500                                                                  10350004
103600                                                                  10360004
103700     PERFORM CAT1-SEARCH THRU CAT1-SEARCH-EXIT                    10370004
103800       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10380005
103900                                                                  10390004
104000     PERFORM CAT2-SEARCH THRU CAT2-SEARCH-EXIT                    10400004
104100       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10410005
104200                                                                  10420004
104300     PERFORM CAT3-SEARCH-2 THRU CAT3-SEARCH-2-EXIT                10430004
104400       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10440005
104500                                                                  10450004
104600     PERFORM CAT4-SEARCH THRU CAT4-SEARCH-EXIT                    10460004
104700       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10470005
104800                                                                  10480004
104900     PERFORM CAT5-SEARCH-100105 THRU CAT5-SEARCH-100105-EXIT      10490004
105000              VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.               10500005
105100                                                                  10510004
105200     PERFORM CAT6-SEARCH-2 THRU CAT6-SEARCH-2-EXIT                10520004
105300       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25                       10530005
105400         AFTER X2 FROM 1 BY 1 UNTIL X2 > 25.                      10540005
105500                                                                  10550004
105600     PERFORM CAT7-SEARCH THRU CAT7-SEARCH-EXIT                    10560004
105700       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10570005
105800                                                                  10580004
105900     PERFORM CAT8-SEARCH THRU CAT8-SEARCH-EXIT                    10590004
106000       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10600005
106100                                                                  10610004
106200     PERFORM CAT9-SEARCH THRU CAT9-SEARCH-EXIT                    10620004
106300       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10630005
106400                                                                  10640004
106500     PERFORM CAT10-SEARCH THRU CAT10-SEARCH-EXIT                  10650004
106600       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10660005
106700                                                                  10670004
106800     PERFORM CAT11-SEARCH THRU CAT11-SEARCH-EXIT                  10680004
106900       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10690005
107000                                                                  10700004
107100     PERFORM CAT12-SEARCH THRU CAT12-SEARCH-EXIT                  10710004
107200       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10720005
107300                                                                  10730004
107400     PERFORM CAT13-SEARCH THRU CAT13-SEARCH-EXIT                  10740004
107500       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10750005
107600                                                                  10760004
107700     PERFORM CAT14-SEARCH-100105 THRU CAT14-SEARCH-100105-EXIT    10770004
107800          VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                   10780005
107900                                                                  10790004
108000     PERFORM CAT15-SEARCH THRU CAT15-SEARCH-EXIT                  10800004
108100       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10810005
108200                                                                  10820004
108300     PERFORM CAT16-SEARCH THRU CAT16-SEARCH-EXIT                  10830004
108400       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10840005
108500                                                                  10850004
108600     PERFORM CAT17-SEARCH THRU CAT17-SEARCH-EXIT                  10860004
108700       VARYING X1 FROM 1 BY 1 UNTIL X1 > 25.                      10870005
108800                                                                  10880004
108900     MOVE HOLDADJ TO IPF-COMORB-FACTOR.                           10890004
109000                                                                  10900004
109100 3300-EXIT.   EXIT.                                               10910004
109200                                                                  10920004
109300 3400-ALTER-COMB-DATA.                                            10930004
109400*                                                                 10940004
109500     IF BILL-DDXX-1ST(X1) = 'V'                                   10950004
109600        GO TO 3400-EXIT                                           10960004
109700     ELSE                                                         10970004
109800        PERFORM 3500-ZERO-FILL-DDXX THRU 3500-EXIT.               10980004
109900                                                                  10990004
110000 3400-EXIT.    EXIT.                                              11000004
110100                                                                  11010004
110200 3500-ZERO-FILL-DDXX.                                             11020004
110300     MOVE SPACES TO OUT-DDXX-ZERO.                                11030004
110400     IF WK-DDXX7(X1) > SPACES                                     11040004
110500        GO TO 3500-EXIT                                           11050004
110600     ELSE                                                         11060004
110700     IF WK-DDXX6(X1) > SPACES                                     11070004
110800        MOVE WK-DDXX6(X1) TO OUT-Z-DDXX7                          11080004
110900        MOVE WK-DDXX5(X1) TO OUT-Z-DDXX6                          11090004
111000        MOVE WK-DDXX4(X1) TO OUT-Z-DDXX5                          11100004
111100        MOVE WK-DDXX3(X1) TO OUT-Z-DDXX4                          11110004
111200        MOVE WK-DDXX2(X1) TO OUT-Z-DDXX3                          11120004
111300        MOVE WK-DDXX1(X1) TO OUT-Z-DDXX2                          11130004
111400        MOVE SPACE        TO OUT-Z-DDXX1                          11140004
111500        MOVE OUT-DDXX-ZERO TO DDXX(X1)                            11150004
111600        GO TO 3500-EXIT                                           11160004
111700     ELSE                                                         11170004
111800     IF WK-DDXX5(X1) > SPACES                                     11180004
111900        MOVE WK-DDXX5(X1) TO OUT-Z-DDXX7                          11190004
112000        MOVE WK-DDXX4(X1) TO OUT-Z-DDXX6                          11200004
112100        MOVE WK-DDXX3(X1) TO OUT-Z-DDXX5                          11210004
112200        MOVE WK-DDXX2(X1) TO OUT-Z-DDXX4                          11220004
112300        MOVE WK-DDXX1(X1) TO OUT-Z-DDXX3                          11230004
112400        MOVE SPACE        TO OUT-Z-DDXX2                          11240004
112500                             OUT-Z-DDXX1                          11250004
112600        MOVE OUT-DDXX-ZERO TO DDXX(X1)                            11260004
112700        GO TO 3500-EXIT                                           11270004
112800     ELSE                                                         11280004
112900     IF WK-DDXX4(X1) > SPACES                                     11290004
113000        MOVE WK-DDXX4(X1) TO OUT-Z-DDXX7                          11300004
113100        MOVE WK-DDXX3(X1) TO OUT-Z-DDXX6                          11310004
113200        MOVE WK-DDXX2(X1) TO OUT-Z-DDXX5                          11320004
113300        MOVE WK-DDXX1(X1) TO OUT-Z-DDXX4                          11330004
113400        MOVE SPACE        TO OUT-Z-DDXX3                          11340004
113500                             OUT-Z-DDXX2                          11350004
113600                             OUT-Z-DDXX1                          11360004
113700        MOVE OUT-DDXX-ZERO TO DDXX(X1)                            11370004
113800        GO TO 3500-EXIT                                           11380004
113900     ELSE                                                         11390004
114000     IF WK-DDXX3(X1) > SPACES                                     11400004
114100        MOVE WK-DDXX3(X1) TO OUT-Z-DDXX7                          11410004
114200        MOVE WK-DDXX2(X1) TO OUT-Z-DDXX6                          11420004
114300        MOVE WK-DDXX1(X1) TO OUT-Z-DDXX5                          11430004
114400        MOVE SPACE        TO OUT-Z-DDXX4                          11440004
114500                             OUT-Z-DDXX3                          11450004
114600                             OUT-Z-DDXX2                          11460004
114700                             OUT-Z-DDXX1                          11470004
114800        MOVE OUT-DDXX-ZERO TO DDXX(X1)                            11480004
114900        GO TO 3500-EXIT                                           11490004
115000     ELSE                                                         11500004
115100     IF WK-DDXX2(X1) > SPACES                                     11510004
115200        MOVE WK-DDXX2(X1) TO OUT-Z-DDXX7                          11520004
115300        MOVE WK-DDXX1(X1) TO OUT-Z-DDXX6                          11530004
115400        MOVE SPACE        TO OUT-Z-DDXX5                          11540004
115500                             OUT-Z-DDXX4                          11550004
115600                             OUT-Z-DDXX3                          11560004
115700                             OUT-Z-DDXX2                          11570004
115800                             OUT-Z-DDXX1                          11580004
115900        MOVE OUT-DDXX-ZERO TO DDXX(X1)                            11590004
116000        GO TO 3500-EXIT                                           11600004
116100      ELSE                                                        11610004
116200        MOVE SPACES TO DDXX(X1).                                  11620004
116300 3500-EXIT.    EXIT.                                              11630004
116400                                                                  11640004
116500* DEVELOPMENTAL DISABILITIES                                      11650004
116600 CAT1-SEARCH.                                                     11660004
116700     IF  (DDXX (X1) = '    317' OR '   3180' OR '   3181' OR      11670004
116800                      '   3182' OR '    319')                     11680004
116900         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.04                 11690004
117000         MOVE 26 TO X1.                                           11700005
117100 CAT1-SEARCH-EXIT.   EXIT.                                        11710004
117200                                                                  11720004
117300*CONGULATION FACTOR DEFICITS                                      11730004
117400 CAT2-SEARCH.                                                     11740004
117500     IF  (DDXX (X1) = '   2860' OR '   2861' OR '   2862' OR      11750004
117600                      '   2863' OR '   2864')                     11760004
117700         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.13                 11770004
117800         MOVE 26 TO X1.                                           11780005
117900 CAT2-SEARCH-EXIT.   EXIT.                                        11790004
118000                                                                  11800004
118100*TRACHEOSTOMY                                                     11810004
118200 CAT3-SEARCH-2.                                                   11820004
118300      IF  (DDXX (X1) = '  51900' OR '  51901' OR '  51909' OR     11830004
118400                       '  51902' OR                               11840004
118500                       'V440')                                    11850004
118600          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.06                11860004
118700          MOVE 26 TO X1.                                          11870005
118800 CAT3-SEARCH-2-EXIT.   EXIT.                                      11880004
118900                                                                  11890004
119000*  RENAL FAILURE, ACUTE                                           11900004
119100 CAT4-SEARCH.                                                     11910004
119200      IF   (DDXX (X1) = '  63630' OR '  63631' OR '  63632' OR    11920004
119300                        '  63730' OR '  63731' OR '  63732' OR    11930004
119400                        '   6383' OR                              11940004
119500                        '   6393' OR '  66932' OR '  66934' OR    11950004
119600                        '   5845' OR '   5846' OR '   5847' OR    11960004
119700                        '   5848' OR '   5849' OR                 11970004
119800                        '   9585')                                11980004
119900          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.11                11990004
120000          MOVE 26 TO X1.                                          12000005
120100 CAT4-SEARCH-EXIT.   EXIT.                                        12010004
120200                                                                  12020004
120300* RENAL FAILURE, CHRONIC EFFECTIVE 10/01/2005                     12030004
120400 CAT5-SEARCH-100105.                                              12040004
120500      IF  (DDXX (X1) = '  40301' OR '  40311' OR '  40391' OR     12050004
120600                       '  40402' OR '  40412' OR                  12060004
120700                       '  40413' OR '  40492' OR '  40493' OR     12070004
120800                       '   5853' OR '   5854' OR                  12080004
120900                       '   5855' OR '   5856' OR                  12090004
121000                       '   5859' OR '    586' OR                  12100004
121100                       'V4511' OR 'V4512' OR                      12110004
121200                       'V560'  OR                                 12120004
121300                       'V561'  OR 'V562')                         12130004
121400          COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.11                12140004
121500          MOVE 26 TO X1.                                          12150005
121600                                                                  12160004
121700 CAT5-SEARCH-100105-EXIT.   EXIT.                                 12170004
121800                                                                  12180004
121900* ONCOLOGY TREATMENT                                              12190004
122000 CAT6-SEARCH-2.                                                   12200004
122100     IF (((DDXX (X1) > '   1399' AND < '   1770')  OR             12210004
122200          (DDXX (X1) > '   1799' AND < '   1810')  OR             12220004
122300          (DDXX (X1) > '   1819' AND < '   1850')  OR             12230004
122400          (DDXX (X1) > '   1859' AND < '   1930')  OR             12240004
122500          (DDXX (X1) > '   1939' AND < '   1988')  OR             12250004
122600          (DDXX (X1) > '   2099' AND < '   2170')  OR             12260004
122700          (DDXX (X1) > '   2179' AND < '   2200')  OR             12270004
122800          (DDXX (X1) > '   2209' AND < '   2234')  OR             12280004
122900          (DDXX (X1) > '   2238' AND < '   2260')  OR             12290004
123000          (DDXX (X1) > '   2269' AND < '   2280')  OR             12300004
123100          (DDXX (X1) > '   2280' AND < '   2333')  OR             12310004
123200          (DDXX (X1) > '   2333' AND < '   2368')  OR             12320004
123300          (DDXX (X1) > '   2369' AND < '   2377')  OR             12330004
123400          (DDXX (X1) > '   2378' AND < '   2387')  OR             12340004
123500          (DDXX (X1) > '   2387' AND < '   2398')  OR             12350004
123600          (DDXX (X1) > '  19880' AND < '  19890')  OR             12360004
123700          (DDXX (X1) > '  19999' AND < '  20892')  OR             12370004
123800          (DDXX (X1) > '  20029' AND < '  20079')  OR             12380004
123900          (DDXX (X1) > '  20269' AND < '  20279')  OR             12390004
124000          (DDXX (X1) > '  20930' AND < '  20937')  OR             12400004
124100          (DDXX (X1) > '  20969' AND < '  20980')  OR             12410004
124200          (DDXX (X1) > '  22799' AND < '  22810')  OR             12420004
124300          (DDXX (X1) > '  23329' AND < '  23333')  OR             12430004
124400          (DDXX (X1) > '  23689' AND < '  23700')  OR             12440004
124500          (DDXX (X1) > '  23769' AND < '  23773')  OR             12450004
124600          (DDXX (X1) > '  23870' AND < '  23880')  OR             12460004
124700          (DDXX (X1) = '  22381' OR '  22389' OR '  23339' OR     12470004
124800                       '    179' OR '    181' OR '    185' OR     12480004
124900                       '    193' OR '    217' OR '    220' OR     12490004
125000                       '   1990' OR '   1991' OR                  12500004
125100                       '   1992' OR '   2399' OR                  12510004
125200                       '  20302' OR '  20312' OR                  12520004
125300                       '  20382' OR '  20402' OR                  12530004
125400                       '  20412' OR '  20422' OR '  20482' OR     12540004
125500                       '  20492' OR '  20502' OR '  20512' OR     12550004
125600                       '  20522' OR '  20532' OR                  12560004
125700                       '  20582' OR '  20592' OR '  20602' OR     12570004
125800                       '  20612' OR '  20622' OR '  20682' OR     12580004
125900                       '  20692' OR '  20702' OR                  12590004
126000                       '  20712' OR '  20722' OR '  20782' OR     12600004
126100                       '  20802' OR '  20812' OR '  20822' OR     12610004
126200                       '  20882' OR '  20892' OR                  12620004
126300                       '  20900' OR '  20901' OR '  20902' OR     12630004
126400                       '  20903' OR '  20910' OR '  20911' OR     12640004
126500                       '  20912' OR '  20913' OR                  12650004
126600                       '  20914' OR '  20915' OR '  20916' OR     12660004
126700                       '  20917' OR '  20920' OR '  20921' OR     12670004
126800                       '  20922' OR '  20923' OR                  12680004
126900                       '  20924' OR '  20925' OR '  20926' OR     12690004
127000                       '  20927' OR '  20929' OR '  20930' OR     12700004
127100                       '  20940' OR '  20941' OR                  12710004
127200                       '  20942' OR '  20943' OR '  20950' OR     12720004
127300                       '  20951' OR '  20952' OR '  20953' OR     12730004
127400                       '  20954' OR '  20955' OR                  12740004
127500                       '  20956' OR '  20957' OR '  20960' OR     12750004
127600                       '  20961' OR '  20962' OR '  20963' OR     12760004
127700                       '  20964' OR '  20965' OR                  12770004
127800                       '  20966' OR '  20967' OR '  20969' OR     12780004
127900                       '  23773' OR '  23779' OR                  12790004
128000                       '  23877' OR '  23981' OR '  23989' OR     12800004
128100                       '    226' OR '  23873'))                   12810004
128200      AND                                                         12820004
128300          (SRGX (X2) = '9221' OR '9222' OR                        12830004
128400                       '9223' OR '9224' OR                        12840004
128500                       '9225' OR '9226' OR                        12850004
128600                       '9227' OR '9228' OR                        12860004
128700                       '9229' OR '9925'))                         12870004
128800         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.07                 12880004
128900         MOVE 26 TO X2                                            12890005
129000         MOVE 26 TO X1.                                           12900005
129100 CAT6-SEARCH-2-EXIT.   EXIT.                                      12910004
129200                                                                  12920004
129300* UNCONTROLLED DIABETES-MELLITUS W OR WO COMPLICTIONS             12930004
129400 CAT7-SEARCH.                                                     12940004
129500     IF  (DDXX (X1) = '  25002' OR '  25003' OR '  25012' OR      12950004
129600                      '  25013' OR '  25022' OR '  25023' OR      12960004
129700                      '  25032' OR '  25033' OR '  25042' OR      12970004
129800                      '  25043' OR '  25052' OR '  25053' OR      12980004
129900                      '  25062' OR '  25063' OR '  25072' OR      12990004
130000                      '  25073' OR '  25082' OR '  25083' OR      13000004
130100                      '  25092' OR '  25093')                     13010004
130200         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.05                 13020004
130300         MOVE 26 TO X1.                                           13030005
130400 CAT7-SEARCH-EXIT.   EXIT.                                        13040004
130500                                                                  13050004
130600* SEVERE PROTEIN CALORIE MALNUTRITION                             13060004
130700 CAT8-SEARCH.                                                     13070004
130800     IF  (DDXX (X1) = '    260' OR '    261' OR '    262')        13080004
130900         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.13                 13090004
131000         MOVE 26 TO X1.                                           13100005
131100 CAT8-SEARCH-EXIT.   EXIT.                                        13110004
131200                                                                  13120004
131300* EATING AND CONDUCT DISORDERS                                    13130004
131400 CAT9-SEARCH.                                                     13140004
131500     IF  (DDXX (X1) = '   3071' OR '  30750' OR '  31203' OR      13150004
131600                      '  31233' OR '  31234')                     13160004
131700         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.12                 13170004
131800         MOVE 26 TO X1.                                           13180005
131900 CAT9-SEARCH-EXIT.   EXIT.                                        13190004
132000                                                                  13200004
132100* INFECTIOUS DISEASE                                              13210004
132200 CAT10-SEARCH.                                                    13220004
132300     IF ((DDXX (X1) > '  00999' AND < '  01897') OR               13230004
132400         (DDXX (X1) > '   0199' AND < '   0240') OR               13240004
132500         (DDXX (X1) > '   0259' AND < '   0324') OR               13250004
132600         (DDXX (X1) > '   0328' AND < '   0342') OR               13260004
132700         (DDXX (X1) > '   0359' AND < '   0364') OR               13270004
132800         (DDXX (X1) > '   0387' AND < '   0404') OR               13280004
132900         (DDXX (X1) > '   0459' AND < '   0461') OR               13290004
133000         (DDXX (X1) > '   0461' AND < '   0480') OR               13300004
133100         (DDXX (X1) > '   0489' AND < '   0510') OR               13310004
133200         (DDXX (X1) > '   0510' AND < '   0531') OR               13320004
133300         (DDXX (X1) > '   0549' AND < '   0553') OR               13330004
133400         (DDXX (X1) > '   0567' AND < '   0580') OR               13340004
133500         (DDXX (X1) > '   0599' AND < '   0610') OR               13350004
133600         (DDXX (X1) > '   0619' AND < '   0640') OR               13360004
133700         (DDXX (X1) > '   0649' AND < '   0664') OR               13370004
133800         (DDXX (X1) > '   0719' AND < '   0724') OR               13380004
133900         (DDXX (X1) > '   0727' AND < '   0742') OR               13390004
134000         (DDXX (X1) > '   0759' AND < '   0771') OR               13400004
134100         (DDXX (X1) > '   0781' AND < '   0788') OR               13410004
134200         (DDXX (X1) > '  03280' AND < '  03290') OR               13420004
134300         (DDXX (X1) > '  03639' AND < '  03644') OR               13430004
134400         (DDXX (X1) > '  03680' AND < '  03690') OR               13440004
134500         (DDXX (X1) > '  03809' AND < '  03820') OR               13450004
134600         (DDXX (X1) > '  03839' AND < '  03850') OR               13460004
134700         (DDXX (X1) > '  04040' AND < '  04043') OR               13470004
134800         (DDXX (X1) > '  04080' AND < '  04090') OR               13480004
134900         (DDXX (X1) > '  04099' AND < '  04111') OR               13490004
135000         (DDXX (X1) > '  04499' AND < '  04594') OR               13500004
135100         (DDXX (X1) > '  05309' AND < '  05320') OR               13510004
135200         (DDXX (X1) > '  05439' AND < '  05450') OR               13520004
135300         (DDXX (X1) > '  05570' AND < '  05580') OR               13530004
135400         (DDXX (X1) > '  05599' AND < '  05610') OR               13540004
135500         (DDXX (X1) > '  05670' AND < '  05680') OR               13550004
135600         (DDXX (X1) > '  05809' AND < '  05813') OR               13560004
135700         (DDXX (X1) > '  05880' AND < '  05883') OR               13570004
135800         (DDXX (X1) > '  06639' AND < '  06650') OR               13580004
135900         (DDXX (X1) > '  07019' AND < '  07060') OR               13590004
136000         (DDXX (X1) > '  07270' AND < '  07280') OR               13600004
136100         (DDXX (X1) > '  07419' AND < '  07424') OR               13610004
136200         (DDXX (X1) > '  07880' AND < '  07890') OR               13620004
136300         (DDXX (X1) > '  07949' AND < '  07960') OR               13630004
136400         (DDXX (X1) = '    042' OR '    024' OR '    025' OR      13640004
136500                      '    035' OR '    037' OR '    048' OR      13650004
136600                      '    061' OR '    064' OR '    071' OR      13660004
136700                      '   0382' OR '   0383' OR '   0558' OR      13670004
136800                      '   0559' OR '   0668' OR '   0669' OR      13680004
136900                      '   0700' OR '   0701' OR '   0706' OR      13690004
137000                      '  07070' OR '  07071' OR '   0709' OR      13700004
137100                      '  05821' OR '  05829' OR '  05889' OR      13710004
137200                      '   0743' OR '   0748' OR '    075' OR      13720004
137300                      '  05900' OR '  03812' OR '  04611' OR      13730004
137400                      '  04619' OR '  04671' OR '  04672' OR      13740004
137500                      '  04679' OR '  05101' OR '  05102' OR      13750004
137600                      '  05901' OR '  05909' OR '  05910' OR      13760004
137700                      '  05911' OR '  05912' OR '  05919' OR      13770004
137800                      '  05920' OR '  05921' OR '  05922' OR      13780004
137900                      '   0598' OR '   0599' OR                   13790004
138000                      '   0380'))                                 13800004
138100         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.07                 13810004
138200         MOVE 26 TO X1.                                           13820005
138300 CAT10-SEARCH-EXIT.   EXIT.                                       13830004
138400                                                                  13840004
138500* DRUG AND/OR ALCOHOL INDUCED MENTAL DISORDERS                    13850004
138600 CAT11-SEARCH.                                                    13860004
138700     IF  (DDXX (X1) = '   2910' OR '   2920' OR '  29212' OR      13870004
138800                      '   2922' OR '  30300' OR                   13880004
138900                      '  30400')                                  13890004
139000         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.03                 13900004
139100         MOVE 26 TO X1.                                           13910005
139200 CAT11-SEARCH-EXIT.   EXIT.                                       13920004
139300                                                                  13930004
139400* CARDIAC CONDITIONS                                              13940004
139500 CAT12-SEARCH.                                                    13950004
139600     IF  (DDXX (X1) = '   3910' OR '   3911' OR '   3912' OR      13960004
139700                      '  40201' OR '  40403' OR '   4160' OR      13970004
139800                      '   4210' OR '   4211' OR '   4219')        13980004
139900         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.11                 13990004
140000         MOVE 26 TO X1.                                           14000005
140100 CAT12-SEARCH-EXIT.   EXIT.                                       14010004
140200                                                                  14020004
140300* GANGRENE                                                        14030004
140400 CAT13-SEARCH.                                                    14040004
140500     IF  (DDXX (X1) = '  44024' OR '   7854')                     14050004
140600         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.10                 14060004
140700         MOVE 26 TO X1.                                           14070005
140800 CAT13-SEARCH-EXIT.   EXIT.                                       14080004
140900                                                                  14090004
141000* CHRONIC OBSTRUCTIVE PULMONARY DISEASE EFFECTIVE 10/01/2005      14100004
141100 CAT14-SEARCH-100105.                                             14110004
141200     IF  (DDXX (X1) = '  49121' OR '   4941' OR '   5100' OR      14120004
141300                      '  51883' OR '  51884' OR                   14130004
141400                      'V4611' OR 'V4612' OR                       14140004
141500                      'V4613' OR 'V4614')                         14150004
141600         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.12                 14160004
141700         MOVE 26 TO X1.                                           14170005
141800 CAT14-SEARCH-100105-EXIT.   EXIT.                                14180004
141900                                                                  14190004
142000* ARTIFICIAL OPENINGS - DIGESTIVE AND URINARY                     14200004
142100 CAT15-SEARCH.                                                    14210004
142200     IF  (DDXX (X1) = '  56960' OR '  56961' OR                   14220004
142300                      '  56962' OR '  56969' OR '   9975'  OR     14230004
142400                      'V441'  OR 'V442'  OR 'V443'  OR            14240004
142500                      'V444'  OR 'V4450' OR 'V4451' OR            14250004
142600                      'V4452' OR 'V4459' OR 'V446')               14260004
142700         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.08                 14270004
142800         MOVE 26 TO X1.                                           14280005
142900 CAT15-SEARCH-EXIT.   EXIT.                                       14290004
143000                                                                  14300004
143100* SEVERE MUSCLOSKELETAL AND CONNECTIVE TISSUE                     14310004
143200 CAT16-SEARCH.                                                    14320004
143300     IF  ((DDXX (X1) > '  72999' AND < '  73030') OR              14330004
143400          (DDXX (X1) = '   6960' OR '   7100'))                   14340004
143500         COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.09                 14350004
143600         MOVE 26 TO X1.                                           14360005
143700 CAT16-SEARCH-EXIT.   EXIT.                                       14370004
143800                                                                  14380004
143900* POISONING                                                       14390004
144000 CAT17-SEARCH.                                                    14400004
144100     IF ((DDXX (X1) > '   9669'  AND < '   9690')  OR             14410004
144200         (DDXX (X1) > '   9799'  AND < '   9810')  OR             14420004
144300         (DDXX (X1) > '   9829'  AND < '   9840')  OR             14430004
144400         (DDXX (X1) > '   9889'  AND < '   9898')  OR             14440004
144500         (DDXX (X1) > '  96499'  AND < '  96510')  OR             14450004
144600         (DDXX (X1) > '  96899'  AND < '  96906')  OR             14460004
144700         (DDXX (X1) > '  96969'  AND < '  96974')  OR             14470004
144800         (DDXX (X1) = '   9691' OR '   9692' OR '   9693' OR      14480004
144900                      '   9694' OR '   9695' OR '   9696' OR      14490004
145000                      '   9698' OR '   9699' OR                   14500004
145100                      '   9654' OR '    986' OR '   9770' OR      14510004
145200                      '  96909' OR '  96979'))                    14520004
145300        COMPUTE HOLDADJ ROUNDED = HOLDADJ * 1.11                  14530004
145400        MOVE 26 TO X1.                                            14540005
145500 CAT17-SEARCH-EXIT.   EXIT.                                       14550004
145600***************************************************************   14560004
145700******       L A S T   S O U R C E   S T A T E M E N T    *****   14570004
