000100 IDENTIFICATION DIVISION.                                         00010029
000200 PROGRAM-ID.           IRCAL064.                                  00020029
000300*AUTHOR.            ED FRANEY.                                    00030029
000400*REMARKS.                CMS.                                     00040029
000500*       EFFECTIVE OCT 1 2005                                      00050029
000600 DATE-COMPILED.                                                   00060029
000610******************* CHANGE LOG ***********************************00061031
000620* JULY, 2009 - ALLOW A9999 TO PASS THROUGH PRICER AS A VALID CMG *00062031
000621*            - REFER TO CR# 6329                                 *00062134
000630******************************************************************00063031
000700 ENVIRONMENT DIVISION.                                            00070029
000800 CONFIGURATION SECTION.                                           00080029
000900 SOURCE-COMPUTER.            IBM-370.                             00090029
001000 OBJECT-COMPUTER.            IBM-370.                             00100029
001100 INPUT-OUTPUT  SECTION.                                           00110029
001200 FILE-CONTROL.                                                    00120029
001300                                                                  00130029
001400 DATA DIVISION.                                                   00140029
001500 FILE SECTION.                                                    00150029
001600                                                                  00160029
001700 WORKING-STORAGE SECTION.                                         00170029
001800 01  W-STORAGE-REF                  PIC X(46)  VALUE              00180029
001900     'IRCAL064      - W O R K I N G   S T O R A G E'.             00190029
002000 01  CAL-VERSION                    PIC X(05)  VALUE 'C06.4'.     00200029
002100                                                                  00210029
002200***************************************************************   00220029
002300*    LAYUP TABLE AREA FOR FY2006 CMGS                         *   00230029
002400*    EFFECTIVE DATE OF OCTOBER 1, 2005                        *   00240029
002500***************************************************************   00250029
002600 01  CMG-TABLE.                                                   00260029
002700     05  CMG-TABLE-DATA.                                          00270029
002800         10                      PIC X(32)   VALUE                00280029
002900           '01010769107299064840635008110909'.                    00290029
003000         10                      PIC X(32)   VALUE                00300029
003100           '01020947108989079850782011151110'.                    00310029
003200         10                      PIC X(32)   VALUE                00320029
003300           '01031116210594094110921714131212'.                    00330029
003400         10                      PIC X(32)   VALUE                00340029
003500           '01041185911255099990979213141313'.                    00350029
003600         10                      PIC X(32)   VALUE                00360029
003700           '01051423313509120011175316171515'.                    00370029
003800         10                      PIC X(32)   VALUE                00380029
003900           '01061656715724139691368018201818'.                    00390029
004000         10                      PIC X(32)   VALUE                00400029
004100           '01071912118148161221579021232021'.                    00410029
004200         10                      PIC X(32)   VALUE                00420029
004300           '01082210620981186391825427292424'.                    00430029
004400         10                      PIC X(32)   VALUE                00440029
004500           '01092197620858185291814723262423'.                    00450029
004600         10                      PIC X(32)   VALUE                00460029
004700           '01102626224926221432168630332828'.                    00470029
004800         10                      PIC X(32)   VALUE                00480029
004900           '02010814006826060210564810090908'.                    00490029
005000         10                      PIC X(32)   VALUE                00500029
005100           '02021043708753077200724112101109'.                    00510029
005200         10                      PIC X(32)   VALUE                00520029
005300           '02031248710472092360866415151212'.                    00530029
005400         10                      PIC X(32)   VALUE                00540029
005500           '02041335611201098790926715161313'.                    00550029
005600         10                      PIC X(32)   VALUE                00560029
005700           '02051638113738121161136517181615'.                    00570029
005800         10                      PIC X(32)   VALUE                00580029
005900           '02062137917930158141483323222120'.                    00590029
006000         10                      PIC X(32)   VALUE                00600029
006100           '02072765723194204571918835292625'.                    00610029
006200         10                      PIC X(32)   VALUE                00620029
006300           '03011129309536084400776412121110'.                    00630029
006400         10                      PIC X(32)   VALUE                00640029
006500           '03021472912438110081012614161413'.                    00650029
006600         10                      PIC X(32)   VALUE                00660029
006700           '03031757514841131361208320191716'.                    00670029
006800         10                      PIC X(32)   VALUE                00680029
006900           '03042422120453181031665131252321'.                    00690029
007000         10                      PIC X(32)   VALUE                00700029
007100           '04010989108517076560683712121010'.                    00710029
007200         10                      PIC X(32)   VALUE                00720029
007300           '04021364011746105580942819161412'.                    00730029
007400         10                      PIC X(32)   VALUE                00740029
007500           '04032374320446183791641222242322'.                    00750029
007600         10                      PIC X(32)   VALUE                00760029
007700           '04044256736656329502942451463937'.                    00770029
007800         10                      PIC X(32)   VALUE                00780029
007900           '04053247727967251392244932383328'.                    00790029
008000         10                      PIC X(32)   VALUE                00800029
008100           '05010770506449056410505909080807'.                    00810029
008200         10                      PIC X(32)   VALUE                00820029
008300           '05021031608634075530677413121009'.                    00830029
008400         10                      PIC X(32)   VALUE                00840029
008500           '05031367611446100130897915151312'.                    00850029
008600         10                      PIC X(32)   VALUE                00860029
008700           '05041712014328125341124020191615'.                    00870029
008800         10                      PIC X(32)   VALUE                00880029
008900           '05052028916981148551332123221918'.                    00890029
009000         10                      PIC X(32)   VALUE                00900029
009100           '05062760723106202121812629282523'.                    00910029
009200         10                      PIC X(32)   VALUE                00920029
009300           '06010896507331069660649311100909'.                    00930029
009400         10                      PIC X(32)   VALUE                00940029
009500           '06021192509752092670863613131212'.                    00950029
009600         10                      PIC X(32)   VALUE                00960029
009700           '06031526612484118631105616171515'.                    00970029
009800         10                      PIC X(32)   VALUE                00980029
009900           '06041953915979151831415122202019'.                    00990029
010000         10                      PIC X(32)   VALUE                01000029
010100           '07010905507736072650658512111009'.                    01010029
010200         10                      PIC X(32)   VALUE                01020029
010300           '07021175710044094320854913141312'.                    01030029
010400         10                      PIC X(32)   VALUE                01040029
010500           '07031463612504117421064316171514'.                    01050029
010600         10                      PIC X(32)   VALUE                01060029
010700           '07041796215345144101306220201918'.                    01070029
010800         10                      PIC X(32)   VALUE                01080029
010900           '08010656105511051090459607070706'.                    01090029
011000         10                      PIC X(32)   VALUE                01100029
011100           '08020857007198066730600410100908'.                    01110029
011200         10                      PIC X(32)   VALUE                01120029
011300           '08031270710672098940890115151312'.                    01130029
011400         10                      PIC X(32)   VALUE                01140029
011500           '08041106909296086180775413121110'.                    01150029
011600         10                      PIC X(32)   VALUE                01160029
011700           '08051393711705108520976317161413'.                    01170029
011800         10                      PIC X(32)   VALUE                01180029
011900           '08061672614047130231171618191715'.                    01190029
012000         10                      PIC X(32)   VALUE                01200029
012100           '09010841207658068050609010111009'.                    01210029
012200         10                      PIC X(32)   VALUE                01220029
012300           '09021105410063089420800213131211'.                    01230029
012400         10                      PIC X(32)   VALUE                01240029
012500           '09031458313276117971055718191615'.                    01250029
012600         10                      PIC X(32)   VALUE                01260029
012700           '09041828116643147881323425232019'.                    01270029
012800         10                      PIC X(32)   VALUE                01280029
012900           '10010963808888079310731211111110'.                    01290029
013000         10                      PIC X(32)   VALUE                01300029
013100           '10021270911719104570964114151413'.                    01310029
013200         10                      PIC X(32)   VALUE                01320029
013300           '10031787616483147091356119221918'.                    01330029
013400         10                      PIC X(32)   VALUE                01340029
013500           '11011254410496091890846214151211'.                    01350029
013600         10                      PIC X(32)   VALUE                01360029
013700           '11021878015713137561266819191817'.                    01370029
013800         10                      PIC X(32)   VALUE                01380029
013900           '12011018408794081060731711121110'.                    01390029
014000         10                      PIC X(32)   VALUE                01400029
014100           '12021318111383104920947015161413'.                    01410029
014200         10                      PIC X(32)   VALUE                01420029
014300           '12031623814022129251166621191716'.                    01430029
014400         10                      PIC X(32)   VALUE                01440029
014500           '13011033809617083250735812131110'.                    01450029
014600         10                      PIC X(32)   VALUE                01460029
014700           '13021432413325115341019515181514'.                    01470029
014800         10                      PIC X(32)   VALUE                01480029
014900           '13031830817032147431303222212018'.                    01490029
015000         10                      PIC X(32)   VALUE                01500029
015100           '14010817207352063960580610090908'.                    01510029
015200         10                      PIC X(32)   VALUE                01520029
015300           '14021103409926086360783912131211'.                    01530029
015400         10                      PIC X(32)   VALUE                01540029
015500           '14031373512356107500975916161413'.                    01550029
015600         10                      PIC X(32)   VALUE                01560029
015700           '14041741915671136331237621201816'.                    01570029
015800         10                      PIC X(32)   VALUE                01580029
015900           '15010922208995076870739711121010'.                    01590029
016000         10                      PIC X(32)   VALUE                01600029
016100           '15021165911371097180935212151212'.                    01610029
016200         10                      PIC X(32)   VALUE                01620029
016300           '15031426913917118941144512171515'.                    01630029
016400         10                      PIC X(32)   VALUE                01640029
016500           '15041881218348156811508921222018'.                    01650029
016600         10                      PIC X(32)   VALUE                01660029
016700           '16011006508544077310690412111009'.                    01670029
016800         10                      PIC X(32)   VALUE                01680029
016900           '16021381011724106070947315171413'.                    01690029
017000         10                      PIC X(32)   VALUE                01700029
017100           '16031698814421130481165319191716'.                    01710029
017200         10                      PIC X(32)   VALUE                01720029
017300           '17011010209634083230732112121110'.                    01730029
017400         10                      PIC X(32)   VALUE                01740029
017500           '17021330512688109620964314161513'.                    01750029
017600         10                      PIC X(32)   VALUE                01760029
017700           '17031583215098130431147417201716'.                    01770029
017800         10                      PIC X(32)   VALUE                01780029
017900           '17041980818889163191435526262120'.                    01790029
018000         10                      PIC X(32)   VALUE                01800029
018100           '18011211809832082450728215131210'.                    01810029
018200         10                      PIC X(32)   VALUE                01820029
018300           '18021938515728131901164920211816'.                    01830029
018400         10                      PIC X(32)   VALUE                01840029
018500           '18033478428222236682090343333027'.                    01850029
018600         10                      PIC X(32)   VALUE                01860029
018700           '19011236210981106770934914131412'.                    01870029
018800         10                      PIC X(32)   VALUE                01880029
018900           '19022316220574200041751527252423'.                    01890029
019000         10                      PIC X(32)   VALUE                01900029
019100           '19033343929703288812528737393133'.                    01910029
019200         10                      PIC X(32)   VALUE                01920029
019300           '20010874307387066230604710100908'.                    01930029
019400         10                      PIC X(32)   VALUE                01940029
019500           '20021144809672086710791712131111'.                    01950029
019600         10                      PIC X(32)   VALUE                01960029
019700           '20031478912495112021022716161514'.                    01970029
019800         10                      PIC X(32)   VALUE                01980029
019900           '20041975616692149641366325222018'.                    01990029
020000         10                      PIC X(32)   VALUE                02000029
020100           '21012185821858159101476229241917'.                    02010029
020200         10                      PIC X(32)   VALUE                02020029
020300           '50010000000000000000220100000002'.                    02030029
020400         10                      PIC X(32)   VALUE                02040029
020500           '51010000000000000000635100000008'.                    02050029
020600         10                      PIC X(32)   VALUE                02060029
020700           '51020000000000000001600200000022'.                    02070029
020800         10                      PIC X(32)   VALUE                02080029
020900           '51030000000000000000720400000008'.                    02090029
021000         10                      PIC X(32)   VALUE                02100029
021100           '51040000000000000001877100000024'.                    02110029
021101         10                      PIC X(32)   VALUE                02110132
021110           '99990000000000000000000000000000'.                    02111031
021200     05  W-CMG-TABLE REDEFINES CMG-TABLE-DATA.                    02120029
021300         10  CMG-DATA            OCCURS 93 TIMES                  02130031
021400                                 ASCENDING KEY IS CMG-NUM         02140029
021500                                 INDEXED BY DX6.                  02150029
021600             15  CMG-NUM         PIC X(4).                        02160029
021700             15  CMG-NUM-REDEF REDEFINES CMG-NUM.                 02170029
021800                 20  CMG-RIC     PIC XX.                          02180029
021900                 20  FILLER      PIC XX.                          02190029
022000             15  B-REL-WGT       PIC 9(1)V9(4).                   02200029
022100             15  C-REL-WGT       PIC 9(1)V9(4).                   02210029
022200             15  D-REL-WGT       PIC 9(1)V9(4).                   02220029
022300             15  A-REL-WGT       PIC 9(1)V9(4).                   02230029
022400             15  B-LOS-TABLE     PIC 9(2).                        02240029
022500             15  C-LOS-TABLE     PIC 9(2).                        02250029
022600             15  D-LOS-TABLE     PIC 9(2).                        02260029
022700             15  A-LOS-TABLE     PIC 9(2).                        02270029
022800                                                                  02280029
022900 01  HOLD-PPS-COMPONENTS.                                         02290029
023000     05  H-LOS                        PIC 9(05).                  02300029
023100     05  H-WK-DSH                     PIC 9(01)V9(04).            02310029
023200     05  H-TEACH-PCT                  PIC 9(01)V9(04).            02320029
023300     05  H-LABOR-PORTION              PIC 9(07)V9(06).            02330029
023400     05  H-NONLABOR-PORTION           PIC 9(07)V9(06).            02340029
023500     05  H-OUTLIER-LABOR-PORTION      PIC 9(07)V9(06).            02350029
023600     05  H-OUTLIER-NONLABOR-PORTION   PIC 9(07)V9(06).            02360029
023700     05  H-FP-OUTLIER-THRESHOLD       PIC 9(07)V9(06).            02370029
023800     05  H-OUTLIER-THRESHOLD          PIC 9(07)V9(06).            02380029
023900     05  H-CHG-OUTLIER-THRESHOLD      PIC 9(07)V9(04).            02390029
024000     05  H-FY-BEGIN-DATE              PIC 9(08).                  02400029
024100     05  H-DISCHARGE-DATE             PIC 9(08).                  02410029
024200                                                                  02420029
024300 LINKAGE SECTION.                                                 02430029
024400**************************************************************    02440029
024500*      THIS IS THE BILL-RECORD THAT WILL BE PASSED FROM      *    02450029
024600*      THE IRCAL___ PROGRAM                                  *    02460029
024700**************************************************************    02470029
024800 01  BILL-NEW-DATA.                                               02480029
024900         10  B-NPI10.                                             02490029
025000             15  B-NPI8             PIC X(08).                    02500029
025100             15  B-NPI-FILLER       PIC X(02).                    02510029
025200         10  B-PROVIDER-NO          PIC X(06).                    02520029
025300         10  B-PATIENT-STATUS       PIC X(02).                    02530029
025400         10  B-CMG-CODE             PIC X(05).                    02540029
025500         10  B-LOS                  PIC 9(03).                    02550029
025600         10  B-COV-DAYS             PIC 9(03).                    02560029
025700         10  B-LTR-DAYS             PIC 9(02).                    02570029
025800         10  B-SPEC-PAY-IND         PIC X(01).                    02580029
025900         10  B-DISCHARGE-DATE.                                    02590029
026000             15  B-DISCHG-CC        PIC 9(02).                    02600029
026100             15  B-DISCHG-YY        PIC 9(02).                    02610029
026200             15  B-DISCHG-MM        PIC 9(02).                    02620029
026300             15  B-DISCHG-DD        PIC 9(02).                    02630029
026400         10  B-COV-CHARGES          PIC 9(07)V9(02).              02640029
026500         10  FILLER                 PIC X(11).                    02650029
026600                                                                  02660029
026700***************************************************************   02670029
026800*    THIS DATA IS CALCULATED BY THIS IRCAL SUBROUTINE         *   02680029
026900*    AND PASSED BACK TO THE CALLING PROGRAM                   *   02690029
027000*            RETURN CODE VALUES (PPS-RTC)                     *   02700029
027100*                                                             *   02710029
027200*     ****   PPS-RTC 00-49 = HOW THE BILL WAS PAID            *   02720029
027300*              00 = PAID NORMAL CMG PAYMENT WITHOUT OUTLIER   *   02730029
027400*                                                             *   02740029
027500*              01 = PAID NORMAL CMG PAYMENT WITH OUTLIER      *   02750029
027600*                                                             *   02760029
027700*              02 = TRANSFER PAID ON A PERDIEM BASIS WITHOUT  *   02770029
027800*                   OUTLIER                                   *   02780029
027900*              03 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   02790029
028000*                   OUTLIER                                   *   02800029
028100*              04 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02810029
028200*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02820029
028300*                   WITHOUT OUTLIER                           *   02830029
028400*              05 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02840029
028500*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02850029
028600*                   WITH OUTLIER                              *   02860029
028700*              06 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   02870029
028800*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   02880029
028900*                   RATE -- WITHOUT OUTLIER                   *   02890029
029000*              07 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   02900029
029100*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   02910029
029200*                   RATE -- WITH OUTLIER                      *   02920029
029300*       **** NEW RT CODES FOR PAYMENT WITH PENALTIES          *   02930029
029400*              10 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   02940029
029500*                   WITHOUT OUTLIER                           *   02950029
029600*              11 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   02960029
029700*                   WITH OUTLIER                              *   02970029
029800*              12 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   02980029
029900*                   PENALTY WITHOUT OUTLIER                   *   02990029
030000*              13 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   03000029
030100*                   PENALTY WITH OUTLIER                      *   03010029
030200*              14 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   03020029
030300*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   03030029
030400*                   WITH PENALTY WITHOUT OUTLIER              *   03040029
030500*              15 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   03050029
030600*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   03060029
030700*                   WITH PENALTY WITH OUTLIER                 *   03070029
030800*              16 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03080029
030900*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03090029
031000*                   RATE -- WITH PENALTY WITHOUT OUTLIER      *   03100029
031100*              17 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03110029
031200*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03120029
031300*                   RATE -- WITH PENALTY WITH OUTLIER         *   03130029
031400*                                                             *   03140029
031500*      ****  PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   03150029
031600*              50 = PROVIDER SPECIFIC RATE NOT NUMERIC        *   03160029
031700*              51 = PROVIDER RECORD TERMINATED                *   03170029
031800*              52 = INVALID WAGE INDEX                        *   03180029
031900*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   03190029
032000*              54 = CMG ON CLAIM NOT FOUND IN TABLE           *   03200029
032100*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   03210029
032200*                                      OR                     *   03220029
032300*                   DISCHARGE DATE < MSA EFF START DATE       *   03230029
032400*                   FOR PPS                                   *   03240029
032500*              56 = INVALID LENGTH OF STAY                    *   03250029
032600*              57 = PROVIDER SPECIFIC RATE ZERO WHEN BLENDED  *   03260029
032700*                   PAYMENT REQUESTED                         *   03270029
032800*              58 = TOTAL COVERED CHARGES NOT NUMERIC         *   03280029
032900*              59 = PROVIDER SPECIFIC RECORD NOT FOUND        *   03290029
033000*              60 = MSA WAGE INDEX RECORD NOT FOUND           *   03300029
033100*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *   03310029
033200*                   OR BILL-LTR-DAYS > 60                     *   03320029
033300*              62 = INVALID NUMBER OF COVERED DAYS            *   03330029
033400*              65 = OPERATING COST-TO-CHARGE RATIO NOT NUMERIC*   03340029
033500*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *   03350029
033600*                   OR COST OUTLIER THRESHOLD CALCULATION     *   03360029
033700*              72 = INVALID BLEND INDICATOR (NOT 3 OR 4)      *   03370029
033800*              73 = DISCHARGED BEFORE PROVIDER FY BEGIN       *   03380029
033900*              74 = PROVIDER FY BEGIN DATE NOT IN 2002        *   03390029
034000***************************************************************   03400029
034100 01  PPS-DATA-ALL.                                                03410029
034200     05  PPS-RTC                      PIC 9(02).                  03420029
034300     05  PPS-DATA.                                                03430029
034400         10  PPS-MSA                  PIC X(04).                  03440029
034500         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).            03450029
034600         10  PPS-AVG-LOS              PIC 9(02).                  03460029
034700         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).            03470029
034800         10  PPS-TOTAL-PAY-AMT        PIC 9(07)V9(02).            03480029
034900         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).            03490029
035000         10  PPS-FAC-SPEC-PAY-AMT     PIC 9(07)V9(02).            03500029
035100         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).            03510029
035200         10  PPS-LIP-PAY-AMT          PIC 9(07)V9(02).            03520029
035300         10  PPS-LIP-PCT              PIC 9(01)V9(04).            03530029
035400         10  PPS-LOS                  PIC 9(03).                  03540029
035500         10  PPS-REG-DAYS-USED        PIC 9(03).                  03550029
035600         10  PPS-LTR-DAYS-USED        PIC 9(03).                  03560029
035700         10  PPS-TRANSFER-PCT         PIC 9(01)V9(04).            03570029
035800         10  PPS-FAC-SPEC-RT-PREBLEND PIC 9(05)V9(02).            03580029
035900         10  PPS-STANDARD-PAY-AMT     PIC 9(07)V9(02).            03590029
036000         10  PPS-FAC-COSTS            PIC 9(07)V9(02).            03600029
036100         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).            03610029
036200         10  PPS-CHG-OUTLIER-THRESHOLD PIC 9(07)V9(02).           03620029
036300         10  PPS-TOTAL-PENALTY-AMT    PIC 9(07)V9(02).            03630029
036400         10  PPS-FED-PENALTY-AMT      PIC 9(07)V9(02).            03640029
036500         10  PPS-LIP-PENALTY-AMT      PIC 9(07)V9(02).            03650029
036600         10  PPS-OUT-PENALTY-AMT      PIC 9(07)V9(02).            03660029
036700         10  PPS-SUBM-CMG-CODE        PIC X(05).                  03670029
036800         10  PPS-CMG-CODE-REDEF REDEFINES PPS-SUBM-CMG-CODE.      03680029
036900            15  PPS-CMG-ALPHA         PIC X(01).                  03690029
037000            15  PPS-CMG-NUMERIC.                                  03700029
037100               20  PPS-CMG-RIC        PIC X(02).                  03710029
037200               20  FILLER             PIC X(02).                  03720029
037300         10  PPS-PRICED-CMG-CODE      PIC X(05).                  03730029
037400         10  PPS-CALC-VERS-CD         PIC X(05).                  03740029
037500         10  PPS-CBSA                 PIC X(05).                  03750029
037600         10  FILLER                   PIC X(08).                  03760029
037700     05  PPS-OTHER-DATA.                                          03770029
037800         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).            03780029
037900         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).            03790029
038000         10  PPS-NAT-THRESHOLD-ADJ    PIC 9(05)V9(02).            03800029
038100         10  PPS-BDGT-NEUT-CONV-AMT   PIC 9(05)V9(02).            03810029
038200         10  PPS-FED-RATE-PCT         PIC 9(01)V9(04).            03820029
038300         10  PPS-FAC-RATE-PCT         PIC 9(01)V9(04).            03830029
038400         10  PPS-RURAL-ADJUSTMENT     PIC 9(01)V9(04).            03840029
038500         10  PPS-TEACH-PAY-AMT        PIC 9(07)V9(02).            03850029
038600         10  PPS-TEACH-PENALTY-AMT    PIC 9(07)V9(02).            03860029
038700         10  FILLER                   PIC X(02).                  03870029
038800     05  PPS-PC-DATA.                                             03880029
038900         10  PPS-COT-IND              PIC X(01).                  03890029
039000         10  FILLER                   PIC X(20).                  03900029
039100                                                                  03910029
039200******************************************************************03920029
039300*            THESE ARE THE VERSIONS OF THE IRDRV___               03930029
039400*           PROGRAMS THAT WILL BE PASSED BACK----                 03940029
039500*          ASSOCIATED WITH THE BILL BEING PROCESSED               03950029
039600******************************************************************03960029
039700 01  PRICER-OPT-VERS-SW.                                          03970029
039800     05  PRICER-OPTION-SW          PIC X(01).                     03980029
039900         88  ALL-TABLES-PASSED          VALUE 'A'.                03990029
040000         88  PROV-RECORD-PASSED         VALUE 'P'.                04000029
040100     05  PPS-VERSIONS.                                            04010029
040200         10  PPDRV-VERSION         PIC X(05).                     04020029
040300                                                                  04030029
040400**************************************************************    04040029
040500*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BY        *    04050029
040600*      THE IRCAL___ PROGRAM                                  *    04060029
040700**************************************************************    04070029
040800 01  PROV-NEW-HOLD.                                               04080029
040900     02  PROV-NEWREC-HOLD1.                                       04090029
041000         05  P-NEW-NPI10.                                         04100029
041100             10  P-NEW-NPI8             PIC X(08).                04110029
041200             10  P-NEW-NPI-FILLER       PIC X(02).                04120029
041300         05  P-NEW-PROVIDER-NO.                                   04130029
041400             10  P-NEW-STATE            PIC 9(02).                04140029
041500             10  FILLER                 PIC X(04).                04150029
041600         05  P-NEW-DATE-DATA.                                     04160029
041700             10  P-NEW-EFF-DATE.                                  04170029
041800                 15  P-NEW-EFF-DT-CC    PIC 9(02).                04180029
041900                 15  P-NEW-EFF-DT-YY    PIC 9(02).                04190029
042000                 15  P-NEW-EFF-DT-MM    PIC 9(02).                04200029
042100                 15  P-NEW-EFF-DT-DD    PIC 9(02).                04210029
042200             10  P-NEW-FY-BEGIN-DATE.                             04220029
042300                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                04230029
042400                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                04240029
042500                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                04250029
042600                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                04260029
042700             10  P-NEW-REPORT-DATE.                               04270029
042800                 15  P-NEW-REPORT-DT-CC PIC 9(02).                04280029
042900                 15  P-NEW-REPORT-DT-YY PIC 9(02).                04290029
043000                 15  P-NEW-REPORT-DT-MM PIC 9(02).                04300029
043100                 15  P-NEW-REPORT-DT-DD PIC 9(02).                04310029
043200             10  P-NEW-TERMINATION-DATE.                          04320029
043300                 15  P-NEW-TERM-DT-CC   PIC 9(02).                04330029
043400                 15  P-NEW-TERM-DT-YY   PIC 9(02).                04340029
043500                 15  P-NEW-TERM-DT-MM   PIC 9(02).                04350029
043600                 15  P-NEW-TERM-DT-DD   PIC 9(02).                04360029
043700         05  P-NEW-WAIVER-CODE          PIC X(01).                04370029
043800             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              04380029
043900         05  P-NEW-INTER-NO             PIC 9(05).                04390029
044000         05  P-NEW-PROVIDER-TYPE        PIC X(02).                04400029
044100         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                04410029
044200         05  P-NEW-CURRENT-DIV   REDEFINES                        04420029
044300                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         04430029
044400         05  P-NEW-MSA-DATA.                                      04440029
044500             10  P-NEW-CHG-CODE-INDEX       PIC X.                04450029
044600             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 04460029
044700             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   04470029
044800                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       04480029
044900             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 04490029
045000             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 04500029
045100             10  P-NEW-STAND-AMT-LOC-MSA9                         04510029
045200                 REDEFINES P-NEW-STAND-AMT-LOC-MSA.               04520029
045300                 15  P-NEW-RURAL-1ST.                             04530029
045400                     20  P-NEW-STAND-RURAL  PIC XX.               04540029
045500                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    04550029
045600                 15  P-NEW-RURAL-2ND        PIC XX.               04560029
045700         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    04570029
045800         05  P-NEW-LUGAR                    PIC X.                04580029
045900         05  P-NEW-TEMP-RELIEF-IND          PIC X.                04590029
046000         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                04600029
046100         05  FILLER                         PIC X(05).            04610029
046200     02  PROV-NEWREC-HOLD2.                                       04620029
046300         05  P-NEW-VARIABLES.                                     04630029
046400             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        04640029
046500             10  P-NEW-COLA              PIC  9(01)V9(03).        04650029
046600             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        04660029
046700             10  P-NEW-BED-SIZE          PIC  9(05).              04670029
046800             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        04680029
046900             10  P-NEW-CMI               PIC  9(01)V9(04).        04690029
047000             10  P-NEW-SSI-RATIO         PIC  V9(04).             04700029
047100             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             04710029
047200             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              04720029
047300             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        04730029
047400             10  P-NEW-DSH-PERCENT       PIC  V9(04).             04740029
047500             10  P-NEW-FYE-DATE          PIC  X(08).              04750029
047600         05  P-NEW-CBSA-DATA.                                     04760029
047700             10  P-NEW-CBSA-SPEC-PAY-IND   PIC X.                 04770029
047800             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.                 04780029
047900             10  P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.  04790029
048000             10  P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.  04800029
048100             10  P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.  04810029
048200             10  P-NEW-CBSA-STAND-AMT-LOC9                        04820029
048300                 REDEFINES P-NEW-CBSA-STAND-AMT-LOC.              04830029
048400                 15  P-NEW-CBSA-RURAL-1ST.                        04840029
048500                     20  P-NEW-CBSA-STAND-RURAL PIC 999.          04850029
048600                 15  P-NEW-CBSA-RURAL-2ND       PIC 99.           04860029
048700             10  P-NEW-CBSA-SPEC-WAGE-INDEX     PIC 9(02)V9(04).  04870029
048800     02  PROV-NEWREC-HOLD3.                                       04880029
048900         05  P-NEW-PASS-AMT-DATA.                                 04890029
049000             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          04900029
049100             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          04910029
049200             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          04920029
049300             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          04930029
049400         05  P-NEW-CAPI-DATA.                                     04940029
049500             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 04950029
049600             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          04960029
049700             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          04970029
049800             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        04980029
049900             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             04990029
050000             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 05000029
050100             15  P-NEW-CAPI-IME            PIC 9V9999.            05010029
050200             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          05020029
050300         05  FILLER                        PIC X(22).             05030029
050400******************************************************************05040029
050500*                   THIS IS THE WAGE-INDEX                        05050029
050600*          ASSOCIATED WITH THE BILL BEING PROCESSED               05060029
050700******************************************************************05070029
050800 01  WAGE-NEW-INDEX-RECORD-CBSA.                                  05080029
050900     05  W-NEW-CBSA                    PIC X(5).                  05090029
051000        88  VALID-RURAL-CBSA    VALUE                             05100029
051100              '50001' '50007' '50016' '50020' '50031'             05110029
051200              '50036' '50054' '50060' '50067' '50087'             05120029
051300              '50089' '50091' '50092' '50100' '50104'             05130029
051400              '50108' '50114' '50121' '50125' '50140'             05140029
051500              '50145' '50152' '50164' '50170' '50192'             05150029
051600              '50199' '50206' '50210' '50214' '50218'             05160029
051700              '50222' '50225' '50226' '50231' '50234'             05170029
051800              '50237' '50243' '50248' '50250' '50255'             05180029
051900              '50256' '50257' '50260' '50261' '50262'             05190029
052000              '50263' '50266' '50268' '50272' '50275'             05200029
052100              '50281' '50286' '50293' '50313' '50314'             05210029
052200              '50316' '50325' '50326' '50327' '50329'             05220029
052300              '50336' '50344' '50352'.                            05230029
052400     05  W-NEW-EFF-DATE-C              PIC X(8).                  05240029
052500     05  W-NEW-WAGE-INDEX-C            PIC S9(02)V9(04).          05250029
052600                                                                  05260029
052700 PROCEDURE DIVISION  USING BILL-NEW-DATA                          05270029
052800                           PPS-DATA-ALL                           05280029
052900                           PRICER-OPT-VERS-SW                     05290029
053000                           PROV-NEW-HOLD                          05300029
053100                           WAGE-NEW-INDEX-RECORD-CBSA.            05310029
053200***************************************************************   05320029
053300*    PROCESSING:                                              *   05330029
053400*        A. WILL PROCESS CLAIMS BASED ON DISCHARGE DATE       *   05340029
053500*        B. INITIALIZE IRCAL HOLD VARIABLES.                  *   05350029
053600*        C. EDIT THE DATA PASSED FROM THE CLAIM BEFORE        *   05360029
053700*           ATTEMPTING TO CALCULATE PPS. IF THIS CLAIM        *   05370029
053800*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   05380029
053900*           GOBACK.                                           *   05390029
054000*        D. ASSEMBLE PRICING COMPONENTS.                      *   05400029
054100*        E. CALCULATE THE PRICE.                              *   05410029
054200*        F. CALCULATE OUTLIERS IF APPLICABLE.                 *   05420029
054300***************************************************************   05430029
054420                                                                  05442033
054500 0000-MAINLINE-CONTROL.                                           05450029
054600                                                                  05460029
054700     PERFORM 0100-INITIAL-ROUTINE                                 05470029
054800        THRU 0100-EXIT.                                           05480029
054900                                                                  05490029
055000     PERFORM 1000-EDIT-THE-BILL-INFO                              05500029
055100        THRU 1000-EXIT.                                           05510029
055200                                                                  05520029
055300     IF PPS-RTC = 00                                              05530029
055400        PERFORM 1700-EDIT-CMG-CODE                                05540029
055500           THRU 1700-EXIT.                                        05550029
055600                                                                  05560029
055700     IF PPS-RTC = 00                                              05570029
055800        PERFORM 2000-ASSEMBLE-PPS-VARIABLES                       05580029
055900           THRU 2000-EXIT.                                        05590029
056000                                                                  05600029
056100     IF PPS-RTC = 00                                              05610029
056200        PERFORM 3000-CALC-PAYMENT                                 05620029
056300           THRU 3000-EXIT                                         05630029
056400        PERFORM 3500-CONTINUE-CALC                                05640029
056500           THRU 3500-EXIT                                         05650029
056600        PERFORM 4000-CALC-OUTLIER                                 05660029
056700           THRU 4000-EXIT                                         05670029
056800        PERFORM 5000-FINAL-PAYMENTS                               05680029
056900           THRU 5000-EXIT.                                        05690029
057000                                                                  05700029
057100     PERFORM 9000-MOVE-RESULTS                                    05710029
057200        THRU 9000-EXIT.                                           05720029
057300                                                                  05730029
057400     GOBACK.                                                      05740029
057500                                                                  05750029
057600 0100-INITIAL-ROUTINE.                                            05760029
057700                                                                  05770029
057800     MOVE ZEROS TO PPS-RTC.                                       05780029
057900     INITIALIZE PPS-DATA.                                         05790029
058000     INITIALIZE PPS-OTHER-DATA.                                   05800029
058100     INITIALIZE HOLD-PPS-COMPONENTS.                              05810029
058200                                                                  05820029
058300     MOVE .75865 TO PPS-NAT-LABOR-PCT.                            05830029
058400     MOVE .24135 TO PPS-NAT-NONLABOR-PCT.                         05840029
058500     MOVE 5129   TO PPS-NAT-THRESHOLD-ADJ.                        05850029
058600     MOVE 12762  TO PPS-BDGT-NEUT-CONV-AMT.                       05860029
058700                                                                  05870029
058800 0100-EXIT.                                                       05880029
058900      EXIT.                                                       05890029
059000                                                                  05900029
059100 1000-EDIT-THE-BILL-INFO.                                         05910029
059200***************************************************************   05920029
059300*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *   05930029
059400*    AND DO NOT ATTEMPT TO PRICE.                             *   05940029
059500***************************************************************   05950029
059600                                                                  05960029
059700     MOVE B-CMG-CODE TO PPS-SUBM-CMG-CODE.                        05970029
059800                                                                  05980029
059900     IF (B-LOS NUMERIC) AND (B-LOS > 0)                           05990029
060000        MOVE B-LOS TO H-LOS                                       06000029
060100     ELSE                                                         06010029
060200        IF B-LOS = 0                                              06020029
060300           MOVE 1 TO H-LOS                                        06030029
060400        ELSE                                                      06040029
060500           MOVE 56 TO PPS-RTC.                                    06050029
060600                                                                  06060029
060700     MOVE P-NEW-FY-BEGIN-DATE TO H-FY-BEGIN-DATE.                 06070029
060800     IF H-FY-BEGIN-DATE (5:2) < 11                                06080029
060900       COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 10200          06090029
061000     ELSE                                                         06100029
061100       COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 19000.         06110029
061200     MOVE B-DISCHARGE-DATE TO H-DISCHARGE-DATE.                   06120029
061300     IF (H-DISCHARGE-DATE > H-FY-BEGIN-DATE)                      06130029
061400        OR (P-NEW-FY-BEGIN-DATE > 20020930 AND                    06140029
061500            P-NEW-FY-BEGIN-DATE < 20030101)                       06150029
061600        MOVE '4' TO P-NEW-FED-PPS-BLEND-IND.                      06160029
061700     IF P-NEW-FY-BEGIN-DATE > 20011231                            06170029
061800        IF (P-NEW-FY-BEGIN-DATE <= B-DISCHARGE-DATE)              06180029
061900           IF P-NEW-FED-PPS-BLEND-IND = '4'                       06190029
062000              MOVE 1.0000 TO PPS-FED-RATE-PCT                     06200029
062100              MOVE 0.0000 TO PPS-FAC-RATE-PCT                     06210029
062200           ELSE                                                   06220029
062300             IF P-NEW-FED-PPS-BLEND-IND = '3'                     06230029
062400                MOVE .6667 TO PPS-FED-RATE-PCT                    06240029
062500                MOVE .3333 TO PPS-FAC-RATE-PCT                    06250029
062600             ELSE                                                 06260029
062700               MOVE 72 TO PPS-RTC                                 06270029
062800        ELSE                                                      06280029
062900           MOVE 73 TO PPS-RTC                                     06290029
063000     ELSE                                                         06300029
063100        MOVE 74 TO PPS-RTC.                                       06310029
063200                                                                  06320029
063300     IF PPS-RTC = 00                                              06330029
063400       IF P-NEW-WAIVER-STATE                                      06340029
063500          MOVE 53 TO PPS-RTC.                                     06350029
063600                                                                  06360029
063700     IF PPS-RTC = 00                                              06370029
063800         IF ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR               06380029
063900            (B-DISCHARGE-DATE < W-NEW-EFF-DATE-C))                06390029
064000            MOVE 55 TO PPS-RTC.                                   06400029
064100                                                                  06410029
064200     IF PPS-RTC = 00                                              06420029
064300         IF P-NEW-TERMINATION-DATE > 00000000                     06430029
064400            IF B-DISCHARGE-DATE >= P-NEW-TERMINATION-DATE         06440029
064500               MOVE 51 TO PPS-RTC.                                06450029
064600                                                                  06460029
064700     IF PPS-RTC = 00                                              06470029
064800         IF B-COV-CHARGES NOT NUMERIC                             06480029
064900            MOVE 58 TO PPS-RTC.                                   06490029
065000                                                                  06500029
065100     IF PPS-RTC = 00                                              06510029
065200        IF B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60              06520029
065300           MOVE 61 TO PPS-RTC                                     06530029
065400        ELSE                                                      06540029
065500           MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.                  06550029
065600                                                                  06560029
065700     IF PPS-RTC = 00                                              06570029
065800        IF B-COV-DAYS NOT NUMERIC                                 06580029
065900             MOVE 62 TO PPS-RTC                                   06590029
066000        ELSE                                                      06600029
066100          IF B-COV-DAYS = 0 AND H-LOS > 0                         06610029
066200             MOVE 62 TO PPS-RTC.                                  06620029
066300                                                                  06630029
066400     IF PPS-RTC = 00                                              06640029
066500        IF B-LTR-DAYS  > B-COV-DAYS                               06650029
066600           MOVE 62 TO PPS-RTC                                     06660029
066700        ELSE                                                      06670029
066800           COMPUTE PPS-REG-DAYS-USED = B-COV-DAYS - B-LTR-DAYS.   06680029
066900                                                                  06690029
067000     IF PPS-RTC = 00                                              06700029
067100        IF PPS-REG-DAYS-USED > 0                                  06710029
067200           IF PPS-REG-DAYS-USED > H-LOS                           06720029
067300              MOVE H-LOS TO PPS-REG-DAYS-USED                     06730029
067400           ELSE                                                   06740029
067500              NEXT SENTENCE                                       06750029
067600        ELSE                                                      06760029
067700           IF B-LTR-DAYS > H-LOS                                  06770029
067800              MOVE H-LOS TO PPS-LTR-DAYS-USED                     06780029
067900           ELSE                                                   06790029
068000              MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.               06800029
068100                                                                  06810029
068200 1000-EXIT.                                                       06820029
068300      EXIT.                                                       06830029
068400                                                                  06840029
068500***************************************************************   06850029
068600*    FINDS THE CMG CODE IN THE TABLE                          *   06860029
068700***************************************************************   06870029
068800 1700-EDIT-CMG-CODE.                                              06880029
068900                                                                  06890029
069000     IF PPS-CMG-NUMERIC = '9999'                                  06900031
069010        NEXT SENTENCE                                             06901031
069011     ELSE                                                         06901131
069020        IF PPS-CMG-NUMERIC < '2103'                               06902031
069100           NEXT SENTENCE                                          06910031
069200        ELSE                                                      06920031
069300           MOVE 54 TO PPS-RTC.                                    06930031
069400                                                                  06940029
069500     IF PPS-RTC = 00                                              06950029
069600        SEARCH ALL CMG-DATA                                       06960029
069700           AT END                                                 06970029
069800             MOVE 54 TO PPS-RTC                                   06980029
069900        WHEN CMG-NUM (DX6) = PPS-CMG-NUMERIC                      06990029
070000             PERFORM 1750-FIND-VALUE                              07000029
070100                THRU 1750-EXIT                                    07010029
070200        END-SEARCH.                                               07020029
070300                                                                  07030029
070400 1700-EXIT.                                                       07040029
070500      EXIT.                                                       07050029
070600                                                                  07060029
070700***************************************************************   07070029
070800*    FINDS THE VALUE IN THE CMG CODE IN THE TABLE             *   07080029
070900***************************************************************   07090029
071000 1750-FIND-VALUE.                                                 07100029
071100                                                                  07110029
071200      IF PPS-CMG-ALPHA = 'A'                                      07120029
071300         MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                 07130029
071400         MOVE A-LOS-TABLE (DX6) TO PPS-AVG-LOS                    07140029
071500      ELSE                                                        07150029
071600         IF PPS-CMG-ALPHA = 'B'                                   07160029
071700            MOVE B-REL-WGT (DX6) TO PPS-RELATIVE-WGT              07170029
071800            MOVE B-LOS-TABLE (DX6) TO PPS-AVG-LOS                 07180029
071900         ELSE                                                     07190029
072000            IF PPS-CMG-ALPHA = 'C'                                07200029
072100               MOVE C-REL-WGT (DX6) TO PPS-RELATIVE-WGT           07210029
072200               MOVE C-LOS-TABLE (DX6) TO PPS-AVG-LOS              07220029
072300            ELSE                                                  07230029
072400               IF PPS-CMG-ALPHA = 'D'                             07240029
072500                  MOVE D-REL-WGT (DX6) TO PPS-RELATIVE-WGT        07250029
072600                  MOVE D-LOS-TABLE (DX6) TO PPS-AVG-LOS           07260029
072700               ELSE                                               07270029
072800                  MOVE 54 TO PPS-RTC.                             07280029
072900                                                                  07290029
073000 1750-EXIT.                                                       07300029
073100      EXIT.                                                       07310029
073200                                                                  07320029
073300***************************************************************   07330029
073400*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *   07340029
073500*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   07350029
073600*    OF THAT VARIABLE.                                        *   07360029
073700***************************************************************   07370029
073800***  GET THE PROVIDER SPECIFIC VARIABLE AND WAGE INDEX            07380029
073900***************************************************************   07390029
074000 2000-ASSEMBLE-PPS-VARIABLES.                                     07400029
074100                                                                  07410029
074200     IF P-NEW-FAC-SPEC-RATE NUMERIC                               07420029
074300        MOVE P-NEW-FAC-SPEC-RATE TO PPS-FAC-SPEC-RT-PREBLEND      07430029
074400     ELSE                                                         07440029
074500        MOVE 50 TO PPS-RTC                                        07450029
074600        GO TO 2000-EXIT.                                          07460029
074700                                                                  07470029
074800     IF P-NEW-FED-PPS-BLEND-IND = '3'                             07480029
074900        IF PPS-FAC-SPEC-RT-PREBLEND = 0                           07490029
075000          MOVE 57 TO PPS-RTC                                      07500029
075100          GO TO 2000-EXIT.                                        07510029
075200                                                                  07520029
075300     IF W-NEW-WAGE-INDEX-C NUMERIC                                07530029
075400            AND W-NEW-WAGE-INDEX-C > 0                            07540029
075500        MOVE W-NEW-WAGE-INDEX-C TO PPS-WAGE-INDEX                 07550029
075600     ELSE                                                         07560029
075700        MOVE 52 TO PPS-RTC                                        07570029
075800        GO TO 2000-EXIT.                                          07580029
075900                                                                  07590029
076000     IF P-NEW-OPER-CSTCHG-RATIO NOT NUMERIC                       07600029
076100        MOVE 65 TO PPS-RTC.                                       07610029
076200                                                                  07620029
076300 2000-EXIT.                                                       07630029
076400      EXIT.                                                       07640029
076500                                                                  07650029
076600***************************************************************   07660029
076700*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *   07670029
076800*        CALCULATE THE FEDERAL PORTION.                       *   07680029
076900*        CALCULATE THE HOSPITAL PORTION.                      *   07690029
077000*        CALCULATE THE COST-OUTLIER PORTION.                  *   07700029
077100*        CALCULATE THE LIP ADJUSTMENT PERCENTAGE.             *   07710029
077200***************************************************************   07720029
077300 3000-CALC-PAYMENT.                                               07730029
077400                                                                  07740029
077500***  LIP PERCENTAGE CALCULATION *******************************   07750029
077600                                                                  07760029
077700      COMPUTE H-WK-DSH = (P-NEW-SSI-RATIO                         07770029
077800                           + P-NEW-MEDICAID-RATIO).               07780029
077900                                                                  07790029
078000      COMPUTE PPS-LIP-PCT ROUNDED =                               07800029
078100            ((1 + H-WK-DSH) ** .6229) - 1.                        07810029
078200                                                                  07820029
078300      COMPUTE H-TEACH-PCT ROUNDED =                               07830029
078400            ((1 + P-NEW-CAPI-IME) ** .9012) - 1.                  07840029
078500                                                                  07850029
078600***************************************************************   07860029
078700                                                                  07870029
078800     MOVE 1.0000 TO PPS-TRANSFER-PCT.                             07880029
078900                                                                  07890029
079000     IF B-PATIENT-STATUS =                                        07900029
079100         ('02' OR '03' OR '61' OR '62' OR '63' OR '64')           07910029
079200        IF H-LOS < PPS-AVG-LOS                                    07920029
079300           COMPUTE PPS-TRANSFER-PCT =                             07930029
079400               ((H-LOS + .5) / PPS-AVG-LOS)                       07940029
079500           MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE          07950029
079600           GO TO 3000-EXIT.                                       07960029
079700                                                                  07970029
079800     IF H-LOS > 3                                                 07980029
079900        NEXT SENTENCE                                             07990029
080000     ELSE                                                         08000029
080100        MOVE 'A5001' TO PPS-PRICED-CMG-CODE                       08010029
080200        SET DX6 TO 88                                             08020029
080300        MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                  08030029
080400        GO TO 3000-EXIT.                                          08040029
080500                                                                  08050029
080600     IF B-PATIENT-STATUS = '20'                                   08060029
080700        NEXT SENTENCE                                             08070029
080800     ELSE                                                         08080029
080900        MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE             08090029
081000        GO TO 3000-EXIT.                                          08100029
081100                                                                  08110029
081200     IF PPS-CMG-RIC = ('07' OR '08' OR '09')                      08120029
081300        IF H-LOS < 14                                             08130029
081400           MOVE 'A5101' TO PPS-PRICED-CMG-CODE                    08140029
081500           SET DX6 TO 89                                          08150029
081600           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08160029
081700        ELSE                                                      08170029
081800           MOVE 'A5102' TO PPS-PRICED-CMG-CODE                    08180029
081900           SET DX6 TO 90                                          08190029
082000           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08200029
082100     ELSE                                                         08210029
082200        IF H-LOS < 16                                             08220029
082300           MOVE 'A5103' TO PPS-PRICED-CMG-CODE                    08230029
082400           SET DX6 TO 91                                          08240029
082500           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08250029
082600        ELSE                                                      08260029
082700           MOVE 'A5104' TO PPS-PRICED-CMG-CODE                    08270029
082800           SET DX6 TO 92                                          08280029
082900           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT.              08290029
083000                                                                  08300029
083100 3000-EXIT.                                                       08310029
083200      EXIT.                                                       08320029
083300                                                                  08330029
083400 3500-CONTINUE-CALC.                                              08340029
083500                                                                  08350029
083600     COMPUTE PPS-STANDARD-PAY-AMT =                               08360029
083700            (PPS-TRANSFER-PCT * PPS-RELATIVE-WGT                  08370029
083800                      * PPS-BDGT-NEUT-CONV-AMT).                  08380029
083900                                                                  08390029
084000     IF W-NEW-CBSA (1:3) = '   ' OR VALID-RURAL-CBSA              08400029
084100        MOVE 1.2130 TO PPS-RURAL-ADJUSTMENT                       08410029
084200     ELSE                                                         08420029
084300        MOVE 1.0000 TO PPS-RURAL-ADJUSTMENT.                      08430029
084400                                                                  08440029
084500     IF P-NEW-TEMP-RELIEF-IND = 'Y'                               08450029
084600        MOVE 1.1276 TO PPS-RURAL-ADJUSTMENT.                      08460029
084700                                                                  08470029
084800     COMPUTE H-LABOR-PORTION =                                    08480029
084900        (PPS-STANDARD-PAY-AMT * PPS-NAT-LABOR-PCT)                08490029
085000          * PPS-WAGE-INDEX.                                       08500029
085100                                                                  08510029
085200     COMPUTE H-NONLABOR-PORTION =                                 08520029
085300        (PPS-STANDARD-PAY-AMT * PPS-NAT-NONLABOR-PCT).            08530029
085400                                                                  08540029
085500     COMPUTE PPS-FED-PAY-AMT ROUNDED =                            08550029
085600        ((H-LABOR-PORTION + H-NONLABOR-PORTION) *                 08560029
085700         PPS-RURAL-ADJUSTMENT).                                   08570029
085800                                                                  08580029
085900     COMPUTE PPS-LIP-PAY-AMT ROUNDED =                            08590029
086000        (PPS-FED-PAY-AMT * PPS-LIP-PCT).                          08600029
086100                                                                  08610029
086200     COMPUTE PPS-TEACH-PAY-AMT ROUNDED =                          08620029
086300        (PPS-FED-PAY-AMT * H-TEACH-PCT).                          08630029
086400                                                                  08640029
086500 3500-EXIT.                                                       08650029
086600      EXIT.                                                       08660029
086700                                                                  08670029
086800 4000-CALC-OUTLIER.                                               08680029
086900                                                                  08690029
087000     COMPUTE PPS-FAC-COSTS ROUNDED =                              08700029
087100         (B-COV-CHARGES * P-NEW-OPER-CSTCHG-RATIO).               08710029
087200                                                                  08720029
087300     COMPUTE H-OUTLIER-LABOR-PORTION =                            08730029
087400        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-LABOR-PCT)               08740029
087500              * PPS-WAGE-INDEX.                                   08750029
087600                                                                  08760029
087700     COMPUTE H-OUTLIER-NONLABOR-PORTION =                         08770029
087800        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-NONLABOR-PCT).           08780029
087900                                                                  08790029
088000     COMPUTE H-FP-OUTLIER-THRESHOLD ROUNDED =                     08800029
088100        ((H-OUTLIER-LABOR-PORTION + H-OUTLIER-NONLABOR-PORTION) * 08810029
088200         PPS-RURAL-ADJUSTMENT * (PPS-LIP-PCT + H-TEACH-PCT + 1)). 08820029
088300                                                                  08830029
088400     COMPUTE H-OUTLIER-THRESHOLD ROUNDED =                        08840029
088500        (PPS-FED-PAY-AMT + H-FP-OUTLIER-THRESHOLD +               08850029
088600         PPS-LIP-PAY-AMT + PPS-TEACH-PAY-AMT).                    08860029
088700                                                                  08870029
088800     IF PPS-FAC-COSTS > H-OUTLIER-THRESHOLD                       08880029
088900        COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                     08890029
089000           ((PPS-FAC-COSTS - H-OUTLIER-THRESHOLD) * .8).          08900029
089100                                                                  08910029
089200     COMPUTE H-CHG-OUTLIER-THRESHOLD ROUNDED =                    08920029
089300         H-OUTLIER-THRESHOLD / P-NEW-OPER-CSTCHG-RATIO.           08930029
089400                                                                  08940029
089500                                                                  08950029
089600 4000-EXIT.                                                       08960029
089700      EXIT.                                                       08970029
089800                                                                  08980029
089900 5000-FINAL-PAYMENTS.                                             08990029
090000                                                                  09000029
090100     IF B-SPEC-PAY-IND = '1' OR '3'                               09010029
090200         MOVE ZEROES TO PPS-OUTLIER-PAY-AMT.                      09020029
090300                                                                  09030029
090400     IF PPS-FED-RATE-PCT = 1.0000                                 09040029
090500         MOVE 0 TO PPS-FAC-SPEC-PAY-AMT                           09050029
090600     ELSE                                                         09060029
090700         COMPUTE PPS-FED-PAY-AMT ROUNDED =                        09070029
090800           (PPS-FED-RATE-PCT * PPS-FED-PAY-AMT)                   09080029
090900         COMPUTE PPS-FAC-SPEC-PAY-AMT ROUNDED =                   09090029
091000           (PPS-FAC-RATE-PCT * PPS-FAC-SPEC-RT-PREBLEND)          09100029
091100         COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                    09110029
091200           (PPS-FED-RATE-PCT * PPS-OUTLIER-PAY-AMT)               09120029
091300         COMPUTE PPS-TEACH-PAY-AMT ROUNDED =                      09130029
091400           (PPS-FED-RATE-PCT * PPS-TEACH-PAY-AMT)                 09140029
091500         COMPUTE PPS-LIP-PAY-AMT ROUNDED =                        09150029
091600           (PPS-FED-RATE-PCT * PPS-LIP-PAY-AMT).                  09160029
091700                                                                  09170029
091800     IF B-SPEC-PAY-IND = '2' OR '3'                               09180029
091900        COMPUTE PPS-FED-PENALTY-AMT ROUNDED =                     09190029
092000           (PPS-FED-PAY-AMT * .25)                                09200029
092100        COMPUTE PPS-FED-PAY-AMT =                                 09210029
092200           (PPS-FED-PAY-AMT - PPS-FED-PENALTY-AMT)                09220029
092300        COMPUTE PPS-LIP-PENALTY-AMT ROUNDED =                     09230029
092400           (PPS-LIP-PAY-AMT * .25)                                09240029
092500        COMPUTE PPS-LIP-PAY-AMT =                                 09250029
092600           (PPS-LIP-PAY-AMT - PPS-LIP-PENALTY-AMT)                09260029
092700        COMPUTE PPS-OUT-PENALTY-AMT ROUNDED =                     09270029
092800           (PPS-OUTLIER-PAY-AMT * .25)                            09280029
092900        COMPUTE PPS-OUTLIER-PAY-AMT =                             09290029
093000           (PPS-OUTLIER-PAY-AMT - PPS-OUT-PENALTY-AMT)            09300029
093100        COMPUTE PPS-TEACH-PENALTY-AMT ROUNDED =                   09310029
093200           (PPS-TEACH-PAY-AMT * .25)                              09320029
093300        COMPUTE PPS-TEACH-PAY-AMT =                               09330029
093400           (PPS-TEACH-PAY-AMT - PPS-TEACH-PENALTY-AMT)            09340029
093500        COMPUTE PPS-TOTAL-PENALTY-AMT =                           09350029
093600           (PPS-FED-PENALTY-AMT + PPS-LIP-PENALTY-AMT             09360029
093700           + PPS-OUT-PENALTY-AMT + PPS-TEACH-PENALTY-AMT).        09370029
093800                                                                  09380029
093900     COMPUTE PPS-TOTAL-PAY-AMT ROUNDED =                          09390029
094000        (PPS-FED-PAY-AMT + PPS-FAC-SPEC-PAY-AMT                   09400029
094100         + PPS-OUTLIER-PAY-AMT + PPS-LIP-PAY-AMT +                09410029
094200         PPS-TEACH-PAY-AMT).                                      09420029
094300                                                                  09430029
094400     IF PPS-FED-RATE-PCT = 1.0000                                 09440029
094500        IF PPS-TRANSFER-PCT = 1.0000                              09450029
094600           IF PPS-OUTLIER-PAY-AMT > 0.0                           09460029
094700              MOVE 01 TO PPS-RTC                                  09470029
094800           ELSE                                                   09480029
094900              MOVE 00 TO PPS-RTC                                  09490029
095000        ELSE                                                      09500029
095100           IF PPS-OUTLIER-PAY-AMT > 0.0                           09510029
095200              MOVE 03 TO PPS-RTC                                  09520029
095300           ELSE                                                   09530029
095400              MOVE 02 TO PPS-RTC                                  09540029
095500     ELSE                                                         09550029
095600        IF PPS-TRANSFER-PCT = 1.0000                              09560029
095700           IF PPS-OUTLIER-PAY-AMT > 0.0                           09570029
095800              MOVE 05 TO PPS-RTC                                  09580029
095900           ELSE                                                   09590029
096000              MOVE 04 TO PPS-RTC                                  09600029
096100        ELSE                                                      09610029
096200           IF PPS-OUTLIER-PAY-AMT > 0.0                           09620029
096300              MOVE 07 TO PPS-RTC                                  09630029
096400           ELSE                                                   09640029
096500              MOVE 06 TO PPS-RTC.                                 09650029
096600                                                                  09660029
096700     IF B-SPEC-PAY-IND = '2' OR '3'                               09670029
096800        COMPUTE PPS-RTC = PPS-RTC + 10.                           09680029
096900     IF PPS-RTC = (01 OR 03 OR 05 OR 07                           09690029
097000                OR 11 OR 13 OR 15 OR 17)                          09700029
097100        IF ((PPS-REG-DAYS-USED + PPS-LTR-DAYS-USED) < H-LOS)      09710029
097200           OR PPS-COT-IND = 'Y'                                   09720029
097300            MOVE 67 TO PPS-RTC.                                   09730029
097400                                                                  09740029
097500 5000-EXIT.                                                       09750029
097600      EXIT.                                                       09760029
097700                                                                  09770029
097800 9000-MOVE-RESULTS.                                               09780029
097900                                                                  09790029
098000     IF PPS-RTC < 50                                              09800029
098100      MOVE H-LOS                   TO  PPS-LOS                    09810029
098200      MOVE H-OUTLIER-THRESHOLD     TO  PPS-OUTLIER-THRESHOLD      09820029
098300      MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD   09830029
098400      MOVE W-NEW-CBSA              TO  PPS-CBSA                   09840029
098500      MOVE 'V06.4'                 TO  PPS-CALC-VERS-CD           09850029
098600     ELSE                                                         09860029
098700       INITIALIZE PPS-DATA                                        09870029
098800       INITIALIZE PPS-OTHER-DATA                                  09880029
098900       MOVE 'V06.4'                TO  PPS-CALC-VERS-CD.          09890029
099000                                                                  09900029
099100     IF PPS-RTC = 67                                              09910029
099200       MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD. 09920029
099300                                                                  09930029
099400 9000-EXIT.                                                       09940029
099500      EXIT.                                                       09950029
099600                                                                  09960029
099700******        L A S T   S O U R C E   S T A T E M E N T   *****   09970029
