000100 IDENTIFICATION DIVISION.                                         00010010
000200 PROGRAM-ID.    IRCAL090.                                         00020010
000300*AUTHOR.        STEVE ZIOLKOWSKI.                                 00030010
000400*REMARKS.       CMS.                                              00040010
000500                                                                  00050010
000600 DATE-COMPILED.                                                   00060010
000610******************************************************************00061010
000620*               CHANGE FOR 2009 - EFFECTIVE 10/01/2008           *00062010
000621*----------------------------------------------------------------*00062110
000622*  UPDATED CMG-TABLE FOR 2009                                    *00062211
000623*                                                                *00062310
000624*  MOVE .75464 TO PPS-NAT-LABOR-PCT.                             *00062410
000625*  MOVE .24536 TO PPS-NAT-NONLABOR-PCT.                          *00062510
000626*  MOVE 10250  TO PPS-NAT-THRESHOLD-ADJ.                         *00062610
000627*  MOVE 12958  TO PPS-BDGT-NEUT-CONV-AMT.                        *00062710
000628*                                                                *00062810
000629*  ADDED   15  P-VAL-BASED-PURCH-SCORE   PIC 9V999               *00062910
000630******************************************************************00063010
000631 ENVIRONMENT DIVISION.                                            00063110
000640 CONFIGURATION SECTION.                                           00064010
000650 SOURCE-COMPUTER.            IBM-370.                             00065010
000660 OBJECT-COMPUTER.            IBM-370.                             00066010
000670 INPUT-OUTPUT  SECTION.                                           00067010
000680 FILE-CONTROL.                                                    00068010
000690                                                                  00069010
000700 DATA DIVISION.                                                   00070010
000800 FILE SECTION.                                                    00080010
000900                                                                  00090010
001000 WORKING-STORAGE SECTION.                                         00100010
001100 01  W-STORAGE-REF                  PIC X(46)  VALUE              00110010
001200     'IRCAL090      - W O R K I N G   S T O R A G E'.             00120010
001300 01  CAL-VERSION                    PIC X(05)  VALUE 'V09.0'.     00130010
001400                                                                  00140010
001500***************************************************************   00150010
001600*    LAYUP TABLE AREA FOR FY2009 CMGS                         *   00160010
001700*    EFFECTIVE DATE OF OCTOBER 1, 2008                        *   00170010
001800***************************************************************   00180010
001900 01  CMG-TABLE.                                                   00190010
002000     05  CMG-TABLE-DATA.                                          00200010
002100         10                      PIC X(32)   VALUE                00210010
002200           '01010771207108063810605909100908'.                    00220010
002300         10                      PIC X(32)   VALUE                00230010
002400           '01020969408936080210761711111110'.                    00240010
002500         10                      PIC X(32)   VALUE                00250010
002600           '01031147810580094960901814141212'.                    00260010
002700         10                      PIC X(32)   VALUE                00270010
002800           '01041219211238100870957913141313'.                    00280010
002900         10                      PIC X(32)   VALUE                00290010
003000           '01051432013199118481125116181515'.                    00300010
003100         10                      PIC X(32)   VALUE                00310010
003200           '01061663215330137611306719191717'.                    00320010
003300         10                      PIC X(32)   VALUE                00330010
003400           '01071897017485156951490420211919'.                    00340010
003500         10                      PIC X(32)   VALUE                00350010
003600           '01082279521011188601791027262322'.                    00360010
003700         10                      PIC X(32)   VALUE                00370010
003800           '01092178620081180251711722232122'.                    00380010
003900         10                      PIC X(32)   VALUE                00390010
004000           '01102721725087225182138430302726'.                    00400010
004100         10                      PIC X(32)   VALUE                00410010
004200           '02010755606464058180529510100808'.                    00420010
004300         10                      PIC X(32)   VALUE                00430010
004400           '02021030508817079350722213111010'.                    00440010
004500         10                      PIC X(32)   VALUE                00450010
004600           '02031148709828088460805112131211'.                    00460010
004700         10                      PIC X(32)   VALUE                00470010
004800           '02041293411066099590906415141312'.                    00480010
004900         10                      PIC X(32)   VALUE                00490010
005000           '02051573913466121191103017171614'.                    00500010
005100         10                      PIC X(32)   VALUE                00510010
005200           '02061953016709150391368721211818'.                    00520010
005300         10                      PIC X(32)   VALUE                00530010
005400           '02072630722508202571843736282422'.                    00540010
005500         10                      PIC X(32)   VALUE                00550010
005600           '03011108409308083580765012121110'.                    00560010
005700         10                      PIC X(32)   VALUE                00570010
005800           '03021412011857106470974614151313'.                    00580010
005900         10                      PIC X(32)   VALUE                00590010
006000           '03031693814224127721169117171615'.                    00600010
006100         10                      PIC X(32)   VALUE                00610010
006200           '03042313019424174411596627232120'.                    00620010
006300         10                      PIC X(32)   VALUE                00630010
006400           '04010925507883077320656612121109'.                    00640010
006500         10                      PIC X(32)   VALUE                00650010
006600           '04021393311868116400988617151613'.                    00660010
006700         10                      PIC X(32)   VALUE                00670010
006800           '04032282319440190671619428232321'.                    00680010
006900         10                      PIC X(32)   VALUE                00690010
007000           '04043976633872332222821553403734'.                    00700010
007100         10                      PIC X(32)   VALUE                00710010
007200           '04053034725850253542153242302927'.                    00720010
007300         10                      PIC X(32)   VALUE                00730010
007400           '05010810706397059450524509090808'.                    00740010
007500         10                      PIC X(32)   VALUE                00750010
007600           '05021099408675080620711313111110'.                    00760010
007700         10                      PIC X(32)   VALUE                00770010
007800           '05031431511296104970926116141313'.                    00780010
007900         10                      PIC X(32)   VALUE                00790010
008000           '05041722913596126341114721171615'.                    00800010
008100         10                      PIC X(32)   VALUE                00810010
008200           '05052036016066149301317323211917'.                    00820010
008300         10                      PIC X(32)   VALUE                00830010
008400           '05062832522351207701832532272523'.                    00840010
008500         10                      PIC X(32)   VALUE                00850010
008600           '06010924507546071740654211091009'.                    00860010
008700         10                      PIC X(32)   VALUE                00870010
008800           '06021236610094095960875012131212'.                    00880010
008900         10                      PIC X(32)   VALUE                00890010
009000           '06031576312866122321115416161514'.                    00900010
009100         10                      PIC X(32)   VALUE                00910010
009200           '06042088717049162081478024212018'.                    00920010
009300         10                      PIC X(32)   VALUE                00930010
009400           '07010918707742073000656311101009'.                    00940010
009500         10                      PIC X(32)   VALUE                00950010
009600           '07021211610209096270865514141212'.                    00960010
009700         10                      PIC X(32)   VALUE                00970010
009800           '07031484612510117971060616161514'.                    00980010
009900         10                      PIC X(32)   VALUE                00990010
010000           '07041899416005150931356920201917'.                    01000010
010100         10                      PIC X(32)   VALUE                01010010
010200           '08010700005704051720471408070807'.                    01020010
010300         10                      PIC X(32)   VALUE                01030010
010400           '08020938007643069310631710100909'.                    01040010
010500         10                      PIC X(32)   VALUE                01050010
010600           '08031338310905098890901314131312'.                    01060010
010700         10                      PIC X(32)   VALUE                01070010
010800           '08041174509571086790791013121110'.                    01080010
010900         10                      PIC X(32)   VALUE                01090010
011000           '08051466111947108330987416161313'.                    01100010
011100         10                      PIC X(32)   VALUE                01110010
011200           '08061813914780134031221518181715'.                    01120010
011300         10                      PIC X(32)   VALUE                01130010
011400           '09010858407574068290604110100909'.                    01140010
011500         10                      PIC X(32)   VALUE                01150010
011600           '09021147310122091270807413131211'.                    01160010
011700         10                      PIC X(32)   VALUE                01170010
011800           '09031484013093118061044316161514'.                    01180010
011900         10                      PIC X(32)   VALUE                01190010
012000           '09041962017310156081380722221918'.                    01200010
012100         10                      PIC X(32)   VALUE                01210010
012200           '10010935609061077970713711121110'.                    01220010
012300         10                      PIC X(32)   VALUE                01230010
012400           '10021252212127104350955214151312'.                    01240010
012500         10                      PIC X(32)   VALUE                01250010
012600           '10031819317619151611387719211917'.                    01260010
012700         10                      PIC X(32)   VALUE                01270010
012800           '11011184609851098510855812121311'.                    01280010
012900         10                      PIC X(32)   VALUE                01290010
013000           '11021728814377143771249017181715'.                    01300010
013100         10                      PIC X(32)   VALUE                01310010
013200           '12011031909668084830754111121110'.                    01320010
013300         10                      PIC X(32)   VALUE                01330010
013400           '12021303412212107150952514151313'.                    01340010
013500         10                      PIC X(32)   VALUE                01350010
013600           '12031637915346134651196916181715'.                    01360010
013700         10                      PIC X(32)   VALUE                01370010
013800           '13011098309874084990764812121110'.                    01380010
013900         10                      PIC X(32)   VALUE                01390010
014000           '13021479013296114451029915161413'.                    01400010
014100         10                      PIC X(32)   VALUE                01410010
014200           '13031914017208148121332924221817'.                    01420010
014300         10                      PIC X(32)   VALUE                01430010
014400           '14010800307221063880566710110908'.                    01440010
014500         10                      PIC X(32)   VALUE                01450010
014600           '14021109510010088560785613131211'.                    01460010
014700         10                      PIC X(32)   VALUE                01470010
014800           '14031357812251108380961515151313'.                    01480010
014900         10                      PIC X(32)   VALUE                01490010
015000           '14041762815905140711248320201716'.                    01500010
015100         10                      PIC X(32)   VALUE                01510010
015200           '15010960308386074130703811121009'.                    01520010
015300         10                      PIC X(32)   VALUE                01530010
015400           '15021229710739094940901313131211'.                    01540010
015500         10                      PIC X(32)   VALUE                01550010
015600           '15031564013658120741146316171414'.                    01560010
015700         10                      PIC X(32)   VALUE                01570010
015800           '15041952517051150731431022191717'.                    01580010
015900         10                      PIC X(32)   VALUE                01590010
016000           '16011109408968076670706813131010'.                    01600010
016100         10                      PIC X(32)   VALUE                01610010
016200           '16021497812108103510954316161313'.                    01620010
016300         10                      PIC X(32)   VALUE                01630010
016400           '16031928715590133281228722191716'.                    01640010
016500         10                      PIC X(32)   VALUE                01650010
016600           '17011045409189084610741911121110'.                    01660010
016700         10                      PIC X(32)   VALUE                01670010
016800           '17021377712110111510977814151413'.                    01680010
016900         10                      PIC X(32)   VALUE                01690010
017000           '17031656614561134081175718171615'.                    01700010
017100         10                      PIC X(32)   VALUE                01710010
017200           '17042077618261168151474423242119'.                    01720010
017300         10                      PIC X(32)   VALUE                01730010
017400           '18011218909629090440775715131310'.                    01740010
017500         10                      PIC X(32)   VALUE                01750010
017600           '18021839814533136511170819171615'.                    01760010
017700         10                      PIC X(32)   VALUE                01770010
017800           '18033144224838233292000937312624'.                    01780010
017900         10                      PIC X(32)   VALUE                01790010
018000           '19011158209288092880878215111112'.                    01800010
018100         10                      PIC X(32)   VALUE                01810010
018200           '19022340818772187721774926222522'.                    01820010
018300         10                      PIC X(32)   VALUE                01830010
018400           '19033594428825288252725433354131'.                    01840010
018500         10                      PIC X(32)   VALUE                01850010
018600           '20010882007282066140592811090908'.                    01860010
018700         10                      PIC X(32)   VALUE                01870010
018800           '20021187309803089040798012131111'.                    01880010
018900         10                      PIC X(32)   VALUE                01890010
019000           '20031523112575114221023716161413'.                    01900010
019100         10                      PIC X(32)   VALUE                01910010
019200           '20042036316812152711368622201917'.                    01920010
019300         10                      PIC X(32)   VALUE                01930010
019400           '21012366623666214811745425252517'.                    01940010
019500         10                      PIC X(32)   VALUE                01950010
019600           '50010000000000000000147600000003'.                    01960010
019700         10                      PIC X(32)   VALUE                01970010
019800           '51010000000000000000678300000008'.                    01980010
019900         10                      PIC X(32)   VALUE                01990010
020000           '51020000000000000001543200000019'.                    02000010
020100         10                      PIC X(32)   VALUE                02010010
020200           '51030000000000000000708600000009'.                    02020010
020300         10                      PIC X(32)   VALUE                02030010
020400           '51040000000000000001958600000023'.                    02040010
020410         10                      PIC X(32)   VALUE                02041012
020420           '99990000000000000000000000000000'.                    02042012
020500     05  W-CMG-TABLE REDEFINES CMG-TABLE-DATA.                    02050010
020600         10  CMG-DATA            OCCURS 93 TIMES                  02060012
020700                                 ASCENDING KEY IS CMG-NUM         02070010
020800                                 INDEXED BY DX6.                  02080010
020900             15  CMG-NUM         PIC X(4).                        02090010
021000             15  CMG-NUM-REDEF REDEFINES CMG-NUM.                 02100010
021100                 20  CMG-RIC     PIC XX.                          02110010
021200                 20  FILLER      PIC XX.                          02120010
021300             15  B-REL-WGT       PIC 9(1)V9(4).                   02130010
021400             15  C-REL-WGT       PIC 9(1)V9(4).                   02140010
021500             15  D-REL-WGT       PIC 9(1)V9(4).                   02150010
021600             15  A-REL-WGT       PIC 9(1)V9(4).                   02160010
021700             15  B-LOS-TABLE     PIC 9(2).                        02170010
021800             15  C-LOS-TABLE     PIC 9(2).                        02180010
021900             15  D-LOS-TABLE     PIC 9(2).                        02190010
022000             15  A-LOS-TABLE     PIC 9(2).                        02200010
022100                                                                  02210010
022200 01  HOLD-PPS-COMPONENTS.                                         02220010
022300     05  H-LOS                        PIC 9(05).                  02230010
022400     05  H-WK-DSH                     PIC 9(01)V9(04).            02240010
022500     05  H-TEACH-PCT                  PIC 9(01)V9(04).            02250010
022600     05  H-LABOR-PORTION              PIC 9(07)V9(06).            02260010
022700     05  H-NONLABOR-PORTION           PIC 9(07)V9(06).            02270010
022800     05  H-OUTLIER-LABOR-PORTION      PIC 9(07)V9(06).            02280010
022900     05  H-OUTLIER-NONLABOR-PORTION   PIC 9(07)V9(06).            02290010
023000     05  H-FP-OUTLIER-THRESHOLD       PIC 9(07)V9(06).            02300010
023100     05  H-OUTLIER-THRESHOLD          PIC 9(07)V9(06).            02310010
023200     05  H-CHG-OUTLIER-THRESHOLD      PIC 9(07)V9(04).            02320010
023300     05  H-FY-BEGIN-DATE              PIC 9(08).                  02330010
023400     05  H-DISCHARGE-DATE             PIC 9(08).                  02340010
023500                                                                  02350010
023600 LINKAGE SECTION.                                                 02360010
023700**************************************************************    02370010
023800*      THIS IS THE BILL-RECORD THAT WILL BE PASSED FROM      *    02380010
023900*      THE IRCAL___ PROGRAM                                  *    02390010
024000**************************************************************    02400010
024100 01  BILL-NEW-DATA.                                               02410010
024200         10  B-NPI10.                                             02420010
024300             15  B-NPI8             PIC X(08).                    02430010
024400             15  B-NPI-FILLER       PIC X(02).                    02440010
024500         10  B-PROVIDER-NO          PIC X(06).                    02450010
024600         10  B-PATIENT-STATUS       PIC X(02).                    02460010
024700         10  B-CMG-CODE             PIC X(05).                    02470010
024800         10  B-LOS                  PIC 9(03).                    02480010
024900         10  B-COV-DAYS             PIC 9(03).                    02490010
025000         10  B-LTR-DAYS             PIC 9(02).                    02500010
025100         10  B-SPEC-PAY-IND         PIC X(01).                    02510010
025200         10  B-DISCHARGE-DATE.                                    02520010
025300             15  B-DISCHG-CC        PIC 9(02).                    02530010
025400             15  B-DISCHG-YY        PIC 9(02).                    02540010
025500             15  B-DISCHG-MM        PIC 9(02).                    02550010
025600             15  B-DISCHG-DD        PIC 9(02).                    02560010
025700         10  B-COV-CHARGES          PIC 9(07)V9(02).              02570010
025800         10  FILLER                 PIC X(11).                    02580010
025900                                                                  02590010
026000***************************************************************   02600010
026100*    THIS DATA IS CALCULATED BY THIS IRCAL SUBROUTINE         *   02610010
026200*    AND PASSED BACK TO THE CALLING PROGRAM                   *   02620010
026300*            RETURN CODE VALUES (PPS-RTC)                     *   02630010
026400*                                                             *   02640010
026500*     ****   PPS-RTC 00-49 = HOW THE BILL WAS PAID            *   02650010
026600*              00 = PAID NORMAL CMG PAYMENT WITHOUT OUTLIER   *   02660010
026700*                                                             *   02670010
026800*              01 = PAID NORMAL CMG PAYMENT WITH OUTLIER      *   02680010
026900*                                                             *   02690010
027000*              02 = TRANSFER PAID ON A PERDIEM BASIS WITHOUT  *   02700010
027100*                   OUTLIER                                   *   02710010
027200*              03 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   02720010
027300*                   OUTLIER                                   *   02730010
027400*              04 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02740010
027500*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02750010
027600*                   WITHOUT OUTLIER                           *   02760010
027700*              05 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02770010
027800*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02780010
027900*                   WITH OUTLIER                              *   02790010
028000*              06 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   02800010
028100*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   02810010
028200*                   RATE -- WITHOUT OUTLIER                   *   02820010
028300*              07 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   02830010
028400*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   02840010
028500*                   RATE -- WITH OUTLIER                      *   02850010
028600*       **** NEW RT CODES FOR PAYMENT WITH PENALTIES          *   02860010
028700*              10 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   02870010
028800*                   WITHOUT OUTLIER                           *   02880010
028900*              11 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   02890010
029000*                   WITH OUTLIER                              *   02900010
029100*              12 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   02910010
029200*                   PENALTY WITHOUT OUTLIER                   *   02920010
029300*              13 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   02930010
029400*                   PENALTY WITH OUTLIER                      *   02940010
029500*              14 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02950010
029600*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02960010
029700*                   WITH PENALTY WITHOUT OUTLIER              *   02970010
029800*              15 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02980010
029900*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02990010
030000*                   WITH PENALTY WITH OUTLIER                 *   03000010
030100*              16 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03010010
030200*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03020010
030300*                   RATE -- WITH PENALTY WITHOUT OUTLIER      *   03030010
030400*              17 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03040010
030500*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03050010
030600*                   RATE -- WITH PENALTY WITH OUTLIER         *   03060010
030700*                                                             *   03070010
030800*      ****  PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   03080010
030900*              50 = PROVIDER SPECIFIC RATE NOT NUMERIC        *   03090010
031000*              51 = PROVIDER RECORD TERMINATED                *   03100010
031100*              52 = INVALID WAGE INDEX                        *   03110010
031200*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   03120010
031300*              54 = CMG ON CLAIM NOT FOUND IN TABLE           *   03130010
031400*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   03140010
031500*                                      OR                     *   03150010
031600*                   DISCHARGE DATE < MSA EFF START DATE       *   03160010
031700*                   FOR PPS                                   *   03170010
031800*              56 = INVALID LENGTH OF STAY                    *   03180010
031900*              57 = PROVIDER SPECIFIC RATE ZERO WHEN BLENDED  *   03190010
032000*                   PAYMENT REQUESTED                         *   03200010
032100*              58 = TOTAL COVERED CHARGES NOT NUMERIC         *   03210010
032200*              59 = PROVIDER SPECIFIC RECORD NOT FOUND        *   03220010
032300*              60 = MSA WAGE INDEX RECORD NOT FOUND           *   03230010
032400*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *   03240010
032500*                   OR BILL-LTR-DAYS > 60                     *   03250010
032600*              62 = INVALID NUMBER OF COVERED DAYS            *   03260010
032700*              65 = OPERATING COST-TO-CHARGE RATIO NOT NUMERIC*   03270010
032800*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *   03280010
032900*                   OR COST OUTLIER THRESHOLD CALCULATION     *   03290010
033000*              72 = INVALID BLEND INDICATOR (NOT 3 OR 4)      *   03300010
033100*              73 = DISCHARGED BEFORE PROVIDER FY BEGIN       *   03310010
033200*              74 = PROVIDER FY BEGIN DATE NOT IN 2002        *   03320010
033300***************************************************************   03330010
033400 01  PPS-DATA-ALL.                                                03340010
033500     05  PPS-RTC                      PIC 9(02).                  03350010
033600     05  PPS-DATA.                                                03360010
033700         10  PPS-MSA                  PIC X(04).                  03370010
033800         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).            03380010
033900         10  PPS-AVG-LOS              PIC 9(02).                  03390010
034000         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).            03400010
034100         10  PPS-TOTAL-PAY-AMT        PIC 9(07)V9(02).            03410010
034200         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).            03420010
034300         10  PPS-FAC-SPEC-PAY-AMT     PIC 9(07)V9(02).            03430010
034400         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).            03440010
034500         10  PPS-LIP-PAY-AMT          PIC 9(07)V9(02).            03450010
034600         10  PPS-LIP-PCT              PIC 9(01)V9(04).            03460010
034700         10  PPS-LOS                  PIC 9(03).                  03470010
034800         10  PPS-REG-DAYS-USED        PIC 9(03).                  03480010
034900         10  PPS-LTR-DAYS-USED        PIC 9(03).                  03490010
035000         10  PPS-TRANSFER-PCT         PIC 9(01)V9(04).            03500010
035100         10  PPS-FAC-SPEC-RT-PREBLEND PIC 9(05)V9(02).            03510010
035200         10  PPS-STANDARD-PAY-AMT     PIC 9(07)V9(02).            03520010
035300         10  PPS-FAC-COSTS            PIC 9(07)V9(02).            03530010
035400         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).            03540010
035500         10  PPS-CHG-OUTLIER-THRESHOLD PIC 9(07)V9(02).           03550010
035600         10  PPS-TOTAL-PENALTY-AMT    PIC 9(07)V9(02).            03560010
035700         10  PPS-FED-PENALTY-AMT      PIC 9(07)V9(02).            03570010
035800         10  PPS-LIP-PENALTY-AMT      PIC 9(07)V9(02).            03580010
035900         10  PPS-OUT-PENALTY-AMT      PIC 9(07)V9(02).            03590010
036000         10  PPS-SUBM-CMG-CODE        PIC X(05).                  03600010
036100         10  PPS-CMG-CODE-REDEF REDEFINES PPS-SUBM-CMG-CODE.      03610010
036200            15  PPS-CMG-ALPHA         PIC X(01).                  03620010
036300            15  PPS-CMG-NUMERIC.                                  03630010
036400               20  PPS-CMG-RIC        PIC X(02).                  03640010
036500               20  FILLER             PIC X(02).                  03650010
036600         10  PPS-PRICED-CMG-CODE      PIC X(05).                  03660010
036700         10  PPS-CALC-VERS-CD         PIC X(05).                  03670010
036800         10  PPS-CBSA                 PIC X(05).                  03680010
036900         10  FILLER                   PIC X(08).                  03690010
037000     05  PPS-OTHER-DATA.                                          03700010
037100         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).            03710010
037200         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).            03720010
037300         10  PPS-NAT-THRESHOLD-ADJ    PIC 9(05)V9(02).            03730010
037400         10  PPS-BDGT-NEUT-CONV-AMT   PIC 9(05)V9(02).            03740010
037500         10  PPS-FED-RATE-PCT         PIC 9(01)V9(04).            03750010
037600         10  PPS-FAC-RATE-PCT         PIC 9(01)V9(04).            03760010
037700         10  PPS-RURAL-ADJUSTMENT     PIC 9(01)V9(04).            03770010
037800         10  PPS-TEACH-PAY-AMT        PIC 9(07)V9(02).            03780010
037900         10  PPS-TEACH-PENALTY-AMT    PIC 9(07)V9(02).            03790010
038000         10  FILLER                   PIC X(02).                  03800010
038100     05  PPS-PC-DATA.                                             03810010
038200         10  PPS-COT-IND              PIC X(01).                  03820010
038300         10  FILLER                   PIC X(20).                  03830010
038400                                                                  03840010
038500******************************************************************03850010
038600*            THESE ARE THE VERSIONS OF THE IRDRV___               03860010
038700*           PROGRAMS THAT WILL BE PASSED BACK----                 03870010
038800*          ASSOCIATED WITH THE BILL BEING PROCESSED               03880010
038900******************************************************************03890010
039000 01  PRICER-OPT-VERS-SW.                                          03900010
039100     05  PRICER-OPTION-SW          PIC X(01).                     03910010
039200         88  ALL-TABLES-PASSED          VALUE 'A'.                03920010
039300         88  PROV-RECORD-PASSED         VALUE 'P'.                03930010
039400     05  PPS-VERSIONS.                                            03940010
039500         10  PPDRV-VERSION         PIC X(05).                     03950010
039600                                                                  03960010
039700**************************************************************    03970010
039800*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BY        *    03980010
039900*      THE IRCAL___ PROGRAM                                  *    03990010
040000**************************************************************    04000010
040100 01  PROV-NEW-HOLD.                                               04010010
040200     02  PROV-NEWREC-HOLD1.                                       04020010
040300         05  P-NEW-NPI10.                                         04030010
040400             10  P-NEW-NPI8             PIC X(08).                04040010
040500             10  P-NEW-NPI-FILLER       PIC X(02).                04050010
040600         05  P-NEW-PROVIDER-NO.                                   04060010
040700             10  P-NEW-STATE            PIC 9(02).                04070010
040800             10  FILLER                 PIC X(04).                04080010
040900         05  P-NEW-DATE-DATA.                                     04090010
041000             10  P-NEW-EFF-DATE.                                  04100010
041100                 15  P-NEW-EFF-DT-CC    PIC 9(02).                04110010
041200                 15  P-NEW-EFF-DT-YY    PIC 9(02).                04120010
041300                 15  P-NEW-EFF-DT-MM    PIC 9(02).                04130010
041400                 15  P-NEW-EFF-DT-DD    PIC 9(02).                04140010
041500             10  P-NEW-FY-BEGIN-DATE.                             04150010
041600                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                04160010
041700                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                04170010
041800                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                04180010
041900                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                04190010
042000             10  P-NEW-REPORT-DATE.                               04200010
042100                 15  P-NEW-REPORT-DT-CC PIC 9(02).                04210010
042200                 15  P-NEW-REPORT-DT-YY PIC 9(02).                04220010
042300                 15  P-NEW-REPORT-DT-MM PIC 9(02).                04230010
042400                 15  P-NEW-REPORT-DT-DD PIC 9(02).                04240010
042500             10  P-NEW-TERMINATION-DATE.                          04250010
042600                 15  P-NEW-TERM-DT-CC   PIC 9(02).                04260010
042700                 15  P-NEW-TERM-DT-YY   PIC 9(02).                04270010
042800                 15  P-NEW-TERM-DT-MM   PIC 9(02).                04280010
042900                 15  P-NEW-TERM-DT-DD   PIC 9(02).                04290010
043000         05  P-NEW-WAIVER-CODE          PIC X(01).                04300010
043100             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              04310010
043200         05  P-NEW-INTER-NO             PIC 9(05).                04320010
043300         05  P-NEW-PROVIDER-TYPE        PIC X(02).                04330010
043400         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                04340010
043500         05  P-NEW-CURRENT-DIV   REDEFINES                        04350010
043600                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         04360010
043700         05  P-NEW-MSA-DATA.                                      04370010
043800             10  P-NEW-CHG-CODE-INDEX       PIC X.                04380010
043900             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 04390010
044000             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   04400010
044100                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       04410010
044200             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 04420010
044300             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 04430010
044400             10  P-NEW-STAND-AMT-LOC-MSA9                         04440010
044500                 REDEFINES P-NEW-STAND-AMT-LOC-MSA.               04450010
044600                 15  P-NEW-RURAL-1ST.                             04460010
044700                     20  P-NEW-STAND-RURAL  PIC XX.               04470010
044800                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    04480010
044900                 15  P-NEW-RURAL-2ND        PIC XX.               04490010
045000         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    04500010
045100         05  P-NEW-LUGAR                    PIC X.                04510010
045200         05  P-NEW-TEMP-RELIEF-IND          PIC X.                04520010
045300         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                04530010
045400         05  FILLER                         PIC X(05).            04540010
045500     02  PROV-NEWREC-HOLD2.                                       04550010
045600         05  P-NEW-VARIABLES.                                     04560010
045700             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        04570010
045800             10  P-NEW-COLA              PIC  9(01)V9(03).        04580010
045900             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        04590010
046000             10  P-NEW-BED-SIZE          PIC  9(05).              04600010
046100             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        04610010
046200             10  P-NEW-CMI               PIC  9(01)V9(04).        04620010
046300             10  P-NEW-SSI-RATIO         PIC  V9(04).             04630010
046400             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             04640010
046500             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              04650010
046600             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        04660010
046700             10  P-NEW-DSH-PERCENT       PIC  V9(04).             04670010
046800             10  P-NEW-FYE-DATE          PIC  X(08).              04680010
046900         05  P-NEW-CBSA-DATA.                                     04690010
047000             10  P-NEW-CBSA-SPEC-PAY-IND   PIC X.                 04700010
047100             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.                 04710010
047200             10  P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.  04720010
047300             10  P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.  04730010
047400             10  P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.  04740010
047500             10  P-NEW-CBSA-STAND-AMT-LOC9                        04750010
047600                 REDEFINES P-NEW-CBSA-STAND-AMT-LOC.              04760010
047700                 15  P-NEW-CBSA-RURAL-1ST.                        04770010
047800                     20  P-NEW-CBSA-STAND-RURAL PIC 999.          04780010
047900                 15  P-NEW-CBSA-RURAL-2ND       PIC 99.           04790010
048000             10  P-NEW-CBSA-SPEC-WAGE-INDEX     PIC 9(02)V9(04).  04800010
048100     02  PROV-NEWREC-HOLD3.                                       04810010
048200         05  P-NEW-PASS-AMT-DATA.                                 04820010
048300             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          04830010
048400             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          04840010
048500             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          04850010
048600             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          04860010
048700         05  P-NEW-CAPI-DATA.                                     04870010
048800             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 04880010
048900             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          04890010
049000             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          04900010
049100             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        04910010
049200             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             04920010
049300             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 04930010
049400             15  P-NEW-CAPI-IME            PIC 9V9999.            04940010
049500             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          04950010
049600             15  P-VAL-BASED-PURCH-SCORE   PIC 9V999.             04960010
049700         05  FILLER                        PIC X(18).             04970010
049800******************************************************************04980010
049900*                   THIS IS THE WAGE-INDEX                        04990010
050000*          ASSOCIATED WITH THE BILL BEING PROCESSED               05000010
050100*                                                                 05010010
050200******************************************************************05020010
050300 01  WAGE-NEW-INDEX-RECORD-CBSA.                                  05030010
050400     05  W-NEW-CBSA                    PIC X(5).                  05040010
050500*       88  VALID-RURAL-CBSA    VALUE                             05050010
050600*             '50001' '50007' '50016' '50020' '50031'             05060010
050700*             '50036' '50054' '50060' '50067' '50087'             05070010
050800*             '50089' '50091' '50092' '50100' '50104'             05080010
050900*             '50108' '50114' '50121' '50125' '50140'             05090010
051000*             '50145' '50152' '50164' '50170' '50192'             05100010
051100*             '50199' '50206' '50210' '50214' '50218'             05110010
051200*             '50222' '50225' '50226' '50231' '50234'             05120010
051300*             '50237' '50243' '50248' '50250' '50255'             05130010
051400*             '50256' '50257' '50260' '50261' '50262'             05140010
051500*             '50263' '50266' '50268' '50272' '50275'             05150010
051600*             '50281' '50286' '50293' '50313' '50314'             05160010
051700*             '50316' '50325' '50326' '50327' '50329'             05170010
051800*             '50336' '50344' '50352'.                            05180010
051900     05  W-NEW-EFF-DATE-C              PIC X(8).                  05190010
052000     05  W-NEW-WAGE-INDEX-C            PIC S9(02)V9(04).          05200010
052100                                                                  05210010
052200 PROCEDURE DIVISION  USING BILL-NEW-DATA                          05220010
052300                           PPS-DATA-ALL                           05230010
052400                           PRICER-OPT-VERS-SW                     05240010
052500                           PROV-NEW-HOLD                          05250010
052600                           WAGE-NEW-INDEX-RECORD-CBSA.            05260010
052700***************************************************************   05270010
052800*    PROCESSING:                                              *   05280010
052900*        A. WILL PROCESS CLAIMS BASED ON DISCHARGE DATE       *   05290010
053000*        B. INITIALIZE IRCAL HOLD VARIABLES.                  *   05300010
053100*        C. EDIT THE DATA PASSED FROM THE CLAIM BEFORE        *   05310010
053200*           ATTEMPTING TO CALCULATE PPS. IF THIS CLAIM        *   05320010
053300*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   05330010
053400*           GOBACK.                                           *   05340010
053500*        D. ASSEMBLE PRICING COMPONENTS.                      *   05350010
053600*        E. CALCULATE THE PRICE.                              *   05360010
053700*        F. CALCULATE OUTLIERS IF APPLICABLE.                 *   05370010
053800***************************************************************   05380010
053900                                                                  05390010
054000 0000-MAINLINE-CONTROL.                                           05400010
054100                                                                  05410010
054200     PERFORM 0100-INITIAL-ROUTINE                                 05420010
054300        THRU 0100-EXIT.                                           05430010
054400                                                                  05440010
054500     PERFORM 1000-EDIT-THE-BILL-INFO                              05450010
054600        THRU 1000-EXIT.                                           05460010
054700                                                                  05470010
054800     IF PPS-RTC = 00                                              05480010
054900        PERFORM 1700-EDIT-CMG-CODE                                05490010
055000           THRU 1700-EXIT.                                        05500010
055100                                                                  05510010
055200     IF PPS-RTC = 00                                              05520010
055300        PERFORM 2000-ASSEMBLE-PPS-VARIABLES                       05530010
055400           THRU 2000-EXIT.                                        05540010
055500                                                                  05550010
055600     IF PPS-RTC = 00                                              05560010
055700        PERFORM 3000-CALC-PAYMENT                                 05570010
055800           THRU 3000-EXIT                                         05580010
055900        PERFORM 3500-CONTINUE-CALC                                05590010
056000           THRU 3500-EXIT                                         05600010
056100        PERFORM 4000-CALC-OUTLIER                                 05610010
056200           THRU 4000-EXIT                                         05620010
056300        PERFORM 5000-FINAL-PAYMENTS                               05630010
056400           THRU 5000-EXIT.                                        05640010
056500                                                                  05650010
056600     PERFORM 9000-MOVE-RESULTS                                    05660010
056700        THRU 9000-EXIT.                                           05670010
056800                                                                  05680010
056900     GOBACK.                                                      05690010
057000                                                                  05700010
057100 0100-INITIAL-ROUTINE.                                            05710010
057200                                                                  05720010
057300     MOVE ZEROS TO PPS-RTC.                                       05730010
057400     INITIALIZE PPS-DATA.                                         05740010
057500     INITIALIZE PPS-OTHER-DATA.                                   05750010
057600     INITIALIZE HOLD-PPS-COMPONENTS.                              05760010
057700***************************************************************   05770010
057800*    UPDATE THE VALUES BELOW FOR EACH FY RELEASE              *   05780010
057900*     - VALUES PER POLICY                                     *   05790010
058000***************************************************************   05800010
058100                                                                  05810010
058200     MOVE .75464 TO PPS-NAT-LABOR-PCT.                            05820010
058300     MOVE .24536 TO PPS-NAT-NONLABOR-PCT.                         05830010
058400     MOVE 10250  TO PPS-NAT-THRESHOLD-ADJ.                        05840010
058500     MOVE 12958  TO PPS-BDGT-NEUT-CONV-AMT.                       05850010
058600                                                                  05860010
058700 0100-EXIT.                                                       05870010
058800      EXIT.                                                       05880010
058900                                                                  05890010
059000 1000-EDIT-THE-BILL-INFO.                                         05900010
059100***************************************************************   05910010
059200*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *   05920010
059300*    AND DO NOT ATTEMPT TO PRICE.                             *   05930010
059400***************************************************************   05940010
059500                                                                  05950010
059600     MOVE B-CMG-CODE TO PPS-SUBM-CMG-CODE.                        05960010
059700                                                                  05970010
059800     IF (B-LOS NUMERIC) AND (B-LOS > 0)                           05980010
059900        MOVE B-LOS TO H-LOS                                       05990010
060000     ELSE                                                         06000010
060100        IF B-LOS = 0                                              06010010
060200           MOVE 1 TO H-LOS                                        06020010
060300        ELSE                                                      06030010
060400           MOVE 56 TO PPS-RTC.                                    06040010
060500                                                                  06050010
060600     MOVE P-NEW-FY-BEGIN-DATE TO H-FY-BEGIN-DATE.                 06060010
060700     IF H-FY-BEGIN-DATE (5:2) < 11                                06070010
060800       COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 10200          06080010
060900     ELSE                                                         06090010
061000       COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 19000.         06100010
061100     MOVE B-DISCHARGE-DATE TO H-DISCHARGE-DATE.                   06110010
061200     IF (H-DISCHARGE-DATE > H-FY-BEGIN-DATE)                      06120010
061300        OR (P-NEW-FY-BEGIN-DATE > 20020930 AND                    06130010
061400            P-NEW-FY-BEGIN-DATE < 20030101)                       06140010
061500        MOVE '4' TO P-NEW-FED-PPS-BLEND-IND.                      06150010
061600     IF P-NEW-FY-BEGIN-DATE > 20011231                            06160010
061700        IF (P-NEW-FY-BEGIN-DATE <= B-DISCHARGE-DATE)              06170010
061800           IF P-NEW-FED-PPS-BLEND-IND = '4'                       06180010
061900              MOVE 1.0000 TO PPS-FED-RATE-PCT                     06190010
062000              MOVE 0.0000 TO PPS-FAC-RATE-PCT                     06200010
062100           ELSE                                                   06210010
062200             IF P-NEW-FED-PPS-BLEND-IND = '3'                     06220010
062300                MOVE .6667 TO PPS-FED-RATE-PCT                    06230010
062400                MOVE .3333 TO PPS-FAC-RATE-PCT                    06240010
062500             ELSE                                                 06250010
062600               MOVE 72 TO PPS-RTC                                 06260010
062700        ELSE                                                      06270010
062800           MOVE 73 TO PPS-RTC                                     06280010
062900     ELSE                                                         06290010
063000        MOVE 74 TO PPS-RTC.                                       06300010
063100                                                                  06310010
063200     IF PPS-RTC = 00                                              06320010
063300       IF P-NEW-WAIVER-STATE                                      06330010
063400          MOVE 53 TO PPS-RTC.                                     06340010
063500                                                                  06350010
063600     IF PPS-RTC = 00                                              06360010
063700         IF ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR               06370010
063800            (B-DISCHARGE-DATE < W-NEW-EFF-DATE-C))                06380010
063900            MOVE 55 TO PPS-RTC.                                   06390010
064000                                                                  06400010
064100     IF PPS-RTC = 00                                              06410010
064200         IF P-NEW-TERMINATION-DATE > 00000000                     06420010
064300            IF B-DISCHARGE-DATE >= P-NEW-TERMINATION-DATE         06430010
064400               MOVE 51 TO PPS-RTC.                                06440010
064500                                                                  06450010
064600     IF PPS-RTC = 00                                              06460010
064700         IF B-COV-CHARGES NOT NUMERIC                             06470010
064800            MOVE 58 TO PPS-RTC.                                   06480010
064900                                                                  06490010
065000     IF PPS-RTC = 00                                              06500010
065100        IF B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60              06510010
065200           MOVE 61 TO PPS-RTC                                     06520010
065300        ELSE                                                      06530010
065400           MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.                  06540010
065500                                                                  06550010
065600     IF PPS-RTC = 00                                              06560010
065700        IF B-COV-DAYS NOT NUMERIC                                 06570010
065800             MOVE 62 TO PPS-RTC                                   06580010
065900        ELSE                                                      06590010
066000          IF B-COV-DAYS = 0 AND H-LOS > 0                         06600010
066100             MOVE 62 TO PPS-RTC.                                  06610010
066200                                                                  06620010
066300     IF PPS-RTC = 00                                              06630010
066400        IF B-LTR-DAYS  > B-COV-DAYS                               06640010
066500           MOVE 62 TO PPS-RTC                                     06650010
066600        ELSE                                                      06660010
066700           COMPUTE PPS-REG-DAYS-USED = B-COV-DAYS - B-LTR-DAYS.   06670010
066800                                                                  06680010
066900     IF PPS-RTC = 00                                              06690010
067000        IF PPS-REG-DAYS-USED > 0                                  06700010
067100           IF PPS-REG-DAYS-USED > H-LOS                           06710010
067200              MOVE H-LOS TO PPS-REG-DAYS-USED                     06720010
067300           ELSE                                                   06730010
067400              NEXT SENTENCE                                       06740010
067500        ELSE                                                      06750010
067600           IF B-LTR-DAYS > H-LOS                                  06760010
067700              MOVE H-LOS TO PPS-LTR-DAYS-USED                     06770010
067800           ELSE                                                   06780010
067900              MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.               06790010
068000                                                                  06800010
068100 1000-EXIT.                                                       06810010
068200      EXIT.                                                       06820010
068300                                                                  06830010
068400***************************************************************   06840010
068500*    FINDS THE CMG CODE IN THE TABLE                          *   06850010
068600***************************************************************   06860010
068700 1700-EDIT-CMG-CODE.                                              06870010
068800                                                                  06880010
068900*------------------ 2008.2---------------------------------------*06890010
069000                                                                  06900010
069100     IF PPS-CMG-NUMERIC = '9999'                                  06910010
069200        NEXT SENTENCE                                             06920010
069300     ELSE                                                         06930010
069400        IF PPS-CMG-NUMERIC < '2103'                               06940010
069500           NEXT SENTENCE                                          06950010
069600        ELSE                                                      06960010
069700           MOVE 54 TO PPS-RTC.                                    06970010
069800                                                                  06980010
069900     IF PPS-RTC = 00                                              06990010
070000        SEARCH ALL CMG-DATA                                       07000010
070100           AT END                                                 07010010
070200             MOVE 54 TO PPS-RTC                                   07020010
070300        WHEN CMG-NUM (DX6) = PPS-CMG-NUMERIC                      07030010
070400             PERFORM 1750-FIND-VALUE                              07040010
070500                THRU 1750-EXIT                                    07050010
070600        END-SEARCH.                                               07060010
070700                                                                  07070010
070800 1700-EXIT.                                                       07080010
070900      EXIT.                                                       07090010
071000                                                                  07100010
071100***************************************************************   07110010
071200*    FINDS THE VALUE IN THE CMG CODE IN THE TABLE             *   07120010
071300***************************************************************   07130010
071400 1750-FIND-VALUE.                                                 07140010
071500                                                                  07150010
071600      IF PPS-CMG-ALPHA = 'A'                                      07160010
071700         MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                 07170010
071800         MOVE A-LOS-TABLE (DX6) TO PPS-AVG-LOS                    07180010
071900      ELSE                                                        07190010
072000         IF PPS-CMG-ALPHA = 'B'                                   07200010
072100            MOVE B-REL-WGT (DX6) TO PPS-RELATIVE-WGT              07210010
072200            MOVE B-LOS-TABLE (DX6) TO PPS-AVG-LOS                 07220010
072300         ELSE                                                     07230010
072400            IF PPS-CMG-ALPHA = 'C'                                07240010
072500               MOVE C-REL-WGT (DX6) TO PPS-RELATIVE-WGT           07250010
072600               MOVE C-LOS-TABLE (DX6) TO PPS-AVG-LOS              07260010
072700            ELSE                                                  07270010
072800               IF PPS-CMG-ALPHA = 'D'                             07280010
072900                  MOVE D-REL-WGT (DX6) TO PPS-RELATIVE-WGT        07290010
073000                  MOVE D-LOS-TABLE (DX6) TO PPS-AVG-LOS           07300010
073100               ELSE                                               07310010
073200                  MOVE 54 TO PPS-RTC.                             07320010
073300                                                                  07330010
073400 1750-EXIT.                                                       07340010
073500      EXIT.                                                       07350010
073600                                                                  07360010
073700***************************************************************   07370010
073800*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *   07380010
073900*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   07390010
074000*    OF THAT VARIABLE.                                        *   07400010
074100***************************************************************   07410010
074200***  GET THE PROVIDER SPECIFIC VARIABLE AND WAGE INDEX            07420010
074300***************************************************************   07430010
074400 2000-ASSEMBLE-PPS-VARIABLES.                                     07440010
074500                                                                  07450010
074600     IF P-NEW-FAC-SPEC-RATE NUMERIC                               07460010
074700        MOVE P-NEW-FAC-SPEC-RATE TO PPS-FAC-SPEC-RT-PREBLEND      07470010
074800     ELSE                                                         07480010
074900        MOVE 50 TO PPS-RTC                                        07490010
075000        GO TO 2000-EXIT.                                          07500010
075100                                                                  07510010
075200     IF P-NEW-FED-PPS-BLEND-IND = '3'                             07520010
075300        IF PPS-FAC-SPEC-RT-PREBLEND = 0                           07530010
075400          MOVE 57 TO PPS-RTC                                      07540010
075500          GO TO 2000-EXIT.                                        07550010
075600                                                                  07560010
075700     IF W-NEW-WAGE-INDEX-C NUMERIC                                07570010
075800            AND W-NEW-WAGE-INDEX-C > 0                            07580010
075900        MOVE W-NEW-WAGE-INDEX-C TO PPS-WAGE-INDEX                 07590010
076000     ELSE                                                         07600010
076100        MOVE 52 TO PPS-RTC                                        07610010
076200        GO TO 2000-EXIT.                                          07620010
076300                                                                  07630010
076400     IF P-NEW-OPER-CSTCHG-RATIO NOT NUMERIC                       07640010
076500        MOVE 65 TO PPS-RTC.                                       07650010
076600                                                                  07660010
076700 2000-EXIT.                                                       07670010
076800      EXIT.                                                       07680010
076900                                                                  07690010
077000***************************************************************   07700010
077100*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *   07710010
077200*        CALCULATE THE FEDERAL PORTION.                       *   07720010
077300*        CALCULATE THE HOSPITAL PORTION.                      *   07730010
077400*        CALCULATE THE COST-OUTLIER PORTION.                  *   07740010
077500*        CALCULATE THE LIP ADJUSTMENT PERCENTAGE.             *   07750010
077600***************************************************************   07760010
077700 3000-CALC-PAYMENT.                                               07770010
077800                                                                  07780010
077900***  LIP PERCENTAGE CALCULATION *******************************   07790010
078000                                                                  07800010
078100      COMPUTE H-WK-DSH = (P-NEW-SSI-RATIO                         07810010
078200                           + P-NEW-MEDICAID-RATIO).               07820010
078300                                                                  07830010
078400      COMPUTE PPS-LIP-PCT ROUNDED =                               07840010
078500            ((1 + H-WK-DSH) ** .6229) - 1.                        07850010
078600                                                                  07860010
078700      COMPUTE H-TEACH-PCT ROUNDED =                               07870010
078800            ((1 + P-NEW-CAPI-IME) ** .9012) - 1.                  07880010
078900                                                                  07890010
079000***************************************************************   07900010
079100                                                                  07910010
079200     MOVE 1.0000 TO PPS-TRANSFER-PCT.                             07920010
079300                                                                  07930010
079400     IF B-PATIENT-STATUS =                                        07940010
079500         ('02' OR '03' OR '61' OR '62' OR '63' OR '64')           07950010
079600        IF H-LOS < PPS-AVG-LOS                                    07960010
079700           COMPUTE PPS-TRANSFER-PCT =                             07970010
079800               ((H-LOS + .5) / PPS-AVG-LOS)                       07980010
079900           MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE          07990010
080000           GO TO 3000-EXIT.                                       08000010
080100                                                                  08010010
080200     IF H-LOS > 3                                                 08020010
080300        NEXT SENTENCE                                             08030010
080400     ELSE                                                         08040010
080500        MOVE 'A5001' TO PPS-PRICED-CMG-CODE                       08050010
080600        SET DX6 TO 88                                             08060010
080700        MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                  08070010
080800        GO TO 3000-EXIT.                                          08080010
080900                                                                  08090010
081000     IF B-PATIENT-STATUS = '20'                                   08100010
081100        NEXT SENTENCE                                             08110010
081200     ELSE                                                         08120010
081300        MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE             08130010
081400        GO TO 3000-EXIT.                                          08140010
081500                                                                  08150010
081600     IF PPS-CMG-RIC = ('07' OR '08' OR '09')                      08160010
081700        IF H-LOS < 14                                             08170010
081800           MOVE 'A5101' TO PPS-PRICED-CMG-CODE                    08180010
081900           SET DX6 TO 89                                          08190010
082000           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08200010
082100        ELSE                                                      08210010
082200           MOVE 'A5102' TO PPS-PRICED-CMG-CODE                    08220010
082300           SET DX6 TO 90                                          08230010
082400           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08240010
082500     ELSE                                                         08250010
082600        IF H-LOS < 16                                             08260010
082700           MOVE 'A5103' TO PPS-PRICED-CMG-CODE                    08270010
082800           SET DX6 TO 91                                          08280010
082900           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08290010
083000        ELSE                                                      08300010
083100           MOVE 'A5104' TO PPS-PRICED-CMG-CODE                    08310010
083200           SET DX6 TO 92                                          08320010
083300           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT.              08330010
083400                                                                  08340010
083500 3000-EXIT.                                                       08350010
083600      EXIT.                                                       08360010
083700                                                                  08370010
083800 3500-CONTINUE-CALC.                                              08380010
083900                                                                  08390010
084000     COMPUTE PPS-STANDARD-PAY-AMT =                               08400010
084100            (PPS-TRANSFER-PCT * PPS-RELATIVE-WGT                  08410010
084200                      * PPS-BDGT-NEUT-CONV-AMT).                  08420010
084300                                                                  08430010
084400***************************************************************   08440010
084500*      CHANGE RURAL ADJUSTMENT AMOUNT IF NECESSARY            *   08450010
084600*      - PER CHANGE REQUEST                                   *   08460010
084700***************************************************************   08470010
084800     IF W-NEW-CBSA (1:3) = '   '                                  08480010
084900        MOVE 1.2130 TO PPS-RURAL-ADJUSTMENT                       08490010
085000     ELSE                                                         08500010
085100        MOVE 1.0000 TO PPS-RURAL-ADJUSTMENT.                      08510010
085200                                                                  08520010
085300***************************************************************   08530010
085400*      CHANGE RURAL ADJUSTMENT BASED ON RELIEF INDICATOR      *   08540010
085500*       IF NECESSARY - PER CHANGE REQUEST                     *   08550010
085600***************************************************************   08560010
085700** REMOVED FOR 2008 RELEASE                                       08570010
085800**   IF P-NEW-TEMP-RELIEF-IND = 'Y'                               08580010
085900**      MOVE 1.0638 TO PPS-RURAL-ADJUSTMENT.                      08590010
086000                                                                  08600010
086100     COMPUTE H-LABOR-PORTION =                                    08610010
086200        (PPS-STANDARD-PAY-AMT * PPS-NAT-LABOR-PCT)                08620010
086300          * PPS-WAGE-INDEX.                                       08630010
086400                                                                  08640010
086500     COMPUTE H-NONLABOR-PORTION =                                 08650010
086600        (PPS-STANDARD-PAY-AMT * PPS-NAT-NONLABOR-PCT).            08660010
086700                                                                  08670010
086800     COMPUTE PPS-FED-PAY-AMT ROUNDED =                            08680010
086900        ((H-LABOR-PORTION + H-NONLABOR-PORTION) *                 08690010
087000         PPS-RURAL-ADJUSTMENT).                                   08700010
087100                                                                  08710010
087200     COMPUTE PPS-LIP-PAY-AMT ROUNDED =                            08720010
087300        (PPS-FED-PAY-AMT * PPS-LIP-PCT).                          08730010
087400                                                                  08740010
087500     COMPUTE PPS-TEACH-PAY-AMT ROUNDED =                          08750010
087600        (PPS-FED-PAY-AMT * H-TEACH-PCT).                          08760010
087700                                                                  08770010
087800 3500-EXIT.                                                       08780010
087900      EXIT.                                                       08790010
088000                                                                  08800010
088100 4000-CALC-OUTLIER.                                               08810010
088200                                                                  08820010
088300     COMPUTE PPS-FAC-COSTS ROUNDED =                              08830010
088400         (B-COV-CHARGES * P-NEW-OPER-CSTCHG-RATIO).               08840010
088500                                                                  08850010
088600     COMPUTE H-OUTLIER-LABOR-PORTION =                            08860010
088700        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-LABOR-PCT)               08870010
088800              * PPS-WAGE-INDEX.                                   08880010
088900                                                                  08890010
089000     COMPUTE H-OUTLIER-NONLABOR-PORTION =                         08900010
089100        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-NONLABOR-PCT).           08910010
089200                                                                  08920010
089300     COMPUTE H-FP-OUTLIER-THRESHOLD ROUNDED =                     08930010
089400        ((H-OUTLIER-LABOR-PORTION + H-OUTLIER-NONLABOR-PORTION) * 08940010
089500         PPS-RURAL-ADJUSTMENT * (PPS-LIP-PCT + H-TEACH-PCT + 1)). 08950010
089600                                                                  08960010
089700     COMPUTE H-OUTLIER-THRESHOLD ROUNDED =                        08970010
089800        (PPS-FED-PAY-AMT + H-FP-OUTLIER-THRESHOLD +               08980010
089900         PPS-LIP-PAY-AMT + PPS-TEACH-PAY-AMT).                    08990010
090000                                                                  09000010
090100     IF PPS-FAC-COSTS > H-OUTLIER-THRESHOLD                       09010010
090200        COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                     09020010
090300           ((PPS-FAC-COSTS - H-OUTLIER-THRESHOLD) * .8).          09030010
090400                                                                  09040010
090500     COMPUTE H-CHG-OUTLIER-THRESHOLD ROUNDED =                    09050010
090600         H-OUTLIER-THRESHOLD / P-NEW-OPER-CSTCHG-RATIO.           09060010
090700                                                                  09070010
090800                                                                  09080010
090900 4000-EXIT.                                                       09090010
091000      EXIT.                                                       09100010
091100                                                                  09110010
091200 5000-FINAL-PAYMENTS.                                             09120010
091300                                                                  09130010
091400     IF B-SPEC-PAY-IND = '1' OR '3'                               09140010
091500         MOVE ZEROES TO PPS-OUTLIER-PAY-AMT.                      09150010
091600                                                                  09160010
091700     IF PPS-FED-RATE-PCT = 1.0000                                 09170010
091800         MOVE 0 TO PPS-FAC-SPEC-PAY-AMT                           09180010
091900     ELSE                                                         09190010
092000         COMPUTE PPS-FED-PAY-AMT ROUNDED =                        09200010
092100           (PPS-FED-RATE-PCT * PPS-FED-PAY-AMT)                   09210010
092200         COMPUTE PPS-FAC-SPEC-PAY-AMT ROUNDED =                   09220010
092300           (PPS-FAC-RATE-PCT * PPS-FAC-SPEC-RT-PREBLEND)          09230010
092400         COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                    09240010
092500           (PPS-FED-RATE-PCT * PPS-OUTLIER-PAY-AMT)               09250010
092600         COMPUTE PPS-TEACH-PAY-AMT ROUNDED =                      09260010
092700           (PPS-FED-RATE-PCT * PPS-TEACH-PAY-AMT)                 09270010
092800         COMPUTE PPS-LIP-PAY-AMT ROUNDED =                        09280010
092900           (PPS-FED-RATE-PCT * PPS-LIP-PAY-AMT).                  09290010
093000                                                                  09300010
093100     IF B-SPEC-PAY-IND = '2' OR '3'                               09310010
093200        COMPUTE PPS-FED-PENALTY-AMT ROUNDED =                     09320010
093300           (PPS-FED-PAY-AMT * .25)                                09330010
093400        COMPUTE PPS-FED-PAY-AMT =                                 09340010
093500           (PPS-FED-PAY-AMT - PPS-FED-PENALTY-AMT)                09350010
093600        COMPUTE PPS-LIP-PENALTY-AMT ROUNDED =                     09360010
093700           (PPS-LIP-PAY-AMT * .25)                                09370010
093800        COMPUTE PPS-LIP-PAY-AMT =                                 09380010
093900           (PPS-LIP-PAY-AMT - PPS-LIP-PENALTY-AMT)                09390010
094000        COMPUTE PPS-OUT-PENALTY-AMT ROUNDED =                     09400010
094100           (PPS-OUTLIER-PAY-AMT * .25)                            09410010
094200        COMPUTE PPS-OUTLIER-PAY-AMT =                             09420010
094300           (PPS-OUTLIER-PAY-AMT - PPS-OUT-PENALTY-AMT)            09430010
094400        COMPUTE PPS-TEACH-PENALTY-AMT ROUNDED =                   09440010
094500           (PPS-TEACH-PAY-AMT * .25)                              09450010
094600        COMPUTE PPS-TEACH-PAY-AMT =                               09460010
094700           (PPS-TEACH-PAY-AMT - PPS-TEACH-PENALTY-AMT)            09470010
094800        COMPUTE PPS-TOTAL-PENALTY-AMT =                           09480010
094900           (PPS-FED-PENALTY-AMT + PPS-LIP-PENALTY-AMT             09490010
095000           + PPS-OUT-PENALTY-AMT + PPS-TEACH-PENALTY-AMT).        09500010
095100                                                                  09510010
095200     COMPUTE PPS-TOTAL-PAY-AMT ROUNDED =                          09520010
095300        (PPS-FED-PAY-AMT + PPS-FAC-SPEC-PAY-AMT                   09530010
095400         + PPS-OUTLIER-PAY-AMT + PPS-LIP-PAY-AMT +                09540010
095500         PPS-TEACH-PAY-AMT).                                      09550010
095600                                                                  09560010
095700     IF PPS-FED-RATE-PCT = 1.0000                                 09570010
095800        IF PPS-TRANSFER-PCT = 1.0000                              09580010
095900           IF PPS-OUTLIER-PAY-AMT > 0.0                           09590010
096000              MOVE 01 TO PPS-RTC                                  09600010
096100           ELSE                                                   09610010
096200              MOVE 00 TO PPS-RTC                                  09620010
096300        ELSE                                                      09630010
096400           IF PPS-OUTLIER-PAY-AMT > 0.0                           09640010
096500              MOVE 03 TO PPS-RTC                                  09650010
096600           ELSE                                                   09660010
096700              MOVE 02 TO PPS-RTC                                  09670010
096800     ELSE                                                         09680010
096900        IF PPS-TRANSFER-PCT = 1.0000                              09690010
097000           IF PPS-OUTLIER-PAY-AMT > 0.0                           09700010
097100              MOVE 05 TO PPS-RTC                                  09710010
097200           ELSE                                                   09720010
097300              MOVE 04 TO PPS-RTC                                  09730010
097400        ELSE                                                      09740010
097500           IF PPS-OUTLIER-PAY-AMT > 0.0                           09750010
097600              MOVE 07 TO PPS-RTC                                  09760010
097700           ELSE                                                   09770010
097800              MOVE 06 TO PPS-RTC.                                 09780010
097900                                                                  09790010
098000     IF B-SPEC-PAY-IND = '2' OR '3'                               09800010
098100        COMPUTE PPS-RTC = PPS-RTC + 10.                           09810010
098200     IF PPS-RTC = (01 OR 03 OR 05 OR 07                           09820010
098300                OR 11 OR 13 OR 15 OR 17)                          09830010
098400        IF ((PPS-REG-DAYS-USED + PPS-LTR-DAYS-USED) < H-LOS)      09840010
098500           OR PPS-COT-IND = 'Y'                                   09850010
098600            MOVE 67 TO PPS-RTC.                                   09860010
098700                                                                  09870010
098800 5000-EXIT.                                                       09880010
098900      EXIT.                                                       09890010
099000                                                                  09900010
099100 9000-MOVE-RESULTS.                                               09910010
099200                                                                  09920010
099300     IF PPS-RTC < 50                                              09930010
099400      MOVE H-LOS                   TO  PPS-LOS                    09940010
099500      MOVE H-OUTLIER-THRESHOLD     TO  PPS-OUTLIER-THRESHOLD      09950010
099600      MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD   09960010
099700      MOVE W-NEW-CBSA              TO  PPS-CBSA                   09970010
099800      MOVE 'V09.0'                 TO  PPS-CALC-VERS-CD           09980010
099900     ELSE                                                         09990010
100000       INITIALIZE PPS-DATA                                        10000010
100100       INITIALIZE PPS-OTHER-DATA                                  10010010
100200       MOVE 'V09.0'                TO  PPS-CALC-VERS-CD.          10020010
100300                                                                  10030010
100400     IF PPS-RTC = 67                                              10040010
100500       MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD. 10050010
100600                                                                  10060010
100700 9000-EXIT.                                                       10070010
100800      EXIT.                                                       10080010
100900                                                                  10090010
101000******        L A S T   S O U R C E   S T A T E M E N T   *****   10100010
