000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.           IRCAL080.                                  00020000
000300*AUTHOR.            ED FRANEY.                                    00030000
000400*REMARKS.                CMS.                                     00040000
000500*       EFFECTIVE OCT 1 2007                                      00050000
000600 DATE-COMPILED.                                                   00060000
000610******************************************************************00061001
000611** REMOVED FOR 2008 RELEASE - 3500-CONTINUE-CALC                 *00061101
000612**   IF P-NEW-TEMP-RELIEF-IND = 'Y'                              *00061201
000613**      MOVE 1.0638 TO PPS-RURAL-ADJUSTMENT.                     *00061301
000614*------------------ 2008.1---------------------------------------*00061408
000616* THE IRF PPS PRICER SHALL UPDATE THE FY08 STANDARD PAYMENT      *00061607
000617* CONVERSION FACTOR FROM $13,451 TO $13,034 EFFECTIVE FOR        *00061707
000618* DISCHARGES ON OR AFTER APRIL 1, 2008                           *00061807
000619*------------------ 2008.2---------------------------------------*00061908
000620* THE IRF PPS PRICER SHALL ADD THE DEFAULT CMG OF A9999 AS A     *00062007
000621* VALID CMG TO ALL "NO-PAY" CLAIMS FOR MEDICARE ADVANTAGE        *00062107
000622* PATIENTS TO BE PROCESSED, EFFECTIVE FOR DISCHARGES ON OR AFTER *00062207
000623* JANUARY 1, 2006                                                *00062307
000630******************************************************************00063001
000700 ENVIRONMENT DIVISION.                                            00070000
000800 CONFIGURATION SECTION.                                           00080000
000900 SOURCE-COMPUTER.            IBM-370.                             00090000
001000 OBJECT-COMPUTER.            IBM-370.                             00100000
001100 INPUT-OUTPUT  SECTION.                                           00110000
001200 FILE-CONTROL.                                                    00120000
001300                                                                  00130000
001400 DATA DIVISION.                                                   00140000
001500 FILE SECTION.                                                    00150000
001600                                                                  00160000
001700 WORKING-STORAGE SECTION.                                         00170000
001800 01  W-STORAGE-REF                  PIC X(46)  VALUE              00180000
001900     'IRCAL080      - W O R K I N G   S T O R A G E'.             00190000
002000 01  CAL-VERSION                    PIC X(05)  VALUE 'C08.0'.     00200000
002100                                                                  00210000
002200***************************************************************   00220000
002300*    LAYUP TABLE AREA FOR FY2007 CMGS                         *   00230000
002400*    EFFECTIVE DATE OF OCTOBER 1, 2007                        *   00240000
002410* 2008.2 - ADDED A9999                                        *   00241008
002500***************************************************************   00250000
002600 01  CMG-TABLE.                                                   00260000
002700     05  CMG-TABLE-DATA.                                          00270000
002800         10                      PIC X(32)   VALUE                00280000
002900           '01010770707303065720634708110909'.                    00290000
003000         10                      PIC X(32)   VALUE                00300000
003100           '01020949308995080950781811151110'.                    00310000
003200         10                      PIC X(32)   VALUE                00320000
003300           '01031119210605095440921814131212'.                    00330000
003400         10                      PIC X(32)   VALUE                00340000
003500           '01041188511260101340978713141313'.                    00350000
003600         10                      PIC X(32)   VALUE                00360000
003700           '01051426113512121611174516171615'.                    00370000
003800         10                      PIC X(32)   VALUE                00380000
003900           '01061659415722141501366618201818'.                    00390000
004000         10                      PIC X(32)   VALUE                00400000
004100           '01071915018145163301577121232120'.                    00410000
004200         10                      PIC X(32)   VALUE                00420000
004300           '01082216020997188971825028292524'.                    00430000
004400         10                      PIC X(32)   VALUE                00440000
004500           '01092199820843187581811623262423'.                    00450000
004600         10                      PIC X(32)   VALUE                00460000
004700           '01102628724907224162164930332827'.                    00470000
004800         10                      PIC X(32)   VALUE                00480000
004900           '02010814306806060800564710090908'.                    00490000
005000         10                      PIC X(32)   VALUE                00500000
005100           '02021046008743078100725412101109'.                    00510000
005200         10                      PIC X(32)   VALUE                00520000
005300           '02031250310450093350867115151212'.                    00530000
005400         10                      PIC X(32)   VALUE                00540000
005500           '02041339011192099980928715161313'.                    00550000
005600         10                      PIC X(32)   VALUE                00560000
005700           '02051641213718122541138217181615'.                    00570000
005800         10                      PIC X(32)   VALUE                00580000
005900           '02062144517924160111487323222120'.                    00590000
006000         10                      PIC X(32)   VALUE                00600000
006100           '02072766423122206551918535292625'.                    00610000
006200         10                      PIC X(32)   VALUE                00620000
006300           '03011139409533085520777212121110'.                    00630000
006400         10                      PIC X(32)   VALUE                00640000
006500           '03021487512446111641014714161413'.                    00650000
006600         10                      PIC X(32)   VALUE                00660000
006700           '03031770114810132851207420191716'.                    00670000
006800         10                      PIC X(32)   VALUE                00680000
006900           '03042439520410183091664032252321'.                    00690000
007000         10                      PIC X(32)   VALUE                00700000
007100           '04010958708456077220685812121110'.                    00710000
007200         10                      PIC X(32)   VALUE                00720000
007300           '04021325611691106760948218161413'.                    00730000
007400         10                      PIC X(32)   VALUE                00740000
007500           '04032306920347185801650222242422'.                    00750000
007600         10                      PIC X(32)   VALUE                00760000
007700           '04044154236639334582971751464137'.                    00770000
007800         10                      PIC X(32)   VALUE                00780000
007900           '04053137127668252662244133373328'.                    00790000
008000         10                      PIC X(32)   VALUE                00800000
008100           '05010764806455056870507109080807'.                    00810000
008200         10                      PIC X(32)   VALUE                00820000
008300           '05021026208661076300680413121109'.                    00830000
008400         10                      PIC X(32)   VALUE                00840000
008500           '05031359611476101090901415151312'.                    00850000
008600         10                      PIC X(32)   VALUE                00860000
008700           '05041698414335126281126021191615'.                    00870000
008800         10                      PIC X(32)   VALUE                00880000
008900           '05052017117025149971337323221918'.                    00890000
009000         10                      PIC X(32)   VALUE                00900000
009100           '05062740223128203741816729282623'.                    00910000
009200         10                      PIC X(32)   VALUE                00920000
009300           '06010899107330070190652211100909'.                    00930000
009400         10                      PIC X(32)   VALUE                00940000
009500           '06021196809757093420868213131312'.                    00950000
009600         10                      PIC X(32)   VALUE                00960000
009700           '06031532612495119651111817171515'.                    00970000
009800         10                      PIC X(32)   VALUE                00980000
009900           '06041959215973152951421322202119'.                    00990000
010000         10                      PIC X(32)   VALUE                01000000
010100           '07010902807717073380661712111009'.                    01010000
010200         10                      PIC X(32)   VALUE                01020000
010300           '07021173610033095390860213141312'.                    01030000
010400         10                      PIC X(32)   VALUE                01040000
010500           '07031462912506118901072216171614'.                    01050000
010600         10                      PIC X(32)   VALUE                01060000
010700           '07041796915361146051317020201918'.                    01070000
010800         10                      PIC X(32)   VALUE                01080000
010900           '08010653705504051310460707070706'.                    01090000
011000         10                      PIC X(32)   VALUE                01100000
011100           '08020854207193067040602010100908'.                    01110000
011200         10                      PIC X(32)   VALUE                01120000
011300           '08031270710700099740895615151312'.                    01130000
011400         10                      PIC X(32)   VALUE                01140000
011500           '08041104009296086650778113121210'.                    01150000
011600         10                      PIC X(32)   VALUE                01160000
011700           '08051392711727109310981617161413'.                    01170000
011800         10                      PIC X(32)   VALUE                01180000
011900           '08061672314082131261178718191715'.                    01190000
012000         10                      PIC X(32)   VALUE                01200000
012100           '09010842507641068680612010111009'.                    01210000
012200         10                      PIC X(32)   VALUE                01220000
012300           '09021108810057090390805613131211'.                    01230000
012400         10                      PIC X(32)   VALUE                01240000
012500           '09031463813277119341063518191615'.                    01250000
012600         10                      PIC X(32)   VALUE                01260000
012700           '09041834116636149521332525232119'.                    01270000
012800         10                      PIC X(32)   VALUE                01280000
012900           '10010962508879079570736111111110'.                    01290000
013000         10                      PIC X(32)   VALUE                01300000
013100           '10021270911724105070971914151413'.                    01310000
013200         10                      PIC X(32)   VALUE                01320000
013300           '10031787616491147791367119221918'.                    01330000
013400         10                      PIC X(32)   VALUE                01340000
013500           '11011255410482092250849614151211'.                    01350000
013600         10                      PIC X(32)   VALUE                01360000
013700           '11021882415717138321273919191817'.                    01370000
013800         10                      PIC X(32)   VALUE                01380000
013900           '12011017708785081820740511121110'.                    01390000
014000         10                      PIC X(32)   VALUE                01400000
014100           '12021316811367105860958115161413'.                    01410000
014200         10                      PIC X(32)   VALUE                01420000
014300           '12031624114020130571181721191716'.                    01430000
014400         10                      PIC X(32)   VALUE                01440000
014500           '13011035409636085110742912131110'.                    01450000
014600         10                      PIC X(32)   VALUE                01460000
014700           '13021432113327117721027515181514'.                    01470000
014800         10                      PIC X(32)   VALUE                01480000
014900           '13031825016984150021309422212018'.                    01490000
015000         10                      PIC X(32)   VALUE                01500000
015100           '14010816007351065340586110090908'.                    01510000
015200         10                      PIC X(32)   VALUE                01520000
015300           '14021103809944088390792812131211'.                    01530000
015400         10                      PIC X(32)   VALUE                01540000
015500           '14031370512347109750984416161413'.                    01550000
015600         10                      PIC X(32)   VALUE                01560000
015700           '14041737015649139101247721201816'.                    01570000
015800         10                      PIC X(32)   VALUE                01580000
015900           '15010998608870077930739911131010'.                    01590000
016000         10                      PIC X(32)   VALUE                01600000
016100           '15021266111246098800938113151212'.                    01610000
016200         10                      PIC X(32)   VALUE                01620000
016300           '15031545713730120621145316161515'.                    01630000
016400         10                      PIC X(32)   VALUE                01640000
016500           '15042021617957157751497926212018'.                    01650000
016600         10                      PIC X(32)   VALUE                01660000
016700           '16011007008550077740695712111010'.                    01670000
016800         10                      PIC X(32)   VALUE                01680000
016900           '16021382611739106730955215171413'.                    01690000
017000         10                      PIC X(32)   VALUE                01700000
017100           '16031702514455131431176219191816'.                    01710000
017200         10                      PIC X(32)   VALUE                01720000
017300           '17010981809641084790736812121110'.                    01730000
017400         10                      PIC X(32)   VALUE                01740000
017500           '17021292112688111580969614161513'.                    01750000
017600         10                      PIC X(32)   VALUE                01760000
017700           '17031535615080132621152417201816'.                    01770000
017800         10                      PIC X(32)   VALUE                01780000
017900           '17041924618899166201444326262219'.                    01790000
018000         10                      PIC X(32)   VALUE                01800000
018100           '18011192009866082430734215131310'.                    01810000
018200         10                      PIC X(32)   VALUE                01820000
018300           '18021905815774131791173819211816'.                    01830000
018400         10                      PIC X(32)   VALUE                01840000
018500           '18033430228391237212112743333027'.                    01850000
018600         10                      PIC X(32)   VALUE                01860000
018700           '19011239910986109650935014131412'.                    01870000
018800         10                      PIC X(32)   VALUE                01880000
018900           '19022319420552205121749127252523'.                    01890000
019000         10                      PIC X(32)   VALUE                01900000
019100           '19033346429651295932523537393133'.                    01910000
019200         10                      PIC X(32)   VALUE                01920000
019300           '20010873407381067350608410100908'.                    01930000
019400         10                      PIC X(32)   VALUE                01940000
019500           '20021144709674088270797512131211'.                    01950000
019600         10                      PIC X(32)   VALUE                01960000
019700           '20031477712488113951029416161514'.                    01970000
019800         10                      PIC X(32)   VALUE                01980000
019900           '20041971616662152041373525222018'.                    01990000
020000         10                      PIC X(32)   VALUE                02000000
020100           '21012184221842166061458727242017'.                    02010000
020200         10                      PIC X(32)   VALUE                02020000
020300           '50010000000000000000220100000002'.                    02030000
020400         10                      PIC X(32)   VALUE                02040000
020500           '51010000000000000000635100000008'.                    02050000
020600         10                      PIC X(32)   VALUE                02060000
020700           '51020000000000000001598500000022'.                    02070000
020800         10                      PIC X(32)   VALUE                02080000
020900           '51030000000000000000720300000008'.                    02090000
021000         10                      PIC X(32)   VALUE                02100000
021100           '51040000000000000001878400000024'.                    02110000
021110         10                      PIC X(32)   VALUE                02111007
021120           '99990000000000000000000000000000'.                    02112007
021200     05  W-CMG-TABLE REDEFINES CMG-TABLE-DATA.                    02120000
021300         10  CMG-DATA            OCCURS 93 TIMES                  02130007
021400                                 ASCENDING KEY IS CMG-NUM         02140000
021500                                 INDEXED BY DX6.                  02150000
021600             15  CMG-NUM         PIC X(4).                        02160000
021700             15  CMG-NUM-REDEF REDEFINES CMG-NUM.                 02170000
021800                 20  CMG-RIC     PIC XX.                          02180000
021900                 20  FILLER      PIC XX.                          02190000
022000             15  B-REL-WGT       PIC 9(1)V9(4).                   02200000
022100             15  C-REL-WGT       PIC 9(1)V9(4).                   02210000
022200             15  D-REL-WGT       PIC 9(1)V9(4).                   02220000
022300             15  A-REL-WGT       PIC 9(1)V9(4).                   02230000
022400             15  B-LOS-TABLE     PIC 9(2).                        02240000
022500             15  C-LOS-TABLE     PIC 9(2).                        02250000
022600             15  D-LOS-TABLE     PIC 9(2).                        02260000
022700             15  A-LOS-TABLE     PIC 9(2).                        02270000
022800                                                                  02280000
022900 01  HOLD-PPS-COMPONENTS.                                         02290000
023000     05  H-LOS                        PIC 9(05).                  02300000
023100     05  H-WK-DSH                     PIC 9(01)V9(04).            02310000
023200     05  H-TEACH-PCT                  PIC 9(01)V9(04).            02320000
023300     05  H-LABOR-PORTION              PIC 9(07)V9(06).            02330000
023400     05  H-NONLABOR-PORTION           PIC 9(07)V9(06).            02340000
023500     05  H-OUTLIER-LABOR-PORTION      PIC 9(07)V9(06).            02350000
023600     05  H-OUTLIER-NONLABOR-PORTION   PIC 9(07)V9(06).            02360000
023700     05  H-FP-OUTLIER-THRESHOLD       PIC 9(07)V9(06).            02370000
023800     05  H-OUTLIER-THRESHOLD          PIC 9(07)V9(06).            02380000
023900     05  H-CHG-OUTLIER-THRESHOLD      PIC 9(07)V9(04).            02390000
024000     05  H-FY-BEGIN-DATE              PIC 9(08).                  02400000
024100     05  H-DISCHARGE-DATE             PIC 9(08).                  02410000
024200                                                                  02420000
024300 LINKAGE SECTION.                                                 02430000
024400**************************************************************    02440000
024500*      THIS IS THE BILL-RECORD THAT WILL BE PASSED FROM      *    02450000
024600*      THE IRCAL___ PROGRAM                                  *    02460000
024700**************************************************************    02470000
024800 01  BILL-NEW-DATA.                                               02480000
024900         10  B-NPI10.                                             02490000
025000             15  B-NPI8             PIC X(08).                    02500000
025100             15  B-NPI-FILLER       PIC X(02).                    02510000
025200         10  B-PROVIDER-NO          PIC X(06).                    02520000
025300         10  B-PATIENT-STATUS       PIC X(02).                    02530000
025400         10  B-CMG-CODE             PIC X(05).                    02540000
025500         10  B-LOS                  PIC 9(03).                    02550000
025600         10  B-COV-DAYS             PIC 9(03).                    02560000
025700         10  B-LTR-DAYS             PIC 9(02).                    02570000
025800         10  B-SPEC-PAY-IND         PIC X(01).                    02580000
025900         10  B-DISCHARGE-DATE.                                    02590000
026000             15  B-DISCHG-CC        PIC 9(02).                    02600000
026100             15  B-DISCHG-YY        PIC 9(02).                    02610000
026200             15  B-DISCHG-MM        PIC 9(02).                    02620000
026300             15  B-DISCHG-DD        PIC 9(02).                    02630000
026400         10  B-COV-CHARGES          PIC 9(07)V9(02).              02640000
026500         10  FILLER                 PIC X(11).                    02650000
026600                                                                  02660000
026700***************************************************************   02670000
026800*    THIS DATA IS CALCULATED BY THIS IRCAL SUBROUTINE         *   02680000
026900*    AND PASSED BACK TO THE CALLING PROGRAM                   *   02690000
027000*            RETURN CODE VALUES (PPS-RTC)                     *   02700000
027100*                                                             *   02710000
027200*     ****   PPS-RTC 00-49 = HOW THE BILL WAS PAID            *   02720000
027300*              00 = PAID NORMAL CMG PAYMENT WITHOUT OUTLIER   *   02730000
027400*                                                             *   02740000
027500*              01 = PAID NORMAL CMG PAYMENT WITH OUTLIER      *   02750000
027600*                                                             *   02760000
027700*              02 = TRANSFER PAID ON A PERDIEM BASIS WITHOUT  *   02770000
027800*                   OUTLIER                                   *   02780000
027900*              03 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   02790000
028000*                   OUTLIER                                   *   02800000
028100*              04 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02810000
028200*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02820000
028300*                   WITHOUT OUTLIER                           *   02830000
028400*              05 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02840000
028500*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02850000
028600*                   WITH OUTLIER                              *   02860000
028700*              06 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   02870000
028800*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   02880000
028900*                   RATE -- WITHOUT OUTLIER                   *   02890000
029000*              07 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   02900000
029100*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   02910000
029200*                   RATE -- WITH OUTLIER                      *   02920000
029300*       **** NEW RT CODES FOR PAYMENT WITH PENALTIES          *   02930000
029400*              10 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   02940000
029500*                   WITHOUT OUTLIER                           *   02950000
029600*              11 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   02960000
029700*                   WITH OUTLIER                              *   02970000
029800*              12 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   02980000
029900*                   PENALTY WITHOUT OUTLIER                   *   02990000
030000*              13 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   03000000
030100*                   PENALTY WITH OUTLIER                      *   03010000
030200*              14 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   03020000
030300*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   03030000
030400*                   WITH PENALTY WITHOUT OUTLIER              *   03040000
030500*              15 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   03050000
030600*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   03060000
030700*                   WITH PENALTY WITH OUTLIER                 *   03070000
030800*              16 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03080000
030900*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03090000
031000*                   RATE -- WITH PENALTY WITHOUT OUTLIER      *   03100000
031100*              17 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03110000
031200*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03120000
031300*                   RATE -- WITH PENALTY WITH OUTLIER         *   03130000
031400*                                                             *   03140000
031500*      ****  PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   03150000
031600*              50 = PROVIDER SPECIFIC RATE NOT NUMERIC        *   03160000
031700*              51 = PROVIDER RECORD TERMINATED                *   03170000
031800*              52 = INVALID WAGE INDEX                        *   03180000
031900*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   03190000
032000*              54 = CMG ON CLAIM NOT FOUND IN TABLE           *   03200000
032100*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   03210000
032200*                                      OR                     *   03220000
032300*                   DISCHARGE DATE < MSA EFF START DATE       *   03230000
032400*                   FOR PPS                                   *   03240000
032500*              56 = INVALID LENGTH OF STAY                    *   03250000
032600*              57 = PROVIDER SPECIFIC RATE ZERO WHEN BLENDED  *   03260000
032700*                   PAYMENT REQUESTED                         *   03270000
032800*              58 = TOTAL COVERED CHARGES NOT NUMERIC         *   03280000
032900*              59 = PROVIDER SPECIFIC RECORD NOT FOUND        *   03290000
033000*              60 = MSA WAGE INDEX RECORD NOT FOUND           *   03300000
033100*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *   03310000
033200*                   OR BILL-LTR-DAYS > 60                     *   03320000
033300*              62 = INVALID NUMBER OF COVERED DAYS            *   03330000
033400*              65 = OPERATING COST-TO-CHARGE RATIO NOT NUMERIC*   03340000
033500*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *   03350000
033600*                   OR COST OUTLIER THRESHOLD CALCULATION     *   03360000
033700*              72 = INVALID BLEND INDICATOR (NOT 3 OR 4)      *   03370000
033800*              73 = DISCHARGED BEFORE PROVIDER FY BEGIN       *   03380000
033900*              74 = PROVIDER FY BEGIN DATE NOT IN 2002        *   03390000
034000***************************************************************   03400000
034100 01  PPS-DATA-ALL.                                                03410000
034200     05  PPS-RTC                      PIC 9(02).                  03420000
034300     05  PPS-DATA.                                                03430000
034400         10  PPS-MSA                  PIC X(04).                  03440000
034500         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).            03450000
034600         10  PPS-AVG-LOS              PIC 9(02).                  03460000
034700         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).            03470000
034800         10  PPS-TOTAL-PAY-AMT        PIC 9(07)V9(02).            03480000
034900         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).            03490000
035000         10  PPS-FAC-SPEC-PAY-AMT     PIC 9(07)V9(02).            03500000
035100         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).            03510000
035200         10  PPS-LIP-PAY-AMT          PIC 9(07)V9(02).            03520000
035300         10  PPS-LIP-PCT              PIC 9(01)V9(04).            03530000
035400         10  PPS-LOS                  PIC 9(03).                  03540000
035500         10  PPS-REG-DAYS-USED        PIC 9(03).                  03550000
035600         10  PPS-LTR-DAYS-USED        PIC 9(03).                  03560000
035700         10  PPS-TRANSFER-PCT         PIC 9(01)V9(04).            03570000
035800         10  PPS-FAC-SPEC-RT-PREBLEND PIC 9(05)V9(02).            03580000
035900         10  PPS-STANDARD-PAY-AMT     PIC 9(07)V9(02).            03590000
036000         10  PPS-FAC-COSTS            PIC 9(07)V9(02).            03600000
036100         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).            03610000
036200         10  PPS-CHG-OUTLIER-THRESHOLD PIC 9(07)V9(02).           03620000
036300         10  PPS-TOTAL-PENALTY-AMT    PIC 9(07)V9(02).            03630000
036400         10  PPS-FED-PENALTY-AMT      PIC 9(07)V9(02).            03640000
036500         10  PPS-LIP-PENALTY-AMT      PIC 9(07)V9(02).            03650000
036600         10  PPS-OUT-PENALTY-AMT      PIC 9(07)V9(02).            03660000
036700         10  PPS-SUBM-CMG-CODE        PIC X(05).                  03670000
036800         10  PPS-CMG-CODE-REDEF REDEFINES PPS-SUBM-CMG-CODE.      03680000
036900            15  PPS-CMG-ALPHA         PIC X(01).                  03690000
037000            15  PPS-CMG-NUMERIC.                                  03700000
037100               20  PPS-CMG-RIC        PIC X(02).                  03710000
037200               20  FILLER             PIC X(02).                  03720000
037300         10  PPS-PRICED-CMG-CODE      PIC X(05).                  03730000
037400         10  PPS-CALC-VERS-CD         PIC X(05).                  03740000
037500         10  PPS-CBSA                 PIC X(05).                  03750000
037600         10  FILLER                   PIC X(08).                  03760000
037700     05  PPS-OTHER-DATA.                                          03770000
037800         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).            03780000
037900         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).            03790000
038000         10  PPS-NAT-THRESHOLD-ADJ    PIC 9(05)V9(02).            03800000
038100         10  PPS-BDGT-NEUT-CONV-AMT   PIC 9(05)V9(02).            03810000
038200         10  PPS-FED-RATE-PCT         PIC 9(01)V9(04).            03820000
038300         10  PPS-FAC-RATE-PCT         PIC 9(01)V9(04).            03830000
038400         10  PPS-RURAL-ADJUSTMENT     PIC 9(01)V9(04).            03840000
038500         10  PPS-TEACH-PAY-AMT        PIC 9(07)V9(02).            03850000
038600         10  PPS-TEACH-PENALTY-AMT    PIC 9(07)V9(02).            03860000
038700         10  FILLER                   PIC X(02).                  03870000
038800     05  PPS-PC-DATA.                                             03880000
038900         10  PPS-COT-IND              PIC X(01).                  03890000
039000         10  FILLER                   PIC X(20).                  03900000
039100                                                                  03910000
039200******************************************************************03920000
039300*            THESE ARE THE VERSIONS OF THE IRDRV___               03930000
039400*           PROGRAMS THAT WILL BE PASSED BACK----                 03940000
039500*          ASSOCIATED WITH THE BILL BEING PROCESSED               03950000
039600******************************************************************03960000
039700 01  PRICER-OPT-VERS-SW.                                          03970000
039800     05  PRICER-OPTION-SW          PIC X(01).                     03980000
039900         88  ALL-TABLES-PASSED          VALUE 'A'.                03990000
040000         88  PROV-RECORD-PASSED         VALUE 'P'.                04000000
040100     05  PPS-VERSIONS.                                            04010000
040200         10  PPDRV-VERSION         PIC X(05).                     04020000
040300                                                                  04030000
040400**************************************************************    04040000
040500*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BY        *    04050000
040600*      THE IRCAL___ PROGRAM                                  *    04060000
040700**************************************************************    04070000
040800 01  PROV-NEW-HOLD.                                               04080000
040900     02  PROV-NEWREC-HOLD1.                                       04090000
041000         05  P-NEW-NPI10.                                         04100000
041100             10  P-NEW-NPI8             PIC X(08).                04110000
041200             10  P-NEW-NPI-FILLER       PIC X(02).                04120000
041300         05  P-NEW-PROVIDER-NO.                                   04130000
041400             10  P-NEW-STATE            PIC 9(02).                04140000
041500             10  FILLER                 PIC X(04).                04150000
041600         05  P-NEW-DATE-DATA.                                     04160000
041700             10  P-NEW-EFF-DATE.                                  04170000
041800                 15  P-NEW-EFF-DT-CC    PIC 9(02).                04180000
041900                 15  P-NEW-EFF-DT-YY    PIC 9(02).                04190000
042000                 15  P-NEW-EFF-DT-MM    PIC 9(02).                04200000
042100                 15  P-NEW-EFF-DT-DD    PIC 9(02).                04210000
042200             10  P-NEW-FY-BEGIN-DATE.                             04220000
042300                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                04230000
042400                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                04240000
042500                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                04250000
042600                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                04260000
042700             10  P-NEW-REPORT-DATE.                               04270000
042800                 15  P-NEW-REPORT-DT-CC PIC 9(02).                04280000
042900                 15  P-NEW-REPORT-DT-YY PIC 9(02).                04290000
043000                 15  P-NEW-REPORT-DT-MM PIC 9(02).                04300000
043100                 15  P-NEW-REPORT-DT-DD PIC 9(02).                04310000
043200             10  P-NEW-TERMINATION-DATE.                          04320000
043300                 15  P-NEW-TERM-DT-CC   PIC 9(02).                04330000
043400                 15  P-NEW-TERM-DT-YY   PIC 9(02).                04340000
043500                 15  P-NEW-TERM-DT-MM   PIC 9(02).                04350000
043600                 15  P-NEW-TERM-DT-DD   PIC 9(02).                04360000
043700         05  P-NEW-WAIVER-CODE          PIC X(01).                04370000
043800             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              04380000
043900         05  P-NEW-INTER-NO             PIC 9(05).                04390000
044000         05  P-NEW-PROVIDER-TYPE        PIC X(02).                04400000
044100         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                04410000
044200         05  P-NEW-CURRENT-DIV   REDEFINES                        04420000
044300                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         04430000
044400         05  P-NEW-MSA-DATA.                                      04440000
044500             10  P-NEW-CHG-CODE-INDEX       PIC X.                04450000
044600             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 04460000
044700             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   04470000
044800                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       04480000
044900             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 04490000
045000             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 04500000
045100             10  P-NEW-STAND-AMT-LOC-MSA9                         04510000
045200                 REDEFINES P-NEW-STAND-AMT-LOC-MSA.               04520000
045300                 15  P-NEW-RURAL-1ST.                             04530000
045400                     20  P-NEW-STAND-RURAL  PIC XX.               04540000
045500                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    04550000
045600                 15  P-NEW-RURAL-2ND        PIC XX.               04560000
045700         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    04570000
045800         05  P-NEW-LUGAR                    PIC X.                04580000
045900         05  P-NEW-TEMP-RELIEF-IND          PIC X.                04590000
046000         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                04600000
046100         05  FILLER                         PIC X(05).            04610000
046200     02  PROV-NEWREC-HOLD2.                                       04620000
046300         05  P-NEW-VARIABLES.                                     04630000
046400             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        04640000
046500             10  P-NEW-COLA              PIC  9(01)V9(03).        04650000
046600             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        04660000
046700             10  P-NEW-BED-SIZE          PIC  9(05).              04670000
046800             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        04680000
046900             10  P-NEW-CMI               PIC  9(01)V9(04).        04690000
047000             10  P-NEW-SSI-RATIO         PIC  V9(04).             04700000
047100             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             04710000
047200             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              04720000
047300             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        04730000
047400             10  P-NEW-DSH-PERCENT       PIC  V9(04).             04740000
047500             10  P-NEW-FYE-DATE          PIC  X(08).              04750000
047600         05  P-NEW-CBSA-DATA.                                     04760000
047700             10  P-NEW-CBSA-SPEC-PAY-IND   PIC X.                 04770000
047800             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.                 04780000
047900             10  P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.  04790000
048000             10  P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.  04800000
048100             10  P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.  04810000
048200             10  P-NEW-CBSA-STAND-AMT-LOC9                        04820000
048300                 REDEFINES P-NEW-CBSA-STAND-AMT-LOC.              04830000
048400                 15  P-NEW-CBSA-RURAL-1ST.                        04840000
048500                     20  P-NEW-CBSA-STAND-RURAL PIC 999.          04850000
048600                 15  P-NEW-CBSA-RURAL-2ND       PIC 99.           04860000
048700             10  P-NEW-CBSA-SPEC-WAGE-INDEX     PIC 9(02)V9(04).  04870000
048800     02  PROV-NEWREC-HOLD3.                                       04880000
048900         05  P-NEW-PASS-AMT-DATA.                                 04890000
049000             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          04900000
049100             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          04910000
049200             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          04920000
049300             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          04930000
049400         05  P-NEW-CAPI-DATA.                                     04940000
049500             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 04950000
049600             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          04960000
049700             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          04970000
049800             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        04980000
049900             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             04990000
050000             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 05000000
050100             15  P-NEW-CAPI-IME            PIC 9V9999.            05010000
050200             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          05020000
050300         05  FILLER                        PIC X(22).             05030000
050400******************************************************************05040000
050500*                   THIS IS THE WAGE-INDEX                        05050000
050600*          ASSOCIATED WITH THE BILL BEING PROCESSED               05060000
050700*                                                                 05070000
050800******************************************************************05080000
050900 01  WAGE-NEW-INDEX-RECORD-CBSA.                                  05090000
051000     05  W-NEW-CBSA                    PIC X(5).                  05100000
051100*       88  VALID-RURAL-CBSA    VALUE                             05110000
051200*             '50001' '50007' '50016' '50020' '50031'             05120000
051300*             '50036' '50054' '50060' '50067' '50087'             05130000
051400*             '50089' '50091' '50092' '50100' '50104'             05140000
051500*             '50108' '50114' '50121' '50125' '50140'             05150000
051600*             '50145' '50152' '50164' '50170' '50192'             05160000
051700*             '50199' '50206' '50210' '50214' '50218'             05170000
051800*             '50222' '50225' '50226' '50231' '50234'             05180000
051900*             '50237' '50243' '50248' '50250' '50255'             05190000
052000*             '50256' '50257' '50260' '50261' '50262'             05200000
052100*             '50263' '50266' '50268' '50272' '50275'             05210000
052200*             '50281' '50286' '50293' '50313' '50314'             05220000
052300*             '50316' '50325' '50326' '50327' '50329'             05230000
052400*             '50336' '50344' '50352'.                            05240000
052500     05  W-NEW-EFF-DATE-C              PIC X(8).                  05250000
052600     05  W-NEW-WAGE-INDEX-C            PIC S9(02)V9(04).          05260000
052700                                                                  05270000
052800 PROCEDURE DIVISION  USING BILL-NEW-DATA                          05280000
052900                           PPS-DATA-ALL                           05290000
053000                           PRICER-OPT-VERS-SW                     05300000
053100                           PROV-NEW-HOLD                          05310000
053200                           WAGE-NEW-INDEX-RECORD-CBSA.            05320000
053300***************************************************************   05330000
053400*    PROCESSING:                                              *   05340000
053500*        A. WILL PROCESS CLAIMS BASED ON DISCHARGE DATE       *   05350000
053600*        B. INITIALIZE IRCAL HOLD VARIABLES.                  *   05360000
053700*        C. EDIT THE DATA PASSED FROM THE CLAIM BEFORE        *   05370000
053800*           ATTEMPTING TO CALCULATE PPS. IF THIS CLAIM        *   05380000
053900*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   05390000
054000*           GOBACK.                                           *   05400000
054100*        D. ASSEMBLE PRICING COMPONENTS.                      *   05410000
054200*        E. CALCULATE THE PRICE.                              *   05420000
054300*        F. CALCULATE OUTLIERS IF APPLICABLE.                 *   05430000
054400***************************************************************   05440000
054500                                                                  05450000
054600 0000-MAINLINE-CONTROL.                                           05460000
054700                                                                  05470000
054800     PERFORM 0100-INITIAL-ROUTINE                                 05480000
054900        THRU 0100-EXIT.                                           05490000
055000                                                                  05500000
055100     PERFORM 1000-EDIT-THE-BILL-INFO                              05510000
055200        THRU 1000-EXIT.                                           05520000
055300                                                                  05530000
055400     IF PPS-RTC = 00                                              05540000
055500        PERFORM 1700-EDIT-CMG-CODE                                05550000
055600           THRU 1700-EXIT.                                        05560000
055700                                                                  05570000
055800     IF PPS-RTC = 00                                              05580000
055900        PERFORM 2000-ASSEMBLE-PPS-VARIABLES                       05590000
056000           THRU 2000-EXIT.                                        05600000
056100                                                                  05610000
056200     IF PPS-RTC = 00                                              05620000
056300        PERFORM 3000-CALC-PAYMENT                                 05630000
056400           THRU 3000-EXIT                                         05640000
056500        PERFORM 3500-CONTINUE-CALC                                05650000
056600           THRU 3500-EXIT                                         05660000
056700        PERFORM 4000-CALC-OUTLIER                                 05670000
056800           THRU 4000-EXIT                                         05680000
056900        PERFORM 5000-FINAL-PAYMENTS                               05690000
057000           THRU 5000-EXIT.                                        05700000
057100                                                                  05710000
057200     PERFORM 9000-MOVE-RESULTS                                    05720000
057300        THRU 9000-EXIT.                                           05730000
057400                                                                  05740000
057500     GOBACK.                                                      05750000
057600                                                                  05760000
057700 0100-INITIAL-ROUTINE.                                            05770000
057800                                                                  05780000
057900     MOVE ZEROS TO PPS-RTC.                                       05790000
058000     INITIALIZE PPS-DATA.                                         05800000
058100     INITIALIZE PPS-OTHER-DATA.                                   05810000
058200     INITIALIZE HOLD-PPS-COMPONENTS.                              05820000
058300***************************************************************   05830000
058400*    UPDATE THE VALUES BELOW FOR EACH FY RELEASE              *   05840000
058500*     - VALUES PER POLICY                                     *   05850000
058600***************************************************************   05860000
058700                                                                  05870000
058800     MOVE .75818 TO PPS-NAT-LABOR-PCT.                            05880000
058900     MOVE .24182 TO PPS-NAT-NONLABOR-PCT.                         05890000
059000     MOVE 7362   TO PPS-NAT-THRESHOLD-ADJ.                        05900000
059110**   MOVE 13034  TO PPS-BDGT-NEUT-CONV-AMT.                       05911007
059120                                                                  05912007
059130*----2008.1---------------------------------------------------*   05913008
059131                                                                  05913112
059140     IF B-DISCHARGE-DATE >= '20080401'                            05914010
059141        MOVE 13034  TO PPS-BDGT-NEUT-CONV-AMT                     05914107
059142     ELSE                                                         05914207
059143        MOVE 13451  TO PPS-BDGT-NEUT-CONV-AMT                     05914307
059144     END-IF.                                                      05914407
059200                                                                  05920000
059300 0100-EXIT.                                                       05930000
059400      EXIT.                                                       05940000
059500                                                                  05950000
059600 1000-EDIT-THE-BILL-INFO.                                         05960000
059700***************************************************************   05970000
059800*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *   05980000
059900*    AND DO NOT ATTEMPT TO PRICE.                             *   05990000
060000***************************************************************   06000000
060100                                                                  06010000
060200     MOVE B-CMG-CODE TO PPS-SUBM-CMG-CODE.                        06020000
060300                                                                  06030000
060400     IF (B-LOS NUMERIC) AND (B-LOS > 0)                           06040000
060500        MOVE B-LOS TO H-LOS                                       06050000
060600     ELSE                                                         06060000
060700        IF B-LOS = 0                                              06070000
060800           MOVE 1 TO H-LOS                                        06080000
060900        ELSE                                                      06090000
061000           MOVE 56 TO PPS-RTC.                                    06100000
061100                                                                  06110000
061200     MOVE P-NEW-FY-BEGIN-DATE TO H-FY-BEGIN-DATE.                 06120000
061300     IF H-FY-BEGIN-DATE (5:2) < 11                                06130000
061400       COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 10200          06140000
061500     ELSE                                                         06150000
061600       COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 19000.         06160000
061700     MOVE B-DISCHARGE-DATE TO H-DISCHARGE-DATE.                   06170000
061800     IF (H-DISCHARGE-DATE > H-FY-BEGIN-DATE)                      06180000
061900        OR (P-NEW-FY-BEGIN-DATE > 20020930 AND                    06190000
062000            P-NEW-FY-BEGIN-DATE < 20030101)                       06200000
062100        MOVE '4' TO P-NEW-FED-PPS-BLEND-IND.                      06210000
062200     IF P-NEW-FY-BEGIN-DATE > 20011231                            06220000
062300        IF (P-NEW-FY-BEGIN-DATE <= B-DISCHARGE-DATE)              06230000
062400           IF P-NEW-FED-PPS-BLEND-IND = '4'                       06240000
062500              MOVE 1.0000 TO PPS-FED-RATE-PCT                     06250000
062600              MOVE 0.0000 TO PPS-FAC-RATE-PCT                     06260000
062700           ELSE                                                   06270000
062800             IF P-NEW-FED-PPS-BLEND-IND = '3'                     06280000
062900                MOVE .6667 TO PPS-FED-RATE-PCT                    06290000
063000                MOVE .3333 TO PPS-FAC-RATE-PCT                    06300000
063100             ELSE                                                 06310000
063200               MOVE 72 TO PPS-RTC                                 06320000
063300        ELSE                                                      06330000
063400           MOVE 73 TO PPS-RTC                                     06340000
063500     ELSE                                                         06350000
063600        MOVE 74 TO PPS-RTC.                                       06360000
063700                                                                  06370000
063800     IF PPS-RTC = 00                                              06380000
063900       IF P-NEW-WAIVER-STATE                                      06390000
064000          MOVE 53 TO PPS-RTC.                                     06400000
064100                                                                  06410000
064200     IF PPS-RTC = 00                                              06420000
064300         IF ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR               06430000
064400            (B-DISCHARGE-DATE < W-NEW-EFF-DATE-C))                06440000
064500            MOVE 55 TO PPS-RTC.                                   06450000
064600                                                                  06460000
064700     IF PPS-RTC = 00                                              06470000
064800         IF P-NEW-TERMINATION-DATE > 00000000                     06480000
064900            IF B-DISCHARGE-DATE >= P-NEW-TERMINATION-DATE         06490000
065000               MOVE 51 TO PPS-RTC.                                06500000
065100                                                                  06510000
065200     IF PPS-RTC = 00                                              06520000
065300         IF B-COV-CHARGES NOT NUMERIC                             06530000
065400            MOVE 58 TO PPS-RTC.                                   06540000
065500                                                                  06550000
065600     IF PPS-RTC = 00                                              06560000
065700        IF B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60              06570000
065800           MOVE 61 TO PPS-RTC                                     06580000
065900        ELSE                                                      06590000
066000           MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.                  06600000
066100                                                                  06610000
066200     IF PPS-RTC = 00                                              06620000
066300        IF B-COV-DAYS NOT NUMERIC                                 06630000
066400             MOVE 62 TO PPS-RTC                                   06640000
066500        ELSE                                                      06650000
066600          IF B-COV-DAYS = 0 AND H-LOS > 0                         06660000
066700             MOVE 62 TO PPS-RTC.                                  06670000
066800                                                                  06680000
066900     IF PPS-RTC = 00                                              06690000
067000        IF B-LTR-DAYS  > B-COV-DAYS                               06700000
067100           MOVE 62 TO PPS-RTC                                     06710000
067200        ELSE                                                      06720000
067300           COMPUTE PPS-REG-DAYS-USED = B-COV-DAYS - B-LTR-DAYS.   06730000
067400                                                                  06740000
067500     IF PPS-RTC = 00                                              06750000
067600        IF PPS-REG-DAYS-USED > 0                                  06760000
067700           IF PPS-REG-DAYS-USED > H-LOS                           06770000
067800              MOVE H-LOS TO PPS-REG-DAYS-USED                     06780000
067900           ELSE                                                   06790000
068000              NEXT SENTENCE                                       06800000
068100        ELSE                                                      06810000
068200           IF B-LTR-DAYS > H-LOS                                  06820000
068300              MOVE H-LOS TO PPS-LTR-DAYS-USED                     06830000
068400           ELSE                                                   06840000
068500              MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.               06850000
068600                                                                  06860000
068700 1000-EXIT.                                                       06870000
068800      EXIT.                                                       06880000
068900                                                                  06890000
069000***************************************************************   06900000
069100*    FINDS THE CMG CODE IN THE TABLE                          *   06910000
069200***************************************************************   06920000
069300 1700-EDIT-CMG-CODE.                                              06930000
069400                                                                  06940000
069401*------------------ 2008.2---------------------------------------*06940107
069402                                                                  06940212
069410     IF PPS-CMG-NUMERIC = '9999'                                  06941007
069420        NEXT SENTENCE                                             06942007
069430     ELSE                                                         06943007
069500        IF PPS-CMG-NUMERIC < '2103'                               06950007
069600           NEXT SENTENCE                                          06960007
069700        ELSE                                                      06970007
069800           MOVE 54 TO PPS-RTC.                                    06980007
069900                                                                  06990000
070000     IF PPS-RTC = 00                                              07000000
070100        SEARCH ALL CMG-DATA                                       07010000
070200           AT END                                                 07020000
070300             MOVE 54 TO PPS-RTC                                   07030000
070400        WHEN CMG-NUM (DX6) = PPS-CMG-NUMERIC                      07040000
070500             PERFORM 1750-FIND-VALUE                              07050000
070600                THRU 1750-EXIT                                    07060000
070700        END-SEARCH.                                               07070000
070800                                                                  07080000
070900 1700-EXIT.                                                       07090000
071000      EXIT.                                                       07100000
071100                                                                  07110000
071200***************************************************************   07120000
071300*    FINDS THE VALUE IN THE CMG CODE IN THE TABLE             *   07130000
071400***************************************************************   07140000
071500 1750-FIND-VALUE.                                                 07150000
071600                                                                  07160000
071700      IF PPS-CMG-ALPHA = 'A'                                      07170000
071800         MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                 07180000
071900         MOVE A-LOS-TABLE (DX6) TO PPS-AVG-LOS                    07190000
072000      ELSE                                                        07200000
072100         IF PPS-CMG-ALPHA = 'B'                                   07210000
072200            MOVE B-REL-WGT (DX6) TO PPS-RELATIVE-WGT              07220000
072300            MOVE B-LOS-TABLE (DX6) TO PPS-AVG-LOS                 07230000
072400         ELSE                                                     07240000
072500            IF PPS-CMG-ALPHA = 'C'                                07250000
072600               MOVE C-REL-WGT (DX6) TO PPS-RELATIVE-WGT           07260000
072700               MOVE C-LOS-TABLE (DX6) TO PPS-AVG-LOS              07270000
072800            ELSE                                                  07280000
072900               IF PPS-CMG-ALPHA = 'D'                             07290000
073000                  MOVE D-REL-WGT (DX6) TO PPS-RELATIVE-WGT        07300000
073100                  MOVE D-LOS-TABLE (DX6) TO PPS-AVG-LOS           07310000
073200               ELSE                                               07320000
073300                  MOVE 54 TO PPS-RTC.                             07330000
073400                                                                  07340000
073500 1750-EXIT.                                                       07350000
073600      EXIT.                                                       07360000
073700                                                                  07370000
073800***************************************************************   07380000
073900*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *   07390000
074000*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   07400000
074100*    OF THAT VARIABLE.                                        *   07410000
074200***************************************************************   07420000
074300***  GET THE PROVIDER SPECIFIC VARIABLE AND WAGE INDEX            07430000
074400***************************************************************   07440000
074500 2000-ASSEMBLE-PPS-VARIABLES.                                     07450000
074600                                                                  07460000
074700     IF P-NEW-FAC-SPEC-RATE NUMERIC                               07470000
074800        MOVE P-NEW-FAC-SPEC-RATE TO PPS-FAC-SPEC-RT-PREBLEND      07480000
074900     ELSE                                                         07490000
075000        MOVE 50 TO PPS-RTC                                        07500000
075100        GO TO 2000-EXIT.                                          07510000
075200                                                                  07520000
075300     IF P-NEW-FED-PPS-BLEND-IND = '3'                             07530000
075400        IF PPS-FAC-SPEC-RT-PREBLEND = 0                           07540000
075500          MOVE 57 TO PPS-RTC                                      07550000
075600          GO TO 2000-EXIT.                                        07560000
075700                                                                  07570000
075800     IF W-NEW-WAGE-INDEX-C NUMERIC                                07580000
075900            AND W-NEW-WAGE-INDEX-C > 0                            07590000
076000        MOVE W-NEW-WAGE-INDEX-C TO PPS-WAGE-INDEX                 07600000
076100     ELSE                                                         07610000
076200        MOVE 52 TO PPS-RTC                                        07620000
076300        GO TO 2000-EXIT.                                          07630000
076400                                                                  07640000
076500     IF P-NEW-OPER-CSTCHG-RATIO NOT NUMERIC                       07650000
076600        MOVE 65 TO PPS-RTC.                                       07660000
076700                                                                  07670000
076800 2000-EXIT.                                                       07680000
076900      EXIT.                                                       07690000
077000                                                                  07700000
077100***************************************************************   07710000
077200*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *   07720000
077300*        CALCULATE THE FEDERAL PORTION.                       *   07730000
077400*        CALCULATE THE HOSPITAL PORTION.                      *   07740000
077500*        CALCULATE THE COST-OUTLIER PORTION.                  *   07750000
077600*        CALCULATE THE LIP ADJUSTMENT PERCENTAGE.             *   07760000
077700***************************************************************   07770000
077800 3000-CALC-PAYMENT.                                               07780000
077900                                                                  07790000
078000***  LIP PERCENTAGE CALCULATION *******************************   07800000
078100                                                                  07810000
078200      COMPUTE H-WK-DSH = (P-NEW-SSI-RATIO                         07820000
078300                           + P-NEW-MEDICAID-RATIO).               07830000
078400                                                                  07840000
078500      COMPUTE PPS-LIP-PCT ROUNDED =                               07850000
078600            ((1 + H-WK-DSH) ** .6229) - 1.                        07860000
078700                                                                  07870000
078800      COMPUTE H-TEACH-PCT ROUNDED =                               07880000
078900            ((1 + P-NEW-CAPI-IME) ** .9012) - 1.                  07890000
079000                                                                  07900000
079100***************************************************************   07910000
079200                                                                  07920000
079300     MOVE 1.0000 TO PPS-TRANSFER-PCT.                             07930000
079400                                                                  07940000
079500     IF B-PATIENT-STATUS =                                        07950000
079600         ('02' OR '03' OR '61' OR '62' OR '63' OR '64')           07960000
079700        IF H-LOS < PPS-AVG-LOS                                    07970000
079800           COMPUTE PPS-TRANSFER-PCT =                             07980000
079900               ((H-LOS + .5) / PPS-AVG-LOS)                       07990000
080000           MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE          08000000
080100           GO TO 3000-EXIT.                                       08010000
080200                                                                  08020000
080300     IF H-LOS > 3                                                 08030000
080400        NEXT SENTENCE                                             08040000
080500     ELSE                                                         08050000
080600        MOVE 'A5001' TO PPS-PRICED-CMG-CODE                       08060000
080700        SET DX6 TO 88                                             08070000
080800        MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                  08080000
080900        GO TO 3000-EXIT.                                          08090000
081000                                                                  08100000
081100     IF B-PATIENT-STATUS = '20'                                   08110000
081200        NEXT SENTENCE                                             08120000
081300     ELSE                                                         08130000
081400        MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE             08140000
081500        GO TO 3000-EXIT.                                          08150000
081600                                                                  08160000
081700     IF PPS-CMG-RIC = ('07' OR '08' OR '09')                      08170000
081800        IF H-LOS < 14                                             08180000
081900           MOVE 'A5101' TO PPS-PRICED-CMG-CODE                    08190000
082000           SET DX6 TO 89                                          08200000
082100           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08210000
082200        ELSE                                                      08220000
082300           MOVE 'A5102' TO PPS-PRICED-CMG-CODE                    08230000
082400           SET DX6 TO 90                                          08240000
082500           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08250000
082600     ELSE                                                         08260000
082700        IF H-LOS < 16                                             08270000
082800           MOVE 'A5103' TO PPS-PRICED-CMG-CODE                    08280000
082900           SET DX6 TO 91                                          08290000
083000           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08300000
083100        ELSE                                                      08310000
083200           MOVE 'A5104' TO PPS-PRICED-CMG-CODE                    08320000
083300           SET DX6 TO 92                                          08330000
083400           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT.              08340000
083500                                                                  08350000
083600 3000-EXIT.                                                       08360000
083700      EXIT.                                                       08370000
083800                                                                  08380000
083900 3500-CONTINUE-CALC.                                              08390000
084000                                                                  08400000
084100     COMPUTE PPS-STANDARD-PAY-AMT =                               08410000
084200            (PPS-TRANSFER-PCT * PPS-RELATIVE-WGT                  08420000
084300                      * PPS-BDGT-NEUT-CONV-AMT).                  08430000
084400                                                                  08440000
084500***************************************************************   08450000
084600*      CHANGE RURAL ADJUSTMENT AMOUNT IF NECESSARY            *   08460000
084700*      - PER CHANGE REQUEST                                   *   08470000
084800***************************************************************   08480000
084900     IF W-NEW-CBSA (1:3) = '   '                                  08490000
085000        MOVE 1.2130 TO PPS-RURAL-ADJUSTMENT                       08500000
085100     ELSE                                                         08510000
085200        MOVE 1.0000 TO PPS-RURAL-ADJUSTMENT.                      08520000
085300                                                                  08530000
085400***************************************************************   08540000
085500*      CHANGE RURAL ADJUSTMENT BASED ON RELIEF INDICATOR      *   08550000
085600*       IF NECESSARY - PER CHANGE REQUEST                     *   08560000
085700***************************************************************   08570000
085710** REMOVED FOR 2008 RELEASE                                       08571001
085800**   IF P-NEW-TEMP-RELIEF-IND = 'Y'                               08580001
085900**      MOVE 1.0638 TO PPS-RURAL-ADJUSTMENT.                      08590001
086000                                                                  08600000
086100     COMPUTE H-LABOR-PORTION =                                    08610000
086200        (PPS-STANDARD-PAY-AMT * PPS-NAT-LABOR-PCT)                08620000
086300          * PPS-WAGE-INDEX.                                       08630000
086400                                                                  08640000
086500     COMPUTE H-NONLABOR-PORTION =                                 08650000
086600        (PPS-STANDARD-PAY-AMT * PPS-NAT-NONLABOR-PCT).            08660000
086700                                                                  08670000
086800     COMPUTE PPS-FED-PAY-AMT ROUNDED =                            08680000
086900        ((H-LABOR-PORTION + H-NONLABOR-PORTION) *                 08690000
087000         PPS-RURAL-ADJUSTMENT).                                   08700000
087100                                                                  08710000
087200     COMPUTE PPS-LIP-PAY-AMT ROUNDED =                            08720000
087300        (PPS-FED-PAY-AMT * PPS-LIP-PCT).                          08730000
087400                                                                  08740000
087500     COMPUTE PPS-TEACH-PAY-AMT ROUNDED =                          08750000
087600        (PPS-FED-PAY-AMT * H-TEACH-PCT).                          08760000
087700                                                                  08770000
087800 3500-EXIT.                                                       08780000
087900      EXIT.                                                       08790000
088000                                                                  08800000
088100 4000-CALC-OUTLIER.                                               08810000
088200                                                                  08820000
088300     COMPUTE PPS-FAC-COSTS ROUNDED =                              08830000
088400         (B-COV-CHARGES * P-NEW-OPER-CSTCHG-RATIO).               08840000
088500                                                                  08850000
088600     COMPUTE H-OUTLIER-LABOR-PORTION =                            08860000
088700        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-LABOR-PCT)               08870000
088800              * PPS-WAGE-INDEX.                                   08880000
088900                                                                  08890000
089000     COMPUTE H-OUTLIER-NONLABOR-PORTION =                         08900000
089100        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-NONLABOR-PCT).           08910000
089200                                                                  08920000
089300     COMPUTE H-FP-OUTLIER-THRESHOLD ROUNDED =                     08930000
089400        ((H-OUTLIER-LABOR-PORTION + H-OUTLIER-NONLABOR-PORTION) * 08940000
089500         PPS-RURAL-ADJUSTMENT * (PPS-LIP-PCT + H-TEACH-PCT + 1)). 08950000
089600                                                                  08960000
089700     COMPUTE H-OUTLIER-THRESHOLD ROUNDED =                        08970000
089800        (PPS-FED-PAY-AMT + H-FP-OUTLIER-THRESHOLD +               08980000
089900         PPS-LIP-PAY-AMT + PPS-TEACH-PAY-AMT).                    08990000
090000                                                                  09000000
090100     IF PPS-FAC-COSTS > H-OUTLIER-THRESHOLD                       09010000
090200        COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                     09020000
090300           ((PPS-FAC-COSTS - H-OUTLIER-THRESHOLD) * .8).          09030000
090400                                                                  09040000
090500     COMPUTE H-CHG-OUTLIER-THRESHOLD ROUNDED =                    09050000
090600         H-OUTLIER-THRESHOLD / P-NEW-OPER-CSTCHG-RATIO.           09060000
090700                                                                  09070000
090800                                                                  09080000
090900 4000-EXIT.                                                       09090000
091000      EXIT.                                                       09100000
091100                                                                  09110000
091200 5000-FINAL-PAYMENTS.                                             09120000
091300                                                                  09130000
091400     IF B-SPEC-PAY-IND = '1' OR '3'                               09140000
091500         MOVE ZEROES TO PPS-OUTLIER-PAY-AMT.                      09150000
091600                                                                  09160000
091700     IF PPS-FED-RATE-PCT = 1.0000                                 09170000
091800         MOVE 0 TO PPS-FAC-SPEC-PAY-AMT                           09180000
091900     ELSE                                                         09190000
092000         COMPUTE PPS-FED-PAY-AMT ROUNDED =                        09200000
092100           (PPS-FED-RATE-PCT * PPS-FED-PAY-AMT)                   09210000
092200         COMPUTE PPS-FAC-SPEC-PAY-AMT ROUNDED =                   09220000
092300           (PPS-FAC-RATE-PCT * PPS-FAC-SPEC-RT-PREBLEND)          09230000
092400         COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                    09240000
092500           (PPS-FED-RATE-PCT * PPS-OUTLIER-PAY-AMT)               09250000
092600         COMPUTE PPS-TEACH-PAY-AMT ROUNDED =                      09260000
092700           (PPS-FED-RATE-PCT * PPS-TEACH-PAY-AMT)                 09270000
092800         COMPUTE PPS-LIP-PAY-AMT ROUNDED =                        09280000
092900           (PPS-FED-RATE-PCT * PPS-LIP-PAY-AMT).                  09290000
093000                                                                  09300000
093100     IF B-SPEC-PAY-IND = '2' OR '3'                               09310000
093200        COMPUTE PPS-FED-PENALTY-AMT ROUNDED =                     09320000
093300           (PPS-FED-PAY-AMT * .25)                                09330000
093400        COMPUTE PPS-FED-PAY-AMT =                                 09340000
093500           (PPS-FED-PAY-AMT - PPS-FED-PENALTY-AMT)                09350000
093600        COMPUTE PPS-LIP-PENALTY-AMT ROUNDED =                     09360000
093700           (PPS-LIP-PAY-AMT * .25)                                09370000
093800        COMPUTE PPS-LIP-PAY-AMT =                                 09380000
093900           (PPS-LIP-PAY-AMT - PPS-LIP-PENALTY-AMT)                09390000
094000        COMPUTE PPS-OUT-PENALTY-AMT ROUNDED =                     09400000
094100           (PPS-OUTLIER-PAY-AMT * .25)                            09410000
094200        COMPUTE PPS-OUTLIER-PAY-AMT =                             09420000
094300           (PPS-OUTLIER-PAY-AMT - PPS-OUT-PENALTY-AMT)            09430000
094400        COMPUTE PPS-TEACH-PENALTY-AMT ROUNDED =                   09440000
094500           (PPS-TEACH-PAY-AMT * .25)                              09450000
094600        COMPUTE PPS-TEACH-PAY-AMT =                               09460000
094700           (PPS-TEACH-PAY-AMT - PPS-TEACH-PENALTY-AMT)            09470000
094800        COMPUTE PPS-TOTAL-PENALTY-AMT =                           09480000
094900           (PPS-FED-PENALTY-AMT + PPS-LIP-PENALTY-AMT             09490000
095000           + PPS-OUT-PENALTY-AMT + PPS-TEACH-PENALTY-AMT).        09500000
095100                                                                  09510000
095200     COMPUTE PPS-TOTAL-PAY-AMT ROUNDED =                          09520000
095300        (PPS-FED-PAY-AMT + PPS-FAC-SPEC-PAY-AMT                   09530000
095400         + PPS-OUTLIER-PAY-AMT + PPS-LIP-PAY-AMT +                09540000
095500         PPS-TEACH-PAY-AMT).                                      09550000
095600                                                                  09560000
095700     IF PPS-FED-RATE-PCT = 1.0000                                 09570000
095800        IF PPS-TRANSFER-PCT = 1.0000                              09580000
095900           IF PPS-OUTLIER-PAY-AMT > 0.0                           09590000
096000              MOVE 01 TO PPS-RTC                                  09600000
096100           ELSE                                                   09610000
096200              MOVE 00 TO PPS-RTC                                  09620000
096300        ELSE                                                      09630000
096400           IF PPS-OUTLIER-PAY-AMT > 0.0                           09640000
096500              MOVE 03 TO PPS-RTC                                  09650000
096600           ELSE                                                   09660000
096700              MOVE 02 TO PPS-RTC                                  09670000
096800     ELSE                                                         09680000
096900        IF PPS-TRANSFER-PCT = 1.0000                              09690000
097000           IF PPS-OUTLIER-PAY-AMT > 0.0                           09700000
097100              MOVE 05 TO PPS-RTC                                  09710000
097200           ELSE                                                   09720000
097300              MOVE 04 TO PPS-RTC                                  09730000
097400        ELSE                                                      09740000
097500           IF PPS-OUTLIER-PAY-AMT > 0.0                           09750000
097600              MOVE 07 TO PPS-RTC                                  09760000
097700           ELSE                                                   09770000
097800              MOVE 06 TO PPS-RTC.                                 09780000
097900                                                                  09790000
098000     IF B-SPEC-PAY-IND = '2' OR '3'                               09800000
098100        COMPUTE PPS-RTC = PPS-RTC + 10.                           09810000
098200     IF PPS-RTC = (01 OR 03 OR 05 OR 07                           09820000
098300                OR 11 OR 13 OR 15 OR 17)                          09830000
098400        IF ((PPS-REG-DAYS-USED + PPS-LTR-DAYS-USED) < H-LOS)      09840000
098500           OR PPS-COT-IND = 'Y'                                   09850000
098600            MOVE 67 TO PPS-RTC.                                   09860000
098700                                                                  09870000
098800 5000-EXIT.                                                       09880000
098900      EXIT.                                                       09890000
099000                                                                  09900000
099100 9000-MOVE-RESULTS.                                               09910000
099200                                                                  09920000
099300     IF PPS-RTC < 50                                              09930000
099400      MOVE H-LOS                   TO  PPS-LOS                    09940000
099500      MOVE H-OUTLIER-THRESHOLD     TO  PPS-OUTLIER-THRESHOLD      09950000
099600      MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD   09960000
099700      MOVE W-NEW-CBSA              TO  PPS-CBSA                   09970000
099800      MOVE 'V08.0'                 TO  PPS-CALC-VERS-CD           09980006
099900     ELSE                                                         09990000
100000       INITIALIZE PPS-DATA                                        10000000
100100       INITIALIZE PPS-OTHER-DATA                                  10010000
100200       MOVE 'V08.0'                TO  PPS-CALC-VERS-CD.          10020006
100300                                                                  10030000
100400     IF PPS-RTC = 67                                              10040000
100500       MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD. 10050000
100600                                                                  10060000
100700 9000-EXIT.                                                       10070000
100800      EXIT.                                                       10080000
100900                                                                  10090000
101000******        L A S T   S O U R C E   S T A T E M E N T   *****   10100000
