000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.           IRCAL041.                                  00020001
000300*AUTHOR.            ED FRANEY.                                    00030000
000400*REMARKS.                CMS.                                     00040000
000500*       EFFECTIVE OCT 1 2003                                      00050000
000600 DATE-COMPILED.                                                   00060000
000700 ENVIRONMENT DIVISION.                                            00070000
000800 CONFIGURATION SECTION.                                           00080000
000900 SOURCE-COMPUTER.            IBM-370.                             00090000
001000 OBJECT-COMPUTER.            IBM-370.                             00100000
001100 INPUT-OUTPUT  SECTION.                                           00110000
001200 FILE-CONTROL.                                                    00120000
001300                                                                  00130000
001400 DATA DIVISION.                                                   00140000
001500 FILE SECTION.                                                    00150000
001600                                                                  00160000
001700 WORKING-STORAGE SECTION.                                         00170000
001800 01  W-STORAGE-REF                  PIC X(46)  VALUE              00180000
001900     'IRCAL041      - W O R K I N G   S T O R A G E'.             00190001
002000 01  CAL-VERSION                    PIC X(05)  VALUE 'C04.1'.     00200001
002100                                                                  00210000
002200***************************************************************   00220000
002300*    LAYUP TABLE AREA FOR FY2002 CMGS                         *   00230000
002400*    EFFECTIVE DATE OF JANUARY 1, 2002                        *   00240000
002500***************************************************************   00250000
002600 01  CMG-TABLE.                                                   00260000
002700     05  CMG-TABLE-DATA.                                          00270000
002800       10  FILLER                  PIC X(32) VALUE                00280000
002900         '01010477804279040780385910090608'.                      00290000
003000       10  FILLER                  PIC X(32) VALUE                00300000
003100         '01020650605827055530525511121010'.                      00310000
003200       10  FILLER                  PIC X(32) VALUE                00320000
003300         '01030829607430070800670014121212'.                      00330000
003400       10  FILLER                  PIC X(32) VALUE                00340000
003500         '01040900708067076870727517131213'.                      00350000
003600       10  FILLER                  PIC X(32) VALUE                00360000
003700         '01051133910155096770915816171515'.                      00370000
003800       10  FILLER                  PIC X(32) VALUE                00380000
003900         '01061395112494119051126718181818'.                      00390000
004000       10  FILLER                  PIC X(32) VALUE                00400000
004100         '01071615914472137901305017202121'.                      00410000
004200       10  FILLER                  PIC X(32) VALUE                00420000
004300         '01081747715653149151411525272223'.                      00430000
004400       10  FILLER                  PIC X(32) VALUE                00440000
004500         '01091890116928161301526524242224'.                      00450000
004600       10  FILLER                  PIC X(32) VALUE                00460000
004700         '01102027518159173031637529252726'.                      00470000
004800       10  FILLER                  PIC X(32) VALUE                00480000
004900         '01112088918709178271687129262427'.                      00490000
005000       10  FILLER                  PIC X(32) VALUE                00500000
005100         '01122478222195211492001540333031'.                      00510000
005200       10  FILLER                  PIC X(32) VALUE                00520000
005300         '01132237520040190951807130272728'.                      00530000
005400       10  FILLER                  PIC X(32) VALUE                00540000
005500         '01142730224452233002205037343233'.                      00550000
005600       10  FILLER                  PIC X(32) VALUE                00560000
005700         '02010768907276067240617013141411'.                      00570000
005800       10  FILLER                  PIC X(32) VALUE                00580000
005900         '02021118110581097780897318161716'.                      00590000
006000       10  FILLER                  PIC X(32) VALUE                00600000
006100         '02031307712375114361049519201918'.                      00610000
006200       10  FILLER                  PIC X(32) VALUE                00620000
006300         '02041653415646144591326924232222'.                      00630000
006400       10  FILLER                  PIC X(32) VALUE                00640000
006500         '02052510023752219492014344363531'.                      00650000
006600       10  FILLER                  PIC X(32) VALUE                00660000
006700         '03010965508239078950719514141213'.                      00670000
006800       10  FILLER                  PIC X(32) VALUE                00680000
006900         '03021367811672111841019419171716'.                      00690000
007000       10  FILLER                  PIC X(32) VALUE                00700000
007100         '03031875216002153341397623232222'.                      00710000
007200       10  FILLER                  PIC X(32) VALUE                00720000
007300         '03042791123817228242080144323431'.                      00730000
007400       10  FILLER                  PIC X(32) VALUE                00740000
007500         '04010928208716082220690815151614'.                      00750000
007600       10  FILLER                  PIC X(32) VALUE                00760000
007700         '04021421113344125881057621182219'.                      00770000
007800       10  FILLER                  PIC X(32) VALUE                00780000
007900         '04032348522052208021747832323130'.                      00790000
008000       10  FILLER                  PIC X(32) VALUE                00800000
008100         '04043522733078312032621646436240'.                      00810000
008200       10  FILLER                  PIC X(32) VALUE                00820000
008300         '05010759006975062300536312131010'.                      00830000
008400       10  FILLER                  PIC X(32) VALUE                00840000
008500         '05020945808691077630668315171012'.                      00850000
008600       10  FILLER                  PIC X(32) VALUE                00860000
008700         '05031161310672095330820617171514'.                      00870000
008800       10  FILLER                  PIC X(32) VALUE                00880000
008900         '05041675915400137571184223212119'.                      00890000
009000       10  FILLER                  PIC X(32) VALUE                00900000
009100         '05052531423261207781788731312928'.                      00910000
009200       10  FILLER                  PIC X(32) VALUE                00920000
009300         '06010879406750066090594914131212'.                      00930000
009400       10  FILLER                  PIC X(32) VALUE                00940000
009500         '06021197909195090030810515151415'.                      00950000
009600       10  FILLER                  PIC X(32) VALUE                00960000
009700         '06031536811796115501039721181818'.                      00970000
009800       10  FILLER                  PIC X(32) VALUE                00980000
009900         '06042004515386150651356131242523'.                      00990000
010000       10  FILLER                  PIC X(32) VALUE                01000000
010100         '07010701507006067100596013131211'.                      01010000
010200       10  FILLER                  PIC X(32) VALUE                01020000
010300         '07020926409251088610787015151614'.                      01030000
010400       10  FILLER                  PIC X(32) VALUE                01040000
010500         '07031097710962105000932618171716'.                      01050000
010600       10  FILLER                  PIC X(32) VALUE                01060000
010700         '07041248812471119451060914201918'.                      01070000
010800       10  FILLER                  PIC X(32) VALUE                01080000
010900         '07051476014740141191254020222221'.                      01090000
011000       10  FILLER                  PIC X(32) VALUE                01100000
011100         '08010490904696045180389009090808'.                      01110000
011200       10  FILLER                  PIC X(32) VALUE                01120000
011300         '08020566705421052160449010100909'.                      01130000
011400       10  FILLER                  PIC X(32) VALUE                01140000
011500         '08030695606654064020551109111110'.                      01150000
011600       10  FILLER                  PIC X(32) VALUE                01160000
011700         '08040928408881085450735615141412'.                      01170000
011800       10  FILLER                  PIC X(32) VALUE                01180000
011900         '08051002709593092290794516161414'.                      01190000
012000       10  FILLER                  PIC X(32) VALUE                01200000
012100         '08061368113088125921084021201918'.                      01210000
012200       10  FILLER                  PIC X(32) VALUE                01220000
012300         '09010698806390060250521312111111'.                      01230000
012400       10  FILLER                  PIC X(32) VALUE                01240000
012500         '09020949608684081870708415151413'.                      01250000
012600       10  FILLER                  PIC X(32) VALUE                01260000
012700         '09031198710961103340894218181716'.                      01270000
012800       10  FILLER                  PIC X(32) VALUE                01280000
012900         '09041627214880140291213823232321'.                      01290000
013000       10  FILLER                  PIC X(32) VALUE                01300000
013100         '10010782107821071530652313131213'.                      01310000
013200       10  FILLER                  PIC X(32) VALUE                01320000
013300         '10020999809998091440833915151415'.                      01330000
013400       10  FILLER                  PIC X(32) VALUE                01340000
013500         '10031222912229111851020018171718'.                      01350000
013600       10  FILLER                  PIC X(32) VALUE                01360000
013700         '10041426414264130461189720201919'.                      01370000
013800       10  FILLER                  PIC X(32) VALUE                01380000
013900         '10051758817588160861467021252323'.                      01390000
014000       10  FILLER                  PIC X(32) VALUE                01400000
014100         '11011262107683071490663118111312'.                      01410000
014200       10  FILLER                  PIC X(32) VALUE                01420000
014300         '11021953411892110641026325181718'.                      01430000
014400       10  FILLER                  PIC X(32) VALUE                01440000
014500         '11032654316159150341394533232225'.                      01450000
014600       10  FILLER                  PIC X(32) VALUE                01460000
014700         '12010721905429051030459613101109'.                      01470000
014800       10  FILLER                  PIC X(32) VALUE                01480000
014900         '12020928406983065630591116111313'.                      01490000
015000       10  FILLER                  PIC X(32) VALUE                01500000
015100         '12031077108101076140685818151413'.                      01510000
015200       10  FILLER                  PIC X(32) VALUE                01520000
015300         '12041395010492098610888222191617'.                      01530000
015400       10  FILLER                  PIC X(32) VALUE                01540000
015500         '12051787413443126341138027212120'.                      01550000
015600       10  FILLER                  PIC X(32) VALUE                01560000
015700         '13010771906522064340556613141311'.                      01570000
015800       10  FILLER                  PIC X(32) VALUE                01580000
015900         '13020988208349082370712616141414'.                      01590000
016000       10  FILLER                  PIC X(32) VALUE                01600000
016100         '13031313211095109450946920181617'.                      01610000
016200       10  FILLER                  PIC X(32) VALUE                01620000
016300         '13041866215768155551345725252922'.                      01630000
016400       10  FILLER                  PIC X(32) VALUE                01640000
016500         '14010719006433057220515615121111'.                      01650000
016600       10  FILLER                  PIC X(32) VALUE                01660000
016700         '14020990208858078800710113151313'.                      01670000
016800       10  FILLER                  PIC X(32) VALUE                01680000
016900         '14031297511608103250930521191616'.                      01690000
017000       10  FILLER                  PIC X(32) VALUE                01700000
017100         '14041801316115143351291830242120'.                      01710000
017200       10  FILLER                  PIC X(32) VALUE                01720000
017300         '15010803207633069260661515131313'.                      01730000
017400       10  FILLER                  PIC X(32) VALUE                01740000
017500         '15021026809758088550845717171415'.                      01750000
017600       10  FILLER                  PIC X(32) VALUE                01760000
017700         '15031324212584114191090621201818'.                      01770000
017800       10  FILLER                  PIC X(32) VALUE                01780000
017900         '15042059819575177631696530283026'.                      01790000
018000       10  FILLER                  PIC X(32) VALUE                01800000
018100         '16010870708327078860660315141313'.                      01810000
018200       10  FILLER                  PIC X(32) VALUE                01820000
018300         '16021332012739120661010321202018'.                      01830000
018400       10  FILLER                  PIC X(32) VALUE                01840000
018500         '17010999609022081380720516141113'.                      01850000
018600       10  FILLER                  PIC X(32) VALUE                01860000
018700         '17021475513317120111063421212018'.                      01870000
018800       10  FILLER                  PIC X(32) VALUE                01880000
018900         '17032137019288173961540233282724'.                      01890000
019000       10  FILLER                  PIC X(32) VALUE                01900000
019100         '18010744507445068620628212121210'.                      01910000
019200       10  FILLER                  PIC X(32) VALUE                01920000
019300         '18021067410674098380900716161616'.                      01930000
019400       10  FILLER                  PIC X(32) VALUE                01940000
019500         '18031635016350150691379722252022'.                      01950000
019600       10  FILLER                  PIC X(32) VALUE                01960000
019700         '18042914029140268582458941294040'.                      01970000
019800       10  FILLER                  PIC X(32) VALUE                01980000
019900         '19011158510002097810887615151615'.                      01990000
020000       10  FILLER                  PIC X(32) VALUE                02000000
020100         '19022154218598181881650527272724'.                      02010000
020200       10  FILLER                  PIC X(32) VALUE                02020000
020300         '19033133927056264592401141353040'.                      02030000
020400       10  FILLER                  PIC X(32) VALUE                02040000
020500         '20010837107195067050602912131112'.                      02050000
020600       10  FILLER                  PIC X(32) VALUE                02060000
020700         '20021105609502088550796215151414'.                      02070000
020800       10  FILLER                  PIC X(32) VALUE                02080000
020900         '20031463912581117251054320181818'.                      02090000
021000       10  FILLER                  PIC X(32) VALUE                02100000
021100         '20041747215017139941258330222122'.                      02110000
021200       10  FILLER                  PIC X(32) VALUE                02120000
021300         '20052079917876166591497933252424'.                      02130000
021400       10  FILLER                  PIC X(32) VALUE                02140000
021500         '21011035709425083870838718181516'.                      02150000
021600       10  FILLER                  PIC X(32) VALUE                02160000
021700         '21022250820482182261822631262629'.                      02170000
021800       10  FILLER                  PIC X(32) VALUE                02180000
021900         '5001               01651      03'.                      02190000
022000       10  FILLER                  PIC X(32) VALUE                02200000
022100         '5101               04279      08'.                      02210000
022200       10  FILLER                  PIC X(32) VALUE                02220000
022300         '5102               12390      23'.                      02230000
022400       10  FILLER                  PIC X(32) VALUE                02240000
022500         '5103               05436      09'.                      02250000
022600       10  FILLER                  PIC X(32) VALUE                02260000
022700         '5104               17100      28'.                      02270000
022800     05  CMGX-TAB REDEFINES CMG-TABLE-DATA.                       02280000
022900         10  CMG-DATA              OCCURS 100 TIMES               02290000
023000                                   ASCENDING CMG-NUM              02300000
023100                                   INDEXED BY DX6.                02310000
023200             15  CMG-NUM           PIC X(04).                     02320000
023300             15  CMG-NUM-REDEF REDEFINES CMG-NUM.                 02330000
023400                 20  CMG-RIC       PIC XX.                        02340000
023500                 20  FILLER        PIC XX.                        02350000
023600             15  B-REL-WGT         PIC 9(01)V9(04).               02360000
023700             15  C-REL-WGT         PIC 9(01)V9(04).               02370000
023800             15  D-REL-WGT         PIC 9(01)V9(04).               02380000
023900             15  A-REL-WGT         PIC 9(01)V9(04).               02390000
024000             15  B-LOS-TABLE       PIC 9(02).                     02400000
024100             15  C-LOS-TABLE       PIC 9(02).                     02410000
024200             15  D-LOS-TABLE       PIC 9(02).                     02420000
024300             15  A-LOS-TABLE       PIC 9(02).                     02430000
024400                                                                  02440000
024500 01  HOLD-PPS-COMPONENTS.                                         02450000
024900     05  H-LOS                        PIC 9(05).                  02460000
025200     05  H-WK-DSH                     PIC 9(01)V9(04).            02470000
025700     05  H-LABOR-PORTION              PIC 9(07)V9(06).            02480000
025800     05  H-NONLABOR-PORTION           PIC 9(07)V9(06).            02490000
025900     05  H-OUTLIER-LABOR-PORTION      PIC 9(07)V9(06).            02500000
026000     05  H-OUTLIER-NONLABOR-PORTION   PIC 9(07)V9(06).            02510000
026200     05  H-FP-OUTLIER-THRESHOLD       PIC 9(07)V9(06).            02520000
026300     05  H-OUTLIER-THRESHOLD          PIC 9(07)V9(06).            02530000
026400     05  H-CHG-OUTLIER-THRESHOLD      PIC 9(07)V9(04).            02540000
026400     05  H-FY-BEGIN-DATE              PIC 9(08).                  02541000
026400     05  H-DISCHARGE-DATE             PIC 9(08).                  02542000
028000                                                                  02543000
028100 LINKAGE SECTION.                                                 02544000
028200**************************************************************    02545000
028300*      THIS IS THE BILL-RECORD THAT WILL BE PASSED FROM      *    02546000
028400*      THE IRCAL___ PROGRAM                                  *    02547000
028500**************************************************************    02548000
028600 01  BILL-NEW-DATA.                                               02549000
028700         10  B-NPI10.                                             02550000
028800             15  B-NPI8             PIC X(08).                    02560000
028900             15  B-NPI-FILLER       PIC X(02).                    02570000
029000         10  B-PROVIDER-NO          PIC X(06).                    02580000
029100         10  B-PATIENT-STATUS       PIC X(02).                    02590000
029200         10  B-CMG-CODE             PIC X(05).                    02600000
029300         10  B-LOS                  PIC 9(03).                    02610000
029400         10  B-COV-DAYS             PIC 9(03).                    02620000
029500         10  B-LTR-DAYS             PIC 9(02).                    02630000
029600         10  B-SPEC-PAY-IND         PIC X(01).                    02640000
029700         10  B-DISCHARGE-DATE.                                    02650000
029800             15  B-DISCHG-CC        PIC 9(02).                    02660000
029900             15  B-DISCHG-YY        PIC 9(02).                    02670000
030000             15  B-DISCHG-MM        PIC 9(02).                    02680000
030100             15  B-DISCHG-DD        PIC 9(02).                    02690000
030200         10  B-COV-CHARGES          PIC 9(07)V9(02).              02700000
030300         10  FILLER                 PIC X(11).                    02710000
030400                                                                  02720000
030500***************************************************************   02730000
030600*    THIS DATA IS CALCULATED BY THIS IRCAL SUBROUTINE         *   02740000
030700*    AND PASSED BACK TO THE CALLING PROGRAM                   *   02750000
030800*            RETURN CODE VALUES (PPS-RTC)                     *   02760000
030900*                                                             *   02770000
031000*     ****   PPS-RTC 00-49 = HOW THE BILL WAS PAID            *   02780000
031100*              00 = PAID NORMAL CMG PAYMENT WITHOUT OUTLIER   *   02790000
031200*                                                             *   02800000
031300*              01 = PAID NORMAL CMG PAYMENT WITH OUTLIER      *   02810000
031400*                                                             *   02820000
031500*              02 = TRANSFER PAID ON A PERDIEM BASIS WITHOUT  *   02830000
031600*                   OUTLIER                                   *   02840000
031700*              03 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   02850000
031800*                   OUTLIER                                   *   02860000
031900*              04 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02870000
032000*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02880000
032100*                   WITHOUT OUTLIER                           *   02890000
032200*              05 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02900000
032300*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02910000
032400*                   WITH OUTLIER                              *   02920000
032500*              06 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   02930000
032600*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   02940000
032700*                   RATE -- WITHOUT OUTLIER                   *   02950000
032800*              07 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   02960000
032900*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   02970000
033000*                   RATE -- WITH OUTLIER                      *   02980000
033100*       **** NEW RT CODES FOR PAYMENT WITH PENALTIES          *   02990000
031100*              10 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   03000000
031200*                   WITHOUT OUTLIER                           *   03010000
031300*              11 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   03020000
031400*                   WITH OUTLIER                              *   03030000
031500*              12 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   03040000
031600*                   PENALTY WITHOUT OUTLIER                   *   03050000
031700*              13 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   03060000
031800*                   PENALTY WITH OUTLIER                      *   03070000
031900*              14 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   03080000
032000*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   03090000
032100*                   WITH PENALTY WITHOUT OUTLIER              *   03100000
032200*              15 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   03110000
032300*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   03120000
032400*                   WITH PENALTY WITH OUTLIER                 *   03130000
032500*              16 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03140000
032600*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03150000
032700*                   RATE -- WITH PENALTY WITHOUT OUTLIER      *   03160000
032800*              17 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03170000
032900*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03180000
033000*                   RATE -- WITH PENALTY WITH OUTLIER         *   03190000
033100*                                                             *   03200000
033200*      ****  PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   03210000
033300*              50 = PROVIDER SPECIFIC RATE NOT NUMERIC        *   03220000
033400*              51 = PROVIDER RECORD TERMINATED                *   03230000
033500*              52 = INVALID WAGE INDEX                        *   03240000
033600*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   03250000
033700*              54 = CMG ON CLAIM NOT FOUND IN TABLE           *   03260000
033800*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   03270000
033900*                                      OR                     *   03280000
034000*                   DISCHARGE DATE < MSA EFF START DATE       *   03290000
034100*                   FOR PPS                                   *   03300000
034500*              56 = INVALID LENGTH OF STAY                    *   03310000
034600*              57 = PROVIDER SPECIFIC RATE ZERO WHEN BLENDED  *   03320000
034700*                   PAYMENT REQUESTED                         *   03330000
034800*              58 = TOTAL COVERED CHARGES NOT NUMERIC         *   03340000
034900*              59 = PROVIDER SPECIFIC RECORD NOT FOUND        *   03350000
035000*              60 = MSA WAGE INDEX RECORD NOT FOUND           *   03360000
035100*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *   03370000
035200*                   OR BILL-LTR-DAYS > 60                     *   03380000
035300*              62 = INVALID NUMBER OF COVERED DAYS            *   03390000
035500*              65 = OPERATING COST-TO-CHARGE RATIO NOT NUMERIC*   03400000
035600*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *   03410000
035700*                   OR COST OUTLIER THRESHOLD CALCULATION     *   03420000
035800*              72 = INVALID BLEND INDICATOR (NOT 3 OR 4)      *   03430000
035900*              73 = DISCHARGED BEFORE PROVIDER FY BEGIN       *   03440000
036100*              74 = PROVIDER FY BEGIN DATE NOT IN 2002        *   03450000
036200***************************************************************   03460000
036300 01  PPS-DATA-ALL.                                                03470000
036500     05  PPS-RTC                      PIC 9(02).                  03480000
036400     05  PPS-DATA.                                                03490000
036600         10  PPS-MSA                  PIC X(04).                  03500000
036700         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).            03510000
036800         10  PPS-AVG-LOS              PIC 9(02).                  03520000
036900         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).            03530000
037000         10  PPS-TOTAL-PAY-AMT        PIC 9(07)V9(02).            03540000
037100         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).            03550000
037200         10  PPS-FAC-SPEC-PAY-AMT     PIC 9(07)V9(02).            03560000
037300         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).            03570000
037300         10  PPS-LIP-PAY-AMT          PIC 9(07)V9(02).            03580000
037400         10  PPS-LIP-PCT              PIC 9(01)V9(04).            03590000
037500         10  PPS-LOS                  PIC 9(03).                  03600000
037600         10  PPS-REG-DAYS-USED        PIC 9(03).                  03610000
037700         10  PPS-LTR-DAYS-USED        PIC 9(03).                  03620000
037800         10  PPS-TRANSFER-PCT         PIC 9(01)V9(04).            03630000
037900         10  PPS-FAC-SPEC-RT-PREBLEND PIC 9(05)V9(02).            03640000
038000         10  PPS-STANDARD-PAY-AMT     PIC 9(07)V9(02).            03650000
038200         10  PPS-FAC-COSTS            PIC 9(07)V9(02).            03660000
038300         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).            03670000
038400         10  PPS-CHG-OUTLIER-THRESHOLD PIC 9(07)V9(02).           03680000
037000         10  PPS-TOTAL-PENALTY-AMT    PIC 9(07)V9(02).            03690000
037000         10  PPS-FED-PENALTY-AMT      PIC 9(07)V9(02).            03700000
037000         10  PPS-LIP-PENALTY-AMT      PIC 9(07)V9(02).            03710000
037000         10  PPS-OUT-PENALTY-AMT      PIC 9(07)V9(02).            03720000
038500         10  PPS-SUBM-CMG-CODE        PIC X(05).                  03730000
027300         10  PPS-CMG-CODE-REDEF REDEFINES PPS-SUBM-CMG-CODE.      03740000
027400            15  PPS-CMG-ALPHA         PIC X(01).                  03750000
027500            15  PPS-CMG-NUMERIC.                                  03760000
027600               20  PPS-CMG-RIC        PIC X(02).                  03770000
027700               20  FILLER             PIC X(02).                  03780000
038600         10  PPS-PRICED-CMG-CODE      PIC X(05).                  03790000
038700         10  PPS-CALC-VERS-CD         PIC X(05).                  03800000
038800         10  FILLER                   PIC X(13).                  03810000
038900     05  PPS-OTHER-DATA.                                          03820000
039000         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).            03830000
039100         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).            03840000
039200         10  PPS-NAT-THRESHOLD-ADJ    PIC 9(05)V9(02).            03850000
039400         10  PPS-BDGT-NEUT-CONV-AMT   PIC 9(05)V9(02).            03860000
039500         10  PPS-FED-RATE-PCT         PIC 9(01)V9(04).            03870000
039600         10  PPS-FAC-RATE-PCT         PIC 9(01)V9(04).            03880000
039700         10  PPS-RURAL-ADJUSTMENT     PIC 9(01)V9(04).            03890000
039800         10  FILLER                   PIC X(20).                  03900000
039900     05  PPS-PC-DATA.                                             03910000
040000         10  PPS-COT-IND              PIC X(01).                  03920000
040100         10  FILLER                   PIC X(20).                  03930000
040200                                                                  03940000
040300******************************************************************03950000
040400*            THESE ARE THE VERSIONS OF THE IRDRV___               03960000
040500*           PROGRAMS THAT WILL BE PASSED BACK----                 03970000
040600*          ASSOCIATED WITH THE BILL BEING PROCESSED               03980000
040700******************************************************************03990000
040800 01  PRICER-OPT-VERS-SW.                                          04000000
040900     05  PRICER-OPTION-SW          PIC X(01).                     04010000
041000         88  ALL-TABLES-PASSED          VALUE 'A'.                04020000
041100         88  PROV-RECORD-PASSED         VALUE 'P'.                04030000
041200     05  PPS-VERSIONS.                                            04040000
041300         10  PPDRV-VERSION         PIC X(05).                     04050000
041500                                                                  04060000
041600**************************************************************    04070000
041700*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BY        *    04080000
041800*      THE IRCAL___ PROGRAM                                  *    04090000
041900**************************************************************    04100000
042000 01  PROV-NEW-HOLD.                                               04110000
042100     02  PROV-NEWREC-HOLD1.                                       04120000
042200         05  P-NEW-NPI10.                                         04130000
042300             10  P-NEW-NPI8             PIC X(08).                04140000
042400             10  P-NEW-NPI-FILLER       PIC X(02).                04150000
042500         05  P-NEW-PROVIDER-NO.                                   04160000
042600             10  P-NEW-STATE            PIC 9(02).                04170000
042700             10  FILLER                 PIC X(04).                04180000
042800         05  P-NEW-DATE-DATA.                                     04190000
042900             10  P-NEW-EFF-DATE.                                  04200000
043000                 15  P-NEW-EFF-DT-CC    PIC 9(02).                04210000
043100                 15  P-NEW-EFF-DT-YY    PIC 9(02).                04220000
043200                 15  P-NEW-EFF-DT-MM    PIC 9(02).                04230000
043300                 15  P-NEW-EFF-DT-DD    PIC 9(02).                04240000
043400             10  P-NEW-FY-BEGIN-DATE.                             04250000
043500                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                04260000
043600                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                04270000
043700                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                04280000
043800                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                04290000
043900             10  P-NEW-REPORT-DATE.                               04300000
044000                 15  P-NEW-REPORT-DT-CC PIC 9(02).                04310000
044100                 15  P-NEW-REPORT-DT-YY PIC 9(02).                04320000
044200                 15  P-NEW-REPORT-DT-MM PIC 9(02).                04330000
044300                 15  P-NEW-REPORT-DT-DD PIC 9(02).                04340000
044400             10  P-NEW-TERMINATION-DATE.                          04350000
044500                 15  P-NEW-TERM-DT-CC   PIC 9(02).                04360000
044600                 15  P-NEW-TERM-DT-YY   PIC 9(02).                04370000
044700                 15  P-NEW-TERM-DT-MM   PIC 9(02).                04380000
044800                 15  P-NEW-TERM-DT-DD   PIC 9(02).                04390000
044900         05  P-NEW-WAIVER-CODE          PIC X(01).                04400000
045000             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              04410000
045100         05  P-NEW-INTER-NO             PIC 9(05).                04420000
045200         05  P-NEW-PROVIDER-TYPE        PIC X(02).                04430000
047000         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                04440000
048000         05  P-NEW-CURRENT-DIV   REDEFINES                        04450000
048100                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         04460000
048300         05  P-NEW-MSA-DATA.                                      04470000
048400             10  P-NEW-CHG-CODE-INDEX       PIC X.                04480000
048500             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 04490000
048600             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   04500000
048700                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       04510000
048800             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 04520000
048900             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 04530000
049000             10  P-NEW-STAND-AMT-LOC-MSA9                         04540000
049100                 REDEFINES P-NEW-STAND-AMT-LOC-MSA.               04550000
049200                 15  P-NEW-RURAL-1ST.                             04560000
049300                     20  P-NEW-STAND-RURAL  PIC XX.               04570000
049400                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    04580000
049500                 15  P-NEW-RURAL-2ND        PIC XX.               04590000
049600         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    04600000
050000         05  P-NEW-LUGAR                    PIC X.                04610000
050100         05  P-NEW-TEMP-RELIEF-IND          PIC X.                04620000
050200         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                04630000
050300         05  FILLER                         PIC X(05).            04640000
050400     02  PROV-NEWREC-HOLD2.                                       04650000
050500         05  P-NEW-VARIABLES.                                     04660000
050600             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        04670000
050700             10  P-NEW-COLA              PIC  9(01)V9(03).        04680000
050800             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        04690000
050900             10  P-NEW-BED-SIZE          PIC  9(05).              04700000
051000             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        04710000
051100             10  P-NEW-CMI               PIC  9(01)V9(04).        04720000
051200             10  P-NEW-SSI-RATIO         PIC  V9(04).             04730000
051300             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             04740000
051400             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              04750000
051500             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        04760000
051600             10  P-NEW-DSH-PERCENT       PIC  V9(04).             04770000
051700             10  P-NEW-FYE-DATE          PIC  X(08).              04780000
051800         05  FILLER                      PIC  X(23).              04790000
051900     02  PROV-NEWREC-HOLD3.                                       04800000
052000         05  P-NEW-PASS-AMT-DATA.                                 04810000
052100             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          04820000
052200             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          04830000
052300             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          04840000
052400             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          04850000
052500         05  P-NEW-CAPI-DATA.                                     04860000
052600             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 04870000
052700             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          04880000
052800             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          04890000
052900             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        04900000
053000             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             04910000
053100             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 04920000
053200             15  P-NEW-CAPI-IME            PIC 9V9999.            04930000
053300             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          04940000
053400         05  FILLER                        PIC X(22).             04950000
053500******************************************************************04960000
053600*                   THIS IS THE WAGE-INDEX                        04970000
053700*          ASSOCIATED WITH THE BILL BEING PROCESSED               04980000
053800******************************************************************04990000
053900 01  WAGE-NEW-INDEX-RECORD.                                       05000000
054000     05  W-MSA                         PIC X(4).                  05010000
054100     05  W-EFF-DATE                    PIC X(8).                  05020000
054200     05  W-WAGE-INDEX                  PIC S9(02)V9(04).          05030000
054400                                                                  05040000
054500 PROCEDURE DIVISION  USING BILL-NEW-DATA                          05050000
054600                           PPS-DATA-ALL                           05060000
054700                           PRICER-OPT-VERS-SW                     05070000
054800                           PROV-NEW-HOLD                          05080000
054900                           WAGE-NEW-INDEX-RECORD.                 05090000
055000                                                                  05100000
055100***************************************************************   05110000
055200*    PROCESSING:                                              *   05120000
055300*        A. WILL PROCESS CLAIMS BASED ON DISCHARGE DATE       *   05130000
055400*        B. INITIALIZE IRCAL HOLD VARIABLES.                  *   05140000
055500*        C. EDIT THE DATA PASSED FROM THE CLAIM BEFORE        *   05150000
055600*           ATTEMPTING TO CALCULATE PPS. IF THIS CLAIM        *   05160000
055700*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   05170000
055800*           GOBACK.                                           *   05180000
055900*        D. ASSEMBLE PRICING COMPONENTS.                      *   05190000
056000*        E. CALCULATE THE PRICE.                              *   05200000
056100*        F. CALCULATE OUTLIERS IF APPLICABLE.                 *   05210000
056200***************************************************************   05220000
056300                                                                  05230000
056400 0000-MAINLINE-CONTROL.                                           05240000
056500                                                                  05250000
           PERFORM 0100-INITIAL-ROUTINE                                 05260000
              THRU 0100-EXIT.                                           05270000
063400     PERFORM 1000-EDIT-THE-BILL-INFO                              05280000
063400        THRU 1000-EXIT.                                           05290000
063600     IF PPS-RTC = 00                                              05300000
065800        PERFORM 1700-EDIT-CMG-CODE                                05310000
                 THRU 1700-EXIT.                                        05320000
063500                                                                  05330000
063600     IF PPS-RTC = 00                                              05340000
063700        PERFORM 2000-ASSEMBLE-PPS-VARIABLES                       05350000
063700           THRU 2000-EXIT.                                        05360000
063800                                                                  05370000
063900     IF PPS-RTC = 00                                              05380000
064000        PERFORM 3000-CALC-PAYMENT                                 05390000
064000           THRU 3000-EXIT                                         05400000
064000        PERFORM 3500-CONTINUE-CALC                                05410000
064000           THRU 3500-EXIT                                         05420000
064100        PERFORM 4000-CALC-OUTLIER                                 05430000
064100           THRU 4000-EXIT                                         05440000
064200        PERFORM 5000-FINAL-PAYMENTS                               05450000
064200           THRU 5000-EXIT.                                        05460000
                                                                        05470000
064200     PERFORM 9000-MOVE-RESULTS                                    05480000
064200        THRU 9000-EXIT.                                           05490000
064300                                                                  05500000
061800     GOBACK.                                                      05510000
061900                                                                  05520000
062000 0100-INITIAL-ROUTINE.                                            05530000
062100                                                                  05540000
           MOVE ZEROS TO PPS-RTC.                                       05550000
062200     INITIALIZE PPS-DATA.                                         05560000
062300     INITIALIZE PPS-OTHER-DATA.                                   05570000
062400     INITIALIZE HOLD-PPS-COMPONENTS.                              05580000
062500                                                                  05590000
062600     MOVE .72526 TO PPS-NAT-LABOR-PCT.                            05600000
062700     MOVE .27474 TO PPS-NAT-NONLABOR-PCT.                         05610000
062800     MOVE 11211  TO PPS-NAT-THRESHOLD-ADJ.                        05620000
063000     MOVE 12525  TO PPS-BDGT-NEUT-CONV-AMT.                       05630000
062100                                                                  05640000
062000 0100-EXIT.                                                       05650000
062100      EXIT.                                                       05660000
063100                                                                  05670000
064400 1000-EDIT-THE-BILL-INFO.                                         05680000
064500***************************************************************   05690000
064600*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *   05700000
064700*    AND DO NOT ATTEMPT TO PRICE.                             *   05710000
064800***************************************************************   05720000
064900                                                                  05730000
065000     MOVE B-CMG-CODE TO PPS-SUBM-CMG-CODE.                        05740000
065100                                                                  05750000
065200     IF (B-LOS NUMERIC) AND (B-LOS > 0)                           05760000
065400        MOVE B-LOS TO H-LOS                                       05770000
065500     ELSE                                                         05780000
              IF B-LOS = 0                                              05790000
                 MOVE 1 TO H-LOS                                        05800000
              ELSE                                                      05810000
065600           MOVE 56 TO PPS-RTC.                                    05820000
                                                                        05830000
065900     MOVE P-NEW-FY-BEGIN-DATE TO H-FY-BEGIN-DATE.                 05840000
           IF H-FY-BEGIN-DATE (5:2) < 11                                05850000
             COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 10200          05860000
           ELSE                                                         05870000
             COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 19000.         05880000
065900     MOVE B-DISCHARGE-DATE TO H-DISCHARGE-DATE.                   05890000
066100     IF (H-DISCHARGE-DATE > H-FY-BEGIN-DATE)                      05900000
              OR (P-NEW-FY-BEGIN-DATE > 20020930 AND                    05901000
                  P-NEW-FY-BEGIN-DATE < 20030101)                       05901100
066300        MOVE '4' TO P-NEW-FED-PPS-BLEND-IND.                      05901200
066000     IF P-NEW-FY-BEGIN-DATE > 20011231                            05901300
066100        IF (P-NEW-FY-BEGIN-DATE <= B-DISCHARGE-DATE)              05901400
066300           IF P-NEW-FED-PPS-BLEND-IND = '4'                       05901500
066400              MOVE 1.0000 TO PPS-FED-RATE-PCT                     05901600
066500              MOVE 0.0000 TO PPS-FAC-RATE-PCT                     05901700
066600           ELSE                                                   05901800
066700             IF P-NEW-FED-PPS-BLEND-IND = '3'                     05901900
066800                MOVE .6667 TO PPS-FED-RATE-PCT                    05902000
066900                MOVE .3333 TO PPS-FAC-RATE-PCT                    05903000
067000             ELSE                                                 05904000
067100               MOVE 72 TO PPS-RTC                                 05905000
067200        ELSE                                                      05906000
067300           MOVE 73 TO PPS-RTC                                     05907000
067400     ELSE                                                         05908000
067500        MOVE 74 TO PPS-RTC.                                       05909000
067600                                                                  05910000
067700     IF PPS-RTC = 00                                              05920000
067800       IF P-NEW-WAIVER-STATE                                      05930000
067900          MOVE 53 TO PPS-RTC.                                     05940000
                                                                        05950000
068000     IF PPS-RTC = 00                                              05960000
068200         IF ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR               05970000
068300            (B-DISCHARGE-DATE < W-EFF-DATE))                      05980000
068400            MOVE 55 TO PPS-RTC.                                   05990000
068500                                                                  06000000
068600     IF PPS-RTC = 00                                              06010000
068700         IF P-NEW-TERMINATION-DATE > 00000000                     06020000
068800            IF B-DISCHARGE-DATE >= P-NEW-TERMINATION-DATE         06030000
069000               MOVE 51 TO PPS-RTC.                                06040000
069100                                                                  06050000
069200     IF PPS-RTC = 00                                              06060000
069300         IF B-COV-CHARGES NOT NUMERIC                             06070000
069400            MOVE 58 TO PPS-RTC.                                   06080000
069500                                                                  06090000
069600     IF PPS-RTC = 00                                              06100000
069700        IF B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60              06110000
069800           MOVE 61 TO PPS-RTC                                     06120000
070100        ELSE                                                      06130000
                 MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.                  06140000
                                                                        06150000
070200     IF PPS-RTC = 00                                              06160000
070300        IF B-COV-DAYS NOT NUMERIC                                 06170000
070400             MOVE 62 TO PPS-RTC                                   06180000
070500        ELSE                                                      06190000
070600          IF B-COV-DAYS = 0 AND H-LOS > 0                         06200000
070700             MOVE 62 TO PPS-RTC.                                  06210000
071000                                                                  06220000
071100     IF PPS-RTC = 00                                              06230000
071200        IF B-LTR-DAYS  > B-COV-DAYS                               06240000
071300           MOVE 62 TO PPS-RTC                                     06250000
071400        ELSE                                                      06260000
071500           COMPUTE PPS-REG-DAYS-USED = B-COV-DAYS - B-LTR-DAYS.   06270000
071600                                                                  06280000
071100     IF PPS-RTC = 00                                              06290000
071700        IF PPS-REG-DAYS-USED > 0                                  06300000
071800           IF PPS-REG-DAYS-USED > H-LOS                           06310000
071900              MOVE H-LOS TO PPS-REG-DAYS-USED                     06320000
072000           ELSE                                                   06330000
072100              NEXT SENTENCE                                       06340000
072200        ELSE                                                      06350000
072300           IF B-LTR-DAYS > H-LOS                                  06360000
072400              MOVE H-LOS TO PPS-LTR-DAYS-USED                     06370000
072500           ELSE                                                   06380000
072600              MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.               06390000
072700                                                                  06400000
072900 1000-EXIT.                                                       06410000
073000      EXIT.                                                       06420000
                                                                        06430000
073200***************************************************************   06440000
073300*    FINDS THE CMG CODE IN THE TABLE                          *   06450000
073400***************************************************************   06460000
073100 1700-EDIT-CMG-CODE.                                              06470000
073500                                                                  06480000
           IF PPS-CMG-NUMERIC < '2103'                                  06490000
              NEXT SENTENCE                                             06500000
           ELSE                                                         06510000
              MOVE 54 TO PPS-RTC.                                       06520000
                                                                        06530000
           IF PPS-RTC = 00                                              06540000
074500        SEARCH ALL CMG-DATA                                       06550000
074600           AT END                                                 06560000
074700             MOVE 54 TO PPS-RTC                                   06570000
074800        WHEN CMG-NUM (DX6) = PPS-CMG-NUMERIC                      06580000
075200             PERFORM 1750-FIND-VALUE                              06590000
075300                THRU 1750-EXIT                                    06600000
              END-SEARCH.                                               06610000
                                                                        06620000
       1700-EXIT.                                                       06630000
            EXIT.                                                       06640000
                                                                        06650000
073200***************************************************************   06660000
073300*    FINDS THE VALUE IN THE CMG CODE IN THE TABLE             *   06670000
073400***************************************************************   06680000
073100 1750-FIND-VALUE.                                                 06690000
073500                                                                  06700000
075200      IF PPS-CMG-ALPHA = 'A'                                      06710000
075300         MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                 06720000
075400         MOVE A-LOS-TABLE (DX6) TO PPS-AVG-LOS                    06730000
075500      ELSE                                                        06740000
075600         IF PPS-CMG-ALPHA = 'B'                                   06750000
075700            MOVE B-REL-WGT (DX6) TO PPS-RELATIVE-WGT              06760000
075800            MOVE B-LOS-TABLE (DX6) TO PPS-AVG-LOS                 06770000
075900         ELSE                                                     06780000
076000            IF PPS-CMG-ALPHA = 'C'                                06790000
076100               MOVE C-REL-WGT (DX6) TO PPS-RELATIVE-WGT           06800000
076200               MOVE C-LOS-TABLE (DX6) TO PPS-AVG-LOS              06810000
076300            ELSE                                                  06820000
076400               IF PPS-CMG-ALPHA = 'D'                             06830000
076500                  MOVE D-REL-WGT (DX6) TO PPS-RELATIVE-WGT        06840000
076600                  MOVE D-LOS-TABLE (DX6) TO PPS-AVG-LOS           06850000
076700               ELSE                                               06860000
076800                  MOVE 54 TO PPS-RTC.                             06870000
                                                                        06880000
       1750-EXIT.                                                       06890000
            EXIT.                                                       06900000
                                                                        06910000
077100***************************************************************   06920000
077200*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *   06930000
077300*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   06940000
077400*    OF THAT VARIABLE.                                        *   06950000
077500***************************************************************   06960000
077600***  GET THE PROVIDER SPECIFIC VARIABLE AND WAGE INDEX            06970000
077700***************************************************************   06980000
077000 2000-ASSEMBLE-PPS-VARIABLES.                                     06990000
077800                                                                  07000000
077900     IF P-NEW-FAC-SPEC-RATE NUMERIC                               07010000
078000        MOVE P-NEW-FAC-SPEC-RATE TO PPS-FAC-SPEC-RT-PREBLEND      07020000
078100     ELSE                                                         07030000
078200        MOVE 50 TO PPS-RTC                                        07040000
              GO TO 2000-EXIT.                                          07050000
                                                                        07060000
078400     IF P-NEW-FED-PPS-BLEND-IND = '3'                             07070000
078600        IF PPS-FAC-SPEC-RT-PREBLEND = 0                           07080000
078700          MOVE 57 TO PPS-RTC                                      07090000
                GO TO 2000-EXIT.                                        07100000
078800                                                                  07110000
078900     IF W-WAGE-INDEX NUMERIC AND W-WAGE-INDEX > 0                 07120000
079000        MOVE W-WAGE-INDEX TO PPS-WAGE-INDEX                       07130000
079100     ELSE                                                         07140000
079200        MOVE 52 TO PPS-RTC                                        07150000
              GO TO 2000-EXIT.                                          07160000
079300                                                                  07170000
079400     IF P-NEW-OPER-CSTCHG-RATIO NOT NUMERIC                       07180000
080100        MOVE 65 TO PPS-RTC.                                       07190000
080200                                                                  07200000
077000 2000-EXIT.                                                       07210000
            EXIT.                                                       07220000
080300                                                                  07230000
080500***************************************************************   07240000
080600*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *   07250000
080700*        CALCULATE THE FEDERAL PORTION.                       *   07260000
080800*        CALCULATE THE HOSPITAL PORTION.                      *   07270000
080900*        CALCULATE THE COST-OUTLIER PORTION.                  *   07280000
081000*        CALCULATE THE LIP ADJUSTMENT PERCENTAGE.             *   07290000
081100***************************************************************   07300000
080400 3000-CALC-PAYMENT.                                               07310000
081300                                                                  07320000
081200***  LIP PERCENTAGE CALCULATION *******************************   07330000
081300                                                                  07340000
081400      COMPUTE H-WK-DSH = (P-NEW-SSI-RATIO                         07350000
081500                           + P-NEW-MEDICAID-RATIO).               07360000
081600                                                                  07370000
081700      COMPUTE PPS-LIP-PCT ROUNDED =                               07380000
081800            ((1 + H-WK-DSH) ** .4838) - 1.                        07390000
081900                                                                  07400000
082000***************************************************************   07410000
082100                                                                  07420000
082200     MOVE 1.0000 TO PPS-TRANSFER-PCT.                             07430000
082300                                                                  07440000
082400     IF B-PATIENT-STATUS =                                        07450000
082500         ('02' OR '03' OR '61' OR '62' OR '63' OR '64')           07460000
082600        IF H-LOS < PPS-AVG-LOS                                    07470000
082700           COMPUTE PPS-TRANSFER-PCT =                             07480000
082800               ((H-LOS + .5) / PPS-AVG-LOS)                       07490000
082900           MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE          07500000
083000           GO TO 3000-EXIT.                                       07510000
083100                                                                  07520000
083200     IF H-LOS > 3                                                 07530000
083300        NEXT SENTENCE                                             07540000
083400     ELSE                                                         07550000
083500        MOVE 'A5001' TO PPS-PRICED-CMG-CODE                       07560000
083600        SET DX6 TO 96                                             07570000
083700        MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                  07580000
083800        GO TO 3000-EXIT.                                          07590000
083900                                                                  07600000
084000     IF B-PATIENT-STATUS = '20'                                   07610000
084100        NEXT SENTENCE                                             07620000
084200     ELSE                                                         07630000
084300        MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE             07640000
084400        GO TO 3000-EXIT.                                          07650000
084500                                                                  07660000
084600     IF PPS-CMG-RIC = ('07' OR '08' OR '09')                      07670000
084700        IF H-LOS < 14                                             07680000
084800           MOVE 'A5101' TO PPS-PRICED-CMG-CODE                    07690000
084900           SET DX6 TO 97                                          07700000
085000           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               07710000
085100        ELSE                                                      07720000
085200           MOVE 'A5102' TO PPS-PRICED-CMG-CODE                    07730000
085300           SET DX6 TO 98                                          07740000
085400           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               07750000
085500     ELSE                                                         07760000
085600        IF H-LOS < 16                                             07770000
085700           MOVE 'A5103' TO PPS-PRICED-CMG-CODE                    07780000
085800           SET DX6 TO 99                                          07790000
085900           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               07800000
086000        ELSE                                                      07810000
086100           MOVE 'A5104' TO PPS-PRICED-CMG-CODE                    07820000
086200           SET DX6 TO 100                                         07830000
086300           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT.              07840000
086400                                                                  07850000
086500 3000-EXIT.                                                       07860000
086500      EXIT.                                                       07870000
086600                                                                  07880000
087300 3500-CONTINUE-CALC.                                              07890000
086800                                                                  07900000
086900     COMPUTE PPS-STANDARD-PAY-AMT =                               07910000
087000            (PPS-TRANSFER-PCT * PPS-RELATIVE-WGT                  07920000
087000                      * PPS-BDGT-NEUT-CONV-AMT).                  07930000
087100                                                                  07940000
087400     IF W-MSA (1:2) = '  '                                        07950000
087500        MOVE 1.1914 TO PPS-RURAL-ADJUSTMENT                       07960000
087600     ELSE                                                         07970000
087700        MOVE 1.0000 TO PPS-RURAL-ADJUSTMENT.                      07980000
087800                                                                  07990000
087900     COMPUTE H-LABOR-PORTION =                                    08000000
088000        (PPS-STANDARD-PAY-AMT * PPS-NAT-LABOR-PCT)                08010000
088000          * PPS-WAGE-INDEX.                                       08020000
088100                                                                  08030000
088200     COMPUTE H-NONLABOR-PORTION =                                 08040000
088300        (PPS-STANDARD-PAY-AMT * PPS-NAT-NONLABOR-PCT).            08050000
088400                                                                  08060000
088500     COMPUTE PPS-FED-PAY-AMT ROUNDED =                            08070000
088600        ((H-LABOR-PORTION + H-NONLABOR-PORTION) *                 08080000
088700         PPS-RURAL-ADJUSTMENT).                                   08090000
088400                                                                  08100000
088500     COMPUTE PPS-LIP-PAY-AMT ROUNDED =                            08110000
088600        (PPS-FED-PAY-AMT * PPS-LIP-PCT).                          08120000
088800                                                                  08130000
088900 3500-EXIT.                                                       08140000
089000      EXIT.                                                       08150000
088800                                                                  08160000
089100 4000-CALC-OUTLIER.                                               08170000
089200                                                                  08180000
089300     COMPUTE PPS-FAC-COSTS ROUNDED =                              08190000
089400         (B-COV-CHARGES * P-NEW-OPER-CSTCHG-RATIO).               08200000
089500                                                                  08210000
089600     COMPUTE H-OUTLIER-LABOR-PORTION =                            08220000
089700        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-LABOR-PCT)               08230000
089800              * PPS-WAGE-INDEX.                                   08240000
089900                                                                  08250000
090000     COMPUTE H-OUTLIER-NONLABOR-PORTION =                         08260000
090100        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-NONLABOR-PCT).           08270000
090200                                                                  08280000
090300     COMPUTE H-FP-OUTLIER-THRESHOLD ROUNDED =                     08290000
090400        ((H-OUTLIER-LABOR-PORTION + H-OUTLIER-NONLABOR-PORTION) * 08300000
090500         PPS-RURAL-ADJUSTMENT * (PPS-LIP-PCT + 1)).               08310000
090600                                                                  08320000
090700     COMPUTE H-OUTLIER-THRESHOLD ROUNDED =                        08330000
090800        (PPS-FED-PAY-AMT + H-FP-OUTLIER-THRESHOLD +               08340000
               PPS-LIP-PAY-AMT).                                        08350000
090900                                                                  08360000
091000     IF PPS-FAC-COSTS > H-OUTLIER-THRESHOLD                       08370000
091100        COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                     08380000
091200           ((PPS-FAC-COSTS - H-OUTLIER-THRESHOLD) * .8).          08390000
091300                                                                  08400000
091400     COMPUTE H-CHG-OUTLIER-THRESHOLD ROUNDED =                    08410000
091500         H-OUTLIER-THRESHOLD / P-NEW-OPER-CSTCHG-RATIO.           08420000
091600                                                                  08430000
                                                                        08440000
091700 4000-EXIT.                                                       08450000
091700      EXIT.                                                       08460000
091800                                                                  08470000
091900 5000-FINAL-PAYMENTS.                                             08480000
092000                                                                  08490000
092100     IF B-SPEC-PAY-IND = '1' OR '3'                               08500000
092200         MOVE ZEROES TO PPS-OUTLIER-PAY-AMT.                      08510000
092300                                                                  08520000
092400     IF PPS-FED-RATE-PCT = 1.0000                                 08530000
092600         MOVE 0                  TO PPS-FAC-SPEC-PAY-AMT          08540000
092800     ELSE                                                         08550000
092900         COMPUTE PPS-FED-PAY-AMT ROUNDED =                        08560000
093000           (PPS-FED-RATE-PCT * PPS-FED-PAY-AMT)                   08570000
093100         COMPUTE PPS-FAC-SPEC-PAY-AMT ROUNDED =                   08580000
093200           (PPS-FAC-RATE-PCT * PPS-FAC-SPEC-RT-PREBLEND)          08590000
093300         COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                    08600000
093400           (PPS-FED-RATE-PCT * PPS-OUTLIER-PAY-AMT)               08610000
093300         COMPUTE PPS-LIP-PAY-AMT ROUNDED =                        08620000
093400           (PPS-FED-RATE-PCT * PPS-LIP-PAY-AMT).                  08630000
093500                                                                  08640000
           IF B-SPEC-PAY-IND = '2' OR '3'                               08650000
093600        COMPUTE PPS-FED-PENALTY-AMT ROUNDED =                     08660000
093700           (PPS-FED-PAY-AMT * .25)                                08670000
093600        COMPUTE PPS-FED-PAY-AMT =                                 08680000
093700           (PPS-FED-PAY-AMT - PPS-FED-PENALTY-AMT)                08690000
093600        COMPUTE PPS-LIP-PENALTY-AMT ROUNDED =                     08700000
093700           (PPS-LIP-PAY-AMT * .25)                                08710000
093600        COMPUTE PPS-LIP-PAY-AMT =                                 08720000
093700           (PPS-LIP-PAY-AMT - PPS-LIP-PENALTY-AMT)                08730000
093600        COMPUTE PPS-OUT-PENALTY-AMT ROUNDED =                     08740000
093700           (PPS-OUTLIER-PAY-AMT * .25)                            08750000
093600        COMPUTE PPS-OUTLIER-PAY-AMT =                             08760000
093700           (PPS-OUTLIER-PAY-AMT - PPS-OUT-PENALTY-AMT)            08770000
              COMPUTE PPS-TOTAL-PENALTY-AMT =                           08780000
                 (PPS-FED-PENALTY-AMT + PPS-LIP-PENALTY-AMT             08790000
                 + PPS-OUT-PENALTY-AMT).                                08800000
                                                                        08810000
093600     COMPUTE PPS-TOTAL-PAY-AMT ROUNDED =                          08820000
093700        (PPS-FED-PAY-AMT + PPS-FAC-SPEC-PAY-AMT                   08830000
093800         + PPS-OUTLIER-PAY-AMT + PPS-LIP-PAY-AMT).                08840000
093900                                                                  08850000
                                                                        08860000
094000     IF PPS-FED-RATE-PCT = 1.0000                                 08870000
094100        IF PPS-TRANSFER-PCT = 1.0000                              08880000
094200           IF PPS-OUTLIER-PAY-AMT > 0.0                           08890000
094300              MOVE 01 TO PPS-RTC                                  08900000
094400           ELSE                                                   08910000
094500              MOVE 00 TO PPS-RTC                                  08920000
094600        ELSE                                                      08930000
094700           IF PPS-OUTLIER-PAY-AMT > 0.0                           08940000
094800              MOVE 03 TO PPS-RTC                                  08950000
094900           ELSE                                                   08960000
095000              MOVE 02 TO PPS-RTC                                  08970000
095100     ELSE                                                         08980000
095200        IF PPS-TRANSFER-PCT = 1.0000                              08990000
095300           IF PPS-OUTLIER-PAY-AMT > 0.0                           09000000
095400              MOVE 05 TO PPS-RTC                                  09010000
095500           ELSE                                                   09020000
095600              MOVE 04 TO PPS-RTC                                  09030000
095700        ELSE                                                      09040000
095800           IF PPS-OUTLIER-PAY-AMT > 0.0                           09050000
095900              MOVE 07 TO PPS-RTC                                  09060000
096000           ELSE                                                   09070000
096100              MOVE 06 TO PPS-RTC.                                 09080000
096300                                                                  09090000
           IF B-SPEC-PAY-IND = '2' OR '3'                               09100000
096200        COMPUTE PPS-RTC = PPS-RTC + 10.                           09110000
096400     IF PPS-RTC = (01 OR 03 OR 05 OR 07                           09120000
096400                OR 11 OR 13 OR 15 OR 17)                          09130000
096500        IF ((PPS-REG-DAYS-USED + PPS-LTR-DAYS-USED) < H-LOS)      09140000
096600           OR PPS-COT-IND = 'Y'                                   09150000
096700            MOVE 67 TO PPS-RTC.                                   09160000
097000                                                                  09170000
097100 5000-EXIT.                                                       09180000
097100      EXIT.                                                       09190000
097200                                                                  09200000
       9000-MOVE-RESULTS.                                               09210000
                                                                        09220000
056600     IF PPS-RTC < 50                                              09230000
056700      MOVE H-LOS                   TO  PPS-LOS                    09240000
057300      MOVE H-OUTLIER-THRESHOLD     TO  PPS-OUTLIER-THRESHOLD      09250000
057400      MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD   09260000
057800      MOVE W-MSA                   TO  PPS-MSA                    09270000
058300      MOVE 'V04.0'                 TO  PPS-CALC-VERS-CD           09280000
058400     ELSE                                                         09290000
062200       INITIALIZE PPS-DATA                                        09300000
062300       INITIALIZE PPS-OTHER-DATA                                  09310000
061200       MOVE 'V04.0'                TO  PPS-CALC-VERS-CD.          09320000
061300                                                                  09330000
061400     IF PPS-RTC = 67                                              09340000
061500       MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD. 09350000
097000                                                                  09360000
097100 9000-EXIT.                                                       09370000
097100      EXIT.                                                       09380000
061700                                                                  09390000
097300******        L A S T   S O U R C E   S T A T E M E N T   *****   09400000
