000100 IDENTIFICATION DIVISION.                                         00010004
000200 PROGRAM-ID.           IRCAL070.                                  00020004
000300*AUTHOR.            ED FRANEY.                                    00030004
000400*REMARKS.                CMS.                                     00040004
000500*       EFFECTIVE OCT 1 2006                                      00050004
000600 DATE-COMPILED.                                                   00060004
000610****************  CHANGE LOG *************************************00061006
000690*------------------ 2008.1---------------------------------------*00069006
000691* THE IRF PPS PRICER SHALL ADD THE DEFAULT CMG OF A9999 AS A     *00069106
000692* VALID CMG TO ALL "NO-PAY" CLAIMS FOR MEDICARE ADVANTAGE        *00069206
000693* PATIENTS TO BE PROCESSED, EFFECTIVE FOR DISCHARGES ON OR AFTER *00069306
000700* JANUARY 1, 2006                                                *00070006
000800******************************************************************00080006
000810 ENVIRONMENT DIVISION.                                            00081007
000820 CONFIGURATION SECTION.                                           00082007
000900 SOURCE-COMPUTER.            IBM-370.                             00090004
001000 OBJECT-COMPUTER.            IBM-370.                             00100004
001100 INPUT-OUTPUT  SECTION.                                           00110004
001200 FILE-CONTROL.                                                    00120004
001300                                                                  00130004
001400 DATA DIVISION.                                                   00140004
001500 FILE SECTION.                                                    00150004
001600                                                                  00160004
001700 WORKING-STORAGE SECTION.                                         00170004
001800 01  W-STORAGE-REF                  PIC X(46)  VALUE              00180004
001900     'IRCAL070      - W O R K I N G   S T O R A G E'.             00190004
002000 01  CAL-VERSION                    PIC X(05)  VALUE 'C07.0'.     00200004
002100                                                                  00210004
002200***************************************************************   00220004
002300*    LAYUP TABLE AREA FOR FY2007 CMGS                         *   00230004
002400*    EFFECTIVE DATE OF OCTOBER 1, 2006                        *   00240004
002500***************************************************************   00250004
002600 01  CMG-TABLE.                                                   00260004
002700     05  CMG-TABLE-DATA.                                          00270004
002800         10                      PIC X(32)   VALUE                00280004
002900           '01010770707303065720634708110909'.                    00290004
003000         10                      PIC X(32)   VALUE                00300004
003100           '01020949308995080950781811151110'.                    00310004
003200         10                      PIC X(32)   VALUE                00320004
003300           '01031119210605095440921814131212'.                    00330004
003400         10                      PIC X(32)   VALUE                00340004
003500           '01041188511260101340978713141313'.                    00350004
003600         10                      PIC X(32)   VALUE                00360004
003700           '01051426113512121611174516171615'.                    00370004
003800         10                      PIC X(32)   VALUE                00380004
003900           '01061659415722141501366618201818'.                    00390004
004000         10                      PIC X(32)   VALUE                00400004
004100           '01071915018145163301577121232120'.                    00410004
004200         10                      PIC X(32)   VALUE                00420004
004300           '01082216020997188971825028292524'.                    00430004
004400         10                      PIC X(32)   VALUE                00440004
004500           '01092199820843187581811623262423'.                    00450004
004600         10                      PIC X(32)   VALUE                00460004
004700           '01102628724907224162164930332827'.                    00470004
004800         10                      PIC X(32)   VALUE                00480004
004900           '02010814306806060800564710090908'.                    00490004
005000         10                      PIC X(32)   VALUE                00500004
005100           '02021046008743078100725412101109'.                    00510004
005200         10                      PIC X(32)   VALUE                00520004
005300           '02031250310450093350867115151212'.                    00530004
005400         10                      PIC X(32)   VALUE                00540004
005500           '02041339011192099980928715161313'.                    00550004
005600         10                      PIC X(32)   VALUE                00560004
005700           '02051641213718122541138217181615'.                    00570004
005800         10                      PIC X(32)   VALUE                00580004
005900           '02062144517924160111487323222120'.                    00590004
006000         10                      PIC X(32)   VALUE                00600004
006100           '02072766423122206551918535292625'.                    00610004
006200         10                      PIC X(32)   VALUE                00620004
006300           '03011139409533085520777212121110'.                    00630004
006400         10                      PIC X(32)   VALUE                00640004
006500           '03021487512446111641014714161413'.                    00650004
006600         10                      PIC X(32)   VALUE                00660004
006700           '03031770114810132851207420191716'.                    00670004
006800         10                      PIC X(32)   VALUE                00680004
006900           '03042439520410183091664032252321'.                    00690004
007000         10                      PIC X(32)   VALUE                00700004
007100           '04010958708456077220685812121110'.                    00710004
007200         10                      PIC X(32)   VALUE                00720004
007300           '04021325611691106760948218161413'.                    00730004
007400         10                      PIC X(32)   VALUE                00740004
007500           '04032306920347185801650222242422'.                    00750004
007600         10                      PIC X(32)   VALUE                00760004
007700           '04044154236639334582971751464137'.                    00770004
007800         10                      PIC X(32)   VALUE                00780004
007900           '04053137127668252662244133373328'.                    00790004
008000         10                      PIC X(32)   VALUE                00800004
008100           '05010764806455056870507109080807'.                    00810004
008200         10                      PIC X(32)   VALUE                00820004
008300           '05021026208661076300680413121109'.                    00830004
008400         10                      PIC X(32)   VALUE                00840004
008500           '05031359611476101090901415151312'.                    00850004
008600         10                      PIC X(32)   VALUE                00860004
008700           '05041698414335126281126021191615'.                    00870004
008800         10                      PIC X(32)   VALUE                00880004
008900           '05052017117025149971337323221918'.                    00890004
009000         10                      PIC X(32)   VALUE                00900004
009100           '05062740223128203741816729282623'.                    00910004
009200         10                      PIC X(32)   VALUE                00920004
009300           '06010899107330070190652211100909'.                    00930004
009400         10                      PIC X(32)   VALUE                00940004
009500           '06021196809757093420868213131312'.                    00950004
009600         10                      PIC X(32)   VALUE                00960004
009700           '06031532612495119651111817171515'.                    00970004
009800         10                      PIC X(32)   VALUE                00980004
009900           '06041959215973152951421322202119'.                    00990004
010000         10                      PIC X(32)   VALUE                01000004
010100           '07010902807717073380661712111009'.                    01010004
010200         10                      PIC X(32)   VALUE                01020004
010300           '07021173610033095390860213141312'.                    01030004
010400         10                      PIC X(32)   VALUE                01040004
010500           '07031462912506118901072216171614'.                    01050004
010600         10                      PIC X(32)   VALUE                01060004
010700           '07041796915361146051317020201918'.                    01070004
010800         10                      PIC X(32)   VALUE                01080004
010900           '08010653705504051310460707070706'.                    01090004
011000         10                      PIC X(32)   VALUE                01100004
011100           '08020854207193067040602010100908'.                    01110004
011200         10                      PIC X(32)   VALUE                01120004
011300           '08031270710700099740895615151312'.                    01130004
011400         10                      PIC X(32)   VALUE                01140004
011500           '08041104009296086650778113121210'.                    01150004
011600         10                      PIC X(32)   VALUE                01160004
011700           '08051392711727109310981617161413'.                    01170004
011800         10                      PIC X(32)   VALUE                01180004
011900           '08061672314082131261178718191715'.                    01190004
012000         10                      PIC X(32)   VALUE                01200004
012100           '09010842507641068680612010111009'.                    01210004
012200         10                      PIC X(32)   VALUE                01220004
012300           '09021108810057090390805613131211'.                    01230004
012400         10                      PIC X(32)   VALUE                01240004
012500           '09031463813277119341063518191615'.                    01250004
012600         10                      PIC X(32)   VALUE                01260004
012700           '09041834116636149521332525232119'.                    01270004
012800         10                      PIC X(32)   VALUE                01280004
012900           '10010962508879079570736111111110'.                    01290004
013000         10                      PIC X(32)   VALUE                01300004
013100           '10021270911724105070971914151413'.                    01310004
013200         10                      PIC X(32)   VALUE                01320004
013300           '10031787616491147791367119221918'.                    01330004
013400         10                      PIC X(32)   VALUE                01340004
013500           '11011255410482092250849614151211'.                    01350004
013600         10                      PIC X(32)   VALUE                01360004
013700           '11021882415717138321273919191817'.                    01370004
013800         10                      PIC X(32)   VALUE                01380004
013900           '12011017708785081820740511121110'.                    01390004
014000         10                      PIC X(32)   VALUE                01400004
014100           '12021316811367105860958115161413'.                    01410004
014200         10                      PIC X(32)   VALUE                01420004
014300           '12031624114020130571181721191716'.                    01430004
014400         10                      PIC X(32)   VALUE                01440004
014500           '13011035409636085110742912131110'.                    01450004
014600         10                      PIC X(32)   VALUE                01460004
014700           '13021432113327117721027515181514'.                    01470004
014800         10                      PIC X(32)   VALUE                01480004
014900           '13031825016984150021309422212018'.                    01490004
015000         10                      PIC X(32)   VALUE                01500004
015100           '14010816007351065340586110090908'.                    01510004
015200         10                      PIC X(32)   VALUE                01520004
015300           '14021103809944088390792812131211'.                    01530004
015400         10                      PIC X(32)   VALUE                01540004
015500           '14031370512347109750984416161413'.                    01550004
015600         10                      PIC X(32)   VALUE                01560004
015700           '14041737015649139101247721201816'.                    01570004
015800         10                      PIC X(32)   VALUE                01580004
015900           '15010998608870077930739911131010'.                    01590004
016000         10                      PIC X(32)   VALUE                01600004
016100           '15021266111246098800938113151212'.                    01610004
016200         10                      PIC X(32)   VALUE                01620004
016300           '15031545713730120621145316161515'.                    01630004
016400         10                      PIC X(32)   VALUE                01640004
016500           '15042021617957157751497926212018'.                    01650004
016600         10                      PIC X(32)   VALUE                01660004
016700           '16011007008550077740695712111010'.                    01670004
016800         10                      PIC X(32)   VALUE                01680004
016900           '16021382611739106730955215171413'.                    01690004
017000         10                      PIC X(32)   VALUE                01700004
017100           '16031702514455131431176219191816'.                    01710004
017200         10                      PIC X(32)   VALUE                01720004
017300           '17010981809641084790736812121110'.                    01730004
017400         10                      PIC X(32)   VALUE                01740004
017500           '17021292112688111580969614161513'.                    01750004
017600         10                      PIC X(32)   VALUE                01760004
017700           '17031535615080132621152417201816'.                    01770004
017800         10                      PIC X(32)   VALUE                01780004
017900           '17041924618899166201444326262219'.                    01790004
018000         10                      PIC X(32)   VALUE                01800004
018100           '18011192009866082430734215131310'.                    01810004
018200         10                      PIC X(32)   VALUE                01820004
018300           '18021905815774131791173819211816'.                    01830004
018400         10                      PIC X(32)   VALUE                01840004
018500           '18033430228391237212112743333027'.                    01850004
018600         10                      PIC X(32)   VALUE                01860004
018700           '19011239910986109650935014131412'.                    01870004
018800         10                      PIC X(32)   VALUE                01880004
018900           '19022319420552205121749127252523'.                    01890004
019000         10                      PIC X(32)   VALUE                01900004
019100           '19033346429651295932523537393133'.                    01910004
019200         10                      PIC X(32)   VALUE                01920004
019300           '20010873407381067350608410100908'.                    01930004
019400         10                      PIC X(32)   VALUE                01940004
019500           '20021144709674088270797512131211'.                    01950004
019600         10                      PIC X(32)   VALUE                01960004
019700           '20031477712488113951029416161514'.                    01970004
019800         10                      PIC X(32)   VALUE                01980004
019900           '20041971616662152041373525222018'.                    01990004
020000         10                      PIC X(32)   VALUE                02000004
020100           '21012184221842166061458727242017'.                    02010004
020200         10                      PIC X(32)   VALUE                02020004
020300           '50010000000000000000220100000002'.                    02030004
020400         10                      PIC X(32)   VALUE                02040004
020500           '51010000000000000000635100000008'.                    02050004
020600         10                      PIC X(32)   VALUE                02060004
020700           '51020000000000000001598500000022'.                    02070004
020800         10                      PIC X(32)   VALUE                02080004
020900           '51030000000000000000720300000008'.                    02090004
021000         10                      PIC X(32)   VALUE                02100004
021100           '51040000000000000001878400000024'.                    02110004
021110         10                      PIC X(32)   VALUE                02111006
021120           '99990000000000000000000000000000'.                    02112006
021200     05  W-CMG-TABLE REDEFINES CMG-TABLE-DATA.                    02120004
021300         10  CMG-DATA            OCCURS 93 TIMES                  02130006
021400                                 ASCENDING KEY IS CMG-NUM         02140004
021500                                 INDEXED BY DX6.                  02150004
021600             15  CMG-NUM         PIC X(4).                        02160004
021700             15  CMG-NUM-REDEF REDEFINES CMG-NUM.                 02170004
021800                 20  CMG-RIC     PIC XX.                          02180004
021900                 20  FILLER      PIC XX.                          02190004
022000             15  B-REL-WGT       PIC 9(1)V9(4).                   02200004
022100             15  C-REL-WGT       PIC 9(1)V9(4).                   02210004
022200             15  D-REL-WGT       PIC 9(1)V9(4).                   02220004
022300             15  A-REL-WGT       PIC 9(1)V9(4).                   02230004
022400             15  B-LOS-TABLE     PIC 9(2).                        02240004
022500             15  C-LOS-TABLE     PIC 9(2).                        02250004
022600             15  D-LOS-TABLE     PIC 9(2).                        02260004
022700             15  A-LOS-TABLE     PIC 9(2).                        02270004
022800                                                                  02280004
022900 01  HOLD-PPS-COMPONENTS.                                         02290004
023000     05  H-LOS                        PIC 9(05).                  02300004
023100     05  H-WK-DSH                     PIC 9(01)V9(04).            02310004
023200     05  H-TEACH-PCT                  PIC 9(01)V9(04).            02320004
023300     05  H-LABOR-PORTION              PIC 9(07)V9(06).            02330004
023400     05  H-NONLABOR-PORTION           PIC 9(07)V9(06).            02340004
023500     05  H-OUTLIER-LABOR-PORTION      PIC 9(07)V9(06).            02350004
023600     05  H-OUTLIER-NONLABOR-PORTION   PIC 9(07)V9(06).            02360004
023700     05  H-FP-OUTLIER-THRESHOLD       PIC 9(07)V9(06).            02370004
023800     05  H-OUTLIER-THRESHOLD          PIC 9(07)V9(06).            02380004
023900     05  H-CHG-OUTLIER-THRESHOLD      PIC 9(07)V9(04).            02390004
024000     05  H-FY-BEGIN-DATE              PIC 9(08).                  02400004
024100     05  H-DISCHARGE-DATE             PIC 9(08).                  02410004
024200                                                                  02420004
024300 LINKAGE SECTION.                                                 02430004
024400**************************************************************    02440004
024500*      THIS IS THE BILL-RECORD THAT WILL BE PASSED FROM      *    02450004
024600*      THE IRCAL___ PROGRAM                                  *    02460004
024700**************************************************************    02470004
024800 01  BILL-NEW-DATA.                                               02480004
024900         10  B-NPI10.                                             02490004
025000             15  B-NPI8             PIC X(08).                    02500004
025100             15  B-NPI-FILLER       PIC X(02).                    02510004
025200         10  B-PROVIDER-NO          PIC X(06).                    02520004
025300         10  B-PATIENT-STATUS       PIC X(02).                    02530004
025400         10  B-CMG-CODE             PIC X(05).                    02540004
025500         10  B-LOS                  PIC 9(03).                    02550004
025600         10  B-COV-DAYS             PIC 9(03).                    02560004
025700         10  B-LTR-DAYS             PIC 9(02).                    02570004
025800         10  B-SPEC-PAY-IND         PIC X(01).                    02580004
025900         10  B-DISCHARGE-DATE.                                    02590004
026000             15  B-DISCHG-CC        PIC 9(02).                    02600004
026100             15  B-DISCHG-YY        PIC 9(02).                    02610004
026200             15  B-DISCHG-MM        PIC 9(02).                    02620004
026300             15  B-DISCHG-DD        PIC 9(02).                    02630004
026400         10  B-COV-CHARGES          PIC 9(07)V9(02).              02640004
026500         10  FILLER                 PIC X(11).                    02650004
026600                                                                  02660004
026700***************************************************************   02670004
026800*    THIS DATA IS CALCULATED BY THIS IRCAL SUBROUTINE         *   02680004
026900*    AND PASSED BACK TO THE CALLING PROGRAM                   *   02690004
027000*            RETURN CODE VALUES (PPS-RTC)                     *   02700004
027100*                                                             *   02710004
027200*     ****   PPS-RTC 00-49 = HOW THE BILL WAS PAID            *   02720004
027300*              00 = PAID NORMAL CMG PAYMENT WITHOUT OUTLIER   *   02730004
027400*                                                             *   02740004
027500*              01 = PAID NORMAL CMG PAYMENT WITH OUTLIER      *   02750004
027600*                                                             *   02760004
027700*              02 = TRANSFER PAID ON A PERDIEM BASIS WITHOUT  *   02770004
027800*                   OUTLIER                                   *   02780004
027900*              03 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   02790004
028000*                   OUTLIER                                   *   02800004
028100*              04 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02810004
028200*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02820004
028300*                   WITHOUT OUTLIER                           *   02830004
028400*              05 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02840004
028500*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02850004
028600*                   WITH OUTLIER                              *   02860004
028700*              06 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   02870004
028800*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   02880004
028900*                   RATE -- WITHOUT OUTLIER                   *   02890004
029000*              07 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   02900004
029100*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   02910004
029200*                   RATE -- WITH OUTLIER                      *   02920004
029300*       **** NEW RT CODES FOR PAYMENT WITH PENALTIES          *   02930004
029400*              10 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   02940004
029500*                   WITHOUT OUTLIER                           *   02950004
029600*              11 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   02960004
029700*                   WITH OUTLIER                              *   02970004
029800*              12 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   02980004
029900*                   PENALTY WITHOUT OUTLIER                   *   02990004
030000*              13 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   03000004
030100*                   PENALTY WITH OUTLIER                      *   03010004
030200*              14 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   03020004
030300*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   03030004
030400*                   WITH PENALTY WITHOUT OUTLIER              *   03040004
030500*              15 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   03050004
030600*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   03060004
030700*                   WITH PENALTY WITH OUTLIER                 *   03070004
030800*              16 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03080004
030900*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03090004
031000*                   RATE -- WITH PENALTY WITHOUT OUTLIER      *   03100004
031100*              17 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03110004
031200*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03120004
031300*                   RATE -- WITH PENALTY WITH OUTLIER         *   03130004
031400*                                                             *   03140004
031500*      ****  PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   03150004
031600*              50 = PROVIDER SPECIFIC RATE NOT NUMERIC        *   03160004
031700*              51 = PROVIDER RECORD TERMINATED                *   03170004
031800*              52 = INVALID WAGE INDEX                        *   03180004
031900*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   03190004
032000*              54 = CMG ON CLAIM NOT FOUND IN TABLE           *   03200004
032100*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   03210004
032200*                                      OR                     *   03220004
032300*                   DISCHARGE DATE < MSA EFF START DATE       *   03230004
032400*                   FOR PPS                                   *   03240004
032500*              56 = INVALID LENGTH OF STAY                    *   03250004
032600*              57 = PROVIDER SPECIFIC RATE ZERO WHEN BLENDED  *   03260004
032700*                   PAYMENT REQUESTED                         *   03270004
032800*              58 = TOTAL COVERED CHARGES NOT NUMERIC         *   03280004
032900*              59 = PROVIDER SPECIFIC RECORD NOT FOUND        *   03290004
033000*              60 = MSA WAGE INDEX RECORD NOT FOUND           *   03300004
033100*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *   03310004
033200*                   OR BILL-LTR-DAYS > 60                     *   03320004
033300*              62 = INVALID NUMBER OF COVERED DAYS            *   03330004
033400*              65 = OPERATING COST-TO-CHARGE RATIO NOT NUMERIC*   03340004
033500*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *   03350004
033600*                   OR COST OUTLIER THRESHOLD CALCULATION     *   03360004
033700*              72 = INVALID BLEND INDICATOR (NOT 3 OR 4)      *   03370004
033800*              73 = DISCHARGED BEFORE PROVIDER FY BEGIN       *   03380004
033900*              74 = PROVIDER FY BEGIN DATE NOT IN 2002        *   03390004
034000***************************************************************   03400004
034100 01  PPS-DATA-ALL.                                                03410004
034200     05  PPS-RTC                      PIC 9(02).                  03420004
034300     05  PPS-DATA.                                                03430004
034400         10  PPS-MSA                  PIC X(04).                  03440004
034500         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).            03450004
034600         10  PPS-AVG-LOS              PIC 9(02).                  03460004
034700         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).            03470004
034800         10  PPS-TOTAL-PAY-AMT        PIC 9(07)V9(02).            03480004
034900         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).            03490004
035000         10  PPS-FAC-SPEC-PAY-AMT     PIC 9(07)V9(02).            03500004
035100         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).            03510004
035200         10  PPS-LIP-PAY-AMT          PIC 9(07)V9(02).            03520004
035300         10  PPS-LIP-PCT              PIC 9(01)V9(04).            03530004
035400         10  PPS-LOS                  PIC 9(03).                  03540004
035500         10  PPS-REG-DAYS-USED        PIC 9(03).                  03550004
035600         10  PPS-LTR-DAYS-USED        PIC 9(03).                  03560004
035700         10  PPS-TRANSFER-PCT         PIC 9(01)V9(04).            03570004
035800         10  PPS-FAC-SPEC-RT-PREBLEND PIC 9(05)V9(02).            03580004
035900         10  PPS-STANDARD-PAY-AMT     PIC 9(07)V9(02).            03590004
036000         10  PPS-FAC-COSTS            PIC 9(07)V9(02).            03600004
036100         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).            03610004
036200         10  PPS-CHG-OUTLIER-THRESHOLD PIC 9(07)V9(02).           03620004
036300         10  PPS-TOTAL-PENALTY-AMT    PIC 9(07)V9(02).            03630004
036400         10  PPS-FED-PENALTY-AMT      PIC 9(07)V9(02).            03640004
036500         10  PPS-LIP-PENALTY-AMT      PIC 9(07)V9(02).            03650004
036600         10  PPS-OUT-PENALTY-AMT      PIC 9(07)V9(02).            03660004
036700         10  PPS-SUBM-CMG-CODE        PIC X(05).                  03670004
036800         10  PPS-CMG-CODE-REDEF REDEFINES PPS-SUBM-CMG-CODE.      03680004
036900            15  PPS-CMG-ALPHA         PIC X(01).                  03690004
037000            15  PPS-CMG-NUMERIC.                                  03700004
037100               20  PPS-CMG-RIC        PIC X(02).                  03710004
037200               20  FILLER             PIC X(02).                  03720004
037300         10  PPS-PRICED-CMG-CODE      PIC X(05).                  03730004
037400         10  PPS-CALC-VERS-CD         PIC X(05).                  03740004
037500         10  PPS-CBSA                 PIC X(05).                  03750004
037600         10  FILLER                   PIC X(08).                  03760004
037700     05  PPS-OTHER-DATA.                                          03770004
037800         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).            03780004
037900         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).            03790004
038000         10  PPS-NAT-THRESHOLD-ADJ    PIC 9(05)V9(02).            03800004
038100         10  PPS-BDGT-NEUT-CONV-AMT   PIC 9(05)V9(02).            03810004
038200         10  PPS-FED-RATE-PCT         PIC 9(01)V9(04).            03820004
038300         10  PPS-FAC-RATE-PCT         PIC 9(01)V9(04).            03830004
038400         10  PPS-RURAL-ADJUSTMENT     PIC 9(01)V9(04).            03840004
038500         10  PPS-TEACH-PAY-AMT        PIC 9(07)V9(02).            03850004
038600         10  PPS-TEACH-PENALTY-AMT    PIC 9(07)V9(02).            03860004
038700         10  FILLER                   PIC X(02).                  03870004
038800     05  PPS-PC-DATA.                                             03880004
038900         10  PPS-COT-IND              PIC X(01).                  03890004
039000         10  FILLER                   PIC X(20).                  03900004
039100                                                                  03910004
039200******************************************************************03920004
039300*            THESE ARE THE VERSIONS OF THE IRDRV___               03930004
039400*           PROGRAMS THAT WILL BE PASSED BACK----                 03940004
039500*          ASSOCIATED WITH THE BILL BEING PROCESSED               03950004
039600******************************************************************03960004
039700 01  PRICER-OPT-VERS-SW.                                          03970004
039800     05  PRICER-OPTION-SW          PIC X(01).                     03980004
039900         88  ALL-TABLES-PASSED          VALUE 'A'.                03990004
040000         88  PROV-RECORD-PASSED         VALUE 'P'.                04000004
040100     05  PPS-VERSIONS.                                            04010004
040200         10  PPDRV-VERSION         PIC X(05).                     04020004
040300                                                                  04030004
040400**************************************************************    04040004
040500*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BY        *    04050004
040600*      THE IRCAL___ PROGRAM                                  *    04060004
040700**************************************************************    04070004
040800 01  PROV-NEW-HOLD.                                               04080004
040900     02  PROV-NEWREC-HOLD1.                                       04090004
041000         05  P-NEW-NPI10.                                         04100004
041100             10  P-NEW-NPI8             PIC X(08).                04110004
041200             10  P-NEW-NPI-FILLER       PIC X(02).                04120004
041300         05  P-NEW-PROVIDER-NO.                                   04130004
041400             10  P-NEW-STATE            PIC 9(02).                04140004
041500             10  FILLER                 PIC X(04).                04150004
041600         05  P-NEW-DATE-DATA.                                     04160004
041700             10  P-NEW-EFF-DATE.                                  04170004
041800                 15  P-NEW-EFF-DT-CC    PIC 9(02).                04180004
041900                 15  P-NEW-EFF-DT-YY    PIC 9(02).                04190004
042000                 15  P-NEW-EFF-DT-MM    PIC 9(02).                04200004
042100                 15  P-NEW-EFF-DT-DD    PIC 9(02).                04210004
042200             10  P-NEW-FY-BEGIN-DATE.                             04220004
042300                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                04230004
042400                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                04240004
042500                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                04250004
042600                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                04260004
042700             10  P-NEW-REPORT-DATE.                               04270004
042800                 15  P-NEW-REPORT-DT-CC PIC 9(02).                04280004
042900                 15  P-NEW-REPORT-DT-YY PIC 9(02).                04290004
043000                 15  P-NEW-REPORT-DT-MM PIC 9(02).                04300004
043100                 15  P-NEW-REPORT-DT-DD PIC 9(02).                04310004
043200             10  P-NEW-TERMINATION-DATE.                          04320004
043300                 15  P-NEW-TERM-DT-CC   PIC 9(02).                04330004
043400                 15  P-NEW-TERM-DT-YY   PIC 9(02).                04340004
043500                 15  P-NEW-TERM-DT-MM   PIC 9(02).                04350004
043600                 15  P-NEW-TERM-DT-DD   PIC 9(02).                04360004
043700         05  P-NEW-WAIVER-CODE          PIC X(01).                04370004
043800             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              04380004
043900         05  P-NEW-INTER-NO             PIC 9(05).                04390004
044000         05  P-NEW-PROVIDER-TYPE        PIC X(02).                04400004
044100         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                04410004
044200         05  P-NEW-CURRENT-DIV   REDEFINES                        04420004
044300                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         04430004
044400         05  P-NEW-MSA-DATA.                                      04440004
044500             10  P-NEW-CHG-CODE-INDEX       PIC X.                04450004
044600             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 04460004
044700             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   04470004
044800                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       04480004
044900             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 04490004
045000             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 04500004
045100             10  P-NEW-STAND-AMT-LOC-MSA9                         04510004
045200                 REDEFINES P-NEW-STAND-AMT-LOC-MSA.               04520004
045300                 15  P-NEW-RURAL-1ST.                             04530004
045400                     20  P-NEW-STAND-RURAL  PIC XX.               04540004
045500                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    04550004
045600                 15  P-NEW-RURAL-2ND        PIC XX.               04560004
045700         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    04570004
045800         05  P-NEW-LUGAR                    PIC X.                04580004
045900         05  P-NEW-TEMP-RELIEF-IND          PIC X.                04590004
046000         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                04600004
046100         05  FILLER                         PIC X(05).            04610004
046200     02  PROV-NEWREC-HOLD2.                                       04620004
046300         05  P-NEW-VARIABLES.                                     04630004
046400             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        04640004
046500             10  P-NEW-COLA              PIC  9(01)V9(03).        04650004
046600             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        04660004
046700             10  P-NEW-BED-SIZE          PIC  9(05).              04670004
046800             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        04680004
046900             10  P-NEW-CMI               PIC  9(01)V9(04).        04690004
047000             10  P-NEW-SSI-RATIO         PIC  V9(04).             04700004
047100             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             04710004
047200             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              04720004
047300             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        04730004
047400             10  P-NEW-DSH-PERCENT       PIC  V9(04).             04740004
047500             10  P-NEW-FYE-DATE          PIC  X(08).              04750004
047600         05  P-NEW-CBSA-DATA.                                     04760004
047700             10  P-NEW-CBSA-SPEC-PAY-IND   PIC X.                 04770004
047800             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.                 04780004
047900             10  P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.  04790004
048000             10  P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.  04800004
048100             10  P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.  04810004
048200             10  P-NEW-CBSA-STAND-AMT-LOC9                        04820004
048300                 REDEFINES P-NEW-CBSA-STAND-AMT-LOC.              04830004
048400                 15  P-NEW-CBSA-RURAL-1ST.                        04840004
048500                     20  P-NEW-CBSA-STAND-RURAL PIC 999.          04850004
048600                 15  P-NEW-CBSA-RURAL-2ND       PIC 99.           04860004
048700             10  P-NEW-CBSA-SPEC-WAGE-INDEX     PIC 9(02)V9(04).  04870004
048800     02  PROV-NEWREC-HOLD3.                                       04880004
048900         05  P-NEW-PASS-AMT-DATA.                                 04890004
049000             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          04900004
049100             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          04910004
049200             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          04920004
049300             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          04930004
049400         05  P-NEW-CAPI-DATA.                                     04940004
049500             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 04950004
049600             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          04960004
049700             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          04970004
049800             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        04980004
049900             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             04990004
050000             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 05000004
050100             15  P-NEW-CAPI-IME            PIC 9V9999.            05010004
050200             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          05020004
050300         05  FILLER                        PIC X(22).             05030004
050400******************************************************************05040004
050500*                   THIS IS THE WAGE-INDEX                        05050004
050600*          ASSOCIATED WITH THE BILL BEING PROCESSED               05060004
050700*                                                                 05070004
050800******************************************************************05080004
050900 01  WAGE-NEW-INDEX-RECORD-CBSA.                                  05090004
051000     05  W-NEW-CBSA                    PIC X(5).                  05100004
051100*       88  VALID-RURAL-CBSA    VALUE                             05110004
051200*             '50001' '50007' '50016' '50020' '50031'             05120004
051300*             '50036' '50054' '50060' '50067' '50087'             05130004
051400*             '50089' '50091' '50092' '50100' '50104'             05140004
051500*             '50108' '50114' '50121' '50125' '50140'             05150004
051600*             '50145' '50152' '50164' '50170' '50192'             05160004
051700*             '50199' '50206' '50210' '50214' '50218'             05170004
051800*             '50222' '50225' '50226' '50231' '50234'             05180004
051900*             '50237' '50243' '50248' '50250' '50255'             05190004
052000*             '50256' '50257' '50260' '50261' '50262'             05200004
052100*             '50263' '50266' '50268' '50272' '50275'             05210004
052200*             '50281' '50286' '50293' '50313' '50314'             05220004
052300*             '50316' '50325' '50326' '50327' '50329'             05230004
052400*             '50336' '50344' '50352'.                            05240004
052500     05  W-NEW-EFF-DATE-C              PIC X(8).                  05250004
052600     05  W-NEW-WAGE-INDEX-C            PIC S9(02)V9(04).          05260004
052700                                                                  05270004
052800 PROCEDURE DIVISION  USING BILL-NEW-DATA                          05280004
052900                           PPS-DATA-ALL                           05290004
053000                           PRICER-OPT-VERS-SW                     05300004
053100                           PROV-NEW-HOLD                          05310004
053200                           WAGE-NEW-INDEX-RECORD-CBSA.            05320004
053300***************************************************************   05330004
053400*    PROCESSING:                                              *   05340004
053500*        A. WILL PROCESS CLAIMS BASED ON DISCHARGE DATE       *   05350004
053600*        B. INITIALIZE IRCAL HOLD VARIABLES.                  *   05360004
053700*        C. EDIT THE DATA PASSED FROM THE CLAIM BEFORE        *   05370004
053800*           ATTEMPTING TO CALCULATE PPS. IF THIS CLAIM        *   05380004
053900*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   05390004
054000*           GOBACK.                                           *   05400004
054100*        D. ASSEMBLE PRICING COMPONENTS.                      *   05410004
054200*        E. CALCULATE THE PRICE.                              *   05420004
054300*        F. CALCULATE OUTLIERS IF APPLICABLE.                 *   05430004
054400***************************************************************   05440004
054500                                                                  05450004
054600 0000-MAINLINE-CONTROL.                                           05460004
054700                                                                  05470009
054800     PERFORM 0100-INITIAL-ROUTINE                                 05480004
054900        THRU 0100-EXIT.                                           05490004
055000                                                                  05500004
055100     PERFORM 1000-EDIT-THE-BILL-INFO                              05510004
055200        THRU 1000-EXIT.                                           05520004
055300                                                                  05530004
055400     IF PPS-RTC = 00                                              05540004
055500        PERFORM 1700-EDIT-CMG-CODE                                05550004
055600           THRU 1700-EXIT.                                        05560004
055700                                                                  05570004
055800     IF PPS-RTC = 00                                              05580004
055900        PERFORM 2000-ASSEMBLE-PPS-VARIABLES                       05590004
056000           THRU 2000-EXIT.                                        05600004
056100                                                                  05610004
056200     IF PPS-RTC = 00                                              05620004
056300        PERFORM 3000-CALC-PAYMENT                                 05630004
056400           THRU 3000-EXIT                                         05640004
056500        PERFORM 3500-CONTINUE-CALC                                05650004
056600           THRU 3500-EXIT                                         05660004
056700        PERFORM 4000-CALC-OUTLIER                                 05670004
056800           THRU 4000-EXIT                                         05680004
056900        PERFORM 5000-FINAL-PAYMENTS                               05690004
057000           THRU 5000-EXIT.                                        05700004
057100                                                                  05710004
057200     PERFORM 9000-MOVE-RESULTS                                    05720004
057300        THRU 9000-EXIT.                                           05730004
057400                                                                  05740004
057500     GOBACK.                                                      05750004
057600                                                                  05760004
057700 0100-INITIAL-ROUTINE.                                            05770004
057800                                                                  05780004
057900     MOVE ZEROS TO PPS-RTC.                                       05790004
058000     INITIALIZE PPS-DATA.                                         05800004
058100     INITIALIZE PPS-OTHER-DATA.                                   05810004
058200     INITIALIZE HOLD-PPS-COMPONENTS.                              05820004
058300***************************************************************   05830004
058400*    UPDATE THE VALUES BELOW FOR EACH FY RELEASE              *   05840004
058500*     - VALUES PER POLICY                                     *   05850004
058600***************************************************************   05860004
058700                                                                  05870004
058800     MOVE .75612 TO PPS-NAT-LABOR-PCT.                            05880004
058900     MOVE .24388 TO PPS-NAT-NONLABOR-PCT.                         05890004
059000     MOVE 5534   TO PPS-NAT-THRESHOLD-ADJ.                        05900004
059100     MOVE 12981  TO PPS-BDGT-NEUT-CONV-AMT.                       05910004
059200                                                                  05920004
059300 0100-EXIT.                                                       05930004
059400      EXIT.                                                       05940004
059500                                                                  05950004
059600 1000-EDIT-THE-BILL-INFO.                                         05960004
059700***************************************************************   05970004
059800*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *   05980004
059900*    AND DO NOT ATTEMPT TO PRICE.                             *   05990004
060000***************************************************************   06000004
060100                                                                  06010004
060200     MOVE B-CMG-CODE TO PPS-SUBM-CMG-CODE.                        06020004
060300                                                                  06030004
060400     IF (B-LOS NUMERIC) AND (B-LOS > 0)                           06040004
060500        MOVE B-LOS TO H-LOS                                       06050004
060600     ELSE                                                         06060004
060700        IF B-LOS = 0                                              06070004
060800           MOVE 1 TO H-LOS                                        06080004
060900        ELSE                                                      06090004
061000           MOVE 56 TO PPS-RTC.                                    06100004
061100                                                                  06110004
061200     MOVE P-NEW-FY-BEGIN-DATE TO H-FY-BEGIN-DATE.                 06120004
061300     IF H-FY-BEGIN-DATE (5:2) < 11                                06130004
061400       COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 10200          06140004
061500     ELSE                                                         06150004
061600       COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 19000.         06160004
061700     MOVE B-DISCHARGE-DATE TO H-DISCHARGE-DATE.                   06170004
061800     IF (H-DISCHARGE-DATE > H-FY-BEGIN-DATE)                      06180004
061900        OR (P-NEW-FY-BEGIN-DATE > 20020930 AND                    06190004
062000            P-NEW-FY-BEGIN-DATE < 20030101)                       06200004
062100        MOVE '4' TO P-NEW-FED-PPS-BLEND-IND.                      06210004
062200     IF P-NEW-FY-BEGIN-DATE > 20011231                            06220004
062300        IF (P-NEW-FY-BEGIN-DATE <= B-DISCHARGE-DATE)              06230004
062400           IF P-NEW-FED-PPS-BLEND-IND = '4'                       06240004
062500              MOVE 1.0000 TO PPS-FED-RATE-PCT                     06250004
062600              MOVE 0.0000 TO PPS-FAC-RATE-PCT                     06260004
062700           ELSE                                                   06270004
062800             IF P-NEW-FED-PPS-BLEND-IND = '3'                     06280004
062900                MOVE .6667 TO PPS-FED-RATE-PCT                    06290004
063000                MOVE .3333 TO PPS-FAC-RATE-PCT                    06300004
063100             ELSE                                                 06310004
063200               MOVE 72 TO PPS-RTC                                 06320004
063300        ELSE                                                      06330004
063400           MOVE 73 TO PPS-RTC                                     06340004
063500     ELSE                                                         06350004
063600        MOVE 74 TO PPS-RTC.                                       06360004
063700                                                                  06370004
063800     IF PPS-RTC = 00                                              06380004
063900       IF P-NEW-WAIVER-STATE                                      06390004
064000          MOVE 53 TO PPS-RTC.                                     06400004
064100                                                                  06410004
064200     IF PPS-RTC = 00                                              06420004
064300         IF ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR               06430004
064400            (B-DISCHARGE-DATE < W-NEW-EFF-DATE-C))                06440004
064500            MOVE 55 TO PPS-RTC.                                   06450004
064600                                                                  06460004
064700     IF PPS-RTC = 00                                              06470004
064800         IF P-NEW-TERMINATION-DATE > 00000000                     06480004
064900            IF B-DISCHARGE-DATE >= P-NEW-TERMINATION-DATE         06490004
065000               MOVE 51 TO PPS-RTC.                                06500004
065100                                                                  06510004
065200     IF PPS-RTC = 00                                              06520004
065300         IF B-COV-CHARGES NOT NUMERIC                             06530004
065400            MOVE 58 TO PPS-RTC.                                   06540004
065500                                                                  06550004
065600     IF PPS-RTC = 00                                              06560004
065700        IF B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60              06570004
065800           MOVE 61 TO PPS-RTC                                     06580004
065900        ELSE                                                      06590004
066000           MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.                  06600004
066100                                                                  06610004
066200     IF PPS-RTC = 00                                              06620004
066300        IF B-COV-DAYS NOT NUMERIC                                 06630004
066400             MOVE 62 TO PPS-RTC                                   06640004
066500        ELSE                                                      06650004
066600          IF B-COV-DAYS = 0 AND H-LOS > 0                         06660004
066700             MOVE 62 TO PPS-RTC.                                  06670004
066800                                                                  06680004
066900     IF PPS-RTC = 00                                              06690004
067000        IF B-LTR-DAYS  > B-COV-DAYS                               06700004
067100           MOVE 62 TO PPS-RTC                                     06710004
067200        ELSE                                                      06720004
067300           COMPUTE PPS-REG-DAYS-USED = B-COV-DAYS - B-LTR-DAYS.   06730004
067400                                                                  06740004
067500     IF PPS-RTC = 00                                              06750004
067600        IF PPS-REG-DAYS-USED > 0                                  06760004
067700           IF PPS-REG-DAYS-USED > H-LOS                           06770004
067800              MOVE H-LOS TO PPS-REG-DAYS-USED                     06780004
067900           ELSE                                                   06790004
068000              NEXT SENTENCE                                       06800004
068100        ELSE                                                      06810004
068200           IF B-LTR-DAYS > H-LOS                                  06820004
068300              MOVE H-LOS TO PPS-LTR-DAYS-USED                     06830004
068400           ELSE                                                   06840004
068500              MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.               06850004
068600                                                                  06860004
068700 1000-EXIT.                                                       06870004
068800      EXIT.                                                       06880004
068900                                                                  06890004
069000***************************************************************   06900004
069100*    FINDS THE CMG CODE IN THE TABLE                          *   06910004
069200***************************************************************   06920004
069300 1700-EDIT-CMG-CODE.                                              06930004
069310*------------------ 2008.1---------------------------------------*06931006
069320                                                                  06932009
069330     IF PPS-CMG-NUMERIC = '9999'                                  06933006
069340        NEXT SENTENCE                                             06934006
069350     ELSE                                                         06935006
069360        IF PPS-CMG-NUMERIC < '2103'                               06936006
069370           NEXT SENTENCE                                          06937006
069380        ELSE                                                      06938006
069390           MOVE 54 TO PPS-RTC.                                    06939006
069900                                                                  06990004
070000     IF PPS-RTC = 00                                              07000004
070100        SEARCH ALL CMG-DATA                                       07010004
070200           AT END                                                 07020004
070300             MOVE 54 TO PPS-RTC                                   07030004
070400        WHEN CMG-NUM (DX6) = PPS-CMG-NUMERIC                      07040004
070500             PERFORM 1750-FIND-VALUE                              07050004
070600                THRU 1750-EXIT                                    07060004
070700        END-SEARCH.                                               07070004
070800                                                                  07080004
070900 1700-EXIT.                                                       07090004
071000      EXIT.                                                       07100004
071100                                                                  07110004
071200***************************************************************   07120004
071300*    FINDS THE VALUE IN THE CMG CODE IN THE TABLE             *   07130004
071400***************************************************************   07140004
071500 1750-FIND-VALUE.                                                 07150004
071600                                                                  07160004
071700      IF PPS-CMG-ALPHA = 'A'                                      07170004
071800         MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                 07180004
071900         MOVE A-LOS-TABLE (DX6) TO PPS-AVG-LOS                    07190004
072000      ELSE                                                        07200004
072100         IF PPS-CMG-ALPHA = 'B'                                   07210004
072200            MOVE B-REL-WGT (DX6) TO PPS-RELATIVE-WGT              07220004
072300            MOVE B-LOS-TABLE (DX6) TO PPS-AVG-LOS                 07230004
072400         ELSE                                                     07240004
072500            IF PPS-CMG-ALPHA = 'C'                                07250004
072600               MOVE C-REL-WGT (DX6) TO PPS-RELATIVE-WGT           07260004
072700               MOVE C-LOS-TABLE (DX6) TO PPS-AVG-LOS              07270004
072800            ELSE                                                  07280004
072900               IF PPS-CMG-ALPHA = 'D'                             07290004
073000                  MOVE D-REL-WGT (DX6) TO PPS-RELATIVE-WGT        07300004
073100                  MOVE D-LOS-TABLE (DX6) TO PPS-AVG-LOS           07310004
073200               ELSE                                               07320004
073300                  MOVE 54 TO PPS-RTC.                             07330004
073400                                                                  07340004
073500 1750-EXIT.                                                       07350004
073600      EXIT.                                                       07360004
073700                                                                  07370004
073800***************************************************************   07380004
073900*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *   07390004
074000*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   07400004
074100*    OF THAT VARIABLE.                                        *   07410004
074200***************************************************************   07420004
074300***  GET THE PROVIDER SPECIFIC VARIABLE AND WAGE INDEX            07430004
074400***************************************************************   07440004
074500 2000-ASSEMBLE-PPS-VARIABLES.                                     07450004
074600                                                                  07460004
074700     IF P-NEW-FAC-SPEC-RATE NUMERIC                               07470004
074800        MOVE P-NEW-FAC-SPEC-RATE TO PPS-FAC-SPEC-RT-PREBLEND      07480004
074900     ELSE                                                         07490004
075000        MOVE 50 TO PPS-RTC                                        07500004
075100        GO TO 2000-EXIT.                                          07510004
075200                                                                  07520004
075300     IF P-NEW-FED-PPS-BLEND-IND = '3'                             07530004
075400        IF PPS-FAC-SPEC-RT-PREBLEND = 0                           07540004
075500          MOVE 57 TO PPS-RTC                                      07550004
075600          GO TO 2000-EXIT.                                        07560004
075700                                                                  07570004
075800     IF W-NEW-WAGE-INDEX-C NUMERIC                                07580004
075900            AND W-NEW-WAGE-INDEX-C > 0                            07590004
076000        MOVE W-NEW-WAGE-INDEX-C TO PPS-WAGE-INDEX                 07600004
076100     ELSE                                                         07610004
076200        MOVE 52 TO PPS-RTC                                        07620004
076300        GO TO 2000-EXIT.                                          07630004
076400                                                                  07640004
076500     IF P-NEW-OPER-CSTCHG-RATIO NOT NUMERIC                       07650004
076600        MOVE 65 TO PPS-RTC.                                       07660004
076700                                                                  07670004
076800 2000-EXIT.                                                       07680004
076900      EXIT.                                                       07690004
077000                                                                  07700004
077100***************************************************************   07710004
077200*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *   07720004
077300*        CALCULATE THE FEDERAL PORTION.                       *   07730004
077400*        CALCULATE THE HOSPITAL PORTION.                      *   07740004
077500*        CALCULATE THE COST-OUTLIER PORTION.                  *   07750004
077600*        CALCULATE THE LIP ADJUSTMENT PERCENTAGE.             *   07760004
077700***************************************************************   07770004
077800 3000-CALC-PAYMENT.                                               07780004
077900                                                                  07790004
078000***  LIP PERCENTAGE CALCULATION *******************************   07800004
078100                                                                  07810004
078200      COMPUTE H-WK-DSH = (P-NEW-SSI-RATIO                         07820004
078300                           + P-NEW-MEDICAID-RATIO).               07830004
078400                                                                  07840004
078500      COMPUTE PPS-LIP-PCT ROUNDED =                               07850004
078600            ((1 + H-WK-DSH) ** .6229) - 1.                        07860004
078700                                                                  07870004
078800      COMPUTE H-TEACH-PCT ROUNDED =                               07880004
078900            ((1 + P-NEW-CAPI-IME) ** .9012) - 1.                  07890004
079000                                                                  07900004
079100***************************************************************   07910004
079200                                                                  07920004
079300     MOVE 1.0000 TO PPS-TRANSFER-PCT.                             07930004
079400                                                                  07940004
079500     IF B-PATIENT-STATUS =                                        07950004
079600         ('02' OR '03' OR '61' OR '62' OR '63' OR '64')           07960004
079700        IF H-LOS < PPS-AVG-LOS                                    07970004
079800           COMPUTE PPS-TRANSFER-PCT =                             07980004
079900               ((H-LOS + .5) / PPS-AVG-LOS)                       07990004
080000           MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE          08000004
080100           GO TO 3000-EXIT.                                       08010004
080200                                                                  08020004
080300     IF H-LOS > 3                                                 08030004
080400        NEXT SENTENCE                                             08040004
080500     ELSE                                                         08050004
080600        MOVE 'A5001' TO PPS-PRICED-CMG-CODE                       08060004
080700        SET DX6 TO 88                                             08070004
080800        MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                  08080004
080900        GO TO 3000-EXIT.                                          08090004
081000                                                                  08100004
081100     IF B-PATIENT-STATUS = '20'                                   08110004
081200        NEXT SENTENCE                                             08120004
081300     ELSE                                                         08130004
081400        MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE             08140004
081500        GO TO 3000-EXIT.                                          08150004
081600                                                                  08160004
081700     IF PPS-CMG-RIC = ('07' OR '08' OR '09')                      08170004
081800        IF H-LOS < 14                                             08180004
081900           MOVE 'A5101' TO PPS-PRICED-CMG-CODE                    08190004
082000           SET DX6 TO 89                                          08200004
082100           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08210004
082200        ELSE                                                      08220004
082300           MOVE 'A5102' TO PPS-PRICED-CMG-CODE                    08230004
082400           SET DX6 TO 90                                          08240004
082500           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08250004
082600     ELSE                                                         08260004
082700        IF H-LOS < 16                                             08270004
082800           MOVE 'A5103' TO PPS-PRICED-CMG-CODE                    08280004
082900           SET DX6 TO 91                                          08290004
083000           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08300004
083100        ELSE                                                      08310004
083200           MOVE 'A5104' TO PPS-PRICED-CMG-CODE                    08320004
083300           SET DX6 TO 92                                          08330004
083400           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT.              08340004
083500                                                                  08350004
083600 3000-EXIT.                                                       08360004
083700      EXIT.                                                       08370004
083800                                                                  08380004
083900 3500-CONTINUE-CALC.                                              08390004
084000                                                                  08400004
084100     COMPUTE PPS-STANDARD-PAY-AMT =                               08410004
084200            (PPS-TRANSFER-PCT * PPS-RELATIVE-WGT                  08420004
084300                      * PPS-BDGT-NEUT-CONV-AMT).                  08430004
084400                                                                  08440004
084500***************************************************************   08450004
084600*      CHANGE RURAL ADJUSTMENT AMOUNT IF NECESSARY            *   08460004
084700*      - PER CHANGE REQUEST                                   *   08470004
084800***************************************************************   08480004
084900     IF W-NEW-CBSA (1:3) = '   '                                  08490004
085000        MOVE 1.2130 TO PPS-RURAL-ADJUSTMENT                       08500004
085100     ELSE                                                         08510004
085200        MOVE 1.0000 TO PPS-RURAL-ADJUSTMENT.                      08520004
085300                                                                  08530004
085400***************************************************************   08540004
085500*      CHANGE RURAL ADJUSTMENT BASED ON RELIEF INDICATOR      *   08550004
085600*       IF NECESSARY - PER CHANGE REQUEST                     *   08560004
085700***************************************************************   08570004
085800     IF P-NEW-TEMP-RELIEF-IND = 'Y'                               08580004
085900        MOVE 1.0638 TO PPS-RURAL-ADJUSTMENT.                      08590004
086000                                                                  08600004
086100     COMPUTE H-LABOR-PORTION =                                    08610004
086200        (PPS-STANDARD-PAY-AMT * PPS-NAT-LABOR-PCT)                08620004
086300          * PPS-WAGE-INDEX.                                       08630004
086400                                                                  08640004
086500     COMPUTE H-NONLABOR-PORTION =                                 08650004
086600        (PPS-STANDARD-PAY-AMT * PPS-NAT-NONLABOR-PCT).            08660004
086700                                                                  08670004
086800     COMPUTE PPS-FED-PAY-AMT ROUNDED =                            08680004
086900        ((H-LABOR-PORTION + H-NONLABOR-PORTION) *                 08690004
087000         PPS-RURAL-ADJUSTMENT).                                   08700004
087100                                                                  08710004
087200     COMPUTE PPS-LIP-PAY-AMT ROUNDED =                            08720004
087300        (PPS-FED-PAY-AMT * PPS-LIP-PCT).                          08730004
087400                                                                  08740004
087500     COMPUTE PPS-TEACH-PAY-AMT ROUNDED =                          08750004
087600        (PPS-FED-PAY-AMT * H-TEACH-PCT).                          08760004
087700                                                                  08770004
087800 3500-EXIT.                                                       08780004
087900      EXIT.                                                       08790004
088000                                                                  08800004
088100 4000-CALC-OUTLIER.                                               08810004
088200                                                                  08820004
088300     COMPUTE PPS-FAC-COSTS ROUNDED =                              08830004
088400         (B-COV-CHARGES * P-NEW-OPER-CSTCHG-RATIO).               08840004
088500                                                                  08850004
088600     COMPUTE H-OUTLIER-LABOR-PORTION =                            08860004
088700        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-LABOR-PCT)               08870004
088800              * PPS-WAGE-INDEX.                                   08880004
088900                                                                  08890004
089000     COMPUTE H-OUTLIER-NONLABOR-PORTION =                         08900004
089100        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-NONLABOR-PCT).           08910004
089200                                                                  08920004
089300     COMPUTE H-FP-OUTLIER-THRESHOLD ROUNDED =                     08930004
089400        ((H-OUTLIER-LABOR-PORTION + H-OUTLIER-NONLABOR-PORTION) * 08940004
089500         PPS-RURAL-ADJUSTMENT * (PPS-LIP-PCT + H-TEACH-PCT + 1)). 08950004
089600                                                                  08960004
089700     COMPUTE H-OUTLIER-THRESHOLD ROUNDED =                        08970004
089800        (PPS-FED-PAY-AMT + H-FP-OUTLIER-THRESHOLD +               08980004
089900         PPS-LIP-PAY-AMT + PPS-TEACH-PAY-AMT).                    08990004
090000                                                                  09000004
090100     IF PPS-FAC-COSTS > H-OUTLIER-THRESHOLD                       09010004
090200        COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                     09020004
090300           ((PPS-FAC-COSTS - H-OUTLIER-THRESHOLD) * .8).          09030004
090400                                                                  09040004
090500     COMPUTE H-CHG-OUTLIER-THRESHOLD ROUNDED =                    09050004
090600         H-OUTLIER-THRESHOLD / P-NEW-OPER-CSTCHG-RATIO.           09060004
090700                                                                  09070004
090800                                                                  09080004
090900 4000-EXIT.                                                       09090004
091000      EXIT.                                                       09100004
091100                                                                  09110004
091200 5000-FINAL-PAYMENTS.                                             09120004
091300                                                                  09130004
091400     IF B-SPEC-PAY-IND = '1' OR '3'                               09140004
091500         MOVE ZEROES TO PPS-OUTLIER-PAY-AMT.                      09150004
091600                                                                  09160004
091700     IF PPS-FED-RATE-PCT = 1.0000                                 09170004
091800         MOVE 0 TO PPS-FAC-SPEC-PAY-AMT                           09180004
091900     ELSE                                                         09190004
092000         COMPUTE PPS-FED-PAY-AMT ROUNDED =                        09200004
092100           (PPS-FED-RATE-PCT * PPS-FED-PAY-AMT)                   09210004
092200         COMPUTE PPS-FAC-SPEC-PAY-AMT ROUNDED =                   09220004
092300           (PPS-FAC-RATE-PCT * PPS-FAC-SPEC-RT-PREBLEND)          09230004
092400         COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                    09240004
092500           (PPS-FED-RATE-PCT * PPS-OUTLIER-PAY-AMT)               09250004
092600         COMPUTE PPS-TEACH-PAY-AMT ROUNDED =                      09260004
092700           (PPS-FED-RATE-PCT * PPS-TEACH-PAY-AMT)                 09270004
092800         COMPUTE PPS-LIP-PAY-AMT ROUNDED =                        09280004
092900           (PPS-FED-RATE-PCT * PPS-LIP-PAY-AMT).                  09290004
093000                                                                  09300004
093100     IF B-SPEC-PAY-IND = '2' OR '3'                               09310004
093200        COMPUTE PPS-FED-PENALTY-AMT ROUNDED =                     09320004
093300           (PPS-FED-PAY-AMT * .25)                                09330004
093400        COMPUTE PPS-FED-PAY-AMT =                                 09340004
093500           (PPS-FED-PAY-AMT - PPS-FED-PENALTY-AMT)                09350004
093600        COMPUTE PPS-LIP-PENALTY-AMT ROUNDED =                     09360004
093700           (PPS-LIP-PAY-AMT * .25)                                09370004
093800        COMPUTE PPS-LIP-PAY-AMT =                                 09380004
093900           (PPS-LIP-PAY-AMT - PPS-LIP-PENALTY-AMT)                09390004
094000        COMPUTE PPS-OUT-PENALTY-AMT ROUNDED =                     09400004
094100           (PPS-OUTLIER-PAY-AMT * .25)                            09410004
094200        COMPUTE PPS-OUTLIER-PAY-AMT =                             09420004
094300           (PPS-OUTLIER-PAY-AMT - PPS-OUT-PENALTY-AMT)            09430004
094400        COMPUTE PPS-TEACH-PENALTY-AMT ROUNDED =                   09440004
094500           (PPS-TEACH-PAY-AMT * .25)                              09450004
094600        COMPUTE PPS-TEACH-PAY-AMT =                               09460004
094700           (PPS-TEACH-PAY-AMT - PPS-TEACH-PENALTY-AMT)            09470004
094800        COMPUTE PPS-TOTAL-PENALTY-AMT =                           09480004
094900           (PPS-FED-PENALTY-AMT + PPS-LIP-PENALTY-AMT             09490004
095000           + PPS-OUT-PENALTY-AMT + PPS-TEACH-PENALTY-AMT).        09500004
095100                                                                  09510004
095200     COMPUTE PPS-TOTAL-PAY-AMT ROUNDED =                          09520004
095300        (PPS-FED-PAY-AMT + PPS-FAC-SPEC-PAY-AMT                   09530004
095400         + PPS-OUTLIER-PAY-AMT + PPS-LIP-PAY-AMT +                09540004
095500         PPS-TEACH-PAY-AMT).                                      09550004
095600                                                                  09560004
095700     IF PPS-FED-RATE-PCT = 1.0000                                 09570004
095800        IF PPS-TRANSFER-PCT = 1.0000                              09580004
095900           IF PPS-OUTLIER-PAY-AMT > 0.0                           09590004
096000              MOVE 01 TO PPS-RTC                                  09600004
096100           ELSE                                                   09610004
096200              MOVE 00 TO PPS-RTC                                  09620004
096300        ELSE                                                      09630004
096400           IF PPS-OUTLIER-PAY-AMT > 0.0                           09640004
096500              MOVE 03 TO PPS-RTC                                  09650004
096600           ELSE                                                   09660004
096700              MOVE 02 TO PPS-RTC                                  09670004
096800     ELSE                                                         09680004
096900        IF PPS-TRANSFER-PCT = 1.0000                              09690004
097000           IF PPS-OUTLIER-PAY-AMT > 0.0                           09700004
097100              MOVE 05 TO PPS-RTC                                  09710004
097200           ELSE                                                   09720004
097300              MOVE 04 TO PPS-RTC                                  09730004
097400        ELSE                                                      09740004
097500           IF PPS-OUTLIER-PAY-AMT > 0.0                           09750004
097600              MOVE 07 TO PPS-RTC                                  09760004
097700           ELSE                                                   09770004
097800              MOVE 06 TO PPS-RTC.                                 09780004
097900                                                                  09790004
098000     IF B-SPEC-PAY-IND = '2' OR '3'                               09800004
098100        COMPUTE PPS-RTC = PPS-RTC + 10.                           09810004
098200     IF PPS-RTC = (01 OR 03 OR 05 OR 07                           09820004
098300                OR 11 OR 13 OR 15 OR 17)                          09830004
098400        IF ((PPS-REG-DAYS-USED + PPS-LTR-DAYS-USED) < H-LOS)      09840004
098500           OR PPS-COT-IND = 'Y'                                   09850004
098600            MOVE 67 TO PPS-RTC.                                   09860004
098700                                                                  09870004
098800 5000-EXIT.                                                       09880004
098900      EXIT.                                                       09890004
099000                                                                  09900004
099100 9000-MOVE-RESULTS.                                               09910004
099200                                                                  09920004
099300     IF PPS-RTC < 50                                              09930004
099400      MOVE H-LOS                   TO  PPS-LOS                    09940004
099500      MOVE H-OUTLIER-THRESHOLD     TO  PPS-OUTLIER-THRESHOLD      09950004
099600      MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD   09960004
099700      MOVE W-NEW-CBSA              TO  PPS-CBSA                   09970004
099800      MOVE 'V07.0'                 TO  PPS-CALC-VERS-CD           09980004
099900     ELSE                                                         09990004
100000       INITIALIZE PPS-DATA                                        10000004
100100       INITIALIZE PPS-OTHER-DATA                                  10010004
100200       MOVE 'V07.0'                TO  PPS-CALC-VERS-CD.          10020004
100300                                                                  10030004
100400     IF PPS-RTC = 67                                              10040004
100500       MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD. 10050004
100600                                                                  10060004
100700 9000-EXIT.                                                       10070004
100800      EXIT.                                                       10080004
100900                                                                  10090004
101000******        L A S T   S O U R C E   S T A T E M E N T   *****   10100004
