000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.           IRCAL031.                                  00020012
000300*AUTHOR.            ED FRANEY.                                    00030000
000400*REMARKS.                CMS.                                     00040000
000500*       EFFECTIVE OCT 1 2002                                      00050013
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     'IRCAL031      - W O R K I N G   S T O R A G E'.             00190012
002000 01  CAL-VERSION                    PIC X(05)  VALUE 'C03.1'.     00200012
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).                  02541002
026400     05  H-DISCHARGE-DATE             PIC 9(08).                  02542003
028000                                                                  02550000
028100 LINKAGE SECTION.                                                 02560000
028200**************************************************************    02570000
028300*      THIS IS THE BILL-RECORD THAT WILL BE PASSED FROM      *    02580000
028400*      THE IRCAL___ PROGRAM                                  *    02590005
028500**************************************************************    02600000
028600 01  BILL-NEW-DATA.                                               02610000
028700         10  B-NPI10.                                             02620000
028800             15  B-NPI8             PIC X(08).                    02630000
028900             15  B-NPI-FILLER       PIC X(02).                    02640000
029000         10  B-PROVIDER-NO          PIC X(06).                    02650000
029100         10  B-PATIENT-STATUS       PIC X(02).                    02660000
029200         10  B-CMG-CODE             PIC X(05).                    02670000
029300         10  B-LOS                  PIC 9(03).                    02680000
029400         10  B-COV-DAYS             PIC 9(03).                    02690000
029500         10  B-LTR-DAYS             PIC 9(02).                    02700000
029600         10  B-SPEC-PAY-IND         PIC X(01).                    02710000
029700         10  B-DISCHARGE-DATE.                                    02720000
029800             15  B-DISCHG-CC        PIC 9(02).                    02730000
029900             15  B-DISCHG-YY        PIC 9(02).                    02740000
030000             15  B-DISCHG-MM        PIC 9(02).                    02750000
030100             15  B-DISCHG-DD        PIC 9(02).                    02760000
030200         10  B-COV-CHARGES          PIC 9(07)V9(02).              02770000
030300         10  FILLER                 PIC X(11).                    02780000
030400                                                                  02790000
030500***************************************************************   02800000
030600*    THIS DATA IS CALCULATED BY THIS IRCAL SUBROUTINE         *   02810000
030700*    AND PASSED BACK TO THE CALLING PROGRAM                   *   02820000
030800*            RETURN CODE VALUES (PPS-RTC)                     *   02830000
030900*                                                             *   02840000
031000*     ****   PPS-RTC 00-49 = HOW THE BILL WAS PAID            *   02850000
031100*              00 = PAID NORMAL CMG PAYMENT WITHOUT OUTLIER   *   02860000
031200*                                                             *   02870000
031300*              01 = PAID NORMAL CMG PAYMENT WITH OUTLIER      *   02880000
031400*                                                             *   02890000
031500*              02 = TRANSFER PAID ON A PERDIEM BASIS WITHOUT  *   02900000
031600*                   OUTLIER                                   *   02910000
031700*              03 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   02920000
031800*                   OUTLIER                                   *   02930000
031900*              04 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02940000
032000*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02950000
032100*                   WITHOUT OUTLIER                           *   02960000
032200*              05 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02970000
032300*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02980000
032400*                   WITH OUTLIER                              *   02990000
032500*              06 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03000000
032600*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03010000
032700*                   RATE -- WITHOUT OUTLIER                   *   03020000
032800*              07 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03030000
032900*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03040000
033000*                   RATE -- WITH OUTLIER                      *   03050000
033100*       **** NEW RT CODES FOR PAYMENT WITH PENALTIES          *   03060000
031100*              10 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   03070000
031200*                   WITHOUT OUTLIER                           *   03080000
031300*              11 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   03090000
031400*                   WITH OUTLIER                              *   03100000
031500*              12 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   03110000
031600*                   PENALTY WITHOUT OUTLIER                   *   03120000
031700*              13 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   03130000
031800*                   PENALTY WITH OUTLIER                      *   03140000
031900*              14 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   03150000
032000*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   03160000
032100*                   WITH PENALTY WITHOUT OUTLIER              *   03170000
032200*              15 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   03180000
032300*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   03190000
032400*                   WITH PENALTY WITH OUTLIER                 *   03200000
032500*              16 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03210000
032600*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03220000
032700*                   RATE -- WITH PENALTY WITHOUT OUTLIER      *   03230000
032800*              17 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03240000
032900*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03250000
033000*                   RATE -- WITH PENALTY WITH OUTLIER         *   03260000
033100*                                                             *   03270000
033200*      ****  PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   03280000
033300*              50 = PROVIDER SPECIFIC RATE NOT NUMERIC        *   03290000
033400*              51 = PROVIDER RECORD TERMINATED                *   03300000
033500*              52 = INVALID WAGE INDEX                        *   03310000
033600*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   03320000
033700*              54 = CMG ON CLAIM NOT FOUND IN TABLE           *   03330000
033800*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   03340000
033900*                                      OR                     *   03350000
034000*                   DISCHARGE DATE < MSA EFF START DATE       *   03360000
034100*                   FOR PPS                                   *   03370000
034500*              56 = INVALID LENGTH OF STAY                    *   03380000
034600*              57 = PROVIDER SPECIFIC RATE ZERO WHEN BLENDED  *   03390000
034700*                   PAYMENT REQUESTED                         *   03400000
034800*              58 = TOTAL COVERED CHARGES NOT NUMERIC         *   03410000
034900*              59 = PROVIDER SPECIFIC RECORD NOT FOUND        *   03420000
035000*              60 = MSA WAGE INDEX RECORD NOT FOUND           *   03430000
035100*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *   03440000
035200*                   OR BILL-LTR-DAYS > 60                     *   03450000
035300*              62 = INVALID NUMBER OF COVERED DAYS            *   03460000
035500*              65 = OPERATING COST-TO-CHARGE RATIO NOT NUMERIC*   03470000
035600*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *   03480000
035700*                   OR COST OUTLIER THRESHOLD CALCULATION     *   03490000
035800*              72 = INVALID BLEND INDICATOR (NOT 3 OR 4)      *   03500000
035900*              73 = DISCHARGED BEFORE PROVIDER FY BEGIN       *   03510000
036100*              74 = PROVIDER FY BEGIN DATE NOT IN 2002        *   03520000
036200***************************************************************   03530000
036300 01  PPS-DATA-ALL.                                                03540000
036500     05  PPS-RTC                      PIC 9(02).                  03550000
036400     05  PPS-DATA.                                                03560000
036600         10  PPS-MSA                  PIC X(04).                  03570000
036700         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).            03580000
036800         10  PPS-AVG-LOS              PIC 9(02).                  03590000
036900         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).            03600000
037000         10  PPS-TOTAL-PAY-AMT        PIC 9(07)V9(02).            03610000
037100         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).            03620000
037200         10  PPS-FAC-SPEC-PAY-AMT     PIC 9(07)V9(02).            03630000
037300         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).            03640000
037300         10  PPS-LIP-PAY-AMT          PIC 9(07)V9(02).            03650000
037400         10  PPS-LIP-PCT              PIC 9(01)V9(04).            03660000
037500         10  PPS-LOS                  PIC 9(03).                  03670000
037600         10  PPS-REG-DAYS-USED        PIC 9(03).                  03680000
037700         10  PPS-LTR-DAYS-USED        PIC 9(03).                  03690000
037800         10  PPS-TRANSFER-PCT         PIC 9(01)V9(04).            03700000
037900         10  PPS-FAC-SPEC-RT-PREBLEND PIC 9(05)V9(02).            03710000
038000         10  PPS-STANDARD-PAY-AMT     PIC 9(07)V9(02).            03720000
038200         10  PPS-FAC-COSTS            PIC 9(07)V9(02).            03730000
038300         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).            03740000
038400         10  PPS-CHG-OUTLIER-THRESHOLD PIC 9(07)V9(02).           03750000
037000         10  PPS-TOTAL-PENALTY-AMT    PIC 9(07)V9(02).            03760000
037000         10  PPS-FED-PENALTY-AMT      PIC 9(07)V9(02).            03770000
037000         10  PPS-LIP-PENALTY-AMT      PIC 9(07)V9(02).            03780000
037000         10  PPS-OUT-PENALTY-AMT      PIC 9(07)V9(02).            03790000
038500         10  PPS-SUBM-CMG-CODE        PIC X(05).                  03800000
027300         10  PPS-CMG-CODE-REDEF REDEFINES PPS-SUBM-CMG-CODE.      03810000
027400            15  PPS-CMG-ALPHA         PIC X(01).                  03820000
027500            15  PPS-CMG-NUMERIC.                                  03830000
027600               20  PPS-CMG-RIC        PIC X(02).                  03840000
027700               20  FILLER             PIC X(02).                  03850000
038600         10  PPS-PRICED-CMG-CODE      PIC X(05).                  03860000
038700         10  PPS-CALC-VERS-CD         PIC X(05).                  03870000
038800         10  FILLER                   PIC X(13).                  03880000
038900     05  PPS-OTHER-DATA.                                          03890000
039000         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).            03900000
039100         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).            03910000
039200         10  PPS-NAT-THRESHOLD-ADJ    PIC 9(05)V9(02).            03920000
039400         10  PPS-BDGT-NEUT-CONV-AMT   PIC 9(05)V9(02).            03930000
039500         10  PPS-FED-RATE-PCT         PIC 9(01)V9(04).            03940000
039600         10  PPS-FAC-RATE-PCT         PIC 9(01)V9(04).            03950000
039700         10  PPS-RURAL-ADJUSTMENT     PIC 9(01)V9(04).            03960000
039800         10  FILLER                   PIC X(20).                  03970000
039900     05  PPS-PC-DATA.                                             03980000
040000         10  PPS-COT-IND              PIC X(01).                  03990000
040100         10  FILLER                   PIC X(20).                  04000000
040200                                                                  04010000
040300******************************************************************04020000
040400*            THESE ARE THE VERSIONS OF THE IRDRV___               04030004
040500*           PROGRAMS THAT WILL BE PASSED BACK----                 04040000
040600*          ASSOCIATED WITH THE BILL BEING PROCESSED               04050000
040700******************************************************************04060000
040800 01  PRICER-OPT-VERS-SW.                                          04070000
040900     05  PRICER-OPTION-SW          PIC X(01).                     04080000
041000         88  ALL-TABLES-PASSED          VALUE 'A'.                04090000
041100         88  PROV-RECORD-PASSED         VALUE 'P'.                04100000
041200     05  PPS-VERSIONS.                                            04110000
041300         10  PPDRV-VERSION         PIC X(05).                     04120000
041500                                                                  04130000
041600**************************************************************    04140000
041700*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BY        *    04150000
041800*      THE IRCAL___ PROGRAM                                  *    04160004
041900**************************************************************    04170000
042000 01  PROV-NEW-HOLD.                                               04180000
042100     02  PROV-NEWREC-HOLD1.                                       04190000
042200         05  P-NEW-NPI10.                                         04200000
042300             10  P-NEW-NPI8             PIC X(08).                04210000
042400             10  P-NEW-NPI-FILLER       PIC X(02).                04220000
042500         05  P-NEW-PROVIDER-NO.                                   04230000
042600             10  P-NEW-STATE            PIC 9(02).                04240000
042700             10  FILLER                 PIC X(04).                04250000
042800         05  P-NEW-DATE-DATA.                                     04260000
042900             10  P-NEW-EFF-DATE.                                  04270000
043000                 15  P-NEW-EFF-DT-CC    PIC 9(02).                04280000
043100                 15  P-NEW-EFF-DT-YY    PIC 9(02).                04290000
043200                 15  P-NEW-EFF-DT-MM    PIC 9(02).                04300000
043300                 15  P-NEW-EFF-DT-DD    PIC 9(02).                04310000
043400             10  P-NEW-FY-BEGIN-DATE.                             04320000
043500                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                04330000
043600                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                04340000
043700                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                04350000
043800                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                04360000
043900             10  P-NEW-REPORT-DATE.                               04370000
044000                 15  P-NEW-REPORT-DT-CC PIC 9(02).                04380000
044100                 15  P-NEW-REPORT-DT-YY PIC 9(02).                04390000
044200                 15  P-NEW-REPORT-DT-MM PIC 9(02).                04400000
044300                 15  P-NEW-REPORT-DT-DD PIC 9(02).                04410000
044400             10  P-NEW-TERMINATION-DATE.                          04420000
044500                 15  P-NEW-TERM-DT-CC   PIC 9(02).                04430000
044600                 15  P-NEW-TERM-DT-YY   PIC 9(02).                04440000
044700                 15  P-NEW-TERM-DT-MM   PIC 9(02).                04450000
044800                 15  P-NEW-TERM-DT-DD   PIC 9(02).                04460000
044900         05  P-NEW-WAIVER-CODE          PIC X(01).                04470000
045000             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              04480000
045100         05  P-NEW-INTER-NO             PIC 9(05).                04490000
045200         05  P-NEW-PROVIDER-TYPE        PIC X(02).                04500000
047000         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                04510000
048000         05  P-NEW-CURRENT-DIV   REDEFINES                        04520000
048100                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         04530000
048300         05  P-NEW-MSA-DATA.                                      04540000
048400             10  P-NEW-CHG-CODE-INDEX       PIC X.                04550000
048500             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 04560000
048600             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   04570000
048700                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       04580000
048800             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 04590000
048900             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 04600000
049000             10  P-NEW-STAND-AMT-LOC-MSA9                         04610000
049100                 REDEFINES P-NEW-STAND-AMT-LOC-MSA.               04620000
049200                 15  P-NEW-RURAL-1ST.                             04630000
049300                     20  P-NEW-STAND-RURAL  PIC XX.               04640000
049400                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    04650000
049500                 15  P-NEW-RURAL-2ND        PIC XX.               04660000
049600         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    04670000
050000         05  P-NEW-LUGAR                    PIC X.                04680000
050100         05  P-NEW-TEMP-RELIEF-IND          PIC X.                04690000
050200         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                04700000
050300         05  FILLER                         PIC X(05).            04710000
050400     02  PROV-NEWREC-HOLD2.                                       04720000
050500         05  P-NEW-VARIABLES.                                     04730000
050600             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        04740000
050700             10  P-NEW-COLA              PIC  9(01)V9(03).        04750000
050800             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        04760000
050900             10  P-NEW-BED-SIZE          PIC  9(05).              04770000
051000             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        04780000
051100             10  P-NEW-CMI               PIC  9(01)V9(04).        04790000
051200             10  P-NEW-SSI-RATIO         PIC  V9(04).             04800000
051300             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             04810000
051400             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              04820000
051500             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        04830000
051600             10  P-NEW-DSH-PERCENT       PIC  V9(04).             04840000
051700             10  P-NEW-FYE-DATE          PIC  X(08).              04850000
051800         05  FILLER                      PIC  X(23).              04860000
051900     02  PROV-NEWREC-HOLD3.                                       04870000
052000         05  P-NEW-PASS-AMT-DATA.                                 04880000
052100             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          04890000
052200             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          04900000
052300             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          04910000
052400             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          04920000
052500         05  P-NEW-CAPI-DATA.                                     04930000
052600             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 04940000
052700             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          04950000
052800             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          04960000
052900             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        04970000
053000             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             04980000
053100             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 04990000
053200             15  P-NEW-CAPI-IME            PIC 9V9999.            05000000
053300             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          05010000
053400         05  FILLER                        PIC X(22).             05020000
053500******************************************************************05030000
053600*                   THIS IS THE WAGE-INDEX                        05040000
053700*          ASSOCIATED WITH THE BILL BEING PROCESSED               05050000
053800******************************************************************05060000
053900 01  WAGE-NEW-INDEX-RECORD.                                       05070000
054000     05  W-MSA                         PIC X(4).                  05080000
054100     05  W-EFF-DATE                    PIC X(8).                  05090000
054200     05  W-WAGE-INDEX                  PIC S9(02)V9(04).          05100000
054400                                                                  05110000
054500 PROCEDURE DIVISION  USING BILL-NEW-DATA                          05120000
054600                           PPS-DATA-ALL                           05130000
054700                           PRICER-OPT-VERS-SW                     05140000
054800                           PROV-NEW-HOLD                          05150000
054900                           WAGE-NEW-INDEX-RECORD.                 05160000
055000                                                                  05170000
055100***************************************************************   05180000
055200*    PROCESSING:                                              *   05190000
055300*        A. WILL PROCESS CLAIMS BASED ON DISCHARGE DATE       *   05200000
055400*        B. INITIALIZE IRCAL HOLD VARIABLES.                  *   05210000
055500*        C. EDIT THE DATA PASSED FROM THE CLAIM BEFORE        *   05220000
055600*           ATTEMPTING TO CALCULATE PPS. IF THIS CLAIM        *   05230000
055700*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   05240000
055800*           GOBACK.                                           *   05250000
055900*        D. ASSEMBLE PRICING COMPONENTS.                      *   05260000
056000*        E. CALCULATE THE PRICE.                              *   05270000
056100*        F. CALCULATE OUTLIERS IF APPLICABLE.                 *   05280000
056200***************************************************************   05290000
056300                                                                  05300000
056400 0000-MAINLINE-CONTROL.                                           05310000
056500                                                                  05320000
           PERFORM 0100-INITIAL-ROUTINE                                 05330000
              THRU 0100-EXIT.                                           05340000
063400     PERFORM 1000-EDIT-THE-BILL-INFO                              05350000
063400        THRU 1000-EXIT.                                           05360000
063600     IF PPS-RTC = 00                                              05370000
065800        PERFORM 1700-EDIT-CMG-CODE                                05380000
                 THRU 1700-EXIT.                                        05390000
063500                                                                  05400000
063600     IF PPS-RTC = 00                                              05410000
063700        PERFORM 2000-ASSEMBLE-PPS-VARIABLES                       05420000
063700           THRU 2000-EXIT.                                        05430000
063800                                                                  05440000
063900     IF PPS-RTC = 00                                              05450000
064000        PERFORM 3000-CALC-PAYMENT                                 05460000
064000           THRU 3000-EXIT                                         05470000
064000        PERFORM 3500-CONTINUE-CALC                                05480000
064000           THRU 3500-EXIT                                         05490000
064100        PERFORM 4000-CALC-OUTLIER                                 05500000
064100           THRU 4000-EXIT                                         05510000
064200        PERFORM 5000-FINAL-PAYMENTS                               05520000
064200           THRU 5000-EXIT.                                        05530000
                                                                        05540000
064200     PERFORM 9000-MOVE-RESULTS                                    05550000
064200        THRU 9000-EXIT.                                           05560000
064300                                                                  05570000
061800     GOBACK.                                                      05580000
061900                                                                  05590000
062000 0100-INITIAL-ROUTINE.                                            05600000
062100                                                                  05610000
           MOVE ZEROS TO PPS-RTC.                                       05620000
062200     INITIALIZE PPS-DATA.                                         05630000
062300     INITIALIZE PPS-OTHER-DATA.                                   05640000
062400     INITIALIZE HOLD-PPS-COMPONENTS.                              05650000
062500                                                                  05660000
062600     MOVE .72395 TO PPS-NAT-LABOR-PCT.                            05670000
062700     MOVE .27605 TO PPS-NAT-NONLABOR-PCT.                         05680000
062800     MOVE 11211  TO PPS-NAT-THRESHOLD-ADJ.                        05690000
063000     MOVE 12193  TO PPS-BDGT-NEUT-CONV-AMT.                       05700000
062100                                                                  05710000
062000 0100-EXIT.                                                       05720000
062100      EXIT.                                                       05730000
063100                                                                  05740000
064400 1000-EDIT-THE-BILL-INFO.                                         05750000
064500***************************************************************   05760000
064600*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *   05770000
064700*    AND DO NOT ATTEMPT TO PRICE.                             *   05780000
064800***************************************************************   05790000
064900                                                                  05800000
065000     MOVE B-CMG-CODE TO PPS-SUBM-CMG-CODE.                        05810000
065100                                                                  05820000
065200     IF (B-LOS NUMERIC) AND (B-LOS > 0)                           05830000
065400        MOVE B-LOS TO H-LOS                                       05840000
065500     ELSE                                                         05850000
              IF B-LOS = 0                                              05860000
                 MOVE 1 TO H-LOS                                        05870000
              ELSE                                                      05880000
065600           MOVE 56 TO PPS-RTC.                                    05890000
                                                                        05891003
065900     MOVE P-NEW-FY-BEGIN-DATE TO H-FY-BEGIN-DATE.                 05900002
           IF H-FY-BEGIN-DATE (5:2) < 11                                05900110
             COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 10200          05900210
           ELSE                                                         05900310
             COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 19000.         05900510
065900     MOVE B-DISCHARGE-DATE TO H-DISCHARGE-DATE.                   05900603
066100     IF (H-DISCHARGE-DATE > H-FY-BEGIN-DATE)                      05901010
              OR (P-NEW-FY-BEGIN-DATE > 20020930 AND                    05901109
                  P-NEW-FY-BEGIN-DATE < 20030101)                       05901209
066300        MOVE '4' TO P-NEW-FED-PPS-BLEND-IND.                      05902001
                                                                        05903001
066000     IF P-NEW-FY-BEGIN-DATE > 20011231                            05910000
066100        IF (P-NEW-FY-BEGIN-DATE <= B-DISCHARGE-DATE)              05920000
066300           IF P-NEW-FED-PPS-BLEND-IND = '4'                       05930000
066400              MOVE 1.0000 TO PPS-FED-RATE-PCT                     05940000
066500              MOVE 0.0000 TO PPS-FAC-RATE-PCT                     05950000
066600           ELSE                                                   05960000
066700             IF P-NEW-FED-PPS-BLEND-IND = '3'                     05970000
066800                MOVE .6667 TO PPS-FED-RATE-PCT                    05980000
066900                MOVE .3333 TO PPS-FAC-RATE-PCT                    05990000
067000             ELSE                                                 06000000
067100               MOVE 72 TO PPS-RTC                                 06010000
067200        ELSE                                                      06020000
067300           MOVE 73 TO PPS-RTC                                     06030000
067400     ELSE                                                         06040000
067500        MOVE 74 TO PPS-RTC.                                       06050000
067600                                                                  06060000
067700     IF PPS-RTC = 00                                              06070000
067800       IF P-NEW-WAIVER-STATE                                      06080000
067900          MOVE 53 TO PPS-RTC.                                     06090000
                                                                        06100000
068000     IF PPS-RTC = 00                                              06110000
068200         IF ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR               06120000
068300            (B-DISCHARGE-DATE < W-EFF-DATE))                      06130000
068400            MOVE 55 TO PPS-RTC.                                   06140000
068500                                                                  06150000
068600     IF PPS-RTC = 00                                              06160000
068700         IF P-NEW-TERMINATION-DATE > 00000000                     06170000
068800            IF B-DISCHARGE-DATE >= P-NEW-TERMINATION-DATE         06180000
069000               MOVE 51 TO PPS-RTC.                                06190000
069100                                                                  06200000
069200     IF PPS-RTC = 00                                              06210000
069300         IF B-COV-CHARGES NOT NUMERIC                             06220000
069400            MOVE 58 TO PPS-RTC.                                   06230000
069500                                                                  06240000
069600     IF PPS-RTC = 00                                              06250000
069700        IF B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60              06260000
069800           MOVE 61 TO PPS-RTC                                     06270000
070100        ELSE                                                      06280000
                 MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.                  06290000
                                                                        06300000
070200     IF PPS-RTC = 00                                              06310000
070300        IF B-COV-DAYS NOT NUMERIC                                 06320000
070400             MOVE 62 TO PPS-RTC                                   06330000
070500        ELSE                                                      06340000
070600          IF B-COV-DAYS = 0 AND H-LOS > 0                         06350000
070700             MOVE 62 TO PPS-RTC.                                  06360000
071000                                                                  06370000
071100     IF PPS-RTC = 00                                              06380000
071200        IF B-LTR-DAYS  > B-COV-DAYS                               06390000
071300           MOVE 62 TO PPS-RTC                                     06400000
071400        ELSE                                                      06410000
071500           COMPUTE PPS-REG-DAYS-USED = B-COV-DAYS - B-LTR-DAYS.   06420000
071600                                                                  06430000
071100     IF PPS-RTC = 00                                              06440000
071700        IF PPS-REG-DAYS-USED > 0                                  06450000
071800           IF PPS-REG-DAYS-USED > H-LOS                           06460000
071900              MOVE H-LOS TO PPS-REG-DAYS-USED                     06470000
072000           ELSE                                                   06480000
072100              NEXT SENTENCE                                       06490000
072200        ELSE                                                      06500000
072300           IF B-LTR-DAYS > H-LOS                                  06510000
072400              MOVE H-LOS TO PPS-LTR-DAYS-USED                     06520000
072500           ELSE                                                   06530000
072600              MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.               06540000
072700                                                                  06550000
072900 1000-EXIT.                                                       06560000
073000      EXIT.                                                       06570000
                                                                        06580000
073200***************************************************************   06590000
073300*    FINDS THE CMG CODE IN THE TABLE                          *   06600000
073400***************************************************************   06610000
073100 1700-EDIT-CMG-CODE.                                              06620000
073500                                                                  06630000
           IF PPS-CMG-NUMERIC < '2103'                                  06640000
              NEXT SENTENCE                                             06650000
           ELSE                                                         06660000
              MOVE 54 TO PPS-RTC.                                       06670000
                                                                        06680000
           IF PPS-RTC = 00                                              06690000
074500        SEARCH ALL CMG-DATA                                       06700000
074600           AT END                                                 06710000
074700             MOVE 54 TO PPS-RTC                                   06720000
074800        WHEN CMG-NUM (DX6) = PPS-CMG-NUMERIC                      06730000
075200             PERFORM 1750-FIND-VALUE                              06740000
075300                THRU 1750-EXIT                                    06750000
              END-SEARCH.                                               06760000
                                                                        06770000
       1700-EXIT.                                                       06780000
            EXIT.                                                       06790000
                                                                        06800000
073200***************************************************************   06810000
073300*    FINDS THE VALUE IN THE CMG CODE IN THE TABLE             *   06820000
073400***************************************************************   06830000
073100 1750-FIND-VALUE.                                                 06840000
073500                                                                  06850000
075200      IF PPS-CMG-ALPHA = 'A'                                      06860000
075300         MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                 06870000
075400         MOVE A-LOS-TABLE (DX6) TO PPS-AVG-LOS                    06880000
075500      ELSE                                                        06890000
075600         IF PPS-CMG-ALPHA = 'B'                                   06900000
075700            MOVE B-REL-WGT (DX6) TO PPS-RELATIVE-WGT              06910000
075800            MOVE B-LOS-TABLE (DX6) TO PPS-AVG-LOS                 06920000
075900         ELSE                                                     06930000
076000            IF PPS-CMG-ALPHA = 'C'                                06940000
076100               MOVE C-REL-WGT (DX6) TO PPS-RELATIVE-WGT           06950000
076200               MOVE C-LOS-TABLE (DX6) TO PPS-AVG-LOS              06960000
076300            ELSE                                                  06970000
076400               IF PPS-CMG-ALPHA = 'D'                             06980000
076500                  MOVE D-REL-WGT (DX6) TO PPS-RELATIVE-WGT        06990000
076600                  MOVE D-LOS-TABLE (DX6) TO PPS-AVG-LOS           07000000
076700               ELSE                                               07010000
076800                  MOVE 54 TO PPS-RTC.                             07020000
                                                                        07030000
       1750-EXIT.                                                       07040000
            EXIT.                                                       07050000
                                                                        07060000
077100***************************************************************   07070000
077200*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *   07080000
077300*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   07090000
077400*    OF THAT VARIABLE.                                        *   07100000
077500***************************************************************   07110000
077600***  GET THE PROVIDER SPECIFIC VARIABLE AND WAGE INDEX            07120000
077700***************************************************************   07130000
077000 2000-ASSEMBLE-PPS-VARIABLES.                                     07140000
077800                                                                  07150000
077900     IF P-NEW-FAC-SPEC-RATE NUMERIC                               07160000
078000        MOVE P-NEW-FAC-SPEC-RATE TO PPS-FAC-SPEC-RT-PREBLEND      07170000
078100     ELSE                                                         07180000
078200        MOVE 50 TO PPS-RTC                                        07190000
              GO TO 2000-EXIT.                                          07200000
                                                                        07210000
078400     IF P-NEW-FED-PPS-BLEND-IND = '3'                             07220000
078600        IF PPS-FAC-SPEC-RT-PREBLEND = 0                           07230000
078700          MOVE 57 TO PPS-RTC                                      07240000
                GO TO 2000-EXIT.                                        07250000
078800                                                                  07260000
078900     IF W-WAGE-INDEX NUMERIC AND W-WAGE-INDEX > 0                 07270000
079000        MOVE W-WAGE-INDEX TO PPS-WAGE-INDEX                       07280000
079100     ELSE                                                         07290000
079200        MOVE 52 TO PPS-RTC                                        07300000
              GO TO 2000-EXIT.                                          07310000
079300                                                                  07320000
079400     IF P-NEW-OPER-CSTCHG-RATIO NOT NUMERIC                       07330000
080100        MOVE 65 TO PPS-RTC.                                       07340000
080200                                                                  07350000
077000 2000-EXIT.                                                       07360000
            EXIT.                                                       07370000
080300                                                                  07380000
080500***************************************************************   07390000
080600*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *   07400000
080700*        CALCULATE THE FEDERAL PORTION.                       *   07410000
080800*        CALCULATE THE HOSPITAL PORTION.                      *   07420000
080900*        CALCULATE THE COST-OUTLIER PORTION.                  *   07430000
081000*        CALCULATE THE LIP ADJUSTMENT PERCENTAGE.             *   07440000
081100***************************************************************   07450000
080400 3000-CALC-PAYMENT.                                               07460000
081300                                                                  07470000
081200***  LIP PERCENTAGE CALCULATION *******************************   07480000
081300                                                                  07490000
081400      COMPUTE H-WK-DSH = (P-NEW-SSI-RATIO                         07500000
081500                           + P-NEW-MEDICAID-RATIO).               07510000
081600                                                                  07520000
081700      COMPUTE PPS-LIP-PCT ROUNDED =                               07530000
081800            ((1 + H-WK-DSH) ** .4838) - 1.                        07540000
081900                                                                  07550000
082000***************************************************************   07560000
082100                                                                  07570000
082200     MOVE 1.0000 TO PPS-TRANSFER-PCT.                             07580000
082300                                                                  07590000
082400     IF B-PATIENT-STATUS =                                        07600000
082500         ('02' OR '03' OR '61' OR '62' OR '63' OR '64')           07610011
082600        IF H-LOS < PPS-AVG-LOS                                    07620000
082700           COMPUTE PPS-TRANSFER-PCT =                             07630000
082800               ((H-LOS + .5) / PPS-AVG-LOS)                       07640000
082900           MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE          07650000
083000           GO TO 3000-EXIT.                                       07660000
083100                                                                  07670000
083200     IF H-LOS > 3                                                 07680000
083300        NEXT SENTENCE                                             07690000
083400     ELSE                                                         07700000
083500        MOVE 'A5001' TO PPS-PRICED-CMG-CODE                       07710000
083600        SET DX6 TO 96                                             07720000
083700        MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                  07730000
083800        GO TO 3000-EXIT.                                          07740000
083900                                                                  07750000
084000     IF B-PATIENT-STATUS = '20'                                   07760000
084100        NEXT SENTENCE                                             07770000
084200     ELSE                                                         07780000
084300        MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE             07790000
084400        GO TO 3000-EXIT.                                          07800000
084500                                                                  07810000
084600     IF PPS-CMG-RIC = ('07' OR '08' OR '09')                      07820000
084700        IF H-LOS < 14                                             07830000
084800           MOVE 'A5101' TO PPS-PRICED-CMG-CODE                    07840000
084900           SET DX6 TO 97                                          07850000
085000           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               07860000
085100        ELSE                                                      07870000
085200           MOVE 'A5102' TO PPS-PRICED-CMG-CODE                    07880000
085300           SET DX6 TO 98                                          07890000
085400           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               07900000
085500     ELSE                                                         07910000
085600        IF H-LOS < 16                                             07920000
085700           MOVE 'A5103' TO PPS-PRICED-CMG-CODE                    07930000
085800           SET DX6 TO 99                                          07940000
085900           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               07950000
086000        ELSE                                                      07960000
086100           MOVE 'A5104' TO PPS-PRICED-CMG-CODE                    07970000
086200           SET DX6 TO 100                                         07980000
086300           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT.              07990000
086400                                                                  08000000
086500 3000-EXIT.                                                       08010000
086500      EXIT.                                                       08020000
086600                                                                  08030000
087300 3500-CONTINUE-CALC.                                              08040000
086800                                                                  08050000
086900     COMPUTE PPS-STANDARD-PAY-AMT =                               08060000
087000            (PPS-TRANSFER-PCT * PPS-RELATIVE-WGT                  08070000
087000                      * PPS-BDGT-NEUT-CONV-AMT).                  08080000
087100                                                                  08090000
087400     IF W-MSA (1:2) = '  '                                        08100000
087500        MOVE 1.1914 TO PPS-RURAL-ADJUSTMENT                       08110000
087600     ELSE                                                         08120000
087700        MOVE 1.0000 TO PPS-RURAL-ADJUSTMENT.                      08130000
087800                                                                  08140000
087900     COMPUTE H-LABOR-PORTION =                                    08150000
088000        (PPS-STANDARD-PAY-AMT * PPS-NAT-LABOR-PCT)                08160000
088000          * PPS-WAGE-INDEX.                                       08170000
088100                                                                  08180000
088200     COMPUTE H-NONLABOR-PORTION =                                 08190000
088300        (PPS-STANDARD-PAY-AMT * PPS-NAT-NONLABOR-PCT).            08200000
088400                                                                  08210000
088500     COMPUTE PPS-FED-PAY-AMT ROUNDED =                            08220000
088600        ((H-LABOR-PORTION + H-NONLABOR-PORTION) *                 08230000
088700         PPS-RURAL-ADJUSTMENT).                                   08240000
088400                                                                  08250000
088500     COMPUTE PPS-LIP-PAY-AMT ROUNDED =                            08260000
088600        (PPS-FED-PAY-AMT * PPS-LIP-PCT).                          08270000
088800                                                                  08280000
088900 3500-EXIT.                                                       08290000
089000      EXIT.                                                       08300000
088800                                                                  08310000
089100 4000-CALC-OUTLIER.                                               08320000
089200                                                                  08330000
089300     COMPUTE PPS-FAC-COSTS ROUNDED =                              08340000
089400         (B-COV-CHARGES * P-NEW-OPER-CSTCHG-RATIO).               08350000
089500                                                                  08360000
089600     COMPUTE H-OUTLIER-LABOR-PORTION =                            08370000
089700        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-LABOR-PCT)               08380000
089800              * PPS-WAGE-INDEX.                                   08390000
089900                                                                  08400000
090000     COMPUTE H-OUTLIER-NONLABOR-PORTION =                         08410000
090100        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-NONLABOR-PCT).           08420000
090200                                                                  08430000
090300     COMPUTE H-FP-OUTLIER-THRESHOLD ROUNDED =                     08440000
090400        ((H-OUTLIER-LABOR-PORTION + H-OUTLIER-NONLABOR-PORTION) * 08450000
090500         PPS-RURAL-ADJUSTMENT * (PPS-LIP-PCT + 1)).               08460000
090600                                                                  08470000
090700     COMPUTE H-OUTLIER-THRESHOLD ROUNDED =                        08480000
090800        (PPS-FED-PAY-AMT + H-FP-OUTLIER-THRESHOLD +               08490000
               PPS-LIP-PAY-AMT).                                        08500000
090900                                                                  08510000
091000     IF PPS-FAC-COSTS > H-OUTLIER-THRESHOLD                       08520000
091100        COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                     08530000
091200           ((PPS-FAC-COSTS - H-OUTLIER-THRESHOLD) * .8).          08540000
091300                                                                  08550000
091400     COMPUTE H-CHG-OUTLIER-THRESHOLD ROUNDED =                    08560000
091500         H-OUTLIER-THRESHOLD / P-NEW-OPER-CSTCHG-RATIO.           08570000
091600                                                                  08580000
                                                                        08590000
091700 4000-EXIT.                                                       08600000
091700      EXIT.                                                       08610000
091800                                                                  08620000
091900 5000-FINAL-PAYMENTS.                                             08630000
092000                                                                  08640000
092100     IF B-SPEC-PAY-IND = '1' OR '3'                               08650000
092200         MOVE ZEROES TO PPS-OUTLIER-PAY-AMT.                      08660000
092300                                                                  08670000
092400     IF PPS-FED-RATE-PCT = 1.0000                                 08680000
092600         MOVE 0                  TO PPS-FAC-SPEC-PAY-AMT          08690000
092800     ELSE                                                         08700000
092900         COMPUTE PPS-FED-PAY-AMT ROUNDED =                        08710000
093000           (PPS-FED-RATE-PCT * PPS-FED-PAY-AMT)                   08720000
093100         COMPUTE PPS-FAC-SPEC-PAY-AMT ROUNDED =                   08730000
093200           (PPS-FAC-RATE-PCT * PPS-FAC-SPEC-RT-PREBLEND)          08740000
093300         COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                    08750000
093400           (PPS-FED-RATE-PCT * PPS-OUTLIER-PAY-AMT)               08760000
093300         COMPUTE PPS-LIP-PAY-AMT ROUNDED =                        08770000
093400           (PPS-FED-RATE-PCT * PPS-LIP-PAY-AMT).                  08780000
093500                                                                  08790000
           IF B-SPEC-PAY-IND = '2' OR '3'                               08800000
093600        COMPUTE PPS-FED-PENALTY-AMT ROUNDED =                     08810000
093700           (PPS-FED-PAY-AMT * .25)                                08820000
093600        COMPUTE PPS-FED-PAY-AMT =                                 08830000
093700           (PPS-FED-PAY-AMT - PPS-FED-PENALTY-AMT)                08840000
093600        COMPUTE PPS-LIP-PENALTY-AMT ROUNDED =                     08850000
093700           (PPS-LIP-PAY-AMT * .25)                                08860000
093600        COMPUTE PPS-LIP-PAY-AMT =                                 08870000
093700           (PPS-LIP-PAY-AMT - PPS-LIP-PENALTY-AMT)                08880000
093600        COMPUTE PPS-OUT-PENALTY-AMT ROUNDED =                     08890000
093700           (PPS-OUTLIER-PAY-AMT * .25)                            08900000
093600        COMPUTE PPS-OUTLIER-PAY-AMT =                             08910000
093700           (PPS-OUTLIER-PAY-AMT - PPS-OUT-PENALTY-AMT)            08920000
              COMPUTE PPS-TOTAL-PENALTY-AMT =                           08930000
                 (PPS-FED-PENALTY-AMT + PPS-LIP-PENALTY-AMT             08940000
                 + PPS-OUT-PENALTY-AMT).                                08950000
                                                                        08960000
093600     COMPUTE PPS-TOTAL-PAY-AMT ROUNDED =                          08970000
093700        (PPS-FED-PAY-AMT + PPS-FAC-SPEC-PAY-AMT                   08980000
093800         + PPS-OUTLIER-PAY-AMT + PPS-LIP-PAY-AMT).                08990000
093900                                                                  09000000
                                                                        09010000
094000     IF PPS-FED-RATE-PCT = 1.0000                                 09020000
094100        IF PPS-TRANSFER-PCT = 1.0000                              09030000
094200           IF PPS-OUTLIER-PAY-AMT > 0.0                           09040000
094300              MOVE 01 TO PPS-RTC                                  09050000
094400           ELSE                                                   09060000
094500              MOVE 00 TO PPS-RTC                                  09070000
094600        ELSE                                                      09080000
094700           IF PPS-OUTLIER-PAY-AMT > 0.0                           09090000
094800              MOVE 03 TO PPS-RTC                                  09100000
094900           ELSE                                                   09110000
095000              MOVE 02 TO PPS-RTC                                  09120000
095100     ELSE                                                         09130000
095200        IF PPS-TRANSFER-PCT = 1.0000                              09140000
095300           IF PPS-OUTLIER-PAY-AMT > 0.0                           09150000
095400              MOVE 05 TO PPS-RTC                                  09160000
095500           ELSE                                                   09170000
095600              MOVE 04 TO PPS-RTC                                  09180000
095700        ELSE                                                      09190000
095800           IF PPS-OUTLIER-PAY-AMT > 0.0                           09200000
095900              MOVE 07 TO PPS-RTC                                  09210000
096000           ELSE                                                   09220000
096100              MOVE 06 TO PPS-RTC.                                 09230000
096300                                                                  09240000
           IF B-SPEC-PAY-IND = '2' OR '3'                               09250000
096200        COMPUTE PPS-RTC = PPS-RTC + 10.                           09260000
096400     IF PPS-RTC = (01 OR 03 OR 05 OR 07                           09270000
096400                OR 11 OR 13 OR 15 OR 17)                          09280000
096500        IF ((PPS-REG-DAYS-USED + PPS-LTR-DAYS-USED) < H-LOS)      09290000
096600           OR PPS-COT-IND = 'Y'                                   09300000
096700            MOVE 67 TO PPS-RTC.                                   09310000
097000                                                                  09320000
097100 5000-EXIT.                                                       09330000
097100      EXIT.                                                       09340000
097200                                                                  09350000
       9000-MOVE-RESULTS.                                               09360000
                                                                        09370000
056600     IF PPS-RTC < 50                                              09380000
056700      MOVE H-LOS                   TO  PPS-LOS                    09390000
057300      MOVE H-OUTLIER-THRESHOLD     TO  PPS-OUTLIER-THRESHOLD      09400000
057400      MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD   09410000
057800      MOVE W-MSA                   TO  PPS-MSA                    09420000
058300      MOVE 'V03.1'                 TO  PPS-CALC-VERS-CD           09430013
058400     ELSE                                                         09440000
062200       INITIALIZE PPS-DATA                                        09450000
062300       INITIALIZE PPS-OTHER-DATA                                  09460000
061200       MOVE 'V03.1'                TO  PPS-CALC-VERS-CD.          09470013
061300                                                                  09480000
061400     IF PPS-RTC = 67                                              09490000
061500       MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD. 09500000
097000                                                                  09510000
097100 9000-EXIT.                                                       09520000
097100      EXIT.                                                       09530000
061700                                                                  09540000
097300******        L A S T   S O U R C E   S T A T E M E N T   *****   09550000
