000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.    IRCAL160.                                         00020000
000300*AUTHOR.        PBG/DDS.                                          00030000
000400*REMARKS.       CMS.                                              00040000
000500                                                                  00050000
000600 DATE-COMPILED.                                                   00060000
000610******************************************************************00061000
000611*    V170 - ADDED 193096 TO RURAL-TO-URBAN PROVIDERS             *00061100
000612******************************************************************00061200
000613* CHANGES FOR 2016 - EFFECTIVE 10/01/2015                        *00061300
000614*                                                                *00061400
000615* UPDATED CMG-TABLE                                              *00061500
000616*                                                                *00061600
000617* UPDATED 0100-INITIAL-ROUTINE                                   *00061700
000618*                                                                *00061800
000619*   MOVE .71000 TO PPS-NAT-LABOR-PCT.                            *00061900
000620*   MOVE .29000 TO PPS-NAT-NONLABOR-PCT.                         *00062000
000630*   MOVE  8658  TO PPS-NAT-THRESHOLD-ADJ.                        *00063000
000631*   IF P-NEW-CBSA-HOSP-QUAL-IND IS EQUAL TO '1'                  *00063100
000632*      MOVE 15478  TO PPS-BDGT-NEUT-CONV-AMT                     *00063200
000633*   ELSE                                                         *00063300
000634*      MOVE 15174  TO PPS-BDGT-NEUT-CONV-AMT                     *00063400
000635*   END-IF.                                                      *00063500
000636*                                                                *00063600
000637* UPDATED 3000-CALC-PAYMENT                                      *00063700
000638*   NO CHANGE TO LOW INCOME PATIENT (LIP) ADJ = 0.3177           *00063800
000639*   NO CHANGE TO TEACHING ADJ = 1.10163                          *00063900
000640*                                                                *00064000
000641* ADDED   3510-CHECK-RURAL-ADJ                                   *00064100
000642*   CHECK FOR RURAL-TO-URBAN PROVIDER                            *00064200
000643*                                                                *00064300
000644******************************************************************00064400
000645     EJECT                                                        00064500
000646 ENVIRONMENT DIVISION.                                            00064600
000647 CONFIGURATION SECTION.                                           00064700
000648 SOURCE-COMPUTER.            IBM-370.                             00064800
000649 OBJECT-COMPUTER.            IBM-370.                             00064900
000650 INPUT-OUTPUT  SECTION.                                           00065000
000660 FILE-CONTROL.                                                    00066000
000670                                                                  00067000
000671 DATA DIVISION.                                                   00067100
000672 FILE SECTION.                                                    00067200
000673                                                                  00067300
000674 WORKING-STORAGE SECTION.                                         00067400
000675 01  W-STORAGE-REF                  PIC X(46)  VALUE              00067500
000676     'IRCAL160      - W O R K I N G   S T O R A G E'.             00067600
000677 01  CAL-VERSION                    PIC X(05)  VALUE 'V16.0'.     00067700
000678     EJECT                                                        00067800
000679 COPY R2UIRFS.                                                    00067901
000680     EJECT                                                        00068000
000690***************************************************************   00069000
000700*    LAYUP TABLE AREA FOR FY2016 CMGS                         *   00070000
000800***************************************************************   00080000
000900 01  CMG-TABLE.                                                   00090000
001000     05  CMG-TABLE-DATA.                                          00100000
001100         10                      PIC X(32)   VALUE                00110000
001200           '01010808007077065890630410090908'.                    00120000
001300         10                      PIC X(32)   VALUE                00130000
001400           '01021016508904082900793111101010'.                    00140000
001500         10                      PIC X(32)   VALUE                00150000
001510           '01031142810010093200891612131211'.                    00151000
001520         10                      PIC X(32)   VALUE                00152000
001530           '01041234910817100710963513131212'.                    00153000
001540         10                      PIC X(32)   VALUE                00154000
001550           '01051449412696118201130914151414'.                    00155000
001551         10                      PIC X(32)   VALUE                00155100
001552           '01061616014155131791260916161515'.                    00155200
001553         10                      PIC X(32)   VALUE                00155300
001554           '01071810115855147621412218171717'.                    00155400
001555         10                      PIC X(32)   VALUE                00155500
001556           '01082297820126187391792723232121'.                    00155600
001557         10                      PIC X(32)   VALUE                00155700
001558           '01092095318353170881634821201919'.                    00155800
001559         10                      PIC X(32)   VALUE                00155900
001560           '01102760224177225112153628272424'.                    00156000
001561         10                      PIC X(32)   VALUE                00156100
001562           '02010801206584059410561309090808'.                    00156200
001563         10                      PIC X(32)   VALUE                00156300
001564           '02021053508656078120738011111009'.                    00156400
001565         10                      PIC X(32)   VALUE                00156500
001566           '02031205609906089400844511131011'.                    00156600
001567         10                      PIC X(32)   VALUE                00156700
001568           '02041329210922098560931113131212'.                    00156800
001569         10                      PIC X(32)   VALUE                00156900
001570           '02051590013064117901113815161413'.                    00157000
001571         10                      PIC X(32)   VALUE                00157100
001572           '02061896215580140601328217181716'.                    00157200
001573         10                      PIC X(32)   VALUE                00157300
001574           '02072523820737187141767930242019'.                    00157400
001575         10                      PIC X(32)   VALUE                00157500
001576           '03011117109325085510797910111010'.                    00157600
001577         10                      PIC X(32)   VALUE                00157700
001578           '03021386711576106150990613131212'.                    00157800
001579         10                      PIC X(32)   VALUE                00157900
001580           '03031615913489123701154316151414'.                    00158000
001581         10                      PIC X(32)   VALUE                00158100
001582           '03042149317942164531535322201817'.                    00158200
001583         10                      PIC X(32)   VALUE                00158300
001584           '04010969608252075570698510100909'.                    00158400
001585         10                      PIC X(32)   VALUE                00158500
001586           '04021421712100110811024214141313'.                    00158600
001587         10                      PIC X(32)   VALUE                00158700
001588           '04032268419306176791634228222019'.                    00158800
001589         10                      PIC X(32)   VALUE                00158900
001590           '04043972033805309572861547373334'.                    00159000
001591         10                      PIC X(32)   VALUE                00159100
001592           '04053541530141276022551443392827'.                    00159200
001593         10                      PIC X(32)   VALUE                00159300
001594           '05010867206911064170589009070808'.                    00159400
001595         10                      PIC X(32)   VALUE                00159500
001596           '05021139309079084300773811111010'.                    00159600
001597         10                      PIC X(32)   VALUE                00159700
001598           '05031441911491106690979414131312'.                    00159800
001599         10                      PIC X(32)   VALUE                00159900
001600           '05041655513192122491124415161413'.                    00160000
001601         10                      PIC X(32)   VALUE                00160100
001602           '05051934615417143151314019171616'.                    00160200
001603         10                      PIC X(32)   VALUE                00160300
001604           '05062719721673201231847227242221'.                    00160400
001605         10                      PIC X(32)   VALUE                00160500
001606           '06011041208216076670692810100909'.                    00160600
001607         10                      PIC X(32)   VALUE                00160700
001608           '06021333910525098220887512121111'.                    00160800
001609         10                      PIC X(32)   VALUE                00160900
001610           '06031658113083122091103115141313'.                    00161000
001611         10                      PIC X(32)   VALUE                00161100
001612           '06042176717175160281448220181716'.                    00161200
001613         10                      PIC X(32)   VALUE                00161300
001614           '07010965908088076600695811090909'.                    00161400
001615         10                      PIC X(32)   VALUE                00161500
001616           '07021252910491099360902513121211'.                    00161600
001617         10                      PIC X(32)   VALUE                00161700
001618           '07031502212579119131082114141413'.                    00161800
001619         10                      PIC X(32)   VALUE                00161900
001620           '07041953416357154921407118181716'.                    00162000
001621         10                      PIC X(32)   VALUE                00162100
001622           '08010803406328057410530208080707'.                    00162200
001623         10                      PIC X(32)   VALUE                00162300
001624           '08021056108318075470697010100909'.                    00162400
001625         10                      PIC X(32)   VALUE                00162500
001626           '08031424511220101800940113131211'.                    00162600
001627         10                      PIC X(32)   VALUE                00162700
001628           '08041273910033091030840712111110'.                    00162800
001629         10                      PIC X(32)   VALUE                00162900
001630           '08051535512094109731013415141212'.                    00163000
001631         10                      PIC X(32)   VALUE                00163100
001632           '08061908315031136371259417161514'.                    00163200
001633         10                      PIC X(32)   VALUE                00163300
001634           '09010956307692070500642610090908'.                    00163400
001635         10                      PIC X(32)   VALUE                00163500
001636           '09021271410226093720854413121111'.                    00163600
001637         10                      PIC X(32)   VALUE                00163700
001638           '09031587612770117041066915141313'.                    00163800
001639         10                      PIC X(32)   VALUE                00163900
001640           '09042006016135147881348019181616'.                    00164000
001641         10                      PIC X(32)   VALUE                00164100
001642           '10011068409367083410752611111010'.                    00164200
001643         10                      PIC X(32)   VALUE                00164300
001644           '10021334911704104210940413131211'.                    00164400
001645         10                      PIC X(32)   VALUE                00164500
001646           '10031916016798149581349718191716'.                    00164600
001647         10                      PIC X(32)   VALUE                00164700
001648           '11011393313933110681040014141212'.                    00164800
001649         10                      PIC X(32)   VALUE                00164900
001650           '11021811918119143931352416201516'.                    00165000
001651         10                      PIC X(32)   VALUE                00165100
001652           '12010986309576087200813509111010'.                    00165200
001653         10                      PIC X(32)   VALUE                00165300
001654           '12021210711755107040998612141312'.                    00165400
001655         10                      PIC X(32)   VALUE                00165500
001656           '12031493414500132031231814161514'.                    00165600
001657         10                      PIC X(32)   VALUE                00165700
001658           '13011179109716091610836509111010'.                    00165800
001659         10                      PIC X(32)   VALUE                00165900
001660           '13021494612315116121060314141313'.                    00166000
001661         10                      PIC X(32)   VALUE                00166100
001662           '13031962516171152481392321181616'.                    00166200
001663         10                      PIC X(32)   VALUE                00166300
001664           '14010906907453067400606509090808'.                    00166400
001665         10                      PIC X(32)   VALUE                00166500
001666           '14021201809877089320803711111110'.                    00166600
001667         10                      PIC X(32)   VALUE                00166700
001668           '14031447511896107570968013131212'.                    00166800
001669         10                      PIC X(32)   VALUE                00166900
001670           '14041837115098136531228617171514'.                    00167000
001671         10                      PIC X(32)   VALUE                00167100
001672           '15011052608479078070751211100909'.                    00167200
001673         10                      PIC X(32)   VALUE                00167300
001674           '15021334910754099010952712121111'.                    00167400
001675         10                      PIC X(32)   VALUE                00167500
001676           '15031615013010119781152615131313'.                    00167600
001677         10                      PIC X(32)   VALUE                00167700
001678           '15042006316163148811431921171515'.                    00167800
001679         10                      PIC X(32)   VALUE                00167900
001680           '16011137608365082180755611101009'.                    00168000
001681         10                      PIC X(32)   VALUE                00168100
001682           '16021494010985107920992314131212'.                    00168200
001683         10                      PIC X(32)   VALUE                00168300
001684           '16031910914050138031269215151515'.                    00168400
001685         10                      PIC X(32)   VALUE                00168500
001686           '17011070509081082860771110101109'.                    00168600
001687         10                      PIC X(32)   VALUE                00168700
001688           '17021389711788107561001013141212'.                    00168800
001689         10                      PIC X(32)   VALUE                00168900
001690           '17031591313498123171146319151414'.                    00169000
001691         10                      PIC X(32)   VALUE                00169100
001692           '17042089117721161691504821201817'.                    00169200
001693         10                      PIC X(32)   VALUE                00169300
001694           '18011278309685088490787414121110'.                    00169400
001695         10                      PIC X(32)   VALUE                00169500
001696           '18021880714248130191158418171514'.                    00169600
001697         10                      PIC X(32)   VALUE                00169700
001698           '18033093323435214131905432272221'.                    00169800
001699         10                      PIC X(32)   VALUE                00169900
001700           '19011182610281099980874116111211'.                    00170000
001701         10                      PIC X(32)   VALUE                00170100
001702           '19022240819481189451656326222120'.                    00170200
001703         10                      PIC X(32)   VALUE                00170300
001704           '19033747932583316872770352322732'.                    00170400
001705         10                      PIC X(32)   VALUE                00170500
001706           '20010925207603070130634809090908'.                    00170600
001707         10                      PIC X(32)   VALUE                00170700
001708           '20021200209863090970823411111010'.                    00170800
001709         10                      PIC X(32)   VALUE                00170900
001710           '20031494312280113271025314141312'.                    00171000
001711         10                      PIC X(32)   VALUE                00171100
001712           '20041924315814145861320318181615'.                    00171200
001713         10                      PIC X(32)   VALUE                00171300
001714           '21011715117151133131291518181515'.                    00171400
001715         10                      PIC X(32)   VALUE                00171500
001716           '50010000000000000000155600000002'.                    00171600
001717         10                      PIC X(32)   VALUE                00171700
001718           '51010000000000000000723600000008'.                    00171800
001719         10                      PIC X(32)   VALUE                00171900
001720           '51020000000000000001631500000017'.                    00172000
001721         10                      PIC X(32)   VALUE                00172100
001722           '51030000000000000000773400000008'.                    00172200
001723         10                      PIC X(32)   VALUE                00172300
001724           '51040000000000000001927700000021'.                    00172400
001725         10                      PIC X(32)   VALUE                00172500
001726           '99990000000000000000000000000000'.                    00172600
001727     05  W-CMG-TABLE REDEFINES CMG-TABLE-DATA.                    00172700
001728         10  CMG-DATA            OCCURS 93 TIMES                  00172800
001729                                 ASCENDING KEY IS CMG-NUM         00172900
001730                                 INDEXED BY DX6.                  00173000
001731             15  CMG-NUM         PIC X(4).                        00173100
001732             15  CMG-NUM-REDEF REDEFINES CMG-NUM.                 00173200
001733                 20  CMG-RIC     PIC XX.                          00173300
001734                 20  FILLER      PIC XX.                          00173400
001735             15  B-REL-WGT       PIC 9(1)V9(4).                   00173500
001736             15  C-REL-WGT       PIC 9(1)V9(4).                   00173600
001737             15  D-REL-WGT       PIC 9(1)V9(4).                   00173700
001738             15  A-REL-WGT       PIC 9(1)V9(4).                   00173800
001739             15  B-LOS-TABLE     PIC 9(2).                        00173900
001740             15  C-LOS-TABLE     PIC 9(2).                        00174000
001741             15  D-LOS-TABLE     PIC 9(2).                        00174100
001742             15  A-LOS-TABLE     PIC 9(2).                        00174200
001743**************************************************************    00174300
001744     EJECT                                                        00174400
001745 01  HOLD-PPS-COMPONENTS.                                         00174500
001746     05  H-LOS                        PIC 9(05).                  00174600
001747     05  H-WK-DSH                     PIC 9(01)V9(04).            00174700
001748     05  H-TEACH-PCT                  PIC 9(01)V9(04).            00174800
001749     05  H-LABOR-PORTION              PIC 9(07)V9(06).            00174900
001750     05  H-NONLABOR-PORTION           PIC 9(07)V9(06).            00175000
001760     05  H-OUTLIER-LABOR-PORTION      PIC 9(07)V9(06).            00176000
001770     05  H-OUTLIER-NONLABOR-PORTION   PIC 9(07)V9(06).            00177000
001780     05  H-FP-OUTLIER-THRESHOLD       PIC 9(07)V9(06).            00178000
001790     05  H-OUTLIER-THRESHOLD          PIC 9(07)V9(06).            00179000
001800     05  H-CHG-OUTLIER-THRESHOLD      PIC 9(07)V9(04).            00180000
001900     05  H-FY-BEGIN-DATE              PIC 9(08).                  00190000
002000     05  H-DISCHARGE-DATE             PIC 9(08).                  00200000
002100                                                                  00210000
002200 LINKAGE SECTION.                                                 00220000
002300**************************************************************    00230000
002400*      THIS IS THE BILL-RECORD THAT WILL BE PASSED FROM      *    00240000
002500*      THE IRCAL___ PROGRAM                                  *    00250000
002600**************************************************************    00260000
002700 01  BILL-NEW-DATA.                                               00270000
002800         10  B-NPI10.                                             00280000
002900             15  B-NPI8             PIC X(08).                    00290000
003000             15  B-NPI-FILLER       PIC X(02).                    00300000
003100         10  B-PROVIDER-NO          PIC X(06).                    00310000
003200         10  B-PATIENT-STATUS       PIC X(02).                    00320000
003300         10  B-CMG-CODE             PIC X(05).                    00330000
003400         10  B-LOS                  PIC 9(03).                    00340000
003500         10  B-COV-DAYS             PIC 9(03).                    00350000
003600         10  B-LTR-DAYS             PIC 9(02).                    00360000
003700         10  B-SPEC-PAY-IND         PIC X(01).                    00370000
003800         10  B-DISCHARGE-DATE.                                    00380000
003900             15  B-DISCHG-CC        PIC 9(02).                    00390000
004000             15  B-DISCHG-YY        PIC 9(02).                    00400000
004100             15  B-DISCHG-MM        PIC 9(02).                    00410000
004200             15  B-DISCHG-DD        PIC 9(02).                    00420000
004300         10  B-COV-CHARGES          PIC 9(07)V9(02).              00430000
004400         10  FILLER                 PIC X(11).                    00440000
004500                                                                  00450000
004600***************************************************************   00460000
004700*    THIS DATA IS CALCULATED BY THIS IRCAL SUBROUTINE         *   00470000
004800*    AND PASSED BACK TO THE CALLING PROGRAM                   *   00480000
004900*            RETURN CODE VALUES (PPS-RTC)                     *   00490000
005000*                                                             *   00500000
005100*     ****   PPS-RTC 00-49 = HOW THE BILL WAS PAID            *   00510000
005200*              00 = PAID NORMAL CMG PAYMENT WITHOUT OUTLIER   *   00520000
005300*                                                             *   00530000
005400*              01 = PAID NORMAL CMG PAYMENT WITH OUTLIER      *   00540000
005500*                                                             *   00550000
005600*              02 = TRANSFER PAID ON A PERDIEM BASIS WITHOUT  *   00560000
005700*                   OUTLIER                                   *   00570000
005800*              03 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   00580000
005900*                   OUTLIER                                   *   00590000
006000*              04 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   00600000
006100*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   00610000
006200*                   WITHOUT OUTLIER                           *   00620000
006300*              05 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   00630000
006400*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   00640000
006500*                   WITH OUTLIER                              *   00650000
006600*              06 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   00660000
006700*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   00670000
006800*                   RATE -- WITHOUT OUTLIER                   *   00680000
006900*              07 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   00690000
007000*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   00700000
007100*                   RATE -- WITH OUTLIER                      *   00710000
007200*       **** NEW RT CODES FOR PAYMENT WITH PENALTIES          *   00720000
007300*              10 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   00730000
007400*                   WITHOUT OUTLIER                           *   00740000
007500*              11 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   00750000
007600*                   WITH OUTLIER                              *   00760000
007700*              12 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   00770000
007800*                   PENALTY WITHOUT OUTLIER                   *   00780000
007900*              13 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   00790000
008000*                   PENALTY WITH OUTLIER                      *   00800000
008100*              14 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   00810000
008200*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   00820000
008300*                   WITH PENALTY WITHOUT OUTLIER              *   00830000
008400*              15 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   00840000
008500*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   00850000
008600*                   WITH PENALTY WITH OUTLIER                 *   00860000
008700*              16 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   00870000
008800*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   00880000
008900*                   RATE -- WITH PENALTY WITHOUT OUTLIER      *   00890000
009000*              17 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   00900000
009100*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   00910000
009200*                   RATE -- WITH PENALTY WITH OUTLIER         *   00920000
009300*                                                             *   00930000
009400*      ****  PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   00940000
009500*              50 = PROVIDER SPECIFIC RATE NOT NUMERIC        *   00950000
009600*              51 = PROVIDER RECORD TERMINATED                *   00960000
009700*              52 = INVALID WAGE INDEX                        *   00970000
009800*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   00980000
009900*              54 = CMG ON CLAIM NOT FOUND IN TABLE           *   00990000
010000*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   01000000
010100*                                      OR                     *   01010000
010200*                   DISCHARGE DATE < MSA EFF START DATE       *   01020000
010300*                   FOR PPS                                   *   01030000
010400*              56 = INVALID LENGTH OF STAY                    *   01040000
010500*              57 = PROVIDER SPECIFIC RATE ZERO WHEN BLENDED  *   01050000
010600*                   PAYMENT REQUESTED                         *   01060000
010700*              58 = TOTAL COVERED CHARGES NOT NUMERIC         *   01070000
010800*              59 = PROVIDER SPECIFIC RECORD NOT FOUND        *   01080000
010900*              60 = MSA WAGE INDEX RECORD NOT FOUND           *   01090000
011000*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *   01100000
011100*                   OR BILL-LTR-DAYS > 60                     *   01110000
011200*              62 = INVALID NUMBER OF COVERED DAYS            *   01120000
011300*              65 = OPERATING COST-TO-CHARGE RATIO NOT NUMERIC*   01130000
011400*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *   01140000
011500*                   OR COST OUTLIER THRESHOLD CALCULATION     *   01150000
011600*              72 = INVALID BLEND INDICATOR (NOT 3 OR 4)      *   01160000
011700*              73 = DISCHARGED BEFORE PROVIDER FY BEGIN       *   01170000
011800*              74 = PROVIDER FY BEGIN DATE NOT IN 2002        *   01180000
011900***************************************************************   01190000
012000 01  PPS-DATA-ALL.                                                01200000
012100     05  PPS-RTC                      PIC 9(02).                  01210000
012200     05  PPS-DATA.                                                01220000
012300         10  PPS-MSA                  PIC X(04).                  01230000
012400         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).            01240000
012500         10  PPS-AVG-LOS              PIC 9(02).                  01250000
012600         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).            01260000
012700         10  PPS-TOTAL-PAY-AMT        PIC 9(07)V9(02).            01270000
012800         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).            01280000
012900         10  PPS-FAC-SPEC-PAY-AMT     PIC 9(07)V9(02).            01290000
013000         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).            01300000
013100         10  PPS-LIP-PAY-AMT          PIC 9(07)V9(02).            01310000
013200         10  PPS-LIP-PCT              PIC 9(01)V9(04).            01320000
013300         10  PPS-LOS                  PIC 9(03).                  01330000
013400         10  PPS-REG-DAYS-USED        PIC 9(03).                  01340000
013500         10  PPS-LTR-DAYS-USED        PIC 9(03).                  01350000
013600         10  PPS-TRANSFER-PCT         PIC 9(01)V9(04).            01360000
013700         10  PPS-FAC-SPEC-RT-PREBLEND PIC 9(05)V9(02).            01370000
013800         10  PPS-STANDARD-PAY-AMT     PIC 9(07)V9(02).            01380000
013900         10  PPS-FAC-COSTS            PIC 9(07)V9(02).            01390000
014000         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).            01400000
014100         10  PPS-CHG-OUTLIER-THRESHOLD PIC 9(07)V9(02).           01410000
014200         10  PPS-TOTAL-PENALTY-AMT    PIC 9(07)V9(02).            01420000
014300         10  PPS-FED-PENALTY-AMT      PIC 9(07)V9(02).            01430000
014400         10  PPS-LIP-PENALTY-AMT      PIC 9(07)V9(02).            01440000
014500         10  PPS-OUT-PENALTY-AMT      PIC 9(07)V9(02).            01450000
014600         10  PPS-SUBM-CMG-CODE        PIC X(05).                  01460000
014700         10  PPS-CMG-CODE-REDEF REDEFINES PPS-SUBM-CMG-CODE.      01470000
014800            15  PPS-CMG-ALPHA         PIC X(01).                  01480000
014900            15  PPS-CMG-NUMERIC.                                  01490000
015000               20  PPS-CMG-RIC        PIC X(02).                  01500000
015100               20  FILLER             PIC X(02).                  01510000
015200         10  PPS-PRICED-CMG-CODE      PIC X(05).                  01520000
015300         10  PPS-CALC-VERS-CD         PIC X(05).                  01530000
015400         10  PPS-CBSA                 PIC X(05).                  01540000
015500         10  FILLER                   PIC X(08).                  01550000
015600     05  PPS-OTHER-DATA.                                          01560000
015700         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).            01570000
015800         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).            01580000
015900         10  PPS-NAT-THRESHOLD-ADJ    PIC 9(05)V9(02).            01590000
016000         10  PPS-BDGT-NEUT-CONV-AMT   PIC 9(05)V9(02).            01600000
016100         10  PPS-FED-RATE-PCT         PIC 9(01)V9(04).            01610000
016200         10  PPS-FAC-RATE-PCT         PIC 9(01)V9(04).            01620000
016300         10  PPS-RURAL-ADJUSTMENT     PIC 9(01)V9(04).            01630000
016400         10  PPS-TEACH-PAY-AMT        PIC 9(07)V9(02).            01640000
016500         10  PPS-TEACH-PENALTY-AMT    PIC 9(07)V9(02).            01650000
016600         10  FILLER                   PIC X(02).                  01660000
016700     05  PPS-PC-DATA.                                             01670000
016800         10  PPS-COT-IND              PIC X(01).                  01680000
016900         10  FILLER                   PIC X(20).                  01690000
017000                                                                  01700000
017100******************************************************************01710000
017200*            THESE ARE THE VERSIONS OF THE IRDRV___               01720000
017300*           PROGRAMS THAT WILL BE PASSED BACK----                 01730000
017400*          ASSOCIATED WITH THE BILL BEING PROCESSED               01740000
017500******************************************************************01750000
017600 01  PRICER-OPT-VERS-SW.                                          01760000
017700     05  PRICER-OPTION-SW          PIC X(01).                     01770000
017800         88  ALL-TABLES-PASSED          VALUE 'A'.                01780000
017900         88  PROV-RECORD-PASSED         VALUE 'P'.                01790000
018000     05  PPS-VERSIONS.                                            01800000
018100         10  PPDRV-VERSION         PIC X(05).                     01810000
018200                                                                  01820000
018300**************************************************************    01830000
018400*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BY        *    01840000
018500*      THE IRCAL___ PROGRAM                                  *    01850000
018600**************************************************************    01860000
018700 01  PROV-NEW-HOLD.                                               01870000
018800     02  PROV-NEWREC-HOLD1.                                       01880000
018900         05  P-NEW-NPI10.                                         01890000
019000             10  P-NEW-NPI8             PIC X(08).                01900000
019100             10  P-NEW-NPI-FILLER       PIC X(02).                01910000
019200         05  P-NEW-PROVIDER-NO.                                   01920000
019300             10  P-NEW-STATE            PIC 9(02).                01930000
019400             10  FILLER                 PIC X(04).                01940000
019500         05  P-NEW-DATE-DATA.                                     01950000
019600             10  P-NEW-EFF-DATE.                                  01960000
019700                 15  P-NEW-EFF-DT-CC    PIC 9(02).                01970000
019800                 15  P-NEW-EFF-DT-YY    PIC 9(02).                01980000
019900                 15  P-NEW-EFF-DT-MM    PIC 9(02).                01990000
020000                 15  P-NEW-EFF-DT-DD    PIC 9(02).                02000000
020100             10  P-NEW-FY-BEGIN-DATE.                             02010000
020200                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                02020000
020300                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                02030000
020400                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                02040000
020500                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                02050000
020600             10  P-NEW-REPORT-DATE.                               02060000
020700                 15  P-NEW-REPORT-DT-CC PIC 9(02).                02070000
020800                 15  P-NEW-REPORT-DT-YY PIC 9(02).                02080000
020900                 15  P-NEW-REPORT-DT-MM PIC 9(02).                02090000
021000                 15  P-NEW-REPORT-DT-DD PIC 9(02).                02100000
021100             10  P-NEW-TERMINATION-DATE.                          02110000
021200                 15  P-NEW-TERM-DT-CC   PIC 9(02).                02120000
021300                 15  P-NEW-TERM-DT-YY   PIC 9(02).                02130000
021400                 15  P-NEW-TERM-DT-MM   PIC 9(02).                02140000
021500                 15  P-NEW-TERM-DT-DD   PIC 9(02).                02150000
021600         05  P-NEW-WAIVER-CODE          PIC X(01).                02160000
021700             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              02170000
021800         05  P-NEW-INTER-NO             PIC 9(05).                02180000
021900         05  P-NEW-PROVIDER-TYPE        PIC X(02).                02190000
022000         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                02200000
022100         05  P-NEW-CURRENT-DIV   REDEFINES                        02210000
022200                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         02220000
022300         05  P-NEW-MSA-DATA.                                      02230000
022400             10  P-NEW-CHG-CODE-INDEX       PIC X.                02240000
022500             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 02250000
022600             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   02260000
022700                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       02270000
022800             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 02280000
022900             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 02290000
023000             10  P-NEW-STAND-AMT-LOC-MSA9                         02300000
023100                 REDEFINES P-NEW-STAND-AMT-LOC-MSA.               02310000
023200                 15  P-NEW-RURAL-1ST.                             02320000
023300                     20  P-NEW-STAND-RURAL  PIC XX.               02330000
023400                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    02340000
023500                 15  P-NEW-RURAL-2ND        PIC XX.               02350000
023600         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    02360000
023700         05  P-NEW-LUGAR                    PIC X.                02370000
023800         05  P-NEW-TEMP-RELIEF-IND          PIC X.                02380000
023900         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                02390000
024000         05  FILLER                         PIC X(05).            02400000
024100     02  PROV-NEWREC-HOLD2.                                       02410000
024200         05  P-NEW-VARIABLES.                                     02420000
024300             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        02430000
024400             10  P-NEW-COLA              PIC  9(01)V9(03).        02440000
024500             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        02450000
024600             10  P-NEW-BED-SIZE          PIC  9(05).              02460000
024700             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        02470000
024800             10  P-NEW-CMI               PIC  9(01)V9(04).        02480000
024900             10  P-NEW-SSI-RATIO         PIC  V9(04).             02490000
025000             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             02500000
025100             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              02510000
025200             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        02520000
025300             10  P-NEW-DSH-PERCENT       PIC  V9(04).             02530000
025400             10  P-NEW-FYE-DATE          PIC  X(08).              02540000
025500         05  P-NEW-CBSA-DATA.                                     02550000
025600             10  P-NEW-CBSA-SPEC-PAY-IND   PIC X.                 02560000
025700             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.                 02570000
025800             10  P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.  02580000
025900             10  P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.  02590000
026000             10  P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.  02600000
026100             10  P-NEW-CBSA-STAND-AMT-LOC9                        02610000
026200                 REDEFINES P-NEW-CBSA-STAND-AMT-LOC.              02620000
026300                 15  P-NEW-CBSA-RURAL-1ST.                        02630000
026400                     20  P-NEW-CBSA-STAND-RURAL PIC 999.          02640000
026500                 15  P-NEW-CBSA-RURAL-2ND       PIC 99.           02650000
026600             10  P-NEW-CBSA-SPEC-WAGE-INDEX     PIC 9(02)V9(04).  02660000
026700     02  PROV-NEWREC-HOLD3.                                       02670000
026800         05  P-NEW-PASS-AMT-DATA.                                 02680000
026900             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          02690000
027000             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          02700000
027100             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          02710000
027200             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          02720000
027300         05  P-NEW-CAPI-DATA.                                     02730000
027400             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 02740000
027500             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          02750000
027600             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          02760000
027700             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        02770000
027800             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             02780000
027900             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 02790000
028000             15  P-NEW-CAPI-IME            PIC 9V9999.            02800000
028100             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          02810000
028200             15  P-VAL-BASED-PURCH-SCORE   PIC 9V999.             02820000
028300         05  FILLER                        PIC X(18).             02830000
028400******************************************************************02840000
028500*                   THIS IS THE WAGE-INDEX                        02850000
028600*          ASSOCIATED WITH THE BILL BEING PROCESSED               02860000
028700*                                                                 02870000
028800******************************************************************02880000
028900 01  WAGE-NEW-INDEX-RECORD-CBSA.                                  02890000
029000     05  W-NEW-CBSA                    PIC X(5).                  02900000
029100*       88  VALID-RURAL-CBSA    VALUE                             02910000
029200*             '50001' '50007' '50016' '50020' '50031'             02920000
029300*             '50036' '50054' '50060' '50067' '50087'             02930000
029400*             '50089' '50091' '50092' '50100' '50104'             02940000
029500*             '50108' '50114' '50121' '50125' '50140'             02950000
029600*             '50145' '50152' '50164' '50170' '50192'             02960000
029700*             '50199' '50206' '50210' '50214' '50218'             02970000
029800*             '50222' '50225' '50226' '50231' '50234'             02980000
029900*             '50237' '50243' '50248' '50250' '50255'             02990000
030000*             '50256' '50257' '50260' '50261' '50262'             03000000
030100*             '50263' '50266' '50268' '50272' '50275'             03010000
030200*             '50281' '50286' '50293' '50313' '50314'             03020000
030300*             '50316' '50325' '50326' '50327' '50329'             03030000
030400*             '50336' '50344' '50352'.                            03040000
030500     05  W-NEW-EFF-DATE-C              PIC X(8).                  03050000
030600     05  W-NEW-WAGE-INDEX-C            PIC S9(02)V9(04).          03060000
030700                                                                  03070000
030800 PROCEDURE DIVISION  USING BILL-NEW-DATA                          03080000
030900                           PPS-DATA-ALL                           03090000
031000                           PRICER-OPT-VERS-SW                     03100000
031100                           PROV-NEW-HOLD                          03110000
031200                           WAGE-NEW-INDEX-RECORD-CBSA.            03120000
031300***************************************************************   03130000
031400*    PROCESSING:                                              *   03140000
031500*        A. WILL PROCESS CLAIMS BASED ON DISCHARGE DATE       *   03150000
031600*        B. INITIALIZE IRCAL HOLD VARIABLES.                  *   03160000
031700*        C. EDIT THE DATA PASSED FROM THE CLAIM BEFORE        *   03170000
031800*           ATTEMPTING TO CALCULATE PPS. IF THIS CLAIM        *   03180000
031900*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   03190000
032000*           GOBACK.                                           *   03200000
032100*        D. ASSEMBLE PRICING COMPONENTS.                      *   03210000
032200*        E. CALCULATE THE PRICE.                              *   03220000
032300*        F. CALCULATE OUTLIERS IF APPLICABLE.                 *   03230000
032400***************************************************************   03240000
032500                                                                  03250000
032600 0000-MAINLINE-CONTROL.                                           03260000
032700                                                                  03270000
032800     PERFORM 0100-INITIAL-ROUTINE                                 03280000
032900        THRU 0100-EXIT.                                           03290000
033000                                                                  03300000
033100     PERFORM 1000-EDIT-THE-BILL-INFO                              03310000
033200        THRU 1000-EXIT.                                           03320000
033300                                                                  03330000
033400     IF PPS-RTC = 00                                              03340000
033500        PERFORM 1700-EDIT-CMG-CODE                                03350000
033600           THRU 1700-EXIT.                                        03360000
033700                                                                  03370000
033800     IF PPS-RTC = 00                                              03380000
033900        PERFORM 2000-ASSEMBLE-PPS-VARIABLES                       03390000
034000           THRU 2000-EXIT.                                        03400000
034100                                                                  03410000
034200     IF PPS-RTC = 00                                              03420000
034300        PERFORM 3000-CALC-PAYMENT                                 03430000
034400           THRU 3000-EXIT                                         03440000
034500        PERFORM 3500-CONTINUE-CALC                                03450000
034600           THRU 3500-EXIT                                         03460000
034700        PERFORM 4000-CALC-OUTLIER                                 03470000
034800           THRU 4000-EXIT                                         03480000
034900        PERFORM 5000-FINAL-PAYMENTS                               03490000
035000           THRU 5000-EXIT.                                        03500000
035100                                                                  03510000
035200     PERFORM 9000-MOVE-RESULTS                                    03520000
035300        THRU 9000-EXIT.                                           03530000
035400                                                                  03540000
035500     GOBACK.                                                      03550000
035600                                                                  03560000
035700 0100-INITIAL-ROUTINE.                                            03570000
035800                                                                  03580000
035900     MOVE ZEROS TO PPS-RTC.                                       03590000
036000     INITIALIZE PPS-DATA.                                         03600000
036100     INITIALIZE PPS-OTHER-DATA.                                   03610000
036200     INITIALIZE HOLD-PPS-COMPONENTS.                              03620000
036300***************************************************************   03630000
036400*    UPDATE THE VALUES BELOW FOR EACH FY RELEASE              *   03640000
036500*     - VALUES PER POLICY                                     *   03650000
036600***************************************************************   03660000
036800     MOVE .71000 TO PPS-NAT-LABOR-PCT.                            03680000
036900     MOVE .29000 TO PPS-NAT-NONLABOR-PCT.                         03690000
037000     MOVE  8658  TO PPS-NAT-THRESHOLD-ADJ.                        03700000
037100     IF P-NEW-CBSA-HOSP-QUAL-IND IS EQUAL TO '1'                  03710000
037200        MOVE 15478  TO PPS-BDGT-NEUT-CONV-AMT                     03720000
037300     ELSE                                                         03730000
037400        MOVE 15174  TO PPS-BDGT-NEUT-CONV-AMT                     03740000
037500     END-IF.                                                      03750000
037600                                                                  03760000
037700 0100-EXIT.                                                       03770000
037800      EXIT.                                                       03780000
037900                                                                  03790000
038000 1000-EDIT-THE-BILL-INFO.                                         03800000
038100***************************************************************   03810000
038200*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *   03820000
038300*    AND DO NOT ATTEMPT TO PRICE.                             *   03830000
038400***************************************************************   03840000
038500                                                                  03850000
038600     MOVE B-CMG-CODE TO PPS-SUBM-CMG-CODE.                        03860000
038700                                                                  03870000
038800     IF (B-LOS NUMERIC) AND (B-LOS > 0)                           03880000
038900        MOVE B-LOS TO H-LOS                                       03890000
039000     ELSE                                                         03900000
039100        IF B-LOS = 0                                              03910000
039200           MOVE 1 TO H-LOS                                        03920000
039300        ELSE                                                      03930000
039400           MOVE 56 TO PPS-RTC.                                    03940000
039500                                                                  03950000
039600     MOVE P-NEW-FY-BEGIN-DATE TO H-FY-BEGIN-DATE.                 03960000
039700     IF H-FY-BEGIN-DATE (5:2) < 11                                03970000
039800       COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 10200          03980000
039900     ELSE                                                         03990000
040000       COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 19000.         04000000
040100     MOVE B-DISCHARGE-DATE TO H-DISCHARGE-DATE.                   04010000
040200     IF (H-DISCHARGE-DATE > H-FY-BEGIN-DATE)                      04020000
040300        OR (P-NEW-FY-BEGIN-DATE > 20020930 AND                    04030000
040400            P-NEW-FY-BEGIN-DATE < 20030101)                       04040000
040500        MOVE '4' TO P-NEW-FED-PPS-BLEND-IND.                      04050000
040600     IF P-NEW-FY-BEGIN-DATE > 20011231                            04060000
040700        IF (P-NEW-FY-BEGIN-DATE <= B-DISCHARGE-DATE)              04070000
040800           IF P-NEW-FED-PPS-BLEND-IND = '4'                       04080000
040900              MOVE 1.0000 TO PPS-FED-RATE-PCT                     04090000
041000              MOVE 0.0000 TO PPS-FAC-RATE-PCT                     04100000
041100           ELSE                                                   04110000
041200             IF P-NEW-FED-PPS-BLEND-IND = '3'                     04120000
041300                MOVE .6667 TO PPS-FED-RATE-PCT                    04130000
041400                MOVE .3333 TO PPS-FAC-RATE-PCT                    04140000
041500             ELSE                                                 04150000
041600               MOVE 72 TO PPS-RTC                                 04160000
041700        ELSE                                                      04170000
041800           MOVE 73 TO PPS-RTC                                     04180000
041900     ELSE                                                         04190000
042000        MOVE 74 TO PPS-RTC.                                       04200000
042100                                                                  04210000
042200     IF PPS-RTC = 00                                              04220000
042300       IF P-NEW-WAIVER-STATE                                      04230000
042400          MOVE 53 TO PPS-RTC.                                     04240000
042500                                                                  04250000
042600     IF PPS-RTC = 00                                              04260000
042700         IF ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR               04270000
042800            (B-DISCHARGE-DATE < W-NEW-EFF-DATE-C))                04280000
042900            MOVE 55 TO PPS-RTC.                                   04290000
043000                                                                  04300000
043100     IF PPS-RTC = 00                                              04310000
043200         IF P-NEW-TERMINATION-DATE > 00000000                     04320000
043300            IF B-DISCHARGE-DATE >= P-NEW-TERMINATION-DATE         04330000
043400               MOVE 51 TO PPS-RTC.                                04340000
043500                                                                  04350000
043600     IF PPS-RTC = 00                                              04360000
043700         IF B-COV-CHARGES NOT NUMERIC                             04370000
043800            MOVE 58 TO PPS-RTC.                                   04380000
043900                                                                  04390000
044000     IF PPS-RTC = 00                                              04400000
044100        IF B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60              04410000
044200           MOVE 61 TO PPS-RTC                                     04420000
044300        ELSE                                                      04430000
044400           MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.                  04440000
044500                                                                  04450000
044600     IF PPS-RTC = 00                                              04460000
044700        IF B-COV-DAYS NOT NUMERIC                                 04470000
044800             MOVE 62 TO PPS-RTC                                   04480000
044900        ELSE                                                      04490000
045000          IF B-COV-DAYS = 0 AND H-LOS > 0                         04500000
045100             MOVE 62 TO PPS-RTC.                                  04510000
045200                                                                  04520000
045300     IF PPS-RTC = 00                                              04530000
045400        IF B-LTR-DAYS  > B-COV-DAYS                               04540000
045500           MOVE 62 TO PPS-RTC                                     04550000
045600        ELSE                                                      04560000
045700           COMPUTE PPS-REG-DAYS-USED = B-COV-DAYS - B-LTR-DAYS.   04570000
045800                                                                  04580000
045900     IF PPS-RTC = 00                                              04590000
046000        IF PPS-REG-DAYS-USED > 0                                  04600000
046100           IF PPS-REG-DAYS-USED > H-LOS                           04610000
046200              MOVE H-LOS TO PPS-REG-DAYS-USED                     04620000
046300           ELSE                                                   04630000
046400              NEXT SENTENCE                                       04640000
046500        ELSE                                                      04650000
046600           IF B-LTR-DAYS > H-LOS                                  04660000
046700              MOVE H-LOS TO PPS-LTR-DAYS-USED                     04670000
046800           ELSE                                                   04680000
046900              MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.               04690000
047000                                                                  04700000
047100 1000-EXIT.                                                       04710000
047200      EXIT.                                                       04720000
047300                                                                  04730000
047400***************************************************************   04740000
047500*    FINDS THE CMG CODE IN THE TABLE                          *   04750000
047600***************************************************************   04760000
047700 1700-EDIT-CMG-CODE.                                              04770000
047800* 01/2010 - ADDED 5001 PER C.R. # 6699                            04780000
047900                                                                  04790000
048000     IF PPS-CMG-NUMERIC = '9999' OR '5001'                        04800000
048100        NEXT SENTENCE                                             04810000
048200     ELSE                                                         04820000
048300        IF PPS-CMG-NUMERIC < '2103'                               04830000
048400           NEXT SENTENCE                                          04840000
048500        ELSE                                                      04850000
048600           MOVE 54 TO PPS-RTC.                                    04860000
048700                                                                  04870000
048800     IF PPS-RTC = 00                                              04880000
048900        SEARCH ALL CMG-DATA                                       04890000
049000           AT END                                                 04900000
049100             MOVE 54 TO PPS-RTC                                   04910000
049200        WHEN CMG-NUM (DX6) = PPS-CMG-NUMERIC                      04920000
049300             PERFORM 1750-FIND-VALUE                              04930000
049400                THRU 1750-EXIT                                    04940000
049500        END-SEARCH.                                               04950000
049600                                                                  04960000
049700 1700-EXIT.                                                       04970000
049800      EXIT.                                                       04980000
049900                                                                  04990000
050000***************************************************************   05000000
050100*    FINDS THE VALUE IN THE CMG CODE IN THE TABLE             *   05010000
050200***************************************************************   05020000
050300 1750-FIND-VALUE.                                                 05030000
050400                                                                  05040000
050500      IF PPS-CMG-ALPHA = 'A'                                      05050000
050600         MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                 05060000
050700         MOVE A-LOS-TABLE (DX6) TO PPS-AVG-LOS                    05070000
050800      ELSE                                                        05080000
050900         IF PPS-CMG-ALPHA = 'B'                                   05090000
051000            MOVE B-REL-WGT (DX6) TO PPS-RELATIVE-WGT              05100000
051100            MOVE B-LOS-TABLE (DX6) TO PPS-AVG-LOS                 05110000
051200         ELSE                                                     05120000
051300            IF PPS-CMG-ALPHA = 'C'                                05130000
051400               MOVE C-REL-WGT (DX6) TO PPS-RELATIVE-WGT           05140000
051500               MOVE C-LOS-TABLE (DX6) TO PPS-AVG-LOS              05150000
051600            ELSE                                                  05160000
051700               IF PPS-CMG-ALPHA = 'D'                             05170000
051800                  MOVE D-REL-WGT (DX6) TO PPS-RELATIVE-WGT        05180000
051900                  MOVE D-LOS-TABLE (DX6) TO PPS-AVG-LOS           05190000
052000               ELSE                                               05200000
052100                  MOVE 54 TO PPS-RTC.                             05210000
052200                                                                  05220000
052300 1750-EXIT.                                                       05230000
052400      EXIT.                                                       05240000
052500                                                                  05250000
052600***************************************************************   05260000
052700*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *   05270000
052800*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   05280000
052900*    OF THAT VARIABLE.                                        *   05290000
053000***************************************************************   05300000
053100***  GET THE PROVIDER SPECIFIC VARIABLE AND WAGE INDEX            05310000
053200***************************************************************   05320000
053300 2000-ASSEMBLE-PPS-VARIABLES.                                     05330000
053400                                                                  05340000
053500     IF P-NEW-FAC-SPEC-RATE NUMERIC                               05350000
053600        MOVE P-NEW-FAC-SPEC-RATE TO PPS-FAC-SPEC-RT-PREBLEND      05360000
053700     ELSE                                                         05370000
053800        MOVE 50 TO PPS-RTC                                        05380000
053900        GO TO 2000-EXIT.                                          05390000
054000                                                                  05400000
054100     IF P-NEW-FED-PPS-BLEND-IND = '3'                             05410000
054200        IF PPS-FAC-SPEC-RT-PREBLEND = 0                           05420000
054300          MOVE 57 TO PPS-RTC                                      05430000
054400          GO TO 2000-EXIT.                                        05440000
054500                                                                  05450000
054600     IF W-NEW-WAGE-INDEX-C NUMERIC                                05460000
054700            AND W-NEW-WAGE-INDEX-C > 0                            05470000
054800        MOVE W-NEW-WAGE-INDEX-C TO PPS-WAGE-INDEX                 05480000
054900     ELSE                                                         05490000
055000        MOVE 52 TO PPS-RTC                                        05500000
055100        GO TO 2000-EXIT.                                          05510000
055200                                                                  05520000
055300     IF P-NEW-OPER-CSTCHG-RATIO NOT NUMERIC                       05530000
055400        MOVE 65 TO PPS-RTC.                                       05540000
055500                                                                  05550000
055600 2000-EXIT.                                                       05560000
055700      EXIT.                                                       05570000
055800                                                                  05580000
055900***************************************************************   05590000
056000*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *   05600000
056100*        CALCULATE THE FEDERAL PORTION.                       *   05610000
056200*        CALCULATE THE HOSPITAL PORTION.                      *   05620000
056300*        CALCULATE THE COST-OUTLIER PORTION.                  *   05630000
056400*        CALCULATE THE LIP ADJUSTMENT PERCENTAGE.             *   05640000
056500*-------------------------------------------------------------*   05650000
056600*    NO CHANGE TO LIP FROM 2014 AT  .3177                     *   05660000
056700*    NO CHANGE TO TCH FROM 2014 AT 1.0163                     *   05670000
056800***************************************************************   05680000
056900 3000-CALC-PAYMENT.                                               05690000
057000                                                                  05700000
057100***  LIP ( LOW INCOME PATIENT ) CALCULATION                   *   05710000
057200                                                                  05720000
057300      COMPUTE H-WK-DSH = (P-NEW-SSI-RATIO                         05730000
057400                           + P-NEW-MEDICAID-RATIO).               05740000
057500                                                                  05750000
057600      COMPUTE PPS-LIP-PCT ROUNDED =                               05760000
057700            ((1 + H-WK-DSH) ** .3177) - 1.                        05770000
057800                                                                  05780000
057900      COMPUTE H-TEACH-PCT ROUNDED =                               05790000
058000            ((1 + P-NEW-CAPI-IME) ** 1.0163) - 1.                 05800000
058100                                                                  05810000
058200***************************************************************   05820000
058300                                                                  05830000
058400     MOVE 1.0000 TO PPS-TRANSFER-PCT.                             05840000
058500                                                                  05850000
058600     IF B-PATIENT-STATUS =                                        05860000
058700          '02' OR '03' OR '61' OR '62' OR '63' OR '64' OR         05870000
058800          '82' OR '83' OR '89' OR '90' OR '91' OR '92'            05880000
058900        IF H-LOS < PPS-AVG-LOS                                    05890000
059000           COMPUTE PPS-TRANSFER-PCT =                             05900000
059100               ((H-LOS + .5) / PPS-AVG-LOS)                       05910000
059200           MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE          05920000
059300           GO TO 3000-EXIT.                                       05930000
059400                                                                  05940000
059500     IF H-LOS > 3                                                 05950000
059600        NEXT SENTENCE                                             05960000
059700     ELSE                                                         05970000
059800        MOVE 'A5001' TO PPS-PRICED-CMG-CODE                       05980000
059900        SET DX6 TO 88                                             05990000
060000        MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                  06000000
060100        GO TO 3000-EXIT.                                          06010000
060200                                                                  06020000
060300     IF B-PATIENT-STATUS = '20'                                   06030000
060400        NEXT SENTENCE                                             06040000
060500     ELSE                                                         06050000
060600        MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE             06060000
060700        GO TO 3000-EXIT.                                          06070000
060800                                                                  06080000
060900     IF PPS-CMG-RIC = ('07' OR '08' OR '09')                      06090000
061000        IF H-LOS < 14                                             06100000
061100           MOVE 'A5101' TO PPS-PRICED-CMG-CODE                    06110000
061200           SET DX6 TO 89                                          06120000
061300           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               06130000
061400        ELSE                                                      06140000
061500           MOVE 'A5102' TO PPS-PRICED-CMG-CODE                    06150000
061600           SET DX6 TO 90                                          06160000
061700           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               06170000
061800     ELSE                                                         06180000
061900        IF H-LOS < 16                                             06190000
062000           MOVE 'A5103' TO PPS-PRICED-CMG-CODE                    06200000
062100           SET DX6 TO 91                                          06210000
062200           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               06220000
062300        ELSE                                                      06230000
062400           MOVE 'A5104' TO PPS-PRICED-CMG-CODE                    06240000
062500           SET DX6 TO 92                                          06250000
062600           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT.              06260000
062700                                                                  06270000
062800 3000-EXIT.                                                       06280000
062900      EXIT.                                                       06290000
063000                                                                  06300000
063100 3500-CONTINUE-CALC.                                              06310000
063200                                                                  06320000
063300     COMPUTE PPS-STANDARD-PAY-AMT =                               06330000
063400            (PPS-TRANSFER-PCT * PPS-RELATIVE-WGT                  06340000
063500                      * PPS-BDGT-NEUT-CONV-AMT).                  06350000
063600                                                                  06360000
063700***************************************************************   06370000
063800*      CHANGE RURAL ADJUSTMENT AMOUNT IF NECESSARY            *   06380000
063900***************************************************************   06390000
064000     PERFORM 3510-CHECK-RURAL-ADJ         THRU 3510-EXIT.         06400000
064100                                                                  06410000
064200***************************************************************   06420000
064300*      CHANGE RURAL ADJUSTMENT BASED ON RELIEF INDICATOR      *   06430000
064400*       IF NECESSARY - PER CHANGE REQUEST                     *   06440000
064500***************************************************************   06450000
064600** REMOVED FOR 2008 RELEASE                                       06460000
064700**   IF P-NEW-TEMP-RELIEF-IND = 'Y'                               06470000
064800**      MOVE 1.0638 TO PPS-RURAL-ADJUSTMENT.                      06480000
064900                                                                  06490000
065000     COMPUTE H-LABOR-PORTION =                                    06500000
065100        (PPS-STANDARD-PAY-AMT * PPS-NAT-LABOR-PCT)                06510000
065200          * PPS-WAGE-INDEX.                                       06520000
065300                                                                  06530000
065400     COMPUTE H-NONLABOR-PORTION =                                 06540000
065500        (PPS-STANDARD-PAY-AMT * PPS-NAT-NONLABOR-PCT).            06550000
065600                                                                  06560000
065700     COMPUTE PPS-FED-PAY-AMT ROUNDED =                            06570000
065800        ((H-LABOR-PORTION + H-NONLABOR-PORTION) *                 06580000
065900         PPS-RURAL-ADJUSTMENT).                                   06590000
066000                                                                  06600000
066100     COMPUTE PPS-LIP-PAY-AMT ROUNDED =                            06610000
066200        (PPS-FED-PAY-AMT * PPS-LIP-PCT).                          06620000
066300                                                                  06630000
066400     COMPUTE PPS-TEACH-PAY-AMT ROUNDED =                          06640000
066500        (PPS-FED-PAY-AMT * H-TEACH-PCT).                          06650000
066600                                                                  06660000
066700 3500-EXIT.                                                       06670000
066800      EXIT.                                                       06680000
066900                                                                  06690000
067000***************************************************************   06700000
067100* FOR FY16, IF PROVIDER IS FOUND ON TABLE, USE 1.0993         *   06710000
067200***************************************************************   06720000
067300 3510-CHECK-RURAL-ADJ.                                            06730000
067400                                                                  06740000
067500     MOVE 1.0000          TO PPS-RURAL-ADJUSTMENT                 06750000
067600                                                                  06760000
067700*----------------------------------------------------------------*06770000
067800* IF VALID RURAL TO URBAN PROVIDER, USE THE 2/3 ADJUSTMENT       *06780000
067900*----------------------------------------------------------------*06790000
068000     MOVE B-PROVIDER-NO   TO PROV-NUM.                            06800000
068100     IF VALID-PROV-NUM                                            06810000
068200        MOVE 1.0993       TO PPS-RURAL-ADJUSTMENT                 06820000
068300        GO  TO 3510-EXIT                                          06830000
068400     END-IF.                                                      06840000
068500                                                                  06850000
068600     IF W-NEW-CBSA (1:3) = '   '                                  06860000
068700        MOVE 1.1490 TO PPS-RURAL-ADJUSTMENT                       06870000
068800     ELSE                                                         06880000
068810        MOVE 1.0000 TO PPS-RURAL-ADJUSTMENT.                      06881000
068820                                                                  06882000
068830 3510-EXIT.                                                       06883000
068840      EXIT.                                                       06884000
068850                                                                  06885000
068860 4000-CALC-OUTLIER.                                               06886000
068870                                                                  06887000
068880     COMPUTE PPS-FAC-COSTS ROUNDED =                              06888000
068890         (B-COV-CHARGES * P-NEW-OPER-CSTCHG-RATIO).               06889000
068900                                                                  06890000
069000     COMPUTE H-OUTLIER-LABOR-PORTION =                            06900000
069100        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-LABOR-PCT)               06910000
069200              * PPS-WAGE-INDEX.                                   06920000
069300                                                                  06930000
069400     COMPUTE H-OUTLIER-NONLABOR-PORTION =                         06940000
069500        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-NONLABOR-PCT).           06950000
069600                                                                  06960000
069700     COMPUTE H-FP-OUTLIER-THRESHOLD ROUNDED =                     06970000
069800        ((H-OUTLIER-LABOR-PORTION + H-OUTLIER-NONLABOR-PORTION) * 06980000
069900         PPS-RURAL-ADJUSTMENT * (PPS-LIP-PCT + H-TEACH-PCT + 1)). 06990000
070000                                                                  07000000
070100     COMPUTE H-OUTLIER-THRESHOLD ROUNDED =                        07010000
070200        (PPS-FED-PAY-AMT + H-FP-OUTLIER-THRESHOLD +               07020000
070300         PPS-LIP-PAY-AMT + PPS-TEACH-PAY-AMT).                    07030000
070400                                                                  07040000
070500     IF PPS-FAC-COSTS > H-OUTLIER-THRESHOLD                       07050000
070600        COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                     07060000
070700           ((PPS-FAC-COSTS - H-OUTLIER-THRESHOLD) * .8).          07070000
070800                                                                  07080000
070900     COMPUTE H-CHG-OUTLIER-THRESHOLD ROUNDED =                    07090000
071000         H-OUTLIER-THRESHOLD / P-NEW-OPER-CSTCHG-RATIO.           07100000
071100                                                                  07110000
071200                                                                  07120000
071300 4000-EXIT.                                                       07130000
071400      EXIT.                                                       07140000
071500                                                                  07150000
071600 5000-FINAL-PAYMENTS.                                             07160000
071700                                                                  07170000
071800     IF B-SPEC-PAY-IND = '1' OR '3'                               07180000
071900         MOVE ZEROES TO PPS-OUTLIER-PAY-AMT.                      07190000
072000                                                                  07200000
072100     IF PPS-FED-RATE-PCT = 1.0000                                 07210000
072200         MOVE 0 TO PPS-FAC-SPEC-PAY-AMT                           07220000
072300     ELSE                                                         07230000
072400         COMPUTE PPS-FED-PAY-AMT ROUNDED =                        07240000
072500           (PPS-FED-RATE-PCT * PPS-FED-PAY-AMT)                   07250000
072600         COMPUTE PPS-FAC-SPEC-PAY-AMT ROUNDED =                   07260000
072700           (PPS-FAC-RATE-PCT * PPS-FAC-SPEC-RT-PREBLEND)          07270000
072800         COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                    07280000
072900           (PPS-FED-RATE-PCT * PPS-OUTLIER-PAY-AMT)               07290000
073000         COMPUTE PPS-TEACH-PAY-AMT ROUNDED =                      07300000
073100           (PPS-FED-RATE-PCT * PPS-TEACH-PAY-AMT)                 07310000
073200         COMPUTE PPS-LIP-PAY-AMT ROUNDED =                        07320000
073300           (PPS-FED-RATE-PCT * PPS-LIP-PAY-AMT).                  07330000
073400                                                                  07340000
073500     IF B-SPEC-PAY-IND = '2' OR '3'                               07350000
073600        COMPUTE PPS-FED-PENALTY-AMT ROUNDED =                     07360000
073700           (PPS-FED-PAY-AMT * .25)                                07370000
073800        COMPUTE PPS-FED-PAY-AMT =                                 07380000
073900           (PPS-FED-PAY-AMT - PPS-FED-PENALTY-AMT)                07390000
074000        COMPUTE PPS-LIP-PENALTY-AMT ROUNDED =                     07400000
074100           (PPS-LIP-PAY-AMT * .25)                                07410000
074200        COMPUTE PPS-LIP-PAY-AMT =                                 07420000
074300           (PPS-LIP-PAY-AMT - PPS-LIP-PENALTY-AMT)                07430000
074400        COMPUTE PPS-OUT-PENALTY-AMT ROUNDED =                     07440000
074500           (PPS-OUTLIER-PAY-AMT * .25)                            07450000
074600        COMPUTE PPS-OUTLIER-PAY-AMT =                             07460000
074700           (PPS-OUTLIER-PAY-AMT - PPS-OUT-PENALTY-AMT)            07470000
074800        COMPUTE PPS-TEACH-PENALTY-AMT ROUNDED =                   07480000
074900           (PPS-TEACH-PAY-AMT * .25)                              07490000
075000        COMPUTE PPS-TEACH-PAY-AMT =                               07500000
075100           (PPS-TEACH-PAY-AMT - PPS-TEACH-PENALTY-AMT)            07510000
075200        COMPUTE PPS-TOTAL-PENALTY-AMT =                           07520000
075300           (PPS-FED-PENALTY-AMT + PPS-LIP-PENALTY-AMT             07530000
075400           + PPS-OUT-PENALTY-AMT + PPS-TEACH-PENALTY-AMT).        07540000
075500                                                                  07550000
075600     COMPUTE PPS-TOTAL-PAY-AMT ROUNDED =                          07560000
075700        (PPS-FED-PAY-AMT + PPS-FAC-SPEC-PAY-AMT                   07570000
075800         + PPS-OUTLIER-PAY-AMT + PPS-LIP-PAY-AMT +                07580000
075900         PPS-TEACH-PAY-AMT).                                      07590000
076000                                                                  07600000
076100     IF PPS-FED-RATE-PCT = 1.0000                                 07610000
076200        IF PPS-TRANSFER-PCT = 1.0000                              07620000
076300           IF PPS-OUTLIER-PAY-AMT > 0.0                           07630000
076400              MOVE 01 TO PPS-RTC                                  07640000
076500           ELSE                                                   07650000
076600              MOVE 00 TO PPS-RTC                                  07660000
076700        ELSE                                                      07670000
076800           IF PPS-OUTLIER-PAY-AMT > 0.0                           07680000
076900              MOVE 03 TO PPS-RTC                                  07690000
077000           ELSE                                                   07700000
077100              MOVE 02 TO PPS-RTC                                  07710000
077200     ELSE                                                         07720000
077300        IF PPS-TRANSFER-PCT = 1.0000                              07730000
077400           IF PPS-OUTLIER-PAY-AMT > 0.0                           07740000
077500              MOVE 05 TO PPS-RTC                                  07750000
077600           ELSE                                                   07760000
077700              MOVE 04 TO PPS-RTC                                  07770000
077800        ELSE                                                      07780000
077900           IF PPS-OUTLIER-PAY-AMT > 0.0                           07790000
078000              MOVE 07 TO PPS-RTC                                  07800000
078100           ELSE                                                   07810000
078200              MOVE 06 TO PPS-RTC.                                 07820000
078300                                                                  07830000
078400     IF B-SPEC-PAY-IND = '2' OR '3'                               07840000
078500        COMPUTE PPS-RTC = PPS-RTC + 10.                           07850000
078600     IF PPS-RTC = (01 OR 03 OR 05 OR 07                           07860000
078700                OR 11 OR 13 OR 15 OR 17)                          07870000
078800        IF ((PPS-REG-DAYS-USED + PPS-LTR-DAYS-USED) < H-LOS)      07880000
078900           OR PPS-COT-IND = 'Y'                                   07890000
079000            MOVE 67 TO PPS-RTC.                                   07900000
079100                                                                  07910000
079200 5000-EXIT.                                                       07920000
079300      EXIT.                                                       07930000
079400                                                                  07940000
079500 9000-MOVE-RESULTS.                                               07950000
079600                                                                  07960000
079700     IF PPS-RTC < 50                                              07970000
079800      MOVE H-LOS                   TO  PPS-LOS                    07980000
079900      MOVE H-OUTLIER-THRESHOLD     TO  PPS-OUTLIER-THRESHOLD      07990000
080000      MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD   08000000
080100      MOVE W-NEW-CBSA              TO  PPS-CBSA                   08010000
080200      MOVE 'V16.0'                 TO  PPS-CALC-VERS-CD           08020000
080300     ELSE                                                         08030000
080400       INITIALIZE PPS-DATA                                        08040000
080500       INITIALIZE PPS-OTHER-DATA                                  08050000
080600       MOVE 'V16.0'                TO  PPS-CALC-VERS-CD.          08060000
080700                                                                  08070000
080800     IF PPS-RTC = 67                                              08080000
080900       MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD. 08090000
081000                                                                  08100000
081100 9000-EXIT.                                                       08110000
081200      EXIT.                                                       08120000
081300***************************************************************   08130000
081400******        L A S T   S O U R C E   S T A T E M E N T   *****   08140000
081500***************************************************************   08150000
