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