000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.    IRCAL130.                                         00020001
000300*AUTHOR.        PBG/DDS.                                          00030000
000400*REMARKS.       CMS.                                              00040000
000500                                                                  00050000
000600 DATE-COMPILED.                                                   00060000
000610******************************************************************00061000
000620*  CHANGE FOR 2013 - EFFECTIVE 10/01/2012                        *00062001
000622*----------------------------------------------------------------*00062200
000623* UPDATED CMG-TABLE FOR 2013                                     *00062301
000624*                                                                *00062400
000625* UPDATED 0100-INITIAL-ROUTINE VALUES                            *00062500
000626*                                                                *00062600
000627* MOVE .69981 TO PPS-NAT-LABOR-PCT.                              *00062702
000628* MOVE .30019 TO PPS-NAT-NONLABOR-PCT.                           *00062802
000629* MOVE 10466  TO PPS-NAT-THRESHOLD-ADJ.                          *00062902
000631* MOVE 14343  TO PPS-BDGT-NEUT-CONV-AMT.                         *00063102
000633*                                                                *00063300
000651******************************************************************00065100
000652     EJECT                                                        00065200
000653 ENVIRONMENT DIVISION.                                            00065300
000654 CONFIGURATION SECTION.                                           00065400
000655 SOURCE-COMPUTER.            IBM-370.                             00065500
000660 OBJECT-COMPUTER.            IBM-370.                             00066000
000670 INPUT-OUTPUT  SECTION.                                           00067000
000680 FILE-CONTROL.                                                    00068000
000690                                                                  00069000
000700 DATA DIVISION.                                                   00070000
000800 FILE SECTION.                                                    00080000
000900                                                                  00090000
001000 WORKING-STORAGE SECTION.                                         00100000
001100 01  W-STORAGE-REF                  PIC X(46)  VALUE              00110000
001200     'IRCAL130      - W O R K I N G   S T O R A G E'.             00120001
001300 01  CAL-VERSION                    PIC X(05)  VALUE 'V13.0'.     00130001
001400                                                                  00140000
001500***************************************************************   00150000
001600*    LAYUP TABLE AREA FOR FY2013 CMGS                         *   00160003
001700*    EFFECTIVE DATE OF OCTOBER 1, 2012                        *   00170003
001800***************************************************************   00180000
001810     EJECT                                                        00181004
001900 01  CMG-TABLE.                                                   00190004
002000     05  CMG-TABLE-DATA.                                          00200004
002100         10                      PIC X(32)   VALUE                00210004
002200           '01010802707192065410625410100908'.                    00220004
002300         10                      PIC X(32)   VALUE                00230004
002400           '01020998008942081320777612101010'.                    00240004
002500         10                      PIC X(32)   VALUE                00250004
002600           '01031162210414094710905612131212'.                    00260004
002700         10                      PIC X(32)   VALUE                00270004
002800           '01041232311041100410960213121212'.                    00280004
002900         10                      PIC X(32)   VALUE                00290004
003000           '01051437812883117161120315161414'.                    00300004
003100         10                      PIC X(32)   VALUE                00310004
003200           '01061637314670133421275817181616'.                    00320004
003300         10                      PIC X(32)   VALUE                00330004
003400           '01071838116469149781432218191718'.                    00340004
003500         10                      PIC X(32)   VALUE                00350004
003600           '01082297520585187211790123232221'.                    00360004
003700         10                      PIC X(32)   VALUE                00370004
003800           '01092122619018172961653920222020'.                    00380004
003900         10                      PIC X(32)   VALUE                00390004
004000           '01102730324463222482127430292525'.                    00400004
004100         10                      PIC X(32)   VALUE                00410004
004200           '02010831306948061990586910100808'.                    00420004
004300         10                      PIC X(32)   VALUE                00430004
004400           '02021016908499075830717912111010'.                    00440004
004500         10                      PIC X(32)   VALUE                00450004
004600           '02031180409865088030833414131211'.                    00460004
004700         10                      PIC X(32)   VALUE                00470004
004800           '02041293810813096480913414131212'.                    00480004
004900         10                      PIC X(32)   VALUE                00490004
005000           '02051555012996115961097816151414'.                    00500004
005100         10                      PIC X(32)   VALUE                00510004
005200           '02061938316200144551368420201817'.                    00520004
005300         10                      PIC X(32)   VALUE                00530004
005400           '02072553521341190421802733252221'.                    00540004
005500         10                      PIC X(32)   VALUE                00550004
005600           '03011121809563084620785211121110'.                    00560004
005700         10                      PIC X(32)   VALUE                00570004
005800           '03021402611957105790981614141312'.                    00580004
005900         10                      PIC X(32)   VALUE                00590004
006000           '03031660514155125251162117161514'.                    00600004
006100         10                      PIC X(32)   VALUE                00610004
006200           '03042206518810166431544325221918'.                    00620004
006300         10                      PIC X(32)   VALUE                00630004
006400           '04011039308778078640710913121110'.                    00640004
006500         10                      PIC X(32)   VALUE                00650004
006600           '04021482412521112181014117151413'.                    00660004
006700         10                      PIC X(32)   VALUE                00670004
006800           '04032387020161180631632931232220'.                    00680004
006900         10                      PIC X(32)   VALUE                00690004
007000           '04044366536881330432987060413335'.                    00700004
007100         10                      PIC X(32)   VALUE                00710004
007200           '04053389328627256482318641412924'.                    00720004
007300         10                      PIC X(32)   VALUE                00730004
007400           '05010843606828063060562409090808'.                    00740004
007500         10                      PIC X(32)   VALUE                00750004
007600           '05021128309132084340752111111110'.                    00760004
007700         10                      PIC X(32)   VALUE                00770004
007800           '05031428411561106770952215141312'.                    00780004
007900         10                      PIC X(32)   VALUE                00790004
008000           '05041722013937128721147922161514'.                    00800004
008100         10                      PIC X(32)   VALUE                00810004
008200           '05051965615909146931310322181816'.                    00820004
008300         10                      PIC X(32)   VALUE                00830004
008400           '05062770722425207111847030262422'.                    00840004
008500         10                      PIC X(32)   VALUE                00850004
008600           '06010970307915073040664710100909'.                    00860004
008700         10                      PIC X(32)   VALUE                00870004
008800           '06021269510356095570869713121111'.                    00880004
008900         10                      PIC X(32)   VALUE                00890004
009000           '06031624313250122281112816151414'.                    00900004
009100         10                      PIC X(32)   VALUE                00910004
009200           '06042153717568162131475522201817'.                    00920004
009300         10                      PIC X(32)   VALUE                00930004
009400           '07010934307841074810677211101009'.                    00940004
009500         10                      PIC X(32)   VALUE                00950004
009600           '07021247710471099900904413131212'.                    00960004
009700         10                      PIC X(32)   VALUE                00970004
009800           '07031498412575119961086016151414'.                    00980004
009900         10                      PIC X(32)   VALUE                00990004
010000           '07041899415940152071376719181817'.                    01000004
010100         10                      PIC X(32)   VALUE                01010004
010200           '08010744506142056080515608080807'.                    01020004
010300         10                      PIC X(32)   VALUE                01030004
010400           '08020983908117074120681410100909'.                    01040004
010500         10                      PIC X(32)   VALUE                01050004
010600           '08031338111039100800926613121312'.                    01060004
010700         10                      PIC X(32)   VALUE                01070004
010800           '08041188909807089550823313121110'.                    01080004
010900         10                      PIC X(32)   VALUE                01090004
011000           '08051472812150110941019915141313'.                    01100004
011100         10                      PIC X(32)   VALUE                01110004
011200           '08061796614821135331244117171515'.                    01120004
011300         10                      PIC X(32)   VALUE                01130004
011400           '09010908607488069540628911100908'.                    01140004
011500         10                      PIC X(32)   VALUE                01150004
011600           '09021191609820091200824812121111'.                    01160004
011700         10                      PIC X(32)   VALUE                01170004
011800           '09031542112709118031067416151413'.                    01180004
011900         10                      PIC X(32)   VALUE                01190004
012000           '09041959616149149981356420191716'.                    01200004
012100         10                      PIC X(32)   VALUE                01210004
012200           '10011016809097082240749111111010'.                    01220004
012300         10                      PIC X(32)   VALUE                01230004
012400           '10021281311464103640944014141312'.                    01240004
012500         10                      PIC X(32)   VALUE                01250004
012600           '10031852316572149831364718191716'.                    01260004
012700         10                      PIC X(32)   VALUE                01270004
012800           '11011155311084110840900513181211'.                    01280004
012900         10                      PIC X(32)   VALUE                01290004
013000           '11021608315429154291253617241616'.                    01300004
013100         10                      PIC X(32)   VALUE                01310004
013200           '12010903109031086750807009121110'.                    01320004
013300         10                      PIC X(32)   VALUE                01330004
013400           '12021065210652102320951810131212'.                    01340004
013500         10                      PIC X(32)   VALUE                01350004
013600           '12031374013740131991227812171515'.                    01360004
013700         10                      PIC X(32)   VALUE                01370004
013800           '13011208410270090580806613121110'.                    01380004
013900         10                      PIC X(32)   VALUE                01390004
014000           '13021572013360117831049216151413'.                    01400004
014100         10                      PIC X(32)   VALUE                01410004
014200           '13032000617003149961335419201716'.                    01420004
014300         10                      PIC X(32)   VALUE                01430004
014400           '14010893007627068770626609090908'.                    01440004
014500         10                      PIC X(32)   VALUE                01450004
014600           '14021152809847088770808912121110'.                    01460004
014700         10                      PIC X(32)   VALUE                01470004
014800           '14031389011864106960974714141312'.                    01480004
014900         10                      PIC X(32)   VALUE                01490004
015000           '14041781115213137161249819181615'.                    01500004
015100         10                      PIC X(32)   VALUE                01510004
015200           '15010969808491077730736410100909'.                    01520004
015300         10                      PIC X(32)   VALUE                01530004
015400           '15021211810610097120920112121111'.                    01540004
015500         10                      PIC X(32)   VALUE                01550004
015600           '15031487513025119221129516141313'.                    01560004
015700         10                      PIC X(32)   VALUE                01570004
015800           '15041883416491150951430119181616'.                    01580004
015900         10                      PIC X(32)   VALUE                01590004
016000           '16011049909155083500758110111010'.                    01600004
016100         10                      PIC X(32)   VALUE                01610004
016200           '16021382612056109970998415141312'.                    01620004
016300         10                      PIC X(32)   VALUE                01630004
016400           '16031734615124137961252514181615'.                    01640004
016500         10                      PIC X(32)   VALUE                01650004
016600           '17011073609323085050757411121110'.                    01660004
016700         10                      PIC X(32)   VALUE                01670004
016800           '17021405612206111360991614151312'.                    01680004
016900         10                      PIC X(32)   VALUE                01690004
017000           '17031635314201129561153718171514'.                    01700004
017100         10                      PIC X(32)   VALUE                01710004
017200           '17042088718138165471473522211918'.                    01720004
017300         10                      PIC X(32)   VALUE                01730004
017400           '18011236509356086750759214131210'.                    01740004
017500         10                      PIC X(32)   VALUE                01750004
017600           '18021871014158131271148818171614'.                    01760004
017700         10                      PIC X(32)   VALUE                01770004
017800           '18033316725096232692036438322523'.                    01780004
017900         10                      PIC X(32)   VALUE                01790004
018000           '19011046709509091850874913121211'.                    01800004
018100         10                      PIC X(32)   VALUE                01810004
018200           '19021918917433168391604123201819'.                    01820004
018300         10                      PIC X(32)   VALUE                01830004
018400           '19033311930088290622768541333334'.                    01840004
018500         10                      PIC X(32)   VALUE                01850004
018600           '20010874407276066800609509090908'.                    01860004
018700         10                      PIC X(32)   VALUE                01870004
018800           '20021179609815090120822212121110'.                    01880004
018900         10                      PIC X(32)   VALUE                01890004
019000           '20031481712329113201032815141313'.                    01900004
019100         10                      PIC X(32)   VALUE                01910004
019200           '20041959416304149701365921191716'.                    01920004
019300         10                      PIC X(32)   VALUE                01930004
019400           '21012194719009190091641424221717'.                    01940004
019500         10                      PIC X(32)   VALUE                01950004
019600           '50010000000000000000149400000003'.                    01960004
019700         10                      PIC X(32)   VALUE                01970004
019800           '51010000000000000000586600000007'.                    01980004
019900         10                      PIC X(32)   VALUE                01990004
020000           '51020000000000000001532500000018'.                    02000004
020100         10                      PIC X(32)   VALUE                02010004
020200           '51030000000000000000709100000008'.                    02020004
020300         10                      PIC X(32)   VALUE                02030004
020400           '51040000000000000001905300000022'.                    02040004
020500         10                      PIC X(32)   VALUE                02050004
020600           '99990000000000000000000000000000'.                    02060004
020700     05  W-CMG-TABLE REDEFINES CMG-TABLE-DATA.                    02070004
020800         10  CMG-DATA            OCCURS 93 TIMES                  02080004
020900                                 ASCENDING KEY IS CMG-NUM         02090004
021000                                 INDEXED BY DX6.                  02100004
021100             15  CMG-NUM         PIC X(4).                        02110004
021200             15  CMG-NUM-REDEF REDEFINES CMG-NUM.                 02120004
021300                 20  CMG-RIC     PIC XX.                          02130004
021400                 20  FILLER      PIC XX.                          02140004
021500             15  B-REL-WGT       PIC 9(1)V9(4).                   02150004
021600             15  C-REL-WGT       PIC 9(1)V9(4).                   02160004
021700             15  D-REL-WGT       PIC 9(1)V9(4).                   02170004
021800             15  A-REL-WGT       PIC 9(1)V9(4).                   02180004
021900             15  B-LOS-TABLE     PIC 9(2).                        02190004
022000             15  C-LOS-TABLE     PIC 9(2).                        02200004
022100             15  D-LOS-TABLE     PIC 9(2).                        02210004
022101             15  A-LOS-TABLE     PIC 9(2).                        02210104
023053     EJECT                                                        02305300
023054 01  HOLD-PPS-COMPONENTS.                                         02305400
023055     05  H-LOS                        PIC 9(05).                  02305500
023056     05  H-WK-DSH                     PIC 9(01)V9(04).            02305600
023057     05  H-TEACH-PCT                  PIC 9(01)V9(04).            02305700
023058     05  H-LABOR-PORTION              PIC 9(07)V9(06).            02305800
023059     05  H-NONLABOR-PORTION           PIC 9(07)V9(06).            02305900
023060     05  H-OUTLIER-LABOR-PORTION      PIC 9(07)V9(06).            02306000
023061     05  H-OUTLIER-NONLABOR-PORTION   PIC 9(07)V9(06).            02306100
023070     05  H-FP-OUTLIER-THRESHOLD       PIC 9(07)V9(06).            02307000
023100     05  H-OUTLIER-THRESHOLD          PIC 9(07)V9(06).            02310000
023200     05  H-CHG-OUTLIER-THRESHOLD      PIC 9(07)V9(04).            02320000
023300     05  H-FY-BEGIN-DATE              PIC 9(08).                  02330000
023400     05  H-DISCHARGE-DATE             PIC 9(08).                  02340000
023500                                                                  02350000
023600 LINKAGE SECTION.                                                 02360000
023700**************************************************************    02370000
023800*      THIS IS THE BILL-RECORD THAT WILL BE PASSED FROM      *    02380000
023900*      THE IRCAL___ PROGRAM                                  *    02390000
024000**************************************************************    02400000
024100 01  BILL-NEW-DATA.                                               02410000
024200         10  B-NPI10.                                             02420000
024300             15  B-NPI8             PIC X(08).                    02430000
024400             15  B-NPI-FILLER       PIC X(02).                    02440000
024500         10  B-PROVIDER-NO          PIC X(06).                    02450000
024600         10  B-PATIENT-STATUS       PIC X(02).                    02460000
024700         10  B-CMG-CODE             PIC X(05).                    02470000
024800         10  B-LOS                  PIC 9(03).                    02480000
024900         10  B-COV-DAYS             PIC 9(03).                    02490000
025000         10  B-LTR-DAYS             PIC 9(02).                    02500000
025100         10  B-SPEC-PAY-IND         PIC X(01).                    02510000
025200         10  B-DISCHARGE-DATE.                                    02520000
025300             15  B-DISCHG-CC        PIC 9(02).                    02530000
025400             15  B-DISCHG-YY        PIC 9(02).                    02540000
025500             15  B-DISCHG-MM        PIC 9(02).                    02550000
025600             15  B-DISCHG-DD        PIC 9(02).                    02560000
025700         10  B-COV-CHARGES          PIC 9(07)V9(02).              02570000
025800         10  FILLER                 PIC X(11).                    02580000
025900                                                                  02590000
026000***************************************************************   02600000
026100*    THIS DATA IS CALCULATED BY THIS IRCAL SUBROUTINE         *   02610000
026200*    AND PASSED BACK TO THE CALLING PROGRAM                   *   02620000
026300*            RETURN CODE VALUES (PPS-RTC)                     *   02630000
026400*                                                             *   02640000
026500*     ****   PPS-RTC 00-49 = HOW THE BILL WAS PAID            *   02650000
026600*              00 = PAID NORMAL CMG PAYMENT WITHOUT OUTLIER   *   02660000
026700*                                                             *   02670000
026800*              01 = PAID NORMAL CMG PAYMENT WITH OUTLIER      *   02680000
026900*                                                             *   02690000
027000*              02 = TRANSFER PAID ON A PERDIEM BASIS WITHOUT  *   02700000
027100*                   OUTLIER                                   *   02710000
027200*              03 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   02720000
027300*                   OUTLIER                                   *   02730000
027400*              04 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02740000
027500*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02750000
027600*                   WITHOUT OUTLIER                           *   02760000
027700*              05 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02770000
027800*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02780000
027900*                   WITH OUTLIER                              *   02790000
028000*              06 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   02800000
028100*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   02810000
028200*                   RATE -- WITHOUT OUTLIER                   *   02820000
028300*              07 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   02830000
028400*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   02840000
028500*                   RATE -- WITH OUTLIER                      *   02850000
028600*       **** NEW RT CODES FOR PAYMENT WITH PENALTIES          *   02860000
028700*              10 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   02870000
028800*                   WITHOUT OUTLIER                           *   02880000
028900*              11 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   02890000
029000*                   WITH OUTLIER                              *   02900000
029100*              12 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   02910000
029200*                   PENALTY WITHOUT OUTLIER                   *   02920000
029300*              13 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   02930000
029400*                   PENALTY WITH OUTLIER                      *   02940000
029500*              14 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02950000
029600*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02960000
029700*                   WITH PENALTY WITHOUT OUTLIER              *   02970000
029800*              15 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02980000
029900*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02990000
030000*                   WITH PENALTY WITH OUTLIER                 *   03000000
030100*              16 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03010000
030200*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03020000
030300*                   RATE -- WITH PENALTY WITHOUT OUTLIER      *   03030000
030400*              17 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03040000
030500*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03050000
030600*                   RATE -- WITH PENALTY WITH OUTLIER         *   03060000
030700*                                                             *   03070000
030800*      ****  PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   03080000
030900*              50 = PROVIDER SPECIFIC RATE NOT NUMERIC        *   03090000
031000*              51 = PROVIDER RECORD TERMINATED                *   03100000
031100*              52 = INVALID WAGE INDEX                        *   03110000
031200*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   03120000
031300*              54 = CMG ON CLAIM NOT FOUND IN TABLE           *   03130000
031400*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   03140000
031500*                                      OR                     *   03150000
031600*                   DISCHARGE DATE < MSA EFF START DATE       *   03160000
031700*                   FOR PPS                                   *   03170000
031800*              56 = INVALID LENGTH OF STAY                    *   03180000
031900*              57 = PROVIDER SPECIFIC RATE ZERO WHEN BLENDED  *   03190000
032000*                   PAYMENT REQUESTED                         *   03200000
032100*              58 = TOTAL COVERED CHARGES NOT NUMERIC         *   03210000
032200*              59 = PROVIDER SPECIFIC RECORD NOT FOUND        *   03220000
032300*              60 = MSA WAGE INDEX RECORD NOT FOUND           *   03230000
032400*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *   03240000
032500*                   OR BILL-LTR-DAYS > 60                     *   03250000
032600*              62 = INVALID NUMBER OF COVERED DAYS            *   03260000
032700*              65 = OPERATING COST-TO-CHARGE RATIO NOT NUMERIC*   03270000
032800*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *   03280000
032900*                   OR COST OUTLIER THRESHOLD CALCULATION     *   03290000
033000*              72 = INVALID BLEND INDICATOR (NOT 3 OR 4)      *   03300000
033100*              73 = DISCHARGED BEFORE PROVIDER FY BEGIN       *   03310000
033200*              74 = PROVIDER FY BEGIN DATE NOT IN 2002        *   03320000
033300***************************************************************   03330000
033400 01  PPS-DATA-ALL.                                                03340000
033500     05  PPS-RTC                      PIC 9(02).                  03350000
033600     05  PPS-DATA.                                                03360000
033700         10  PPS-MSA                  PIC X(04).                  03370000
033800         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).            03380000
033900         10  PPS-AVG-LOS              PIC 9(02).                  03390000
034000         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).            03400000
034100         10  PPS-TOTAL-PAY-AMT        PIC 9(07)V9(02).            03410000
034200         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).            03420000
034300         10  PPS-FAC-SPEC-PAY-AMT     PIC 9(07)V9(02).            03430000
034400         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).            03440000
034500         10  PPS-LIP-PAY-AMT          PIC 9(07)V9(02).            03450000
034600         10  PPS-LIP-PCT              PIC 9(01)V9(04).            03460000
034700         10  PPS-LOS                  PIC 9(03).                  03470000
034800         10  PPS-REG-DAYS-USED        PIC 9(03).                  03480000
034900         10  PPS-LTR-DAYS-USED        PIC 9(03).                  03490000
035000         10  PPS-TRANSFER-PCT         PIC 9(01)V9(04).            03500000
035100         10  PPS-FAC-SPEC-RT-PREBLEND PIC 9(05)V9(02).            03510000
035200         10  PPS-STANDARD-PAY-AMT     PIC 9(07)V9(02).            03520000
035300         10  PPS-FAC-COSTS            PIC 9(07)V9(02).            03530000
035400         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).            03540000
035500         10  PPS-CHG-OUTLIER-THRESHOLD PIC 9(07)V9(02).           03550000
035600         10  PPS-TOTAL-PENALTY-AMT    PIC 9(07)V9(02).            03560000
035700         10  PPS-FED-PENALTY-AMT      PIC 9(07)V9(02).            03570000
035800         10  PPS-LIP-PENALTY-AMT      PIC 9(07)V9(02).            03580000
035900         10  PPS-OUT-PENALTY-AMT      PIC 9(07)V9(02).            03590000
036000         10  PPS-SUBM-CMG-CODE        PIC X(05).                  03600000
036100         10  PPS-CMG-CODE-REDEF REDEFINES PPS-SUBM-CMG-CODE.      03610000
036200            15  PPS-CMG-ALPHA         PIC X(01).                  03620000
036300            15  PPS-CMG-NUMERIC.                                  03630000
036400               20  PPS-CMG-RIC        PIC X(02).                  03640000
036500               20  FILLER             PIC X(02).                  03650000
036600         10  PPS-PRICED-CMG-CODE      PIC X(05).                  03660000
036700         10  PPS-CALC-VERS-CD         PIC X(05).                  03670000
036800         10  PPS-CBSA                 PIC X(05).                  03680000
036900         10  FILLER                   PIC X(08).                  03690000
037000     05  PPS-OTHER-DATA.                                          03700000
037100         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).            03710000
037200         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).            03720000
037300         10  PPS-NAT-THRESHOLD-ADJ    PIC 9(05)V9(02).            03730000
037400         10  PPS-BDGT-NEUT-CONV-AMT   PIC 9(05)V9(02).            03740000
037500         10  PPS-FED-RATE-PCT         PIC 9(01)V9(04).            03750000
037600         10  PPS-FAC-RATE-PCT         PIC 9(01)V9(04).            03760000
037700         10  PPS-RURAL-ADJUSTMENT     PIC 9(01)V9(04).            03770000
037800         10  PPS-TEACH-PAY-AMT        PIC 9(07)V9(02).            03780000
037900         10  PPS-TEACH-PENALTY-AMT    PIC 9(07)V9(02).            03790000
038000         10  FILLER                   PIC X(02).                  03800000
038100     05  PPS-PC-DATA.                                             03810000
038200         10  PPS-COT-IND              PIC X(01).                  03820000
038300         10  FILLER                   PIC X(20).                  03830000
038400                                                                  03840000
038500******************************************************************03850000
038600*            THESE ARE THE VERSIONS OF THE IRDRV___               03860000
038700*           PROGRAMS THAT WILL BE PASSED BACK----                 03870000
038800*          ASSOCIATED WITH THE BILL BEING PROCESSED               03880000
038900******************************************************************03890000
039000 01  PRICER-OPT-VERS-SW.                                          03900000
039100     05  PRICER-OPTION-SW          PIC X(01).                     03910000
039200         88  ALL-TABLES-PASSED          VALUE 'A'.                03920000
039300         88  PROV-RECORD-PASSED         VALUE 'P'.                03930000
039400     05  PPS-VERSIONS.                                            03940000
039500         10  PPDRV-VERSION         PIC X(05).                     03950000
039600                                                                  03960000
039700**************************************************************    03970000
039800*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BY        *    03980000
039900*      THE IRCAL___ PROGRAM                                  *    03990000
040000**************************************************************    04000000
040100 01  PROV-NEW-HOLD.                                               04010000
040200     02  PROV-NEWREC-HOLD1.                                       04020000
040300         05  P-NEW-NPI10.                                         04030000
040400             10  P-NEW-NPI8             PIC X(08).                04040000
040500             10  P-NEW-NPI-FILLER       PIC X(02).                04050000
040600         05  P-NEW-PROVIDER-NO.                                   04060000
040700             10  P-NEW-STATE            PIC 9(02).                04070000
040800             10  FILLER                 PIC X(04).                04080000
040900         05  P-NEW-DATE-DATA.                                     04090000
041000             10  P-NEW-EFF-DATE.                                  04100000
041100                 15  P-NEW-EFF-DT-CC    PIC 9(02).                04110000
041200                 15  P-NEW-EFF-DT-YY    PIC 9(02).                04120000
041300                 15  P-NEW-EFF-DT-MM    PIC 9(02).                04130000
041400                 15  P-NEW-EFF-DT-DD    PIC 9(02).                04140000
041500             10  P-NEW-FY-BEGIN-DATE.                             04150000
041600                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                04160000
041700                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                04170000
041800                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                04180000
041900                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                04190000
042000             10  P-NEW-REPORT-DATE.                               04200000
042100                 15  P-NEW-REPORT-DT-CC PIC 9(02).                04210000
042200                 15  P-NEW-REPORT-DT-YY PIC 9(02).                04220000
042300                 15  P-NEW-REPORT-DT-MM PIC 9(02).                04230000
042400                 15  P-NEW-REPORT-DT-DD PIC 9(02).                04240000
042500             10  P-NEW-TERMINATION-DATE.                          04250000
042600                 15  P-NEW-TERM-DT-CC   PIC 9(02).                04260000
042700                 15  P-NEW-TERM-DT-YY   PIC 9(02).                04270000
042800                 15  P-NEW-TERM-DT-MM   PIC 9(02).                04280000
042900                 15  P-NEW-TERM-DT-DD   PIC 9(02).                04290000
043000         05  P-NEW-WAIVER-CODE          PIC X(01).                04300000
043100             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              04310000
043200         05  P-NEW-INTER-NO             PIC 9(05).                04320000
043300         05  P-NEW-PROVIDER-TYPE        PIC X(02).                04330000
043400         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                04340000
043500         05  P-NEW-CURRENT-DIV   REDEFINES                        04350000
043600                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         04360000
043700         05  P-NEW-MSA-DATA.                                      04370000
043800             10  P-NEW-CHG-CODE-INDEX       PIC X.                04380000
043900             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 04390000
044000             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   04400000
044100                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       04410000
044200             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 04420000
044300             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 04430000
044400             10  P-NEW-STAND-AMT-LOC-MSA9                         04440000
044500                 REDEFINES P-NEW-STAND-AMT-LOC-MSA.               04450000
044600                 15  P-NEW-RURAL-1ST.                             04460000
044700                     20  P-NEW-STAND-RURAL  PIC XX.               04470000
044800                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    04480000
044900                 15  P-NEW-RURAL-2ND        PIC XX.               04490000
045000         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    04500000
045100         05  P-NEW-LUGAR                    PIC X.                04510000
045200         05  P-NEW-TEMP-RELIEF-IND          PIC X.                04520000
045300         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                04530000
045400         05  FILLER                         PIC X(05).            04540000
045500     02  PROV-NEWREC-HOLD2.                                       04550000
045600         05  P-NEW-VARIABLES.                                     04560000
045700             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        04570000
045800             10  P-NEW-COLA              PIC  9(01)V9(03).        04580000
045900             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        04590000
046000             10  P-NEW-BED-SIZE          PIC  9(05).              04600000
046100             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        04610000
046200             10  P-NEW-CMI               PIC  9(01)V9(04).        04620000
046300             10  P-NEW-SSI-RATIO         PIC  V9(04).             04630000
046400             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             04640000
046500             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              04650000
046600             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        04660000
046700             10  P-NEW-DSH-PERCENT       PIC  V9(04).             04670000
046800             10  P-NEW-FYE-DATE          PIC  X(08).              04680000
046900         05  P-NEW-CBSA-DATA.                                     04690000
047000             10  P-NEW-CBSA-SPEC-PAY-IND   PIC X.                 04700000
047100             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.                 04710000
047200             10  P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.  04720000
047300             10  P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.  04730000
047400             10  P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.  04740000
047500             10  P-NEW-CBSA-STAND-AMT-LOC9                        04750000
047600                 REDEFINES P-NEW-CBSA-STAND-AMT-LOC.              04760000
047700                 15  P-NEW-CBSA-RURAL-1ST.                        04770000
047800                     20  P-NEW-CBSA-STAND-RURAL PIC 999.          04780000
047900                 15  P-NEW-CBSA-RURAL-2ND       PIC 99.           04790000
048000             10  P-NEW-CBSA-SPEC-WAGE-INDEX     PIC 9(02)V9(04).  04800000
048100     02  PROV-NEWREC-HOLD3.                                       04810000
048200         05  P-NEW-PASS-AMT-DATA.                                 04820000
048300             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          04830000
048400             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          04840000
048500             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          04850000
048600             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          04860000
048700         05  P-NEW-CAPI-DATA.                                     04870000
048800             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 04880000
048900             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          04890000
049000             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          04900000
049100             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        04910000
049200             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             04920000
049300             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 04930000
049400             15  P-NEW-CAPI-IME            PIC 9V9999.            04940000
049500             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          04950000
049600             15  P-VAL-BASED-PURCH-SCORE   PIC 9V999.             04960000
049700         05  FILLER                        PIC X(18).             04970000
049800******************************************************************04980000
049900*                   THIS IS THE WAGE-INDEX                        04990000
050000*          ASSOCIATED WITH THE BILL BEING PROCESSED               05000000
050100*                                                                 05010000
050200******************************************************************05020000
050300 01  WAGE-NEW-INDEX-RECORD-CBSA.                                  05030000
050400     05  W-NEW-CBSA                    PIC X(5).                  05040000
050500*       88  VALID-RURAL-CBSA    VALUE                             05050000
050600*             '50001' '50007' '50016' '50020' '50031'             05060000
050700*             '50036' '50054' '50060' '50067' '50087'             05070000
050800*             '50089' '50091' '50092' '50100' '50104'             05080000
050900*             '50108' '50114' '50121' '50125' '50140'             05090000
051000*             '50145' '50152' '50164' '50170' '50192'             05100000
051100*             '50199' '50206' '50210' '50214' '50218'             05110000
051200*             '50222' '50225' '50226' '50231' '50234'             05120000
051300*             '50237' '50243' '50248' '50250' '50255'             05130000
051400*             '50256' '50257' '50260' '50261' '50262'             05140000
051500*             '50263' '50266' '50268' '50272' '50275'             05150000
051600*             '50281' '50286' '50293' '50313' '50314'             05160000
051700*             '50316' '50325' '50326' '50327' '50329'             05170000
051800*             '50336' '50344' '50352'.                            05180000
051900     05  W-NEW-EFF-DATE-C              PIC X(8).                  05190000
052000     05  W-NEW-WAGE-INDEX-C            PIC S9(02)V9(04).          05200000
052100                                                                  05210000
052200 PROCEDURE DIVISION  USING BILL-NEW-DATA                          05220000
052300                           PPS-DATA-ALL                           05230000
052400                           PRICER-OPT-VERS-SW                     05240000
052500                           PROV-NEW-HOLD                          05250000
052600                           WAGE-NEW-INDEX-RECORD-CBSA.            05260000
052700***************************************************************   05270000
052800*    PROCESSING:                                              *   05280000
052900*        A. WILL PROCESS CLAIMS BASED ON DISCHARGE DATE       *   05290000
053000*        B. INITIALIZE IRCAL HOLD VARIABLES.                  *   05300000
053100*        C. EDIT THE DATA PASSED FROM THE CLAIM BEFORE        *   05310000
053200*           ATTEMPTING TO CALCULATE PPS. IF THIS CLAIM        *   05320000
053300*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   05330000
053400*           GOBACK.                                           *   05340000
053500*        D. ASSEMBLE PRICING COMPONENTS.                      *   05350000
053600*        E. CALCULATE THE PRICE.                              *   05360000
053700*        F. CALCULATE OUTLIERS IF APPLICABLE.                 *   05370000
053800***************************************************************   05380000
053900                                                                  05390000
054000 0000-MAINLINE-CONTROL.                                           05400000
054120                                                                  05412000
054200     PERFORM 0100-INITIAL-ROUTINE                                 05420000
054300        THRU 0100-EXIT.                                           05430000
054400                                                                  05440000
054500     PERFORM 1000-EDIT-THE-BILL-INFO                              05450000
054600        THRU 1000-EXIT.                                           05460000
054700                                                                  05470000
054800     IF PPS-RTC = 00                                              05480000
054900        PERFORM 1700-EDIT-CMG-CODE                                05490000
055000           THRU 1700-EXIT.                                        05500000
055100                                                                  05510000
055200     IF PPS-RTC = 00                                              05520000
055300        PERFORM 2000-ASSEMBLE-PPS-VARIABLES                       05530000
055400           THRU 2000-EXIT.                                        05540000
055500                                                                  05550000
055600     IF PPS-RTC = 00                                              05560000
055700        PERFORM 3000-CALC-PAYMENT                                 05570000
055800           THRU 3000-EXIT                                         05580000
055900        PERFORM 3500-CONTINUE-CALC                                05590000
056000           THRU 3500-EXIT                                         05600000
056100        PERFORM 4000-CALC-OUTLIER                                 05610000
056200           THRU 4000-EXIT                                         05620000
056300        PERFORM 5000-FINAL-PAYMENTS                               05630000
056400           THRU 5000-EXIT.                                        05640000
056500                                                                  05650000
056600     PERFORM 9000-MOVE-RESULTS                                    05660000
056700        THRU 9000-EXIT.                                           05670000
056800                                                                  05680000
056900     GOBACK.                                                      05690000
057000                                                                  05700000
057100 0100-INITIAL-ROUTINE.                                            05710000
057200                                                                  05720000
057300     MOVE ZEROS TO PPS-RTC.                                       05730000
057400     INITIALIZE PPS-DATA.                                         05740000
057500     INITIALIZE PPS-OTHER-DATA.                                   05750000
057600     INITIALIZE HOLD-PPS-COMPONENTS.                              05760000
057700***************************************************************   05770000
057800*    UPDATE THE VALUES BELOW FOR EACH FY RELEASE              *   05780000
057900*     - VALUES PER POLICY                                     *   05790000
058000***************************************************************   05800000
058100                                                                  05810000
058110     MOVE .69981 TO PPS-NAT-LABOR-PCT.                            05811002
058120     MOVE .30019 TO PPS-NAT-NONLABOR-PCT.                         05812002
058130     MOVE 10466  TO PPS-NAT-THRESHOLD-ADJ.                        05813002
058140     MOVE 14343  TO PPS-BDGT-NEUT-CONV-AMT.                       05814002
058600                                                                  05860000
058700 0100-EXIT.                                                       05870000
058800      EXIT.                                                       05880000
058900                                                                  05890000
059000 1000-EDIT-THE-BILL-INFO.                                         05900000
059100***************************************************************   05910000
059200*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *   05920000
059300*    AND DO NOT ATTEMPT TO PRICE.                             *   05930000
059400***************************************************************   05940000
059500                                                                  05950000
059600     MOVE B-CMG-CODE TO PPS-SUBM-CMG-CODE.                        05960000
059700                                                                  05970000
059800     IF (B-LOS NUMERIC) AND (B-LOS > 0)                           05980000
059900        MOVE B-LOS TO H-LOS                                       05990000
060000     ELSE                                                         06000000
060100        IF B-LOS = 0                                              06010000
060200           MOVE 1 TO H-LOS                                        06020000
060300        ELSE                                                      06030000
060400           MOVE 56 TO PPS-RTC.                                    06040000
060500                                                                  06050000
060600     MOVE P-NEW-FY-BEGIN-DATE TO H-FY-BEGIN-DATE.                 06060000
060700     IF H-FY-BEGIN-DATE (5:2) < 11                                06070000
060800       COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 10200          06080000
060900     ELSE                                                         06090000
061000       COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 19000.         06100000
061100     MOVE B-DISCHARGE-DATE TO H-DISCHARGE-DATE.                   06110000
061200     IF (H-DISCHARGE-DATE > H-FY-BEGIN-DATE)                      06120000
061300        OR (P-NEW-FY-BEGIN-DATE > 20020930 AND                    06130000
061400            P-NEW-FY-BEGIN-DATE < 20030101)                       06140000
061500        MOVE '4' TO P-NEW-FED-PPS-BLEND-IND.                      06150000
061600     IF P-NEW-FY-BEGIN-DATE > 20011231                            06160000
061700        IF (P-NEW-FY-BEGIN-DATE <= B-DISCHARGE-DATE)              06170000
061800           IF P-NEW-FED-PPS-BLEND-IND = '4'                       06180000
061900              MOVE 1.0000 TO PPS-FED-RATE-PCT                     06190000
062000              MOVE 0.0000 TO PPS-FAC-RATE-PCT                     06200000
062100           ELSE                                                   06210000
062200             IF P-NEW-FED-PPS-BLEND-IND = '3'                     06220000
062300                MOVE .6667 TO PPS-FED-RATE-PCT                    06230000
062400                MOVE .3333 TO PPS-FAC-RATE-PCT                    06240000
062500             ELSE                                                 06250000
062600               MOVE 72 TO PPS-RTC                                 06260000
062700        ELSE                                                      06270000
062800           MOVE 73 TO PPS-RTC                                     06280000
062900     ELSE                                                         06290000
063000        MOVE 74 TO PPS-RTC.                                       06300000
063100                                                                  06310000
063200     IF PPS-RTC = 00                                              06320000
063300       IF P-NEW-WAIVER-STATE                                      06330000
063400          MOVE 53 TO PPS-RTC.                                     06340000
063500                                                                  06350000
063600     IF PPS-RTC = 00                                              06360000
063700         IF ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR               06370000
063800            (B-DISCHARGE-DATE < W-NEW-EFF-DATE-C))                06380000
063900            MOVE 55 TO PPS-RTC.                                   06390000
064000                                                                  06400000
064100     IF PPS-RTC = 00                                              06410000
064200         IF P-NEW-TERMINATION-DATE > 00000000                     06420000
064300            IF B-DISCHARGE-DATE >= P-NEW-TERMINATION-DATE         06430000
064400               MOVE 51 TO PPS-RTC.                                06440000
064500                                                                  06450000
064600     IF PPS-RTC = 00                                              06460000
064700         IF B-COV-CHARGES NOT NUMERIC                             06470000
064800            MOVE 58 TO PPS-RTC.                                   06480000
064900                                                                  06490000
065000     IF PPS-RTC = 00                                              06500000
065100        IF B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60              06510000
065200           MOVE 61 TO PPS-RTC                                     06520000
065300        ELSE                                                      06530000
065400           MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.                  06540000
065500                                                                  06550000
065600     IF PPS-RTC = 00                                              06560000
065700        IF B-COV-DAYS NOT NUMERIC                                 06570000
065800             MOVE 62 TO PPS-RTC                                   06580000
065900        ELSE                                                      06590000
066000          IF B-COV-DAYS = 0 AND H-LOS > 0                         06600000
066100             MOVE 62 TO PPS-RTC.                                  06610000
066200                                                                  06620000
066300     IF PPS-RTC = 00                                              06630000
066400        IF B-LTR-DAYS  > B-COV-DAYS                               06640000
066500           MOVE 62 TO PPS-RTC                                     06650000
066600        ELSE                                                      06660000
066700           COMPUTE PPS-REG-DAYS-USED = B-COV-DAYS - B-LTR-DAYS.   06670000
066800                                                                  06680000
066900     IF PPS-RTC = 00                                              06690000
067000        IF PPS-REG-DAYS-USED > 0                                  06700000
067100           IF PPS-REG-DAYS-USED > H-LOS                           06710000
067200              MOVE H-LOS TO PPS-REG-DAYS-USED                     06720000
067300           ELSE                                                   06730000
067400              NEXT SENTENCE                                       06740000
067500        ELSE                                                      06750000
067600           IF B-LTR-DAYS > H-LOS                                  06760000
067700              MOVE H-LOS TO PPS-LTR-DAYS-USED                     06770000
067800           ELSE                                                   06780000
067900              MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.               06790000
068000                                                                  06800000
068100 1000-EXIT.                                                       06810000
068200      EXIT.                                                       06820000
068300                                                                  06830000
068400***************************************************************   06840000
068500*    FINDS THE CMG CODE IN THE TABLE                          *   06850000
068600***************************************************************   06860000
068700 1700-EDIT-CMG-CODE.                                              06870000
068710* 01/2010 - ADDED 5001 PER C.R. # 6699                            06871000
069000                                                                  06900000
069100     IF PPS-CMG-NUMERIC = '9999' OR '5001'                        06910000
069200        NEXT SENTENCE                                             06920000
069300     ELSE                                                         06930000
069400        IF PPS-CMG-NUMERIC < '2103'                               06940000
069500           NEXT SENTENCE                                          06950000
069600        ELSE                                                      06960000
069700           MOVE 54 TO PPS-RTC.                                    06970000
069800                                                                  06980000
069900     IF PPS-RTC = 00                                              06990000
070000        SEARCH ALL CMG-DATA                                       07000000
070100           AT END                                                 07010000
070200             MOVE 54 TO PPS-RTC                                   07020000
070300        WHEN CMG-NUM (DX6) = PPS-CMG-NUMERIC                      07030000
070400             PERFORM 1750-FIND-VALUE                              07040000
070500                THRU 1750-EXIT                                    07050000
070600        END-SEARCH.                                               07060000
070700                                                                  07070000
070800 1700-EXIT.                                                       07080000
070900      EXIT.                                                       07090000
071000                                                                  07100000
071100***************************************************************   07110000
071200*    FINDS THE VALUE IN THE CMG CODE IN THE TABLE             *   07120000
071300***************************************************************   07130000
071400 1750-FIND-VALUE.                                                 07140000
071500                                                                  07150000
071600      IF PPS-CMG-ALPHA = 'A'                                      07160000
071700         MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                 07170000
071800         MOVE A-LOS-TABLE (DX6) TO PPS-AVG-LOS                    07180000
071900      ELSE                                                        07190000
072000         IF PPS-CMG-ALPHA = 'B'                                   07200000
072100            MOVE B-REL-WGT (DX6) TO PPS-RELATIVE-WGT              07210000
072200            MOVE B-LOS-TABLE (DX6) TO PPS-AVG-LOS                 07220000
072300         ELSE                                                     07230000
072400            IF PPS-CMG-ALPHA = 'C'                                07240000
072500               MOVE C-REL-WGT (DX6) TO PPS-RELATIVE-WGT           07250000
072600               MOVE C-LOS-TABLE (DX6) TO PPS-AVG-LOS              07260000
072700            ELSE                                                  07270000
072800               IF PPS-CMG-ALPHA = 'D'                             07280000
072900                  MOVE D-REL-WGT (DX6) TO PPS-RELATIVE-WGT        07290000
073000                  MOVE D-LOS-TABLE (DX6) TO PPS-AVG-LOS           07300000
073100               ELSE                                               07310000
073200                  MOVE 54 TO PPS-RTC.                             07320000
073300                                                                  07330000
073400 1750-EXIT.                                                       07340000
073500      EXIT.                                                       07350000
073600                                                                  07360000
073700***************************************************************   07370000
073800*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *   07380000
073900*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   07390000
074000*    OF THAT VARIABLE.                                        *   07400000
074100***************************************************************   07410000
074200***  GET THE PROVIDER SPECIFIC VARIABLE AND WAGE INDEX            07420000
074300***************************************************************   07430000
074400 2000-ASSEMBLE-PPS-VARIABLES.                                     07440000
074500                                                                  07450000
074600     IF P-NEW-FAC-SPEC-RATE NUMERIC                               07460000
074700        MOVE P-NEW-FAC-SPEC-RATE TO PPS-FAC-SPEC-RT-PREBLEND      07470000
074800     ELSE                                                         07480000
074900        MOVE 50 TO PPS-RTC                                        07490000
075000        GO TO 2000-EXIT.                                          07500000
075100                                                                  07510000
075200     IF P-NEW-FED-PPS-BLEND-IND = '3'                             07520000
075300        IF PPS-FAC-SPEC-RT-PREBLEND = 0                           07530000
075400          MOVE 57 TO PPS-RTC                                      07540000
075500          GO TO 2000-EXIT.                                        07550000
075600                                                                  07560000
075700     IF W-NEW-WAGE-INDEX-C NUMERIC                                07570000
075800            AND W-NEW-WAGE-INDEX-C > 0                            07580000
075900        MOVE W-NEW-WAGE-INDEX-C TO PPS-WAGE-INDEX                 07590000
076000     ELSE                                                         07600000
076100        MOVE 52 TO PPS-RTC                                        07610000
076200        GO TO 2000-EXIT.                                          07620000
076300                                                                  07630000
076400     IF P-NEW-OPER-CSTCHG-RATIO NOT NUMERIC                       07640000
076500        MOVE 65 TO PPS-RTC.                                       07650000
076600                                                                  07660000
076700 2000-EXIT.                                                       07670000
076800      EXIT.                                                       07680000
076900                                                                  07690000
077000***************************************************************   07700000
077100*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *   07710000
077200*        CALCULATE THE FEDERAL PORTION.                       *   07720000
077300*        CALCULATE THE HOSPITAL PORTION.                      *   07730000
077400*        CALCULATE THE COST-OUTLIER PORTION.                  *   07740000
077500*        CALCULATE THE LIP ADJUSTMENT PERCENTAGE.             *   07750000
077600***************************************************************   07760000
077700 3000-CALC-PAYMENT.                                               07770000
077800                                                                  07780000
077900***  LIP PERCENTAGE CALCULATION *******************************   07790000
078000                                                                  07800000
078100      COMPUTE H-WK-DSH = (P-NEW-SSI-RATIO                         07810000
078200                           + P-NEW-MEDICAID-RATIO).               07820000
078300                                                                  07830000
078400      COMPUTE PPS-LIP-PCT ROUNDED =                               07840000
078500            ((1 + H-WK-DSH) ** .4613) - 1.                        07850000
078600                                                                  07860000
078700      COMPUTE H-TEACH-PCT ROUNDED =                               07870000
078800            ((1 + P-NEW-CAPI-IME) ** .6876) - 1.                  07880000
078900                                                                  07890000
079000***************************************************************   07900000
079100                                                                  07910000
079200     MOVE 1.0000 TO PPS-TRANSFER-PCT.                             07920000
079300                                                                  07930000
079400     IF B-PATIENT-STATUS =                                        07940000
079500         ('02' OR '03' OR '61' OR '62' OR '63' OR '64')           07950000
079600        IF H-LOS < PPS-AVG-LOS                                    07960000
079700           COMPUTE PPS-TRANSFER-PCT =                             07970000
079800               ((H-LOS + .5) / PPS-AVG-LOS)                       07980000
079900           MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE          07990000
080000           GO TO 3000-EXIT.                                       08000000
080100                                                                  08010000
080200     IF H-LOS > 3                                                 08020000
080300        NEXT SENTENCE                                             08030000
080400     ELSE                                                         08040000
080500        MOVE 'A5001' TO PPS-PRICED-CMG-CODE                       08050000
080600        SET DX6 TO 88                                             08060000
080700        MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                  08070000
080800        GO TO 3000-EXIT.                                          08080000
080900                                                                  08090000
081000     IF B-PATIENT-STATUS = '20'                                   08100000
081100        NEXT SENTENCE                                             08110000
081200     ELSE                                                         08120000
081300        MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE             08130000
081400        GO TO 3000-EXIT.                                          08140000
081500                                                                  08150000
081600     IF PPS-CMG-RIC = ('07' OR '08' OR '09')                      08160000
081700        IF H-LOS < 14                                             08170000
081800           MOVE 'A5101' TO PPS-PRICED-CMG-CODE                    08180000
081900           SET DX6 TO 89                                          08190000
082000           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08200000
082100        ELSE                                                      08210000
082200           MOVE 'A5102' TO PPS-PRICED-CMG-CODE                    08220000
082300           SET DX6 TO 90                                          08230000
082400           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08240000
082500     ELSE                                                         08250000
082600        IF H-LOS < 16                                             08260000
082700           MOVE 'A5103' TO PPS-PRICED-CMG-CODE                    08270000
082800           SET DX6 TO 91                                          08280000
082900           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08290000
083000        ELSE                                                      08300000
083100           MOVE 'A5104' TO PPS-PRICED-CMG-CODE                    08310000
083200           SET DX6 TO 92                                          08320000
083300           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT.              08330000
083400                                                                  08340000
083500 3000-EXIT.                                                       08350000
083600      EXIT.                                                       08360000
083700                                                                  08370000
083800 3500-CONTINUE-CALC.                                              08380000
083900                                                                  08390000
084000     COMPUTE PPS-STANDARD-PAY-AMT =                               08400000
084100            (PPS-TRANSFER-PCT * PPS-RELATIVE-WGT                  08410000
084200                      * PPS-BDGT-NEUT-CONV-AMT).                  08420000
084300                                                                  08430000
084400***************************************************************   08440000
084500*      CHANGE RURAL ADJUSTMENT AMOUNT IF NECESSARY            *   08450000
084600*      - PER CHANGE REQUEST                                   *   08460000
084700***************************************************************   08470000
084800     IF W-NEW-CBSA (1:3) = '   '                                  08480000
084900        MOVE 1.1840 TO PPS-RURAL-ADJUSTMENT                       08490000
085000     ELSE                                                         08500000
085100        MOVE 1.0000 TO PPS-RURAL-ADJUSTMENT.                      08510000
085200                                                                  08520000
085300***************************************************************   08530000
085400*      CHANGE RURAL ADJUSTMENT BASED ON RELIEF INDICATOR      *   08540000
085500*       IF NECESSARY - PER CHANGE REQUEST                     *   08550000
085600***************************************************************   08560000
085700** REMOVED FOR 2008 RELEASE                                       08570000
085800**   IF P-NEW-TEMP-RELIEF-IND = 'Y'                               08580000
085900**      MOVE 1.0638 TO PPS-RURAL-ADJUSTMENT.                      08590000
086000                                                                  08600000
086100     COMPUTE H-LABOR-PORTION =                                    08610000
086200        (PPS-STANDARD-PAY-AMT * PPS-NAT-LABOR-PCT)                08620000
086300          * PPS-WAGE-INDEX.                                       08630000
086400                                                                  08640000
086500     COMPUTE H-NONLABOR-PORTION =                                 08650000
086600        (PPS-STANDARD-PAY-AMT * PPS-NAT-NONLABOR-PCT).            08660000
086700                                                                  08670000
086800     COMPUTE PPS-FED-PAY-AMT ROUNDED =                            08680000
086900        ((H-LABOR-PORTION + H-NONLABOR-PORTION) *                 08690000
087000         PPS-RURAL-ADJUSTMENT).                                   08700000
087100                                                                  08710000
087200     COMPUTE PPS-LIP-PAY-AMT ROUNDED =                            08720000
087300        (PPS-FED-PAY-AMT * PPS-LIP-PCT).                          08730000
087400                                                                  08740000
087500     COMPUTE PPS-TEACH-PAY-AMT ROUNDED =                          08750000
087600        (PPS-FED-PAY-AMT * H-TEACH-PCT).                          08760000
087700                                                                  08770000
087800 3500-EXIT.                                                       08780000
087900      EXIT.                                                       08790000
088000                                                                  08800000
088100 4000-CALC-OUTLIER.                                               08810000
088200                                                                  08820000
088300     COMPUTE PPS-FAC-COSTS ROUNDED =                              08830000
088400         (B-COV-CHARGES * P-NEW-OPER-CSTCHG-RATIO).               08840000
088500                                                                  08850000
088600     COMPUTE H-OUTLIER-LABOR-PORTION =                            08860000
088700        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-LABOR-PCT)               08870000
088800              * PPS-WAGE-INDEX.                                   08880000
088900                                                                  08890000
089000     COMPUTE H-OUTLIER-NONLABOR-PORTION =                         08900000
089100        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-NONLABOR-PCT).           08910000
089200                                                                  08920000
089300     COMPUTE H-FP-OUTLIER-THRESHOLD ROUNDED =                     08930000
089400        ((H-OUTLIER-LABOR-PORTION + H-OUTLIER-NONLABOR-PORTION) * 08940000
089500         PPS-RURAL-ADJUSTMENT * (PPS-LIP-PCT + H-TEACH-PCT + 1)). 08950000
089600                                                                  08960000
089700     COMPUTE H-OUTLIER-THRESHOLD ROUNDED =                        08970000
089800        (PPS-FED-PAY-AMT + H-FP-OUTLIER-THRESHOLD +               08980000
089900         PPS-LIP-PAY-AMT + PPS-TEACH-PAY-AMT).                    08990000
090000                                                                  09000000
090100     IF PPS-FAC-COSTS > H-OUTLIER-THRESHOLD                       09010000
090200        COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                     09020000
090300           ((PPS-FAC-COSTS - H-OUTLIER-THRESHOLD) * .8).          09030000
090400                                                                  09040000
090500     COMPUTE H-CHG-OUTLIER-THRESHOLD ROUNDED =                    09050000
090600         H-OUTLIER-THRESHOLD / P-NEW-OPER-CSTCHG-RATIO.           09060000
090700                                                                  09070000
090800                                                                  09080000
090900 4000-EXIT.                                                       09090000
091000      EXIT.                                                       09100000
091100                                                                  09110000
091200 5000-FINAL-PAYMENTS.                                             09120000
091300                                                                  09130000
091400     IF B-SPEC-PAY-IND = '1' OR '3'                               09140000
091500         MOVE ZEROES TO PPS-OUTLIER-PAY-AMT.                      09150000
091600                                                                  09160000
091700     IF PPS-FED-RATE-PCT = 1.0000                                 09170000
091800         MOVE 0 TO PPS-FAC-SPEC-PAY-AMT                           09180000
091900     ELSE                                                         09190000
092000         COMPUTE PPS-FED-PAY-AMT ROUNDED =                        09200000
092100           (PPS-FED-RATE-PCT * PPS-FED-PAY-AMT)                   09210000
092200         COMPUTE PPS-FAC-SPEC-PAY-AMT ROUNDED =                   09220000
092300           (PPS-FAC-RATE-PCT * PPS-FAC-SPEC-RT-PREBLEND)          09230000
092400         COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                    09240000
092500           (PPS-FED-RATE-PCT * PPS-OUTLIER-PAY-AMT)               09250000
092600         COMPUTE PPS-TEACH-PAY-AMT ROUNDED =                      09260000
092700           (PPS-FED-RATE-PCT * PPS-TEACH-PAY-AMT)                 09270000
092800         COMPUTE PPS-LIP-PAY-AMT ROUNDED =                        09280000
092900           (PPS-FED-RATE-PCT * PPS-LIP-PAY-AMT).                  09290000
093000                                                                  09300000
093100     IF B-SPEC-PAY-IND = '2' OR '3'                               09310000
093200        COMPUTE PPS-FED-PENALTY-AMT ROUNDED =                     09320000
093300           (PPS-FED-PAY-AMT * .25)                                09330000
093400        COMPUTE PPS-FED-PAY-AMT =                                 09340000
093500           (PPS-FED-PAY-AMT - PPS-FED-PENALTY-AMT)                09350000
093600        COMPUTE PPS-LIP-PENALTY-AMT ROUNDED =                     09360000
093700           (PPS-LIP-PAY-AMT * .25)                                09370000
093800        COMPUTE PPS-LIP-PAY-AMT =                                 09380000
093900           (PPS-LIP-PAY-AMT - PPS-LIP-PENALTY-AMT)                09390000
094000        COMPUTE PPS-OUT-PENALTY-AMT ROUNDED =                     09400000
094100           (PPS-OUTLIER-PAY-AMT * .25)                            09410000
094200        COMPUTE PPS-OUTLIER-PAY-AMT =                             09420000
094300           (PPS-OUTLIER-PAY-AMT - PPS-OUT-PENALTY-AMT)            09430000
094400        COMPUTE PPS-TEACH-PENALTY-AMT ROUNDED =                   09440000
094500           (PPS-TEACH-PAY-AMT * .25)                              09450000
094600        COMPUTE PPS-TEACH-PAY-AMT =                               09460000
094700           (PPS-TEACH-PAY-AMT - PPS-TEACH-PENALTY-AMT)            09470000
094800        COMPUTE PPS-TOTAL-PENALTY-AMT =                           09480000
094900           (PPS-FED-PENALTY-AMT + PPS-LIP-PENALTY-AMT             09490000
095000           + PPS-OUT-PENALTY-AMT + PPS-TEACH-PENALTY-AMT).        09500000
095100                                                                  09510000
095200     COMPUTE PPS-TOTAL-PAY-AMT ROUNDED =                          09520000
095300        (PPS-FED-PAY-AMT + PPS-FAC-SPEC-PAY-AMT                   09530000
095400         + PPS-OUTLIER-PAY-AMT + PPS-LIP-PAY-AMT +                09540000
095500         PPS-TEACH-PAY-AMT).                                      09550000
095600                                                                  09560000
095700     IF PPS-FED-RATE-PCT = 1.0000                                 09570000
095800        IF PPS-TRANSFER-PCT = 1.0000                              09580000
095900           IF PPS-OUTLIER-PAY-AMT > 0.0                           09590000
096000              MOVE 01 TO PPS-RTC                                  09600000
096100           ELSE                                                   09610000
096200              MOVE 00 TO PPS-RTC                                  09620000
096300        ELSE                                                      09630000
096400           IF PPS-OUTLIER-PAY-AMT > 0.0                           09640000
096500              MOVE 03 TO PPS-RTC                                  09650000
096600           ELSE                                                   09660000
096700              MOVE 02 TO PPS-RTC                                  09670000
096800     ELSE                                                         09680000
096900        IF PPS-TRANSFER-PCT = 1.0000                              09690000
097000           IF PPS-OUTLIER-PAY-AMT > 0.0                           09700000
097100              MOVE 05 TO PPS-RTC                                  09710000
097200           ELSE                                                   09720000
097300              MOVE 04 TO PPS-RTC                                  09730000
097400        ELSE                                                      09740000
097500           IF PPS-OUTLIER-PAY-AMT > 0.0                           09750000
097600              MOVE 07 TO PPS-RTC                                  09760000
097700           ELSE                                                   09770000
097800              MOVE 06 TO PPS-RTC.                                 09780000
097900                                                                  09790000
098000     IF B-SPEC-PAY-IND = '2' OR '3'                               09800000
098100        COMPUTE PPS-RTC = PPS-RTC + 10.                           09810000
098200     IF PPS-RTC = (01 OR 03 OR 05 OR 07                           09820000
098300                OR 11 OR 13 OR 15 OR 17)                          09830000
098400        IF ((PPS-REG-DAYS-USED + PPS-LTR-DAYS-USED) < H-LOS)      09840000
098500           OR PPS-COT-IND = 'Y'                                   09850000
098600            MOVE 67 TO PPS-RTC.                                   09860000
098700                                                                  09870000
098800 5000-EXIT.                                                       09880000
098900      EXIT.                                                       09890000
099000                                                                  09900000
099100 9000-MOVE-RESULTS.                                               09910000
099200                                                                  09920000
099300     IF PPS-RTC < 50                                              09930000
099400      MOVE H-LOS                   TO  PPS-LOS                    09940000
099500      MOVE H-OUTLIER-THRESHOLD     TO  PPS-OUTLIER-THRESHOLD      09950000
099600      MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD   09960000
099700      MOVE W-NEW-CBSA              TO  PPS-CBSA                   09970000
099800      MOVE 'V13.0'                 TO  PPS-CALC-VERS-CD           09980001
099900     ELSE                                                         09990000
100000       INITIALIZE PPS-DATA                                        10000000
100100       INITIALIZE PPS-OTHER-DATA                                  10010000
100200       MOVE 'V13.0'                TO  PPS-CALC-VERS-CD.          10020001
100300                                                                  10030000
100400     IF PPS-RTC = 67                                              10040000
100500       MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD. 10050000
100600                                                                  10060000
100700 9000-EXIT.                                                       10070000
100800      EXIT.                                                       10080000
100900                                                                  10090000
101000******        L A S T   S O U R C E   S T A T E M E N T   *****   10100000
