000100 IDENTIFICATION DIVISION.                                         00010005
000200 PROGRAM-ID.           IRCAL021.                                  00020056
000300*AUTHOR.            ED FRANEY.                                    00030005
000400*REMARKS.                CMS.                                     00040005
000500*       EFFECTIVE JAN 1 2002                                      00050005
000600 DATE-COMPILED.                                                   00060005
000700 ENVIRONMENT DIVISION.                                            00070005
000800 CONFIGURATION SECTION.                                           00080005
000900 SOURCE-COMPUTER.            IBM-370.                             00090005
001000 OBJECT-COMPUTER.            IBM-370.                             00100005
001100 INPUT-OUTPUT  SECTION.                                           00110005
001200 FILE-CONTROL.                                                    00120005
001300                                                                  00130005
001400 DATA DIVISION.                                                   00140005
001500 FILE SECTION.                                                    00150005
001600                                                                  00160005
001700 WORKING-STORAGE SECTION.                                         00170005
001800 01  W-STORAGE-REF                  PIC X(46)  VALUE              00180005
001900     'IRCAL021      - W O R K I N G   S T O R A G E'.             00190057
002000 01  CAL-VERSION                    PIC X(05)  VALUE 'C02.1'.     00200057
002100                                                                  00210005
002200***************************************************************   00220005
002300*    LAYUP TABLE AREA FOR FY2002 CMGS                         *   00230005
002400*    EFFECTIVE DATE OF JANUARY 1, 2002                        *   00240005
002500***************************************************************   00250005
002600 01  CMG-TABLE.                                                   00260005
002700     05  CMG-TABLE-DATA.                                          00270005
002800       10  FILLER                  PIC X(32) VALUE                00280005
002900         '01010477804279040780385910090608'.                      00290005
003000       10  FILLER                  PIC X(32) VALUE                00300005
003100         '01020650605827055530525511121010'.                      00310005
003200       10  FILLER                  PIC X(32) VALUE                00320005
003300         '01030829607430070800670014121212'.                      00330005
003400       10  FILLER                  PIC X(32) VALUE                00340005
003500         '01040900708067076870727517131213'.                      00350005
003600       10  FILLER                  PIC X(32) VALUE                00360005
003700         '01051133910155096770915816171515'.                      00370005
003800       10  FILLER                  PIC X(32) VALUE                00380005
003900         '01061395112494119051126718181818'.                      00390005
004000       10  FILLER                  PIC X(32) VALUE                00400005
004100         '01071615914472137901305017202121'.                      00410005
004200       10  FILLER                  PIC X(32) VALUE                00420005
004300         '01081747715653149151411525272223'.                      00430005
004400       10  FILLER                  PIC X(32) VALUE                00440005
004500         '01091890116928161301526524242224'.                      00450005
004600       10  FILLER                  PIC X(32) VALUE                00460005
004700         '01102027518159173031637529252726'.                      00470005
004800       10  FILLER                  PIC X(32) VALUE                00480005
004900         '01112088918709178271687129262427'.                      00490005
005000       10  FILLER                  PIC X(32) VALUE                00500005
005100         '01122478222195211492001540333031'.                      00510005
005200       10  FILLER                  PIC X(32) VALUE                00520005
005300         '01132237520040190951807130272728'.                      00530005
005400       10  FILLER                  PIC X(32) VALUE                00540005
005500         '01142730224452233002205037343233'.                      00550005
005600       10  FILLER                  PIC X(32) VALUE                00560005
005700         '02010768907276067240617013141411'.                      00570005
005800       10  FILLER                  PIC X(32) VALUE                00580005
005900         '02021118110581097780897318161716'.                      00590005
006000       10  FILLER                  PIC X(32) VALUE                00600005
006100         '02031307712375114361049519201918'.                      00610005
006200       10  FILLER                  PIC X(32) VALUE                00620005
006300         '02041653415646144591326924232222'.                      00630005
006400       10  FILLER                  PIC X(32) VALUE                00640005
006500         '02052510023752219492014344363531'.                      00650005
006600       10  FILLER                  PIC X(32) VALUE                00660005
006700         '03010965508239078950719514141213'.                      00670005
006800       10  FILLER                  PIC X(32) VALUE                00680005
006900         '03021367811672111841019419171716'.                      00690005
007000       10  FILLER                  PIC X(32) VALUE                00700005
007100         '03031875216002153341397623232222'.                      00710005
007200       10  FILLER                  PIC X(32) VALUE                00720005
007300         '03042791123817228242080144323431'.                      00730005
007400       10  FILLER                  PIC X(32) VALUE                00740005
007500         '04010928208716082220690815151614'.                      00750005
007600       10  FILLER                  PIC X(32) VALUE                00760005
007700         '04021421113344125881057621182219'.                      00770005
007800       10  FILLER                  PIC X(32) VALUE                00780005
007900         '04032348522052208021747832323130'.                      00790005
008000       10  FILLER                  PIC X(32) VALUE                00800005
008100         '04043522733078312032621646436240'.                      00810005
008200       10  FILLER                  PIC X(32) VALUE                00820005
008300         '05010759006975062300536312131010'.                      00830005
008400       10  FILLER                  PIC X(32) VALUE                00840005
008500         '05020945808691077630668315171012'.                      00850005
008600       10  FILLER                  PIC X(32) VALUE                00860005
008700         '05031161310672095330820617171514'.                      00870005
008800       10  FILLER                  PIC X(32) VALUE                00880005
008900         '05041675915400137571184223212119'.                      00890005
009000       10  FILLER                  PIC X(32) VALUE                00900005
009100         '05052531423261207781788731312928'.                      00910005
009200       10  FILLER                  PIC X(32) VALUE                00920005
009300         '06010879406750066090594914131212'.                      00930005
009400       10  FILLER                  PIC X(32) VALUE                00940005
009500         '06021197909195090030810515151415'.                      00950005
009600       10  FILLER                  PIC X(32) VALUE                00960005
009700         '06031536811796115501039721181818'.                      00970005
009800       10  FILLER                  PIC X(32) VALUE                00980005
009900         '06042004515386150651356131242523'.                      00990005
010000       10  FILLER                  PIC X(32) VALUE                01000005
010100         '07010701507006067100596013131211'.                      01010005
010200       10  FILLER                  PIC X(32) VALUE                01020005
010300         '07020926409251088610787015151614'.                      01030005
010400       10  FILLER                  PIC X(32) VALUE                01040005
010500         '07031097710962105000932618171716'.                      01050005
010600       10  FILLER                  PIC X(32) VALUE                01060005
010700         '07041248812471119451060914201918'.                      01070005
010800       10  FILLER                  PIC X(32) VALUE                01080005
010900         '07051476014740141191254020222221'.                      01090005
011000       10  FILLER                  PIC X(32) VALUE                01100005
011100         '08010490904696045180389009090808'.                      01110005
011200       10  FILLER                  PIC X(32) VALUE                01120005
011300         '08020566705421052160449010100909'.                      01130005
011400       10  FILLER                  PIC X(32) VALUE                01140005
011500         '08030695606654064020551109111110'.                      01150005
011600       10  FILLER                  PIC X(32) VALUE                01160005
011700         '08040928408881085450735615141412'.                      01170005
011800       10  FILLER                  PIC X(32) VALUE                01180005
011900         '08051002709593092290794516161414'.                      01190005
012000       10  FILLER                  PIC X(32) VALUE                01200005
012100         '08061368113088125921084021201918'.                      01210005
012200       10  FILLER                  PIC X(32) VALUE                01220005
012300         '09010698806390060250521312111111'.                      01230005
012400       10  FILLER                  PIC X(32) VALUE                01240005
012500         '09020949608684081870708415151413'.                      01250005
012600       10  FILLER                  PIC X(32) VALUE                01260005
012700         '09031198710961103340894218181716'.                      01270005
012800       10  FILLER                  PIC X(32) VALUE                01280005
012900         '09041627214880140291213823232321'.                      01290005
013000       10  FILLER                  PIC X(32) VALUE                01300005
013100         '10010782107821071530652313131213'.                      01310005
013200       10  FILLER                  PIC X(32) VALUE                01320005
013300         '10020999809998091440833915151415'.                      01330005
013400       10  FILLER                  PIC X(32) VALUE                01340005
013500         '10031222912229111851020018171718'.                      01350005
013600       10  FILLER                  PIC X(32) VALUE                01360005
013700         '10041426414264130461189720201919'.                      01370005
013800       10  FILLER                  PIC X(32) VALUE                01380005
013900         '10051758817588160861467021252323'.                      01390005
014000       10  FILLER                  PIC X(32) VALUE                01400005
014100         '11011262107683071490663118111312'.                      01410005
014200       10  FILLER                  PIC X(32) VALUE                01420005
014300         '11021953411892110641026325181718'.                      01430005
014400       10  FILLER                  PIC X(32) VALUE                01440005
014500         '11032654316159150341394533232225'.                      01450005
014600       10  FILLER                  PIC X(32) VALUE                01460005
014700         '12010721905429051030459613101109'.                      01470005
014800       10  FILLER                  PIC X(32) VALUE                01480005
014900         '12020928406983065630591116111313'.                      01490005
015000       10  FILLER                  PIC X(32) VALUE                01500005
015100         '12031077108101076140685818151413'.                      01510005
015200       10  FILLER                  PIC X(32) VALUE                01520005
015300         '12041395010492098610888222191617'.                      01530005
015400       10  FILLER                  PIC X(32) VALUE                01540005
015500         '12051787413443126341138027212120'.                      01550005
015600       10  FILLER                  PIC X(32) VALUE                01560005
015700         '13010771906522064340556613141311'.                      01570005
015800       10  FILLER                  PIC X(32) VALUE                01580005
015900         '13020988208349082370712616141414'.                      01590005
016000       10  FILLER                  PIC X(32) VALUE                01600005
016100         '13031313211095109450946920181617'.                      01610005
016200       10  FILLER                  PIC X(32) VALUE                01620005
016300         '13041866215768155551345725252922'.                      01630005
016400       10  FILLER                  PIC X(32) VALUE                01640005
016500         '14010719006433057220515615121111'.                      01650005
016600       10  FILLER                  PIC X(32) VALUE                01660005
016700         '14020990208858078800710113151313'.                      01670005
016800       10  FILLER                  PIC X(32) VALUE                01680005
016900         '14031297511608103250930521191616'.                      01690005
017000       10  FILLER                  PIC X(32) VALUE                01700005
017100         '14041801316115143351291830242120'.                      01710005
017200       10  FILLER                  PIC X(32) VALUE                01720005
017300         '15010803207633069260661515131313'.                      01730005
017400       10  FILLER                  PIC X(32) VALUE                01740005
017500         '15021026809758088550845717171415'.                      01750005
017600       10  FILLER                  PIC X(32) VALUE                01760005
017700         '15031324212584114191090621201818'.                      01770005
017800       10  FILLER                  PIC X(32) VALUE                01780005
017900         '15042059819575177631696530283026'.                      01790005
018000       10  FILLER                  PIC X(32) VALUE                01800005
018100         '16010870708327078860660315141313'.                      01810005
018200       10  FILLER                  PIC X(32) VALUE                01820005
018300         '16021332012739120661010321202018'.                      01830005
018400       10  FILLER                  PIC X(32) VALUE                01840005
018500         '17010999609022081380720516141113'.                      01850005
018600       10  FILLER                  PIC X(32) VALUE                01860005
018700         '17021475513317120111063421212018'.                      01870005
018800       10  FILLER                  PIC X(32) VALUE                01880005
018900         '17032137019288173961540233282724'.                      01890005
019000       10  FILLER                  PIC X(32) VALUE                01900005
019100         '18010744507445068620628212121210'.                      01910005
019200       10  FILLER                  PIC X(32) VALUE                01920005
019300         '18021067410674098380900716161616'.                      01930005
019400       10  FILLER                  PIC X(32) VALUE                01940005
019500         '18031635016350150691379722252022'.                      01950005
019600       10  FILLER                  PIC X(32) VALUE                01960005
019700         '18042914029140268582458941294040'.                      01970005
019800       10  FILLER                  PIC X(32) VALUE                01980005
019900         '19011158510002097810887615151615'.                      01990005
020000       10  FILLER                  PIC X(32) VALUE                02000005
020100         '19022154218598181881650527272724'.                      02010005
020200       10  FILLER                  PIC X(32) VALUE                02020005
020300         '19033133927056264592401141353040'.                      02030005
020400       10  FILLER                  PIC X(32) VALUE                02040005
020500         '20010837107195067050602912131112'.                      02050005
020600       10  FILLER                  PIC X(32) VALUE                02060005
020700         '20021105609502088550796215151414'.                      02070005
020800       10  FILLER                  PIC X(32) VALUE                02080005
020900         '20031463912581117251054320181818'.                      02090005
021000       10  FILLER                  PIC X(32) VALUE                02100005
021100         '20041747215017139941258330222122'.                      02110005
021200       10  FILLER                  PIC X(32) VALUE                02120005
021300         '20052079917876166591497933252424'.                      02130005
021400       10  FILLER                  PIC X(32) VALUE                02140005
021500         '21011035709425083870838718181516'.                      02150005
021600       10  FILLER                  PIC X(32) VALUE                02160005
021700         '21022250820482182261822631262629'.                      02170005
021800       10  FILLER                  PIC X(32) VALUE                02180005
021900         '5001               01651      03'.                      02190005
022000       10  FILLER                  PIC X(32) VALUE                02200005
022100         '5101               04279      08'.                      02210005
022200       10  FILLER                  PIC X(32) VALUE                02220005
022300         '5102               12390      23'.                      02230005
022400       10  FILLER                  PIC X(32) VALUE                02240005
022500         '5103               05436      09'.                      02250005
022600       10  FILLER                  PIC X(32) VALUE                02260005
022700         '5104               17100      28'.                      02270005
022800     05  CMGX-TAB REDEFINES CMG-TABLE-DATA.                       02280005
022900         10  CMG-DATA              OCCURS 100 TIMES               02290005
023000                                   ASCENDING CMG-NUM              02300005
023100                                   INDEXED BY DX6.                02310005
023200             15  CMG-NUM           PIC X(04).                     02320005
023300             15  CMG-NUM-REDEF REDEFINES CMG-NUM.                 02330005
023400                 20  CMG-RIC       PIC XX.                        02340005
023500                 20  FILLER        PIC XX.                        02350005
023600             15  B-REL-WGT         PIC 9(01)V9(04).               02360005
023700             15  C-REL-WGT         PIC 9(01)V9(04).               02370005
023800             15  D-REL-WGT         PIC 9(01)V9(04).               02380005
023900             15  A-REL-WGT         PIC 9(01)V9(04).               02390005
024000             15  B-LOS-TABLE       PIC 9(02).                     02400005
024100             15  C-LOS-TABLE       PIC 9(02).                     02410005
024200             15  D-LOS-TABLE       PIC 9(02).                     02420005
024300             15  A-LOS-TABLE       PIC 9(02).                     02430005
024400                                                                  02440005
024500 01  HOLD-PPS-COMPONENTS.                                         02450005
024900     05  H-LOS                        PIC 9(05).                  02490005
025200     05  H-WK-DSH                     PIC 9(01)V9(04).            02520005
025700     05  H-LABOR-PORTION              PIC 9(07)V9(06).            02570005
025800     05  H-NONLABOR-PORTION           PIC 9(07)V9(06).            02580005
025900     05  H-OUTLIER-LABOR-PORTION      PIC 9(07)V9(06).            02590005
026000     05  H-OUTLIER-NONLABOR-PORTION   PIC 9(07)V9(06).            02600005
026200     05  H-FP-OUTLIER-THRESHOLD       PIC 9(07)V9(06).            02620005
026300     05  H-OUTLIER-THRESHOLD          PIC 9(07)V9(06).            02630034
026400     05  H-CHG-OUTLIER-THRESHOLD      PIC 9(07)V9(04).            02640036
028000                                                                  02800005
028100 LINKAGE SECTION.                                                 02810005
028200**************************************************************    02820005
028300*      THIS IS THE BILL-RECORD THAT WILL BE PASSED FROM      *    02830005
028400*      THE IRCAL020 PROGRAM                                  *    02840005
028500**************************************************************    02850005
028600 01  BILL-NEW-DATA.                                               02860005
028700         10  B-NPI10.                                             02870005
028800             15  B-NPI8             PIC X(08).                    02880005
028900             15  B-NPI-FILLER       PIC X(02).                    02890005
029000         10  B-PROVIDER-NO          PIC X(06).                    02900005
029100         10  B-PATIENT-STATUS       PIC X(02).                    02910005
029200         10  B-CMG-CODE             PIC X(05).                    02920005
029300         10  B-LOS                  PIC 9(03).                    02930005
029400         10  B-COV-DAYS             PIC 9(03).                    02940034
029500         10  B-LTR-DAYS             PIC 9(02).                    02950005
029600         10  B-SPEC-PAY-IND         PIC X(01).                    02960034
029700         10  B-DISCHARGE-DATE.                                    02970005
029800             15  B-DISCHG-CC        PIC 9(02).                    02980005
029900             15  B-DISCHG-YY        PIC 9(02).                    02990005
030000             15  B-DISCHG-MM        PIC 9(02).                    03000005
030100             15  B-DISCHG-DD        PIC 9(02).                    03010005
030200         10  B-COV-CHARGES          PIC 9(07)V9(02).              03020034
030300         10  FILLER                 PIC X(11).                    03030012
030400                                                                  03040005
030500***************************************************************   03050005
030600*    THIS DATA IS CALCULATED BY THIS IRCAL SUBROUTINE         *   03060005
030700*    AND PASSED BACK TO THE CALLING PROGRAM                   *   03070005
030800*            RETURN CODE VALUES (PPS-RTC)                     *   03080005
030900*                                                             *   03090005
031000*     ****   PPS-RTC 00-49 = HOW THE BILL WAS PAID            *   03100014
031100*              00 = PAID NORMAL CMG PAYMENT WITHOUT OUTLIER   *   03110005
031200*                                                             *   03120005
031300*              01 = PAID NORMAL CMG PAYMENT WITH OUTLIER      *   03130005
031400*                                                             *   03140005
031500*              02 = TRANSFER PAID ON A PERDIEM BASIS WITHOUT  *   03150005
031600*                   OUTLIER                                   *   03160005
031700*              03 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   03170005
031800*                   OUTLIER                                   *   03180005
031900*              04 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   03190005
032000*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   03200005
032100*                   WITHOUT OUTLIER                           *   03210005
032200*              05 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   03220005
032300*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   03230005
032400*                   WITH OUTLIER                              *   03240005
032500*              06 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03250005
032600*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03260005
032700*                   RATE -- WITHOUT OUTLIER                   *   03270005
032800*              07 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03280005
032900*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03290005
033000*                   RATE -- WITH OUTLIER                      *   03300005
033100*       **** NEW RT CODES FOR PAYMENT WITH PENALTIES          *   03310014
031100*              10 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   03311014
031200*                   WITHOUT OUTLIER                           *   03312014
031300*              11 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   03313014
031400*                   WITH OUTLIER                              *   03314014
031500*              12 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   03315014
031600*                   PENALTY WITHOUT OUTLIER                   *   03316014
031700*              13 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   03317014
031800*                   PENALTY WITH OUTLIER                      *   03318014
031900*              14 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   03319014
032000*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   03319114
032100*                   WITH PENALTY WITHOUT OUTLIER              *   03319214
032200*              15 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   03319314
032300*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   03319414
032400*                   WITH PENALTY WITH OUTLIER                 *   03319514
032500*              16 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03319614
032600*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03319714
032700*                   RATE -- WITH PENALTY WITHOUT OUTLIER      *   03319814
032800*              17 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03319914
032900*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03320014
033000*                   RATE -- WITH PENALTY WITH OUTLIER         *   03320114
033100*                                                             *   03320214
033200*      ****  PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   03321014
033300*              50 = PROVIDER SPECIFIC RATE NOT NUMERIC        *   03330005
033400*              51 = PROVIDER RECORD TERMINATED                *   03340005
033500*              52 = INVALID WAGE INDEX                        *   03350005
033600*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   03360005
033700*              54 = CMG ON CLAIM NOT FOUND IN TABLE           *   03370005
033800*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   03380005
033900*                                      OR                     *   03390005
034000*                   DISCHARGE DATE < MSA EFF START DATE       *   03400005
034100*                   FOR PPS                                   *   03410005
034500*              56 = INVALID LENGTH OF STAY                    *   03450005
034600*              57 = PROVIDER SPECIFIC RATE ZERO WHEN BLENDED  *   03460005
034700*                   PAYMENT REQUESTED                         *   03470005
034800*              58 = TOTAL COVERED CHARGES NOT NUMERIC         *   03480055
034900*              59 = PROVIDER SPECIFIC RECORD NOT FOUND        *   03490005
035000*              60 = MSA WAGE INDEX RECORD NOT FOUND           *   03500005
035100*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *   03510005
035200*                   OR BILL-LTR-DAYS > 60                     *   03520005
035300*              62 = INVALID NUMBER OF COVERED DAYS            *   03530005
035500*              65 = OPERATING COST-TO-CHARGE RATIO NOT NUMERIC*   03550005
035600*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *   03560005
035700*                   OR COST OUTLIER THRESHOLD CALCULATION     *   03570005
035800*              72 = INVALID BLEND INDICATOR (NOT 3 OR 4)      *   03580005
035900*              73 = DISCHARGED BEFORE PROVIDER FY BEGIN       *   03590020
036100*              74 = PROVIDER FY BEGIN DATE NOT IN 2002        *   03610005
036200***************************************************************   03620005
036300 01  PPS-DATA-ALL.                                                03630012
036500     05  PPS-RTC                      PIC 9(02).                  03631037
036400     05  PPS-DATA.                                                03640037
036600         10  PPS-MSA                  PIC X(04).                  03660005
036700         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).            03670005
036800         10  PPS-AVG-LOS              PIC 9(02).                  03680005
036900         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).            03690036
037000         10  PPS-TOTAL-PAY-AMT        PIC 9(07)V9(02).            03700033
037100         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).            03710005
037200         10  PPS-FAC-SPEC-PAY-AMT     PIC 9(07)V9(02).            03720005
037300         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).            03730005
037300         10  PPS-LIP-PAY-AMT          PIC 9(07)V9(02).            03731033
037400         10  PPS-LIP-PCT              PIC 9(01)V9(04).            03740005
037500         10  PPS-LOS                  PIC 9(03).                  03750005
037600         10  PPS-REG-DAYS-USED        PIC 9(03).                  03760005
037700         10  PPS-LTR-DAYS-USED        PIC 9(03).                  03770005
037800         10  PPS-TRANSFER-PCT         PIC 9(01)V9(04).            03780036
037900         10  PPS-FAC-SPEC-RT-PREBLEND PIC 9(05)V9(02).            03790005
038000         10  PPS-STANDARD-PAY-AMT     PIC 9(07)V9(02).            03800005
038200         10  PPS-FAC-COSTS            PIC 9(07)V9(02).            03820052
038300         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).            03830005
038400         10  PPS-CHG-OUTLIER-THRESHOLD PIC 9(07)V9(02).           03840036
037000         10  PPS-TOTAL-PENALTY-AMT    PIC 9(07)V9(02).            03841052
037000         10  PPS-FED-PENALTY-AMT      PIC 9(07)V9(02).            03842052
037000         10  PPS-LIP-PENALTY-AMT      PIC 9(07)V9(02).            03843052
037000         10  PPS-OUT-PENALTY-AMT      PIC 9(07)V9(02).            03844052
038500         10  PPS-SUBM-CMG-CODE        PIC X(05).                  03850052
027300         10  PPS-CMG-CODE-REDEF REDEFINES PPS-SUBM-CMG-CODE.      03851052
027400            15  PPS-CMG-ALPHA         PIC X(01).                  03852036
027500            15  PPS-CMG-NUMERIC.                                  03853036
027600               20  PPS-CMG-RIC        PIC X(02).                  03854036
027700               20  FILLER             PIC X(02).                  03855036
038600         10  PPS-PRICED-CMG-CODE      PIC X(05).                  03860036
038700         10  PPS-CALC-VERS-CD         PIC X(05).                  03870005
038800         10  FILLER                   PIC X(13).                  03880014
038900     05  PPS-OTHER-DATA.                                          03890037
039000         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).            03900008
039100         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).            03910008
039200         10  PPS-NAT-THRESHOLD-ADJ    PIC 9(05)V9(02).            03920005
039400         10  PPS-BDGT-NEUT-CONV-AMT   PIC 9(05)V9(02).            03940020
039500         10  PPS-FED-RATE-PCT         PIC 9(01)V9(04).            03950020
039600         10  PPS-FAC-RATE-PCT         PIC 9(01)V9(04).            03960020
039700         10  PPS-RURAL-ADJUSTMENT     PIC 9(01)V9(04).            03970007
039800         10  FILLER                   PIC X(20).                  03980012
039900     05  PPS-PC-DATA.                                             03990037
040000         10  PPS-COT-IND              PIC X(01).                  04000005
040100         10  FILLER                   PIC X(20).                  04010012
040200                                                                  04020005
040300******************************************************************04030005
040400*            THESE ARE THE VERSIONS OF THE IRDRV020               04040005
040500*           PROGRAMS THAT WILL BE PASSED BACK----                 04050005
040600*          ASSOCIATED WITH THE BILL BEING PROCESSED               04060005
040700******************************************************************04070005
040800 01  PRICER-OPT-VERS-SW.                                          04080005
040900     05  PRICER-OPTION-SW          PIC X(01).                     04090037
041000         88  ALL-TABLES-PASSED          VALUE 'A'.                04100005
041100         88  PROV-RECORD-PASSED         VALUE 'P'.                04110005
041200     05  PPS-VERSIONS.                                            04120037
041300         10  PPDRV-VERSION         PIC X(05).                     04130005
041500                                                                  04150005
041600**************************************************************    04160005
041700*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BY        *    04170005
041800*      THE IRCAL020 PROGRAM                                  *    04180005
041900**************************************************************    04190005
042000 01  PROV-NEW-HOLD.                                               04200005
042100     02  PROV-NEWREC-HOLD1.                                       04210005
042200         05  P-NEW-NPI10.                                         04220005
042300             10  P-NEW-NPI8             PIC X(08).                04230005
042400             10  P-NEW-NPI-FILLER       PIC X(02).                04240005
042500         05  P-NEW-PROVIDER-NO.                                   04250005
042600             10  P-NEW-STATE            PIC 9(02).                04260005
042700             10  FILLER                 PIC X(04).                04270005
042800         05  P-NEW-DATE-DATA.                                     04280005
042900             10  P-NEW-EFF-DATE.                                  04290005
043000                 15  P-NEW-EFF-DT-CC    PIC 9(02).                04300005
043100                 15  P-NEW-EFF-DT-YY    PIC 9(02).                04310005
043200                 15  P-NEW-EFF-DT-MM    PIC 9(02).                04320005
043300                 15  P-NEW-EFF-DT-DD    PIC 9(02).                04330005
043400             10  P-NEW-FY-BEGIN-DATE.                             04340005
043500                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                04350005
043600                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                04360005
043700                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                04370005
043800                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                04380005
043900             10  P-NEW-REPORT-DATE.                               04390005
044000                 15  P-NEW-REPORT-DT-CC PIC 9(02).                04400005
044100                 15  P-NEW-REPORT-DT-YY PIC 9(02).                04410005
044200                 15  P-NEW-REPORT-DT-MM PIC 9(02).                04420005
044300                 15  P-NEW-REPORT-DT-DD PIC 9(02).                04430005
044400             10  P-NEW-TERMINATION-DATE.                          04440005
044500                 15  P-NEW-TERM-DT-CC   PIC 9(02).                04450005
044600                 15  P-NEW-TERM-DT-YY   PIC 9(02).                04460005
044700                 15  P-NEW-TERM-DT-MM   PIC 9(02).                04470005
044800                 15  P-NEW-TERM-DT-DD   PIC 9(02).                04480005
044900         05  P-NEW-WAIVER-CODE          PIC X(01).                04490005
045000             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              04500005
045100         05  P-NEW-INTER-NO             PIC 9(05).                04510005
045200         05  P-NEW-PROVIDER-TYPE        PIC X(02).                04520005
047000         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                04700005
048000         05  P-NEW-CURRENT-DIV   REDEFINES                        04800005
048100                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         04810005
048300         05  P-NEW-MSA-DATA.                                      04830005
048400             10  P-NEW-CHG-CODE-INDEX       PIC X.                04840005
048500             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 04850005
048600             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   04860005
048700                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       04870005
048800             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 04880005
048900             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 04890005
049000             10  P-NEW-STAND-AMT-LOC-MSA9                         04900005
049100                 REDEFINES P-NEW-STAND-AMT-LOC-MSA.               04910014
049200                 15  P-NEW-RURAL-1ST.                             04920005
049300                     20  P-NEW-STAND-RURAL  PIC XX.               04930005
049400                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    04940005
049500                 15  P-NEW-RURAL-2ND        PIC XX.               04950005
049600         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    04960005
050000         05  P-NEW-LUGAR                    PIC X.                05000005
050100         05  P-NEW-TEMP-RELIEF-IND          PIC X.                05010005
050200         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                05020005
050300         05  FILLER                         PIC X(05).            05030005
050400     02  PROV-NEWREC-HOLD2.                                       05040005
050500         05  P-NEW-VARIABLES.                                     05050005
050600             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        05060005
050700             10  P-NEW-COLA              PIC  9(01)V9(03).        05070005
050800             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        05080005
050900             10  P-NEW-BED-SIZE          PIC  9(05).              05090005
051000             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        05100005
051100             10  P-NEW-CMI               PIC  9(01)V9(04).        05110005
051200             10  P-NEW-SSI-RATIO         PIC  V9(04).             05120005
051300             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             05130005
051400             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              05140005
051500             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        05150005
051600             10  P-NEW-DSH-PERCENT       PIC  V9(04).             05160005
051700             10  P-NEW-FYE-DATE          PIC  X(08).              05170005
051800         05  FILLER                      PIC  X(23).              05180005
051900     02  PROV-NEWREC-HOLD3.                                       05190005
052000         05  P-NEW-PASS-AMT-DATA.                                 05200005
052100             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          05210005
052200             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          05220005
052300             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          05230005
052400             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          05240005
052500         05  P-NEW-CAPI-DATA.                                     05250005
052600             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 05260005
052700             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          05270005
052800             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          05280005
052900             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        05290005
053000             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             05300005
053100             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 05310005
053200             15  P-NEW-CAPI-IME            PIC 9V9999.            05320005
053300             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          05330005
053400         05  FILLER                        PIC X(22).             05340005
053500******************************************************************05350005
053600*                   THIS IS THE WAGE-INDEX                        05360005
053700*          ASSOCIATED WITH THE BILL BEING PROCESSED               05370005
053800******************************************************************05380005
053900 01  WAGE-NEW-INDEX-RECORD.                                       05390005
054000     05  W-MSA                         PIC X(4).                  05400005
054100     05  W-EFF-DATE                    PIC X(8).                  05410005
054200     05  W-WAGE-INDEX                  PIC S9(02)V9(04).          05420005
054400                                                                  05440005
054500 PROCEDURE DIVISION  USING BILL-NEW-DATA                          05450005
054600                           PPS-DATA-ALL                           05460012
054700                           PRICER-OPT-VERS-SW                     05470005
054800                           PROV-NEW-HOLD                          05480005
054900                           WAGE-NEW-INDEX-RECORD.                 05490005
055000                                                                  05500005
055100***************************************************************   05510005
055200*    PROCESSING:                                              *   05520005
055300*        A. WILL PROCESS CLAIMS BASED ON DISCHARGE DATE       *   05530005
055400*        B. INITIALIZE IRCAL HOLD VARIABLES.                  *   05540005
055500*        C. EDIT THE DATA PASSED FROM THE CLAIM BEFORE        *   05550005
055600*           ATTEMPTING TO CALCULATE PPS. IF THIS CLAIM        *   05560005
055700*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   05570005
055800*           GOBACK.                                           *   05580005
055900*        D. ASSEMBLE PRICING COMPONENTS.                      *   05590005
056000*        E. CALCULATE THE PRICE.                              *   05600005
056100*        F. CALCULATE OUTLIERS IF APPLICABLE.                 *   05610005
056200***************************************************************   05620005
056300                                                                  05630005
056400 0000-MAINLINE-CONTROL.                                           05640030
056500                                                                  05650005
           PERFORM 0100-INITIAL-ROUTINE                                 05650130
              THRU 0100-EXIT.                                           05650232
063400     PERFORM 1000-EDIT-THE-BILL-INFO                              05651030
063400        THRU 1000-EXIT.                                           05651130
063600     IF PPS-RTC = 00                                              05652030
065800        PERFORM 1700-EDIT-CMG-CODE                                05653030
                 THRU 1700-EXIT.                                        05654030
063500                                                                  05655030
063600     IF PPS-RTC = 00                                              05656030
063700        PERFORM 2000-ASSEMBLE-PPS-VARIABLES                       05657030
063700           THRU 2000-EXIT.                                        05657130
063800                                                                  05658030
063900     IF PPS-RTC = 00                                              05659030
064000        PERFORM 3000-CALC-PAYMENT                                 05659130
064000           THRU 3000-EXIT                                         05659230
064000        PERFORM 3500-CONTINUE-CALC                                05659330
064000           THRU 3500-EXIT                                         05659430
064100        PERFORM 4000-CALC-OUTLIER                                 05659530
064100           THRU 4000-EXIT                                         05659630
064200        PERFORM 5000-FINAL-PAYMENTS                               05659730
064200           THRU 5000-EXIT.                                        05659830
                                                                        05659930
064200     PERFORM 9000-MOVE-RESULTS                                    05660030
064200        THRU 9000-EXIT.                                           05661030
061800     GOBACK.                                                      06180005
061900                                                                  06190005
062000 0100-INITIAL-ROUTINE.                                            06200030
062100                                                                  06210005
           MOVE ZEROS TO PPS-RTC.                                       06211025
062200     INITIALIZE PPS-DATA.                                         06220025
062300     INITIALIZE PPS-OTHER-DATA.                                   06230025
062400     INITIALIZE HOLD-PPS-COMPONENTS.                              06240025
062500                                                                  06250011
062600     MOVE .72395 TO PPS-NAT-LABOR-PCT.                            06260005
062700     MOVE .27605 TO PPS-NAT-NONLABOR-PCT.                         06270005
062800     MOVE 11211  TO PPS-NAT-THRESHOLD-ADJ.                        06280005
063000     MOVE 11838  TO PPS-BDGT-NEUT-CONV-AMT.                       06300020
062100                                                                  06300130
062000 0100-EXIT.                                                       06301032
062100      EXIT.                                                       06302032
063100                                                                  06310005
064400 1000-EDIT-THE-BILL-INFO.                                         06440005
064500***************************************************************   06450005
064600*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *   06460005
064700*    AND DO NOT ATTEMPT TO PRICE.                             *   06470005
064800***************************************************************   06480005
064900                                                                  06490005
065000     MOVE B-CMG-CODE TO PPS-SUBM-CMG-CODE.                        06500052
065200     IF (B-LOS NUMERIC) AND (B-LOS > 0)                           06520020
065400        MOVE B-LOS TO H-LOS                                       06540020
065500     ELSE                                                         06550020
              IF B-LOS = 0                                              06551020
                 MOVE 1 TO H-LOS                                        06552020
              ELSE                                                      06553020
065600           MOVE 56 TO PPS-RTC.                                    06560020
065900                                                                  06590005
066000     IF P-NEW-FY-BEGIN-DATE > 20011231                            06600005
066100        IF (P-NEW-FY-BEGIN-DATE <= B-DISCHARGE-DATE)              06610020
066300           IF P-NEW-FED-PPS-BLEND-IND = '4'                       06630005
066400              MOVE 1.0000 TO PPS-FED-RATE-PCT                     06640020
066500              MOVE 0.0000 TO PPS-FAC-RATE-PCT                     06650020
066600           ELSE                                                   06660005
066700             IF P-NEW-FED-PPS-BLEND-IND = '3'                     06670026
066800                MOVE .6667 TO PPS-FED-RATE-PCT                    06680026
066900                MOVE .3333 TO PPS-FAC-RATE-PCT                    06690026
067000             ELSE                                                 06700026
067100               MOVE 72 TO PPS-RTC                                 06710026
067200        ELSE                                                      06720005
067300           MOVE 73 TO PPS-RTC                                     06730005
067400     ELSE                                                         06740005
067500        MOVE 74 TO PPS-RTC.                                       06750005
067600                                                                  06760005
067700     IF PPS-RTC = 00                                              06770020
067800       IF P-NEW-WAIVER-STATE                                      06780026
067900          MOVE 53 TO PPS-RTC.                                     06790026
                                                                        06791026
068000     IF PPS-RTC = 00                                              06800026
068200         IF ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR               06820020
068300            (B-DISCHARGE-DATE < W-EFF-DATE))                      06830020
068400            MOVE 55 TO PPS-RTC.                                   06840020
068500                                                                  06850005
068600     IF PPS-RTC = 00                                              06860020
068700         IF P-NEW-TERMINATION-DATE > 00000000                     06870005
068800            IF B-DISCHARGE-DATE >= P-NEW-TERMINATION-DATE         06880022
069000               MOVE 51 TO PPS-RTC.                                06900052
069100                                                                  06910005
069200     IF PPS-RTC = 00                                              06920020
069300         IF B-COV-CHARGES NOT NUMERIC                             06930034
069400            MOVE 58 TO PPS-RTC.                                   06940020
069500                                                                  06950005
069600     IF PPS-RTC = 00                                              06960020
069700        IF B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60              06970020
069800           MOVE 61 TO PPS-RTC                                     06980055
070100        ELSE                                                      07010055
                 MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.                  07011055
                                                                        07012055
070200     IF PPS-RTC = 00                                              07020020
070300        IF B-COV-DAYS NOT NUMERIC                                 07030034
070400             MOVE 62 TO PPS-RTC                                   07040005
070500        ELSE                                                      07050020
070600          IF B-COV-DAYS = 0 AND H-LOS > 0                         07060055
070700             MOVE 62 TO PPS-RTC.                                  07070034
071000                                                                  07100005
071100     IF PPS-RTC = 00                                              07110020
071200        IF B-LTR-DAYS  > B-COV-DAYS                               07120034
071300           MOVE 62 TO PPS-RTC                                     07130020
071400        ELSE                                                      07140020
071500           COMPUTE PPS-REG-DAYS-USED = B-COV-DAYS - B-LTR-DAYS.   07150036
071600                                                                  07160005
071100     IF PPS-RTC = 00                                              07161020
071700        IF PPS-REG-DAYS-USED > 0                                  07170036
071800           IF PPS-REG-DAYS-USED > H-LOS                           07180036
071900              MOVE H-LOS TO PPS-REG-DAYS-USED                     07190020
072000           ELSE                                                   07200020
072100              NEXT SENTENCE                                       07210036
072200        ELSE                                                      07220020
072300           IF B-LTR-DAYS > H-LOS                                  07230034
072400              MOVE H-LOS TO PPS-LTR-DAYS-USED                     07240020
072500           ELSE                                                   07250020
072600              MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.               07260034
072700                                                                  07270005
072900 1000-EXIT.                                                       07290020
073000      EXIT.                                                       07300020
                                                                        07301020
073200***************************************************************   07320005
073300*    FINDS THE CMG CODE IN THE TABLE                          *   07330005
073400***************************************************************   07340005
073100 1700-EDIT-CMG-CODE.                                              07341030
073500                                                                  07350005
           IF PPS-CMG-NUMERIC < '2103'                                  07360036
              NEXT SENTENCE                                             07370028
           ELSE                                                         07380028
              MOVE 54 TO PPS-RTC.                                       07390028
                                                                        07400028
           IF PPS-RTC = 00                                              07410028
074500        SEARCH ALL CMG-DATA                                       07450005
074600           AT END                                                 07460005
074700             MOVE 54 TO PPS-RTC                                   07470026
074800        WHEN CMG-NUM (DX6) = PPS-CMG-NUMERIC                      07480036
075200             PERFORM 1750-FIND-VALUE                              07520027
075300                THRU 1750-EXIT                                    07530027
              END-SEARCH.                                               07540027
                                                                        07691027
       1700-EXIT.                                                       07692027
            EXIT.                                                       07693027
                                                                        07693127
073200***************************************************************   07693327
073300*    FINDS THE VALUE IN THE CMG CODE IN THE TABLE             *   07693427
073400***************************************************************   07693527
073100 1750-FIND-VALUE.                                                 07693630
073500                                                                  07693727
075200      IF PPS-CMG-ALPHA = 'A'                                      07694136
075300         MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                 07694236
075400         MOVE A-LOS-TABLE (DX6) TO PPS-AVG-LOS                    07694336
075500      ELSE                                                        07694427
075600         IF PPS-CMG-ALPHA = 'B'                                   07694536
075700            MOVE B-REL-WGT (DX6) TO PPS-RELATIVE-WGT              07694636
075800            MOVE B-LOS-TABLE (DX6) TO PPS-AVG-LOS                 07694736
075900         ELSE                                                     07694827
076000            IF PPS-CMG-ALPHA = 'C'                                07694936
076100               MOVE C-REL-WGT (DX6) TO PPS-RELATIVE-WGT           07695036
076200               MOVE C-LOS-TABLE (DX6) TO PPS-AVG-LOS              07695136
076300            ELSE                                                  07695227
076400               IF PPS-CMG-ALPHA = 'D'                             07695336
076500                  MOVE D-REL-WGT (DX6) TO PPS-RELATIVE-WGT        07695436
076600                  MOVE D-LOS-TABLE (DX6) TO PPS-AVG-LOS           07695536
076700               ELSE                                               07695627
076800                  MOVE 54 TO PPS-RTC.                             07695727
                                                                        07695927
       1750-EXIT.                                                       07696027
            EXIT.                                                       07696127
                                                                        07697027
077100***************************************************************   07710005
077200*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *   07720005
077300*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   07730005
077400*    OF THAT VARIABLE.                                        *   07740005
077500***************************************************************   07750005
077600***  GET THE PROVIDER SPECIFIC VARIABLE AND WAGE INDEX            07760005
077700***************************************************************   07770005
077000 2000-ASSEMBLE-PPS-VARIABLES.                                     07771030
077800                                                                  07780005
077900     IF P-NEW-FAC-SPEC-RATE NUMERIC                               07790005
078000        MOVE P-NEW-FAC-SPEC-RATE TO PPS-FAC-SPEC-RT-PREBLEND      07800036
078100     ELSE                                                         07810005
078200        MOVE 50 TO PPS-RTC                                        07820032
              GO TO 2000-EXIT.                                          07821032
                                                                        07822032
078400     IF P-NEW-FED-PPS-BLEND-IND = '3'                             07840032
078600        IF PPS-FAC-SPEC-RT-PREBLEND = 0                           07860036
078700          MOVE 57 TO PPS-RTC                                      07870032
                GO TO 2000-EXIT.                                        07871032
078800                                                                  07880005
078900     IF W-WAGE-INDEX NUMERIC AND W-WAGE-INDEX > 0                 07890020
079000        MOVE W-WAGE-INDEX TO PPS-WAGE-INDEX                       07900036
079100     ELSE                                                         07910005
079200        MOVE 52 TO PPS-RTC                                        07920032
              GO TO 2000-EXIT.                                          07921032
079300                                                                  07930032
079400     IF P-NEW-OPER-CSTCHG-RATIO NOT NUMERIC                       07940032
080100        MOVE 65 TO PPS-RTC.                                       08010032
080200                                                                  08020005
077000 2000-EXIT.                                                       08023032
            EXIT.                                                       08024030
080300                                                                  08030005
080500***************************************************************   08050005
080600*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *   08060005
080700*        CALCULATE THE FEDERAL PORTION.                       *   08070005
080800*        CALCULATE THE HOSPITAL PORTION.                      *   08080005
080900*        CALCULATE THE COST-OUTLIER PORTION.                  *   08090005
081000*        CALCULATE THE LIP ADJUSTMENT PERCENTAGE.             *   08100033
081100***************************************************************   08110005
080400 3000-CALC-PAYMENT.                                               08121030
081300                                                                  08130005
081200***  LIP PERCENTAGE CALCULATION *******************************   08131033
081300                                                                  08132030
081400      COMPUTE H-WK-DSH = (P-NEW-SSI-RATIO                         08140005
081500                           + P-NEW-MEDICAID-RATIO).               08150005
081600                                                                  08160005
081700      COMPUTE PPS-LIP-PCT ROUNDED =                               08170036
081800            ((1 + H-WK-DSH) ** .4838) - 1.                        08180052
081900                                                                  08190005
082000***************************************************************   08200033
082100                                                                  08210005
082200     MOVE 1.0000 TO PPS-TRANSFER-PCT.                             08220036
082300                                                                  08230005
082400     IF B-PATIENT-STATUS =                                        08240005
082500         ('02' OR '03' OR '61' OR '62' OR '63')                   08250014
082600        IF H-LOS < PPS-AVG-LOS                                    08260036
082700           COMPUTE PPS-TRANSFER-PCT =                             08270036
082800               ((H-LOS + .5) / PPS-AVG-LOS)                       08280036
082900           MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE          08290052
083000           GO TO 3000-EXIT.                                       08300030
083100                                                                  08310005
083200     IF H-LOS > 3                                                 08320005
083300        NEXT SENTENCE                                             08330020
083400     ELSE                                                         08340005
083500        MOVE 'A5001' TO PPS-PRICED-CMG-CODE                       08350036
083600        SET DX6 TO 96                                             08360020
083700        MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                  08370036
083800        GO TO 3000-EXIT.                                          08380030
083900                                                                  08390005
084000     IF B-PATIENT-STATUS = '20'                                   08400005
084100        NEXT SENTENCE                                             08410020
084200     ELSE                                                         08420005
084300        MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE             08430052
084400        GO TO 3000-EXIT.                                          08440030
084500                                                                  08450005
084600     IF PPS-CMG-RIC = ('07' OR '08' OR '09')                      08460036
084700        IF H-LOS < 14                                             08470020
084800           MOVE 'A5101' TO PPS-PRICED-CMG-CODE                    08480036
084900           SET DX6 TO 97                                          08490020
085000           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08500036
085100        ELSE                                                      08510020
085200           MOVE 'A5102' TO PPS-PRICED-CMG-CODE                    08520036
085300           SET DX6 TO 98                                          08530020
085400           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08540036
085500     ELSE                                                         08550005
085600        IF H-LOS < 16                                             08560020
085700           MOVE 'A5103' TO PPS-PRICED-CMG-CODE                    08570036
085800           SET DX6 TO 99                                          08580020
085900           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08590036
086000        ELSE                                                      08600020
086100           MOVE 'A5104' TO PPS-PRICED-CMG-CODE                    08610036
086200           SET DX6 TO 100                                         08620020
086300           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT.              08630036
086400                                                                  08640005
086500 3000-EXIT.                                                       08650030
086500      EXIT.                                                       08651030
086600                                                                  08660005
087300 3500-CONTINUE-CALC.                                              08730030
086800                                                                  08730231
086900     COMPUTE PPS-STANDARD-PAY-AMT =                               08730336
087000            (PPS-TRANSFER-PCT * PPS-RELATIVE-WGT                  08730436
087000                      * PPS-BDGT-NEUT-CONV-AMT).                  08730531
087100                                                                  08730631
087400     IF W-MSA (1:2) = '  '                                        08740005
087500        MOVE 1.1914 TO PPS-RURAL-ADJUSTMENT                       08750007
087600     ELSE                                                         08760005
087700        MOVE 1.0000 TO PPS-RURAL-ADJUSTMENT.                      08770007
087800                                                                  08780005
087900     COMPUTE H-LABOR-PORTION =                                    08790005
088000        (PPS-STANDARD-PAY-AMT * PPS-NAT-LABOR-PCT)                08800036
088000          * PPS-WAGE-INDEX.                                       08801036
088100                                                                  08810005
088200     COMPUTE H-NONLABOR-PORTION =                                 08820005
088300        (PPS-STANDARD-PAY-AMT * PPS-NAT-NONLABOR-PCT).            08830036
088400                                                                  08840005
088500     COMPUTE PPS-FED-PAY-AMT ROUNDED =                            08850044
088600        ((H-LABOR-PORTION + H-NONLABOR-PORTION) *                 08860005
088700         PPS-RURAL-ADJUSTMENT).                                   08870020
088400                                                                  08871044
088500     COMPUTE PPS-LIP-PAY-AMT ROUNDED =                            08872044
088600        (PPS-FED-PAY-AMT * PPS-LIP-PCT).                          08873044
088800                                                                  08880005
088900 3500-EXIT.                                                       08890030
089000      EXIT.                                                       08900032
088800                                                                  08901030
089100 4000-CALC-OUTLIER.                                               08910005
089200                                                                  08920005
089300     COMPUTE PPS-FAC-COSTS ROUNDED =                              08930052
089400         (B-COV-CHARGES * P-NEW-OPER-CSTCHG-RATIO).               08940036
089500                                                                  08950005
089600     COMPUTE H-OUTLIER-LABOR-PORTION =                            08960005
089700        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-LABOR-PCT)               08970005
089800              * PPS-WAGE-INDEX.                                   08980036
089900                                                                  08990005
090000     COMPUTE H-OUTLIER-NONLABOR-PORTION =                         09000005
090100        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-NONLABOR-PCT).           09010005
090200                                                                  09020005
090300     COMPUTE H-FP-OUTLIER-THRESHOLD ROUNDED =                     09030005
090400        ((H-OUTLIER-LABOR-PORTION + H-OUTLIER-NONLABOR-PORTION) * 09040005
090500         PPS-RURAL-ADJUSTMENT * (PPS-LIP-PCT + 1)).               09050044
090600                                                                  09060005
090700     COMPUTE H-OUTLIER-THRESHOLD ROUNDED =                        09070034
090800        (PPS-FED-PAY-AMT + H-FP-OUTLIER-THRESHOLD +               09080045
               PPS-LIP-PAY-AMT).                                        09081045
090900                                                                  09090005
091000     IF PPS-FAC-COSTS > H-OUTLIER-THRESHOLD                       09100052
091100        COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                     09110036
091200           ((PPS-FAC-COSTS - H-OUTLIER-THRESHOLD) * .8).          09120052
091300                                                                  09130005
091400     COMPUTE H-CHG-OUTLIER-THRESHOLD ROUNDED =                    09140036
091500         H-OUTLIER-THRESHOLD / P-NEW-OPER-CSTCHG-RATIO.           09150034
091600                                                                  09160005
                                                                        09164046
091700 4000-EXIT.                                                       09170031
091700      EXIT.                                                       09171031
091800                                                                  09180005
091900 5000-FINAL-PAYMENTS.                                             09190005
092000                                                                  09200008
092100     IF B-SPEC-PAY-IND = '1' OR '3'                               09210034
092200         MOVE ZEROES TO PPS-OUTLIER-PAY-AMT.                      09220036
092300                                                                  09230008
092400     IF PPS-FED-RATE-PCT = 1.0000                                 09240020
092600         MOVE 0                  TO PPS-FAC-SPEC-PAY-AMT          09260005
092800     ELSE                                                         09280014
092900         COMPUTE PPS-FED-PAY-AMT ROUNDED =                        09290005
093000           (PPS-FED-RATE-PCT * PPS-FED-PAY-AMT)                   09300038
093100         COMPUTE PPS-FAC-SPEC-PAY-AMT ROUNDED =                   09310005
093200           (PPS-FAC-RATE-PCT * PPS-FAC-SPEC-RT-PREBLEND)          09320036
093300         COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                    09330005
093400           (PPS-FED-RATE-PCT * PPS-OUTLIER-PAY-AMT)               09340053
093300         COMPUTE PPS-LIP-PAY-AMT ROUNDED =                        09341053
093400           (PPS-FED-RATE-PCT * PPS-LIP-PAY-AMT).                  09342053
093500                                                                  09350005
           IF B-SPEC-PAY-IND = '2' OR '3'                               09391034
093600        COMPUTE PPS-FED-PENALTY-AMT ROUNDED =                     09391131
093700           (PPS-FED-PAY-AMT * .25)                                09391231
093600        COMPUTE PPS-FED-PAY-AMT =                                 09391352
093700           (PPS-FED-PAY-AMT - PPS-FED-PENALTY-AMT)                09391439
093600        COMPUTE PPS-LIP-PENALTY-AMT ROUNDED =                     09391539
093700           (PPS-LIP-PAY-AMT * .25)                                09391639
093600        COMPUTE PPS-LIP-PAY-AMT =                                 09391752
093700           (PPS-LIP-PAY-AMT - PPS-LIP-PENALTY-AMT)                09391839
093600        COMPUTE PPS-OUT-PENALTY-AMT ROUNDED =                     09391939
093700           (PPS-OUTLIER-PAY-AMT * .25)                            09392039
093600        COMPUTE PPS-OUTLIER-PAY-AMT =                             09392152
093700           (PPS-OUTLIER-PAY-AMT - PPS-OUT-PENALTY-AMT)            09392239
              COMPUTE PPS-TOTAL-PENALTY-AMT =                           09392339
                 (PPS-FED-PENALTY-AMT + PPS-LIP-PENALTY-AMT             09392439
                 + PPS-OUT-PENALTY-AMT).                                09392552
                                                                        09392652
093600     COMPUTE PPS-TOTAL-PAY-AMT ROUNDED =                          09392752
093700        (PPS-FED-PAY-AMT + PPS-FAC-SPEC-PAY-AMT                   09392852
093800         + PPS-OUTLIER-PAY-AMT + PPS-LIP-PAY-AMT).                09392952
093900                                                                  09393052
                                                                        09395040
094000     IF PPS-FED-RATE-PCT = 1.0000                                 09400020
094100        IF PPS-TRANSFER-PCT = 1.0000                              09410036
094200           IF PPS-OUTLIER-PAY-AMT > 0.0                           09420036
094300              MOVE 01 TO PPS-RTC                                  09430005
094400           ELSE                                                   09440005
094500              MOVE 00 TO PPS-RTC                                  09450005
094600        ELSE                                                      09460005
094700           IF PPS-OUTLIER-PAY-AMT > 0.0                           09470036
094800              MOVE 03 TO PPS-RTC                                  09480005
094900           ELSE                                                   09490005
095000              MOVE 02 TO PPS-RTC                                  09500005
095100     ELSE                                                         09510005
095200        IF PPS-TRANSFER-PCT = 1.0000                              09520036
095300           IF PPS-OUTLIER-PAY-AMT > 0.0                           09530036
095400              MOVE 05 TO PPS-RTC                                  09540005
095500           ELSE                                                   09550005
095600              MOVE 04 TO PPS-RTC                                  09560005
095700        ELSE                                                      09570005
095800           IF PPS-OUTLIER-PAY-AMT > 0.0                           09580036
095900              MOVE 07 TO PPS-RTC                                  09590005
096000           ELSE                                                   09600005
096100              MOVE 06 TO PPS-RTC.                                 09610005
096300                                                                  09610115
           IF B-SPEC-PAY-IND = '2' OR '3'                               09611034
096200        COMPUTE PPS-RTC = PPS-RTC + 10.                           09620015
096400     IF PPS-RTC = (01 OR 03 OR 05 OR 07                           09640015
096400                OR 11 OR 13 OR 15 OR 17)                          09641016
096500        IF ((PPS-REG-DAYS-USED + PPS-LTR-DAYS-USED) < H-LOS)      09650036
096600           OR PPS-COT-IND = 'Y'                                   09660036
096700            MOVE 67 TO PPS-RTC.                                   09670036
097000                                                                  09700005
097100 5000-EXIT.                                                       09710030
097100      EXIT.                                                       09711030
097200                                                                  09720005
       9000-MOVE-RESULTS.                                               09721032
                                                                        09722030
056600     IF PPS-RTC < 50                                              09723030
056700      MOVE H-LOS                   TO  PPS-LOS                    09724030
057300      MOVE H-OUTLIER-THRESHOLD     TO  PPS-OUTLIER-THRESHOLD      09729134
057400      MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD   09729236
057800      MOVE W-MSA                   TO  PPS-MSA                    09729652
058300      MOVE 'V02.1'                 TO  PPS-CALC-VERS-CD           09731060
058400     ELSE                                                         09732030
062200       INITIALIZE PPS-DATA                                        09733030
062300       INITIALIZE PPS-OTHER-DATA                                  09734030
061200       MOVE 'V02.1'                TO  PPS-CALC-VERS-CD.          09735060
061300                                                                  09736030
061400     IF PPS-RTC = 67                                              09737030
061500       MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD. 09738036
097000                                                                  09739246
097100 9000-EXIT.                                                       09739346
097100      EXIT.                                                       09739446
061700                                                                  09739546
097300******        L A S T   S O U R C E   S T A T E M E N T   *****   09740005
