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