000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPCAL974.
000300*AUTHOR.            DDS TEAM.
000400*REMARKS.                HCFA.
000500 DATE-COMPILED.
000600 ENVIRONMENT DIVISION.
000700 CONFIGURATION SECTION.
000800 SOURCE-COMPUTER.            IBM-370.
000900 OBJECT-COMPUTER.            IBM-370.
001000 INPUT-OUTPUT  SECTION.
001100 FILE-CONTROL.
001200
001300 DATA DIVISION.
001400 FILE SECTION.
001500
001600 WORKING-STORAGE SECTION.
001700 01  W-STORAGE-REF                  PIC X(46)  VALUE
001800     'PPCAL974      - W O R K I N G   S T O R A G E'.
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C97.4'.
002000 01  R1                             PIC S9(04) COMP SYNC.
002100 01  R2                             PIC S9(04) COMP SYNC.
002200 01  R3                             PIC S9(04) COMP SYNC.
002300 01  R4                             PIC S9(04) COMP SYNC.
002400
002500***************************************************************
002600*    LAYUP TABLE AREA FOR FY97 RATES                          *
002700***************************************************************
002800***************************************************************
002900***************************************************************
003000***************************************************************
003100 01  RATE-TABLE.
003200     02  RATE-WORK.
003300         05  FILLER PIC X(06) VALUE '961001'.
003400*RATE   961001 REGION  LABOR AND NON-LABOR RATES
003500*                  R3=1     /     R3=2     /     R3=3
003600*               LARGE URBAN /OTHER URBAN & / ALL RURAL
003700*                           /REFERRAL CTR  /
003800*              LABOR / NON  / LABOR / NON  / LABOR / NON
003900*                    /LABOR /       /LABOR /       /LABOR
004000*             --------------------------------------------
004100         05  NE01   PIC X(45) VALUE
004200            ' 0278284 112564 0273879 110783 0273879 110783'.
004300         05  MA02   PIC X(45) VALUE
004400            ' 0278284 112564 0273879 110783 0273879 110783'.
004500         05  SA03   PIC X(45) VALUE
004600            ' 0278284 112564 0273879 110783 0273879 110783'.
004700         05  ENC04  PIC X(45) VALUE
004800            ' 0278284 112564 0273879 110783 0273879 110783'.
004900         05  ESC05  PIC X(45) VALUE
005000            ' 0278284 112564 0273879 110783 0273879 110783'.
005100         05  WNC06  PIC X(45) VALUE
005200            ' 0278284 112564 0273879 110783 0273879 110783'.
005300         05  WSC07  PIC X(45) VALUE
005400            ' 0278284 112564 0273879 110783 0273879 110783'.
005500         05  MNT08  PIC X(45) VALUE
005600            ' 0278284 112564 0273879 110783 0273879 110783'.
005700         05  PAC09  PIC X(45) VALUE
005800            ' 0278284 112564 0273879 110783 0273879 110783'.
005900         05  NTL10  PIC X(45) VALUE
006000            ' 0278284 112564 0273879 110783 0273879 110783'.
006100         05  PR11   PIC X(45) VALUE
006200            ' 0248870 051865 0244931 051044 0244931 051044'.
006300         05  NPR12  PIC X(45) VALUE
006400            ' 0275922 111609 0275922 111609 0275922 111609'.
006500     02  RATE-TAB REDEFINES RATE-WORK.
006600         05  RATE-PERIOD            OCCURS 1.
006700             10  RATE-EFF-DATE      PIC X(06).
006800             10  REG-NAT            OCCURS 12.
006900                 15  R-URBAN-RURAL  OCCURS 3.
007000                     20  FILLER     PIC X(01).
007100                     20  REG-LABOR  PIC 9(05)V9(02).
007200                     20  FILLER     PIC X(01).
007300                     20  REG-NLABOR PIC 9(04)V9(02).
007400
007500
007600***************************************************************
007700*    LAYUP TABLE AREA FOR FY97 DRGS                           *
007800***************************************************************
007900 01  DRG-TABLE.
008000     05  D-TAB.
008100      10  FILLER                  PIC X(06) VALUE
008200     '961001'.
008300      10  FILLER                  PIC X(56) VALUE
008400     '03048607732111030134084321160191671273712702339905930091'.
008500       10  FILLER                  PIC X(56) VALUE
008600     '01514303426044007419024260340248860813212601096202627039'.
008700       10  FILLER                  PIC X(56) VALUE
008800     '01267705429078012196057300810080000352805000945705429077'.
008900       10  FILLER                  PIC X(56) VALUE
009000     '00777005029062011999055300750072310352704501037104929066'.
009100       10  FILLER                  PIC X(56) VALUE
009200     '00633103026040009319048290640062300342704502485408633116'.
009300       10  FILLER                  PIC X(56) VALUE
009400     '01491005830078008353038280490080890362805100969404228058'.
009500       10  FILLER                  PIC X(56) VALUE
009600     '00579303024039007387033270460130600362806301203304829071'.
009700       10  FILLER                  PIC X(56) VALUE
009800     '00637103027041003241020170200084120372805400486102320031'.
009900       10  FILLER                  PIC X(56) VALUE
010000     '00203701609016010673046290650061490322704300613401306016'.
010100       10  FILLER                  PIC X(56) VALUE
010200     '00932302727040004282019170260051840151002000707202226034'.
010300       10  FILLER                  PIC X(56) VALUE
010400     '00329901607016005816016130220045200332704200623704729057'.
010500       10  FILLER                  PIC X(56) VALUE
010600     '00652503122038007656040280560046640282703800290702927029'.
010700       10  FILLER                  PIC X(56) VALUE
010800     '01724504128057007686017090210073450192002901027102124034'.
010900       10  FILLER                  PIC X(56) VALUE
011000     '01012802226036004712032220320078800202203000828302118027'.
011100       10  FILLER                  PIC X(56) VALUE
011200     '00932502827041002676015040150074390232603600203801504015'.
011300       10  FILLER                  PIC X(56) VALUE
011400     '01196002727051002885013050130121680322704701173704829076'.
011500       10  FILLER                  PIC X(56) VALUE
011600     '00519502720034005366029210360083970342404200709803927048'.
011700       10  FILLER                  PIC X(56) VALUE
011800     '00523903120038003727024150290077020312704000653203127044'.
011900       10  FILLER                  PIC X(56) VALUE
012000     '00750503728050003278021200210319510883311202603609133125'.
012100       10  FILLER                  PIC X(56) VALUE
012200     '01159303828055014292070310830163000723109300943605329066'.
012300       10  FILLER                  PIC X(56) VALUE
012400     '01484506330078013319057300790097820492906400531902923037'.
012500       10  FILLER                  PIC X(56) VALUE
012600     '01220005630074007117034270450136150512906900984604929061'.
012700       10  FILLER                  PIC X(56) VALUE
012800     '01115605830071006978043240510075240352704501202905630073'.
012900       10  FILLER                  PIC X(56) VALUE
013000     '00749804028049011780053290710059960332504100827204529055'.
013100       10  FILLER                  PIC X(56) VALUE
013200     '00603503622043007807029270430068690272203500511302012024'.
013300       10  FILLER                  PIC X(56) VALUE
013400     '00874803928052005335024200311533582845240007319912036146'.
013500       10  FILLER                  PIC X(56) VALUE
013600     '05599809033110055564103341170406850783208805913509834126'.
013700       10  FILLER                  PIC X(56) VALUE
013800     '00000000000000041589082321090228750593006702094603527047'.
013900       10  FILLER                  PIC X(56) VALUE
014000     '02693510635144015152068310950368270913311502415003928054'.
014100       10  FILLER                  PIC X(56) VALUE
014200     '01176402727041015825021250320114350332705501931805429092'.
014300       10  FILLER                  PIC X(56) VALUE
014400     '01648206430078011617044280530145550272704701325803828050'.
014500       10  FILLER                  PIC X(56) VALUE
014600     '00924602320031025379110351430102650482906200786105927067'.
014700       10  FILLER                  PIC X(56) VALUE
014800     '01131602026035009352053290670060380432805200684002920036'.
014900       10  FILLER                  PIC X(56) VALUE
015000     '00553702316029005787030230390088380372805000562902618033'.
015100       10  FILLER                  PIC X(56) VALUE
015200     '00799903327033008008035270460049710241602900620502820035'.
015300       10  FILLER                  PIC X(56) VALUE
015400     '00712803427045005288025180320052230211402601085704128057'.
015500       10  FILLER                  PIC X(56) VALUE
015600     '00620802520032026363098341120160180672707303371011235135'.
015700       10  FILLER                  PIC X(56) VALUE
015800     '01599907025077026828095341170129100522906501931107632090'.
015900       10  FILLER                  PIC X(56) VALUE
016000     '01156805624062041817116361500140590452905900823806030060'.
016100       10  FILLER                  PIC X(56) VALUE
016200     '01135204228058006077023180290122680402805300702602416030'.
016300       10  FILLER                  PIC X(56) VALUE
016400     '01006603027044005707017110220077060211102102338608032094'.
016500       10  FILLER                  PIC X(56) VALUE
016600     '01258205124058014497045290570084310281503201092903227050'.
016700       10  FILLER                  PIC X(56) VALUE
016800     '00671702015025027453085331250112020402805401292005730082'.
016900       10  FILLER                  PIC X(56) VALUE
017000     '00676903027044009952044280560054850291703501085604729062'.
017100       10  FILLER                  PIC X(56) VALUE
017200     '00833504028050006091030190360111880553007200919404729061'.
017300       10  FILLER                  PIC X(56) VALUE
017400     '00533803322040007789038280500055530282003400541402827039'.
017500       10  FILLER                  PIC X(56) VALUE
017600     '00842403728052003140029230290071040312704201059104528061'.
017700       10  FILLER                  PIC X(56) VALUE
017800     '00564002727037008769039280510445431213616301788906230079'.
017900       10  FILLER                  PIC X(56) VALUE
018000     '03287811435139017549068310850268940883310501612705830067'.
018100       10  FILLER                  PIC X(56) VALUE
018200     '02267907531092011738043230490237280843211203177207932124'.
018300       10  FILLER                  PIC X(56) VALUE
018400     '03766912136168013675057300780124860553007701200405129068'.
018500       10  FILLER                  PIC X(56) VALUE
018600     '01219405329073007159036280470105080442805800604502621035'.
018700       10  FILLER                  PIC X(56) VALUE
018800     '02260605923067018460072310860127400562306301148711135111'.
018900       10  FILLER                  PIC X(56) VALUE
019000     '01704907031097019255049290650111190302003702078407932111'.
019100       10  FILLER                  PIC X(56) VALUE
019200     '02881210234154014574048290620095530311903800570605329053'.
019300       10  FILLER                  PIC X(56) VALUE
019400     '01834005830081010177031270400087200221602900741701910023'.
019500       10  FILLER                  PIC X(56) VALUE
019600     '01002003327050013831044280670074490231803000934902326035'.
019700       10  FILLER                  PIC X(56) VALUE
019800     '00651201813024010567033270520122630332705101088402627045'.
019900       10  FILLER                  PIC X(56) VALUE
020000     '02017006430091010675031270410083950472906900762004729064'.
020100       10  FILLER                  PIC X(56) VALUE
020200     '00563703327044013796076321010101150583007601211205530075'.
020300       10  FILLER                  PIC X(56) VALUE
020400     '00602903528046010492058300770072410432805600727904328058'.
020500       10  FILLER                  PIC X(56) VALUE
020600     '00495403227043005887036280460055230292704000732503928053'.
020700       10  FILLER                  PIC X(56) VALUE
020800     '00652202927043006915036280510046400252203300247901815018'.
020900       10  FILLER                  PIC X(56) VALUE
021000     '00743804328058004451029250390028860292702900765104028057'.
021100       10  FILLER                  PIC X(56) VALUE
021200     '00901502817034007087022100250086400232603500608301608019'.
021300       10  FILLER                  PIC X(56) VALUE
021400     '00828601912023007695027270390212260993413901127006030083'.
021500       10  FILLER                  PIC X(56) VALUE
021600     '01499304829077007629027270370083300282704300991602527041'.
021700       10  FILLER                  PIC X(56) VALUE
021800     '01641606330093007003024260340108160663108501015805630075'.
021900       10  FILLER                  PIC X(56) VALUE
022000     '00634604128055010760053290790050850252703700637403928050'.
022100       10  FILLER                  PIC X(56) VALUE
022200     '00852605529067005774043250520071900422404200675003728051'.
022300       10  FILLER                  PIC X(56) VALUE
022400     '00456002724036002509022190220069900412805500434002926038'.
022500       10  FILLER                  PIC X(56) VALUE
022600     '02201509534137023775066310870197650943313402010405229069'.
022700       10  FILLER                  PIC X(56) VALUE
022800     '01019802727040008798021150280051890140801802645008432128'.
022900       10  FILLER                  PIC X(56) VALUE
023000     '01267104629068007594043280570071590332704300892904729064'.
023100       10  FILLER                  PIC X(56) VALUE
023200     '00536403326043005221025230340083300392805401095005530073'.
023300       10  FILLER                  PIC X(56) VALUE
023400     '00618203427044039047104341230264090843210202371607531103'.
023500       10  FILLER                  PIC X(56) VALUE
023600     '01177603928049012258043280620067080241503001525204729070'.
023700       10  FILLER                  PIC X(56) VALUE
023800     '00886002318030010015032270460056700181102200912403227048'.
023900       10  FILLER                  PIC X(56) VALUE
024000     '00522301813023004836023260230205740532909301303405429076'.
024100       10  FILLER                  PIC X(56) VALUE
024200     '00484501920029011296050290720057720232403200904805129064'.
024300       10  FILLER                  PIC X(56) VALUE
024400     '00607703924047005133036230440074960272403600415901710021'.
024500       10  FILLER                  PIC X(56) VALUE
024600     '00637703427046004320024190340023410312703100688603127043'.
024700       10  FILLER                  PIC X(56) VALUE
024800     '00456702117028003115016090160099140462906200607002827039'.
024900       10  FILLER                  PIC X(56) VALUE
025000     '00856204328058016653053230610126100421704600884803224041'.
025100       10  FILLER                  PIC X(56) VALUE
025200     '00614702311027010499035270530101940312705300276902413024'.
025300       10  FILLER                  PIC X(56) VALUE
025400     '01074502321033007578027270400015040170601701008302325035'.
025500       10  FILLER                  PIC X(56) VALUE
025600     '00842202827040009559048290680050960242503300710703628049'.
025700       10  FILLER                  PIC X(56) VALUE
025800     '00397402220030006611039240480023090130501300587702827039'.
025900       10  FILLER                  PIC X(56) VALUE
026000     '01917406731083014643052280630090560361103900737602612030'.
026100       10  FILLER                  PIC X(56) VALUE
026200     '02382408032098011713041190480082850301003300845902917035'.
026300       10  FILLER                  PIC X(56) VALUE
026400     '01114802523035002951014050140069110262103500673902627036'.
026500       10  FILLER                  PIC X(56) VALUE
026600     '01723705329081011941053290780052160232403201023005329069'.
026700       10  FILLER                  PIC X(56) VALUE
026800     '00545402627037010401043260560068380321103600543902420034'.
026900       10  FILLER                  PIC X(56) VALUE
027000     '00360201707019006775020110260066980442804400563802325034'.
027100       10  FILLER                  PIC X(56) VALUE
027200     '00818802126033008054024150290035910202103000477501712023'.
027300       10  FILLER                  PIC X(56) VALUE
027400     '00515101714023002013013060160046550282704100392101822031'.
027500       10  FILLER                  PIC X(56) VALUE
027600     '01344301826018044329179421790302761333713301826808633086'.
027700       10  FILLER                  PIC X(56) VALUE
027800     '02245107932107012845036280470014900311103103244308933117'.
027900       10  FILLER                  PIC X(56) VALUE
028000     '01316809133091015994045280800083620392805400696602727038'.
028100       10  FILLER                  PIC X(56) VALUE
028200     '01261204428061012106052290660070300352704402557206731104'.
028300       10  FILLER                  PIC X(56) VALUE
028400     '02483408532124010255031270470169250653009300805903728051'.
028500       10  FILLER                  PIC X(56) VALUE
028600     '01866904929049026841081321130117870382804901739305029082'.
028700       10  FILLER                  PIC X(56) VALUE
028800     '00976304729067007514026200340038370211602700408002123030'.
028900       10  FILLER                  PIC X(56) VALUE
029000     '01325706030084007337037280520344301143515801483806230083'.
029100       10  FILLER                  PIC X(56) VALUE
029200     '00808903728046009697054290680089910442805700626403524043'.
029300       10  FILLER                  PIC X(56) VALUE
029400     '00715303628047005347029250380159470633008802363710935180'.
029500       10  FILLER                  PIC X(56) VALUE
029600     '00705103527049005680039280550054950372805200730305229084'.
029700       10  FILLER                  PIC X(56) VALUE
029800     '00907505930090008391069310980065560492907200736303928065'.
029900       10  FILLER                  PIC X(56) VALUE
030000     '00298602525034007141043280580041640382804800818312136148'.
030100       10  FILLER                  PIC X(56) VALUE
030200     '00765709233109000000000000000161440593008901772506330099'.
030300       10  FILLER                  PIC X(56) VALUE
030400     '00929402426044021653056300870088490252603600731204028053'.
030500       10  FILLER                  PIC X(56) VALUE
030600     '00484502925039002894024220240049180211702800077701001010'.
030700       10  FILLER                  PIC X(56) VALUE
030800     '00790203027045004274018130230025700211702100947303828054'.
030900       10  FILLER                  PIC X(56) VALUE
031000     '00482202420032008575034270510044670211802801832704128084'.
031100       10  FILLER                  PIC X(56) VALUE
031200     '01465702426048034991119361690165380673110300954704629066'.
031300       10  FILLER                  PIC X(56) VALUE
031400     '00996302527049014298110351390071010382805200502802824038'.
031500       10  FILLER                  PIC X(56) VALUE
031600     '00557102326039005905025270480045880242604103602810635153'.
031700       10  FILLER                  PIC X(56) VALUE
031800     '00000000000000000000000000000359800683108110998917041302'.
031900       10  FILLER                  PIC X(56) VALUE
032000     '03574008533147000000000000000367650863312302247910334139'.
032100       10  FILLER                  PIC X(56) VALUE
032200     '01726605930093022883056300830140800352704613942426450326'.
032300       10  FILLER                  PIC X(56) VALUE
032400     '11229929754326036578114351491604133606046405682110635159'.
032500       10  FILLER                  PIC X(56) VALUE
032600     '03205809233117047915090331360203050623009104790514338205'.
032700       10  FILLER                  PIC X(56) VALUE
032800     '01814107231107010116044280660163080361904304029911235174'.
032900       10  FILLER                  PIC X(56) VALUE
033000     '01710004228059009169018150240928701804222700000000000000'.
033100     05  DRGX-TAB REDEFINES D-TAB.
033200         10  DRGX-PERIOD               OCCURS 1
033300                                        INDEXED BY DX5.
033400             15  DRGX-EFF-DATE         PIC X(06).
033500             15  DRG-DATA              OCCURS 496
033600                                        INDEXED BY DX6.
033700                 20  DRG-WT            PIC 9(02)V9(04).
033800                 20  DRG-ALOS          PIC 9(02)V9(01).
033900                 20  DRG-DAYS-TRIM     PIC 9(02).
034000                 20  DRG-ARITH-ALOS    PIC 9(02)V9(01).
034100
034200 01  HOLD-AREA.
034300     02  HOLD-DATES.
034400         05  HOLD-BILL-DATE.
034500             10  H-BILL-YY                PIC 9(02).
034600             10  H-BILL-MM                PIC 9(02).
034700             10  H-BILL-DD                PIC 9(02).
034800
034900         05  HOLD-FY-BEGIN-DATE.
035000             10  H-FY-BEGIN-YY            PIC 9(02).
035100             10  H-FY-BEGIN-MM            PIC 9(02).
035200             10  H-FY-BEGIN-DD            PIC 9(02).
035300
035400         05  HOLD-ADD-FY-BEGN-DATE.
035500             10  H-ADD-FY-BEGN-YY            PIC 9(02).
035600             10  H-ADD-FY-BEGN-MM            PIC 9(02).
035700             10  H-ADD-FY-BEGN-DD            PIC 9(02).
035800
035900     02  HOLD-PPS-COMPONENTS.
036000         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
036100         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
036200
036300         05  H-OPER-HSP-PART              PIC 9(06)V9(09).
036400         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).
036500
036600         05  H-OPER-FSP-PART              PIC 9(06)V9(09).
036700         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).
036800         05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).
036900
037000         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).
037100         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).
037200         05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).
037300
037400         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).
037500         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).
037600
037700         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).
037800         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).
037900
038000         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).
038100         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).
038200
038300         05  H-OPER-DSH                   PIC 9(01)V9(04).
038400         05  H-CAPI-DSH                   PIC 9(01)V9(04).
038500
038600         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).
038700         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).
038800         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).
038900         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).
039000         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).
039100         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).
039200         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).
039300         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
039400         05  H-CAPI-COLA                  PIC 9(01)V9(03).
039500         05  H-CAPI-SCH                   PIC 9(05)V9(02).
039600         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).
039700         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).
039800         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).
039900         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).
040000         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).
040100         05  H-CAPI-GAF                   PIC 9(05)V9(04).
040200         05  H-WAGE-INDEX                 PIC 9(02)V9(04).
040300         05  H-COV-DAYS                   PIC 9(3).
040400         05  H-PERDIEM-DAYS               PIC 9(3).
040500         05  H-REG-DAYS                   PIC 9(3).
040600         05  H-LTR-DAYS                   PIC 9(3).
040700         05  H-DSCHG-FRCTN                PIC 9(1)V9999.
040800         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.
040900         05  H-ALOS                       PIC 9(02)V9(01).
041000         05  H-ARITH-ALOS                 PIC 9(02)V9(01).
041100         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).
041200         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).
041300         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).
041400         05  H-CST-THRESH                 PIC 9(05)V9(02).
041500         05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).
041600         05  H-BUDG-NUTR93                PIC 9(01)V9(06).
041700         05  H-BUDG-NUTR94                PIC 9(01)V9(06).
041800         05  H-BUDG-NUTR95                PIC 9(01)V9(06).
041900         05  H-BUDG-NUTR96                PIC 9(01)V9(06).
042000         05  H-BUDG-NUTR97                PIC 9(01)V9(06).
042100         05  H-UPDATE-95                  PIC 9(01)V9(03).
042200         05  H-UPDATE-96                  PIC 9(01)V9(03).
042300         05  H-UPDATE-97                  PIC 9(01)V9(03).
042400         05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).
042500         05  H-HSP-UPDATE94               PIC 9(01)V9(04).
042600         05  H-HSP-UPDATE95               PIC 9(01)V9(04).
042700         05  H-HSP-UPDATE96               PIC 9(01)V9(04).
042800         05  H-HSP-UPDATE97               PIC 9(01)V9(04).
042900         05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).
043000         05  H-FEDERAL-RATE               PIC 9(04)V9(02).
043100         05  H-LABOR-PCT                  PIC 9(01)V9(04).
043200         05  H-NLABOR-PCT                 PIC 9(01)V9(04).
043300         05  H-HSP-RATE                   PIC 9(06)V9(09).
043400         05  H-FSP-RATE                   PIC 9(06)V9(09).
043500         05  H-OUTLIER-FACT               PIC 9(01)V9(06).
043600         05  H-WK-OPER-DSH                PIC 9(01)V9(04).
043700         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).
043800
043900
044000     02  HOLD-ADDITIONAL-VARIABLES.
044100         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).
044200         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).
044300         05  H-NAT-PCT                    PIC 9(01)V9(02).
044400         05  H-REG-PCT                    PIC 9(01)V9(02).
044500         05  H-CMI-ADJ-CPD                PIC 9(05)V9(02).
044600         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).
044700         05  H-DRG-WT                     PIC 9(02)V9(04).
044800         05  H-NAT-LABOR                  PIC 9(05)V9(02).
044900         05  H-NAT-NLABOR                 PIC 9(05)V9(02).
045000         05  H-REG-LABOR                  PIC 9(05)V9(02).
045100         05  H-REG-NLABOR                 PIC 9(05)V9(02).
045200         05  H-OPER-COLA                  PIC 9(01)V9(03).
045300         05  H-INTERN-RATIO               PIC 9(01)V9(04).
045400         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).
045500         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).
045600         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
045700
045800     02  HOLD-CAPITAL-VARIABLES.
045900         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).
046000         05  H-CAPI-HSP                   PIC 9(07)V9(02).
046100         05  H-CAPI-FSP                   PIC 9(07)V9(02).
046200         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).
046300         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).
046400         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).
046500         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).
046600         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).
046700
046800     02  HOLD-CAPITAL2-VARIABLES.
046900         05  H-CAPI2-PAY-CODE             PIC X(1).
047000         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).
047100         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
047200
047300 LINKAGE SECTION.
047400***************************************************************
047500*                 * * * * * * * * *                           *
047600*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *
047700*    IN HOW TO PAY THE BILL.                                  *
047800*         REVIEW-CODE:                                        *
047900*            00 = PAY-WITH-OUTLIER.                           *
048000*                 WILL CALCULATE THE STANDARD PAYMENT.        *
048100*                 WILL ALSO ATTEMPT TO PAY DAY AND COST       *
048200*                 OUTLIERS.                                   *
048300*            03 = PAY-PERDIEM-DAYS.                           *
048400*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
048500*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
048600*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
048700*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
048800*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
048900*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
049000*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
049100*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
049200*                 BILL EXCEED THE COST THRESHOLD.             *
049300*            06 = PAY-XFER-NO-COST                            *
049400*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
049500*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
049600*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
049700*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *
049800*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
049900*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
050000*                 CALCULATE ANY COST OUTLIER PORTION          *
050100*                 OF THE PAYMENT.                             *
050200*            07 = PAY-WITHOUT-COST.                           *
050300*                 WILL CALCULATE THE STANDARD PAYMENT. WILL   *
050400*                 ALSO CALCULATE THE DAY OUTLIER PORTION OF   *
050500*                 THE PAYMENT IF THE COVERED DAYS EXCEED THE  *
050600*                 OUTLIER CUTOFF FOR THE DRG.                 *
050700***************************************************************
050800 01  BILL-DATA.
050900         10  B-PROVIDER-NO          PIC X(06).
051000         10  B-REVIEW-CODE          PIC 9(02).
051100             88  VALID-REVIEW-CODE  VALUE 00 03 06 07.
051200             88  PAY-WITH-OUTLIER   VALUE 00 07.
051300             88  PAY-PERDIEM-DAYS   VALUE 03.
051400             88  PAY-XFER-NO-COST   VALUE 06.
051500             88  PAY-WITHOUT-COST   VALUE 07.
051600         10  B-DRG                  PIC 9(03).
051700         10  B-LOS                  PIC 9(03).
051800         10  B-COVERED-DAYS         PIC 9(03).
051900         10  B-LTR-DAYS             PIC 9(02).
052000         10  B-DISCHARGE-DATE.
052100             15  B-DISCHG-MM        PIC 9(02).
052200             15  B-DISCHG-DD        PIC 9(02).
052300             15  B-DISCHG-YY        PIC 9(02).
052400         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
052500
052600***************************************************************
052700*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
052800*    AND PASSED BACK TO THE CALLING PROGRAM                   *
052900*            RETURN CODE VALUES (PPS-RTC)                     *
053000*                                                             *
053100*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
053200*              00 = PAID NORMAL DRG PAYMENT                   *
053300*                                                             *
053400*              01 = PAID AS A DAY-OUTLIER.                    *
053500*                                                             *
053600*              02 = PAID AS A COST-OUTLIER.                   *
053700*                                                             *
053800*              03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
053900*                   AND INCLUDING THE FULL DRG.               *
054000*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
054100*                   AND INCLUDING THE FULL DRG WHICH ALSO     *
054200*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *
054300*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
054400*                   AND INCLUDING THE FULL DRG. PROVIDER      *
054500*                   REFUSED COST OUTLIER.                     *
054600*                                                             *
054700*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
054800*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
054900*              52 = INVALID MSA # IN PROVIDER FILE            *
055000*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *
055100*              54 = DRG < 001 OR > 495, OR = 109 OR = 438     *
055200*                                       OR = 469 OR = 470     *
055300*                                       OR = 474              *
055400*              55 = DISCHARGE DATE < PROVIDER PPS START DATE  *
055500*              56 = INVALID LENGTH OF STAY                    *
055600*              57 = REVIEW CODE INVALID (NOT 00 03 06 07)     *
055700*              58 = TOTAL CHARGES NOT NUMERIC                 *
055800*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
055900*              62 = INVALID NUMBER OF COVERED DAYS            *
056000*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *
056100*                   SPECIFIC FILE FOR CAPITAL                 *
056200*              66 = THERE ARE NOT AS MANY BENEFIT DAYS        *
056300*                   AVAILABLE ON THE BILL AS THERE ARE OUTLIER*
056400*                   DAYS COMPUTED BY PRICER --BENEFITS ARE    *
056500*                   EXHAUSTED ---                             *
056600*                   APPORTION THE CORRECT COVERED CHARGES     *
056700*                   FOR THE MAXIMUM NUMBER OF COVERED DAYS    *
056800*                   AVAILABLE BEFORE RESUBMITTING THE BILL    *
056900*                   FOR THE COST OUTLIER PAYMENT.             *
057000*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *
057100***************************************************************
057200 01  PPS-DATA.
057300         10  PPS-RTC                PIC 9(02).
057400         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
057500         10  PPS-OUTLIER-DAYS       PIC 9(03).
057600         10  PPS-AVG-LOS            PIC 9(02)V9(01).
057700         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
057800         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
057900         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
058000         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
058100         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
058200         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
058300         10  PPS-REG-DAYS-USED      PIC 9(03).
058400         10  PPS-LTR-DAYS-USED      PIC 9(02).
058500         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
058600         10  PPS-CALC-VERS          PIC X(05).
058700
058800******************************************************************
058900*            THESE ARE THE VERSIONS OF THE PPCAL
059000*           PROGRAMS THAT WILL BE PASSED BACK----
059100*          ASSOCIATED WITH THE BILL BEING PROCESSED
059200******************************************************************
059300 01  PRICER-OPT-VERS-SW.
059400     02  PRICER-OPTION-SW          PIC X(01).
059500         88  ALL-TABLES-PASSED          VALUE 'A'.
059600         88  PROV-RECORD-PASSED         VALUE 'P'.
059700         88  ADDITIONAL-VARIABLES       VALUE 'M'.
059800     02  PPS-VERSIONS.
059900         10  PPDRV-VERSION         PIC X(05).
060000
060100******************************************************************
060200*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
060300*          ASSOCIATED WITH THE BILL BEING PROCESSED
060400******************************************************************
060500 01  PPS-ADDITIONAL-VARIABLES.
060600     05  PPS-HSP-PCT                PIC 9(01)V9(02).
060700     05  PPS-FSP-PCT                PIC 9(01)V9(02).
060800     05  PPS-NAT-PCT                PIC 9(01)V9(02).
060900     05  PPS-REG-PCT                PIC 9(01)V9(02).
061000     05  PPS-CMI-ADJ-CPD            PIC 9(05)V9(02).
061100     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
061200     05  PPS-DRG-WT                 PIC 9(02)V9(04).
061300     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
061400     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
061500     05  PPS-REG-LABOR              PIC 9(05)V9(02).
061600     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
061700     05  PPS-OPER-COLA              PIC 9(01)V9(03).
061800     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
061900     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
062000     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
062100     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
062200     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
062300     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
062400     05  PPS-CAPITAL-VARIABLES.
062500         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).
062600         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).
062700         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).
062800         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).
062900         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).
063000         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).
063100         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).
063200         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).
063300     05  PPS-CAPITAL2-VARIABLES.
063400         10  PPS-CAPI2-PAY-CODE             PIC X(1).
063500         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).
063600         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
063700         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
063800         10  PPS-HVBP-HRR-DATA.
063900             15  PPS-VAL-BASED-PURCH-PARTIPNT PIC X.
064000             15  PPS-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
064100             15  PPS-HOSP-READMISS-REDUCTN    PIC X.
064200             15  PPS-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
064300         10  PPS-OPERATNG-DATA.
064400             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.
064500             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.
064600             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.
064700         10  PPS-FILLER                      PIC X(0998).
064800
064900
065000******************************************************************
065100*               THIS IS THE PROVIDER RECORD
065200*          ASSOCIATED WITH THE BILL BEING PROCESSED
065300******************************************************************
065400 01  PROV-HOLD.
065500     02  PROV-REC-HOLD.
065600         05  P-PROVIDER-NO.
065700             10  P-STATE                PIC 9(02).
065800             10  FILLER                 PIC X(04).
065900         05  P-EFF-DATE.
066000             10  P-EFF-YY               PIC 9(02).
066100             10  P-EFF-MM               PIC 9(02).
066200             10  P-EFF-DD               PIC 9(02).
066300         05  P-WAIVER-CODE              PIC X(01).
066400             88  WAIVER-STATE           VALUE 'Y'.
066500         05  P-PROVIDER-TYPE            PIC X(02).
066600             88  REFERRAL-CENTER        VALUE '07' '15' '17' '22'.
066700             88  INDIAN-HEALTH-SERVICE  VALUE '08'.
066800             88  MDH-REBASED-FY90       VALUE '14' '15'.
066900             88  MDH-RRC-REBASED-FY90   VALUE '15'.
067000             88  SCH-REBASED-FY90       VALUE '16' '17'.
067100             88  SCH-RRC-REBASED-FY90   VALUE '17'.
067200             88  MEDICAL-ASSIST-FACIL   VALUE '18'.
067300             88  EACH                   VALUE '21' '22'.
067400             88  EACH-REFERRAL-CENTER   VALUE '22'.
067500         05  P-CURRENT-CENSUS-DIV       PIC 9(01).
067600             88  NEW-ENGLAND            VALUE  1.
067700             88  MIDDLE-ATLANTIC        VALUE  2.
067800             88  SOUTH-ATLANTIC         VALUE  3.
067900             88  EAST-NORTH-CENTRAL     VALUE  4.
068000             88  EAST-SOUTH-CENTRAL     VALUE  5.
068100             88  WEST-NORTH-CENTRAL     VALUE  6.
068200             88  WEST-SOUTH-CENTRAL     VALUE  7.
068300             88  MOUNTAIN               VALUE  8.
068400             88  PACIFIC                VALUE  9.
068500         05  P-CENSUS-DIV  REDEFINES
068600                    P-CURRENT-CENSUS-DIV       PIC 9(01).
068700             88  VALID-CENSUS-DIV   VALUE 1 THRU 9.
068800         05  P-PPS-BLEND-YEAR           PIC 9(01).
068900             88  VALID-PPS-BLEND-YEAR   VALUE 1 THRU 8.
069000         05  P-MSA-X.
069100             10  P-MSA-9                PIC X(04).
069200         05  P-FISCAL-YEAR-END.
069300             10  P-MM                   PIC 9(02).
069400             10  P-DD                   PIC 9(02).
069500             10  P-YY                   PIC 9(02).
069600         05  P-VARIABLES.
069700             10  P-CMI-ADJ-CPD          PIC S9(05)V9(02).
069800             10  P-COLA                 PIC S9(01)V9(03).
069900             10  P-INTERN-RATIO         PIC S9(01)V9(04).
070000             10  PRUP-UPDT-FACTOR       PIC S9(01)V9(05).
070100             10  P-BED-SIZE             PIC  9(05).
070200             10  P-DSH-PERCENT          PIC V9(04).
070300             10  P-OPER-CSTCHG-RATIO    PIC  9(01)V9(03).
070400             10  P-CMI                  PIC  9(01)V9(04).
070500             10  FILLER                 PIC  9(01).
070600             10  P-REPORT-DATE          PIC  9(06).
070700             10  FILLER                 PIC  9(01).
070800             10  P-INTER-NO             PIC  9(05).
070900     02  PROV-REC-HOLD2.
071000         05  P-FY-BEGIN-DATE.
071100             10  P-FY-BEGIN-MM          PIC 9(2).
071200             10  P-FY-BEGIN-DD          PIC 9(2).
071300             10  P-FY-BEGIN-YY          PIC 9(2).
071400         05  P-PASS-AMT-CAPITAL         PIC 9(4)V99.
071500         05  P-PASS-AMT-DIR-MED-ED      PIC 9(4)V99.
071600         05  P-PASS-AMT-ORGAN-ACQ       PIC 9(4)V99.
071700         05  P-PASS-AMT-INCL-MISC       PIC 9(4)V99.
071800         05  P-SSI-RATIO                PIC V9(4).
071900         05  P-MEDICAID-RATIO           PIC V9(4).
072000         05  P-TERMINATION-DATE         PIC X(6).
072100         05  P-WAGE-INDEX-LOC-MSA       PIC X(4).
072200         05  P-CHG-CODE-INDEX           PIC X.
072300         05  P-STAND-AMT-LOC-MSA.
072400             10  P-RURAL-1ST            PIC XX.
072500                 88  P-RURAL-CHECK        VALUE '  '.
072600             10  P-RURAL-2ND            PIC XX.
072700         05  P-CAPI-SOL-HOSP-RATE       PIC XX.
072800         05  FILLER                     PIC X.
072900         05  FILLER                     PIC X(06).
073000         05  FILLER                     PIC X(18).
073100     02  PROV-REC-HOLD3.
073200         05  P-CAPI-PPS-PAY-CODE        PIC X.
073300         05  P-CAPI-HOSP-SPEC-RATE      PIC 9(4)V99.
073400         05  P-CAPI-OLD-HARM-RATE       PIC 9(4)V99.
073500         05  P-CAPI-NEW-HARM-RATIO      PIC 9(1)V9999.
073600         05  P-CAPI-CSTCHG-RATIO        PIC 9V999.
073700         05  P-CAPI-NEW-HOSP            PIC X.
073800         05  P-CAPI-IME                 PIC 9V9999.
073900         05  P-CAPI-EXCEPTIONS          PIC 9(4)V99.
074000         05  P-HVBP-HRR-DATA.
074100             10  P-VAL-BASED-PURCH-PARTIPNT PIC X.
074200             10  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
074300             10  P-HOSP-READMISSION-REDUCTN PIC X.
074400             10  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
074500         05  P-MODEL1-BUNDLE-DATA.
074600             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.
074700             15  P-HAC-REDUC-IND            PIC X.
074800             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.
074900             15  P-EHR-REDUC-IND            PIC X.
075000         05  FILLER                         PIC X(09).
075100
075200************************************************************
075300
075400******************************************************************
075500*                   THIS IS THE WAGE-INDEX
075600*          ASSOCIATED WITH THE BILL BEING PROCESSED
075700******************************************************************
075800 01  WAGE-INDEX-RECORD.
075900     05  W-MSA                         PIC X(4).
076000     05  W-SIZE                        PIC X.
076100         88  LARGE-URBAN       VALUE 'L'.
076200         88  OTHER-URBAN       VALUE 'O'.
076300         88  ALL-RURAL         VALUE 'R'.
076400     05  W-EFF-DATE                    PIC X(6).
076500     05  FILLER                        PIC X.
076600     05  W-INDEX-RECORD                PIC S9(02)V9(04).
076700
076800
076900 PROCEDURE DIVISION  USING BILL-DATA
077000                           PPS-DATA
077100                           PRICER-OPT-VERS-SW
077200                           PPS-ADDITIONAL-VARIABLES
077300                           PROV-HOLD
077400                           WAGE-INDEX-RECORD.
077500
077600***************************************************************
077700*    PROCESSING:                                              *
077800*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
077900*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *
078000*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
078100*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
078200*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
078300*           GOBACK.                                           *
078400*        D. ASSEMBLE PRICING COMPONENTS.                      *
078500*        E. CALCULATE THE PRICE.                              *
078600***************************************************************
078700
078800     PERFORM 0200-MAINLINE-CONTROL.
078900
079000     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
079100     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.
079200     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.
079300     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.
079400     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.
079500     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
079600
079700     GOBACK.
079800
079900 0200-MAINLINE-CONTROL.
080000     MOVE ALL '0' TO PPS-DATA
080100                     HOLD-PPS-COMPONENTS
080200                     HOLD-ADDITIONAL-VARIABLES
080300                     HOLD-CAPITAL-VARIABLES
080400                     HOLD-CAPITAL2-VARIABLES.
080500
080600     IF P-CAPI-HOSP-SPEC-RATE NOT NUMERIC
080700        MOVE 0 TO P-CAPI-HOSP-SPEC-RATE.
080800
080900     IF P-CAPI-OLD-HARM-RATE  NOT NUMERIC
081000        MOVE 0 TO P-CAPI-OLD-HARM-RATE.
081100
081200     IF P-CAPI-NEW-HARM-RATIO NOT NUMERIC
081300        MOVE 0 TO P-CAPI-NEW-HARM-RATIO.
081400
081500     IF P-CAPI-CSTCHG-RATIO NOT NUMERIC
081600        MOVE 0 TO P-CAPI-CSTCHG-RATIO.
081700
081800******************************************************************
081900     PERFORM 1000-EDIT-THE-BILL-INFO.
082000
082100     IF  PPS-RTC = 00
082200         PERFORM 2000-ASSEMBLE-PPS-VARIABLES
082300         PERFORM 3000-CALC-PAYMENT.
082400
082500 1000-EDIT-THE-BILL-INFO.
082600***************************************************************
082700*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *
082800*    AND DO NOT ATTEMPT TO PRICE.                             *
082900***************************************************************
083000
083100     MOVE B-DISCHG-YY TO H-BILL-YY.
083200     MOVE B-DISCHG-MM TO H-BILL-MM.
083300     MOVE B-DISCHG-DD TO H-BILL-DD.
083400
083500     MOVE P-FY-BEGIN-YY TO H-FY-BEGIN-YY.
083600     MOVE P-FY-BEGIN-MM TO H-FY-BEGIN-MM.
083700     MOVE P-FY-BEGIN-DD TO H-FY-BEGIN-DD.
083800
083900     IF HOLD-FY-BEGIN-DATE < 961001
084000        MOVE .50 TO H-CAPI-PAYCDE-PCT1
084100        MOVE .50 TO H-CAPI-PAYCDE-PCT2
084200     ELSE
084300        IF (HOLD-FY-BEGIN-DATE < HOLD-BILL-DATE) OR
084400           (HOLD-FY-BEGIN-DATE = HOLD-BILL-DATE)
084500              MOVE .60 TO H-CAPI-PAYCDE-PCT1
084600              MOVE .40 TO H-CAPI-PAYCDE-PCT2
084700        ELSE
084800              MOVE .50 TO H-CAPI-PAYCDE-PCT1
084900              MOVE .50 TO H-CAPI-PAYCDE-PCT2.
085000
085100     IF  PPS-RTC = 00
085200         IF  WAIVER-STATE
085300             MOVE 53 TO PPS-RTC.
085400
085500     IF  PPS-RTC = 00
085600         IF  B-DRG < 001 OR > 495 OR = 109 OR = 438
085700                                  OR = 469 OR = 470
085800                                  OR = 474
085900             MOVE 54 TO PPS-RTC.
086000
086100     IF  PPS-RTC = 00
086200         IF  HOLD-BILL-DATE < P-EFF-DATE
086300             MOVE 55 TO PPS-RTC.
086400
086500     IF  PPS-RTC = 00
086600         IF  B-REVIEW-CODE NOT NUMERIC
086700             MOVE 57 TO PPS-RTC.
086800     IF  PPS-RTC = 00
086900         IF  B-LOS NOT NUMERIC
087000             MOVE 56 TO PPS-RTC
087100         ELSE
087200         IF  B-LOS = 0
087300             IF B-REVIEW-CODE NOT = 03 AND
087400                              NOT = 06
087500             MOVE 56 TO PPS-RTC.
087600
087700     IF  PPS-RTC = 00
087800         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60
087900             MOVE 61 TO PPS-RTC
088000         ELSE
088100             MOVE B-LTR-DAYS TO H-LTR-DAYS.
088200
088300     IF  PPS-RTC = 00
088400         IF  B-COVERED-DAYS NOT NUMERIC
088500             MOVE 62 TO PPS-RTC
088600         ELSE
088700         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
088800             MOVE 62 TO PPS-RTC
088900         ELSE
089000             MOVE B-COVERED-DAYS TO H-COV-DAYS.
089100
089200     IF  PPS-RTC = 00
089300         IF  H-LTR-DAYS  > H-COV-DAYS
089400             MOVE 62 TO PPS-RTC
089500         ELSE
089600             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
089700
089800     IF  PPS-RTC = 00
089900         IF  NOT VALID-REVIEW-CODE
090000             MOVE 57 TO PPS-RTC.
090100
090200     IF  PPS-RTC = 00
090300         IF  B-CHARGES-CLAIMED NOT NUMERIC
090400             MOVE 58 TO PPS-RTC.
090500
090600     IF PPS-RTC = 00
090700        IF NOT INDIAN-HEALTH-SERVICE
090800           IF P-CAPI-NEW-HOSP NOT = 'Y'
090900                 IF P-CAPI-PPS-PAY-CODE NOT = 'A' AND
091000                                        NOT = 'B' AND
091100                                        NOT = 'C'
091200                 MOVE 65 TO PPS-RTC.
091300
091400 2000-ASSEMBLE-PPS-VARIABLES.
091500***************************************************************
091600*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *
091700*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *
091800*    OF THAT VARIABLE.                                        *
091900***************************************************************
092000***  GET THE PROVIDER SPECIFIC VARIABLES.
092100***  GET THE PROVIDER SPECIFIC VARIABLES.
092200
092300     MOVE P-CMI-ADJ-CPD  TO H-CMI-ADJ-CPD.
092400     MOVE P-INTERN-RATIO TO H-INTERN-RATIO.
092500
092600     IF  (P-STATE = 02 OR 12)
092700         MOVE P-COLA TO H-OPER-COLA
092800     ELSE
092900         MOVE 1.000  TO H-OPER-COLA.
093000
093100***************************************************************
093200***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
093300***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
093400
093500     PERFORM 2600-GET-DRG-WEIGHT
093600             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.
093700
093800***************************************************************
093900***  GET THE WAGE-INDEX
094000***  GET THE WAGE-INDEX
094100
094200     MOVE W-INDEX-RECORD TO H-WAGE-INDEX.
094300
094400***************************************************************
094500***  GET THE LABOR, NON-LABOR STANDARD RATES
094600
094700     IF  VALID-CENSUS-DIV
094800         MOVE P-CURRENT-CENSUS-DIV TO R2
094900     ELSE
095000         MOVE 10 TO R2.
095100
095200     MOVE 10 TO R4.
095300
095400     IF  P-STATE = 40
095500         MOVE 11 TO R2
095600         MOVE 12 TO R4.
095700
095800     IF  LARGE-URBAN
095900         MOVE 1 TO R3
096000     ELSE
096100     IF  OTHER-URBAN OR REFERRAL-CENTER
096200         MOVE 2 TO R3
096300     ELSE
096400         MOVE 3 TO R3.
096500
096600     PERFORM 2300-GET-LABOR-NLABOR-RATES
096700             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
096800
096900***************************************************************
097000***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
097100***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
097200
097300     MOVE 0.00  TO H-OPER-HSP-PCT.
097400     MOVE 1.00  TO H-OPER-FSP-PCT.
097500
097600***************************************************************
097700***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
097800***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
097900
098000      MOVE 1.00 TO H-NAT-PCT.
098100      MOVE 0.00 TO H-REG-PCT.
098200
098300***************************************************************
098400*    REGIONAL FLOOR EXPIRED 10/01/96
098500*    REGIONAL FLOOR EXPIRED 10/01/96
098600
098700*    IF  (H-REG-LABOR + H-REG-NLABOR) >
098800*        (H-NAT-LABOR + H-NAT-NLABOR)
098900*          MOVE 0.85 TO H-NAT-PCT
099000*          MOVE 0.15 TO H-REG-PCT.
099100***************************************************************
099200
099300     IF  P-STATE = 40
099400         MOVE 0.25 TO H-NAT-PCT
099500         MOVE 0.75 TO H-REG-PCT.
099600
099700     IF  SCH-REBASED-FY90 OR EACH
099800         MOVE 1.00 TO H-OPER-HSP-PCT.
099900
100000 2300-GET-LABOR-NLABOR-RATES.
100100
100200     IF  HOLD-BILL-DATE NOT < RATE-EFF-DATE (R1)
100300         MOVE REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
100400         MOVE REG-NLABOR (R1 R2 R3) TO H-REG-NLABOR
100500         MOVE REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
100600         MOVE REG-NLABOR (R1 R4 R3) TO H-NAT-NLABOR.
100700
100800 2600-GET-DRG-WEIGHT.
100900     IF  HOLD-BILL-DATE NOT < DRGX-EFF-DATE (DX5)
101000         SET DX6 TO B-DRG
101100         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT
101200         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS
101300         MOVE DRG-DAYS-TRIM (DX5 DX6)  TO H-DAYS-CUTOFF
101400         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.
101500
101600 3000-CALC-PAYMENT.
101700***************************************************************
101800*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *
101900*        CALCULATE COVERED DAYS UTILIZATION.                  *
102000*        CALCULATE THE FEDERAL PORTION.                       *
102100*        CALCULATE THE HOSPITAL PORTION.                      *
102200*        CALCULATE THE DAYS-OUTLIER PORTION.                  *
102300*        CALCULATE THE COST-OUTLIER PORTION.                  *
102400*        CALCULATE THE TOTAL PAYMENT OPERATING AND CAPITAL    *
102500*        CALCULATE THE DSH ADJUSTMENT.                        *
102600*        CALCULATE THE IME TEACHING.                          *
102700***************************************************************
102800     PERFORM 3100-CALC-STAY-UTILIZATION.
102900     PERFORM 3300-CALC-OPER-FSP-AMT.
103000     PERFORM 3900-CALC-OPER-DSH.
103100***********************************************************
103200***  OPERATING IME CALCULATION
103300***  OPERATING IME CALCULATION
103400
103500         COMPUTE H-OPER-IME-TEACH =
103600            1.89 * ((1 + H-INTERN-RATIO) ** .405  - 1).
103700
103800***********************************************************
103900
104000     IF  SCH-REBASED-FY90 OR EACH
104100         PERFORM 3450-CALC-ADDITIONAL-HSP.
104200
104300     MOVE 00                 TO  PPS-RTC.
104400     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.
104500     MOVE H-ALOS             TO  PPS-AVG-LOS.
104600     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.
104700
104800     MOVE B-LOS TO H-PERDIEM-DAYS.
104900     IF H-PERDIEM-DAYS < 1
105000         MOVE 1 TO H-PERDIEM-DAYS.
105100     ADD 1 TO H-PERDIEM-DAYS.
105200
105300     PERFORM 3600-CALC-OUTLIER.
105400
105500     IF PAY-PERDIEM-DAYS
105600         IF  H-PERDIEM-DAYS < H-ALOS
105700             IF  NOT (B-DRG = 385 OR 456)
105800                 PERFORM 3500-CALC-PERDIEM-AMT
105900                 MOVE 03 TO PPS-RTC.
106000
106100     IF  PAY-PERDIEM-DAYS
106200         IF  H-OPER-OUTCST-PART > 0
106300             MOVE H-OPER-OUTCST-PART TO
106400                  H-OPER-OUTLIER-PART
106500             MOVE 05 TO PPS-RTC
106600         ELSE
106700         IF  PPS-RTC NOT = 03
106800             MOVE 00 TO PPS-RTC
106900             MOVE 0  TO H-OPER-OUTLIER-PART.
107000
107100     IF  PAY-PERDIEM-DAYS
107200         IF  H-CAPI-OUTCST-PART > 0
107300             MOVE H-CAPI-OUTCST-PART TO
107400                  H-CAPI-OUTLIER-PART
107500             MOVE 05 TO PPS-RTC
107600         ELSE
107700         IF  PPS-RTC NOT = 03
107800             MOVE 0  TO H-CAPI-OUTLIER-PART.
107900
108000     IF  PAY-XFER-NO-COST
108100         MOVE 0  TO H-OPER-OUTLIER-PART
108200                    H-CAPI-OUTLIER-PART
108300         MOVE 00 TO PPS-RTC
108400         IF H-PERDIEM-DAYS < H-ALOS
108500            IF  NOT (B-DRG = 385 OR 456)
108600                PERFORM 3500-CALC-PERDIEM-AMT
108700                MOVE 06 TO PPS-RTC.
108800
108900     MOVE 1 TO H-DSCHG-FRCTN.
109000
109100     IF  (PAY-PERDIEM-DAYS OR
109200          PAY-XFER-NO-COST)
109300          COMPUTE H-DSCHG-FRCTN = H-PERDIEM-DAYS / H-ALOS
109400          IF H-DSCHG-FRCTN > 1
109500             MOVE 1 TO H-DSCHG-FRCTN.
109600
109700     COMPUTE H-DRG-WT-FRCTN = H-DSCHG-FRCTN * H-DRG-WT.
109800
109900***********************************************************
110000***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF
110100***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
110200
110300     COMPUTE H-CAPI2-B-FSP-PART = H-CAPI-FSP-PART.
110400
110500***********************************************************
110600     IF  PPS-RTC < 50
110700         PERFORM 3800-CALC-TOT-AMT
110800     ELSE
110900         MOVE 0 TO PPS-OPER-HSP-PART
111000                   PPS-OPER-FSP-PART
111100                   PPS-OPER-OUTLIER-PART
111200                   PPS-OUTLIER-DAYS
111300                   PPS-REG-DAYS-USED
111400                   PPS-LTR-DAYS-USED
111500                   PPS-TOTAL-PAYMENT
111600                   PPS-OPER-DSH-ADJ
111700                   PPS-OPER-IME-ADJ
111800                   H-DSCHG-FRCTN
111900                   H-DRG-WT-FRCTN
112000                   HOLD-CAPITAL-VARIABLES
112100                   HOLD-CAPITAL2-VARIABLES.
112200
112300 3100-CALC-STAY-UTILIZATION.
112400
112500     IF  H-REG-DAYS > 0
112600         IF  H-REG-DAYS < H-DAYS-CUTOFF
112700             MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
112800             MOVE 0          TO H-REG-DAYS
112900         ELSE
113000             MOVE H-DAYS-CUTOFF TO PPS-REG-DAYS-USED
113100             SUBTRACT H-DAYS-CUTOFF FROM H-REG-DAYS
113200     ELSE
113300     IF  H-LTR-DAYS < H-DAYS-CUTOFF
113400         MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED
113500         MOVE 0          TO H-LTR-DAYS
113600     ELSE
113700         MOVE H-DAYS-CUTOFF TO PPS-LTR-DAYS-USED
113800         SUBTRACT H-DAYS-CUTOFF FROM H-LTR-DAYS.
113900
114000     IF  B-LOS > H-DAYS-CUTOFF
114100         PERFORM 3200-CALC-OUTLIER-UTILIZATION.
114200
114300 3200-CALC-OUTLIER-UTILIZATION.
114400
114500     COMPUTE PPS-OUTLIER-DAYS =
114600         B-LOS - H-DAYS-CUTOFF.
114700
114800     IF  (H-REG-DAYS + H-LTR-DAYS) < PPS-OUTLIER-DAYS
114900         COMPUTE PPS-OUTLIER-DAYS =
115000             H-REG-DAYS + H-LTR-DAYS
115100         ADD H-REG-DAYS TO PPS-REG-DAYS-USED
115200         ADD H-LTR-DAYS TO PPS-LTR-DAYS-USED
115300     ELSE
115400     IF  H-REG-DAYS < PPS-OUTLIER-DAYS
115500         ADD H-REG-DAYS TO PPS-REG-DAYS-USED
115600         COMPUTE PPS-LTR-DAYS-USED =
115700             PPS-LTR-DAYS-USED + (PPS-OUTLIER-DAYS -
115800                                  H-REG-DAYS)
115900     ELSE
116000         ADD PPS-OUTLIER-DAYS TO PPS-REG-DAYS-USED.
116100
116200     IF  B-REVIEW-CODE = 03
116300         IF  PPS-REG-DAYS-USED > 0
116400             MOVE 0 TO PPS-LTR-DAYS-USED.
116500
116600 3300-CALC-OPER-FSP-AMT.
116700***********************************************************
116800***  OPERATING FSP CALCULATION
116900***  OPERATING FSP CALCULATION
117000
117100     COMPUTE H-OPER-FSP-PART ROUNDED =
117200         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
117300         H-NAT-NLABOR * H-OPER-COLA) * H-DRG-WT)
117400                           +
117500         (H-REG-PCT * (H-REG-LABOR * H-WAGE-INDEX +
117600         H-REG-NLABOR * H-OPER-COLA) * H-DRG-WT).
117700
117800
117900 3450-CALC-ADDITIONAL-HSP.
118000***********************************************************
118100*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR
118200*    SOLE COMMUNITY
118300*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)
118400*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
118500***********************************************************
118600**** CHANGE ESTIMATED OUTLIER FACTORS WHEN FED RATES CHANGE
118700****    USE ACTUAL FEDERAL REGISTER NUMBER
118800
118900     MOVE 0.949001 TO H-OUTLIER-FACT.
119000***************************************************************
119100***         GET THE UPDATING FACTOR
119200***         GET THE UPDATING FACTOR
119300
119400     MOVE 0.999851 TO H-BUDG-NUTR93.
119500     MOVE 0.999003 TO H-BUDG-NUTR94.
119600     MOVE 0.998050 TO H-BUDG-NUTR95.
119700     MOVE 0.999306 TO H-BUDG-NUTR96.
119800     MOVE 0.998703 TO H-BUDG-NUTR97.
119900
120000     MOVE 1.014 TO H-UPDATE-95.
120100     MOVE 1.015 TO H-UPDATE-96.
120200     MOVE 1.020 TO H-UPDATE-97.
120300
120400     COMPUTE H-UPDATE-FACTOR ROUNDED =
120500        (H-UPDATE-95 * H-UPDATE-96 *
120600         H-UPDATE-97 *
120700         H-BUDG-NUTR93 * H-BUDG-NUTR94 *
120800         H-BUDG-NUTR95 * H-BUDG-NUTR96 *
120900         H-BUDG-NUTR97).
121000
121100     COMPUTE H-HSP-RATE ROUNDED =
121200         H-CMI-ADJ-CPD * H-UPDATE-FACTOR.
121300
121400     COMPUTE H-FSP-RATE ROUNDED =
121500         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
121600         H-NAT-NLABOR * H-OPER-COLA))
121700                           +
121800          (H-REG-PCT * (H-REG-LABOR * H-WAGE-INDEX +
121900         H-REG-NLABOR * H-OPER-COLA)))
122000                           *
122100       ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-FACT).
122200
122300     IF  H-HSP-RATE > H-FSP-RATE
122400           COMPUTE H-OPER-HSP-PART =
122500             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT
122600     ELSE
122700         MOVE 0 TO H-OPER-HSP-PART.
122800
122900 3500-CALC-PERDIEM-AMT.
123000***********************************************************
123100***  OPERATING PERDIEM-AMT CALCULATION
123200***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
123300
123400     COMPUTE H-OPER-HSP-PART ROUNDED =
123500        H-OPER-HSP-PART / H-ALOS * H-PERDIEM-DAYS
123600        ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
123700
123800     COMPUTE H-OPER-FSP-PART ROUNDED =
123900        H-OPER-FSP-PART / H-ALOS * H-PERDIEM-DAYS
124000        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
124100
124200***********************************************************
124300***  CAPITAL PERDIEM-AMT CALCULATION
124400***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS
124500
124600     COMPUTE H-CAPI-HSP-PART ROUNDED =
124700        H-CAPI-HSP-PART / H-ALOS * H-PERDIEM-DAYS
124800        ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
124900
125000     COMPUTE H-CAPI-FSP-PART ROUNDED =
125100        H-CAPI-FSP-PART / H-ALOS * H-PERDIEM-DAYS
125200        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
125300
125400***********************************************************
125500***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
125600***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
125700
125800     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
125900        H-CAPI-OLD-HARMLESS / H-ALOS * H-PERDIEM-DAYS
126000        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
126100
126200 3600-CALC-OUTLIER.
126300     MOVE 0.33 TO H-DAYOUT-PCT.
126400
126500     MOVE 0.80 TO H-CSTOUT-PCT.
126600
126700     IF  B-DRG = 456 OR 457 OR 458 OR 459 OR 460 OR 472
126800             MOVE 0.90 TO H-CSTOUT-PCT.
126900
127000     MOVE 0.7120   TO H-LABOR-PCT.
127100     MOVE 0.2880   TO H-NLABOR-PCT.
127200
127300     IF  P-OPER-CSTCHG-RATIO NUMERIC
127400             MOVE P-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO
127500     ELSE
127600             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.
127700
127800     IF P-CAPI-CSTCHG-RATIO NUMERIC
127900             MOVE P-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO
128000     ELSE
128100             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.
128200
128300***********************************************************
128400***  OPERATING DAY OUTLIER CALCULATION
128500***  OPERATING DAY OUTLIER CALCULATION
128600
128700     IF  PPS-OUTLIER-DAYS > 0
128800        COMPUTE H-OPER-OUTDAY-PART =
128900            H-DAYOUT-PCT *  H-OPER-FSP-PART / H-ARITH-ALOS
129000                                       * PPS-OUTLIER-DAYS
129100            ON SIZE ERROR MOVE 0 TO H-OPER-OUTDAY-PART.
129200
129300***********************************************************
129400***********************************************************
129500***  CAPITAL PAYMENT METHOD B
129600***  CAPITAL PAYMENT METHOD B
129700
129800     IF W-SIZE = 'L'
129900        MOVE 1.03 TO H-CAPI-LARG-URBAN
130000     ELSE
130100        MOVE 1.00 TO H-CAPI-LARG-URBAN.
130200
130300     COMPUTE H-CAPI-GAF = (H-WAGE-INDEX ** .6848).
130400
130500     COMPUTE H-CAPI-COLA =
130600                     (.3152 * (H-OPER-COLA - 1) + 1).
130700
130800     MOVE 0337.63 TO H-PUERTO-RICO-RATE.
130900     MOVE 0438.92 TO H-FEDERAL-RATE.
131000
131100     IF P-STATE = 40
131200        COMPUTE  H-CAPI-FED-RATE =
131300                      (.75 * H-PUERTO-RICO-RATE) +
131400                      (.25 * H-FEDERAL-RATE)
131500     ELSE
131600        MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.
131700
131800***********************************************************
131900***  CAPITAL HSP CALCULATION
132000***  CAPITAL HSP CALCULATION
132100
132200     MOVE 0.9784 TO H-HSP-UPDATE94.
132300     MOVE 1.0005 TO H-HSP-UPDATE95.
132400     MOVE 1.2110 TO H-HSP-UPDATE96.
132500     MOVE 0.9568 TO H-HSP-UPDATE97.
132600
132700     COMPUTE H-ACCUM-TO-HSP = (H-HSP-UPDATE94 *
132800                               H-HSP-UPDATE95 *
132900                               H-HSP-UPDATE96 *
133000                               H-HSP-UPDATE97).
133100
133200     COMPUTE H-CAPI-HSP-PART = (H-DRG-WT *
133300                   P-CAPI-HOSP-SPEC-RATE * H-ACCUM-TO-HSP).
133400***********************************************************
133500***  CAPITAL FSP CALCULATION
133600***  CAPITAL FSP CALCULATION
133700
133800     COMPUTE H-CAPI-FSP-PART = H-DRG-WT * H-CAPI-FED-RATE *
133900                               H-CAPI-COLA * H-CAPI-GAF *
134000                               H-CAPI-LARG-URBAN.
134100
134200***********************************************************
134300***  CAPITAL PAYMENT METHOD A
134400***  CAPITAL PAYMENT METHOD A
134500
134600     IF SCH-REBASED-FY90 OR EACH
134700        MOVE 1.00 TO H-CAPI-SCH
134800     ELSE
134900        MOVE 0.85 TO H-CAPI-SCH.
135000
135100***********************************************************
135200***********  CAPITAL OLD-HARMLESS CALCULATION ***********
135300***********  CAPITAL OLD-HARMLESS CALCULATION ***********
135400
135500     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
135600                    (P-CAPI-OLD-HARM-RATE *
135700                    H-CAPI-SCH).
135800
135900***********************************************************
136000***********************************************************
136100***  CAPITAL DAY OUTLIER CALCULATION
136200***  CAPITAL DAY OUTLIER CALCULATION
136300
136400     IF  PPS-OUTLIER-DAYS > 0
136500         COMPUTE H-CAPI-OUTDAY-PART =
136600            H-DAYOUT-PCT * H-CAPI-FSP-PART / H-ARITH-ALOS
136700                                       * PPS-OUTLIER-DAYS
136800            ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.
136900
137000     IF  H-CAPI-OUTDAY-PART  > 0
137100         IF P-CAPI-PPS-PAY-CODE = 'A'
137200             COMPUTE H-CAPI-OUTDAY-PART =
137300                 H-CAPI-OUTDAY-PART * P-CAPI-NEW-HARM-RATIO
137400             ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.
137500
137600     IF  H-CAPI-OUTDAY-PART  > 0
137700         IF P-CAPI-PPS-PAY-CODE = 'C'
137800             COMPUTE H-CAPI-OUTDAY-PART =
137900                    (H-CAPI-OUTDAY-PART * H-CAPI-PAYCDE-PCT1)
138000             ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.
138100
138200***********************************************************
138300***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
138400***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
138500
138600     IF H-CAPI-CSTCHG-RATIO > 0 OR
138700       H-OPER-CSTCHG-RATIO > 0
138800        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD =
138900                H-OPER-CSTCHG-RATIO /
139000               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
139100        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD =
139200                H-CAPI-CSTCHG-RATIO /
139300               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
139400     ELSE
139500         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD
139600                   H-CAPI-SHARE-DOLL-THRESHOLD.
139700
139800     MOVE 09700.00 TO H-CST-THRESH.
139900     MOVE 08850.00 TO H-PRE-CAPI-THRESH.
140000
140100     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
140200        ((H-CST-THRESH * H-LABOR-PCT  * H-WAGE-INDEX) +
140300         (H-CST-THRESH * H-NLABOR-PCT * H-OPER-COLA)) *
140400          H-OPER-SHARE-DOLL-THRESHOLD.
140500
140600***********************************************************
140700***  DIFFERENT THRESHOLD   PRE-CAPITAL
140800***  DIFFERENT THRESHOLD   PRE-CAPITAL
140900
141000     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE
141100        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
141200        (H-PRE-CAPI-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +
141300        (H-PRE-CAPI-THRESH * H-NLABOR-PCT * H-OPER-COLA).
141400***********************************************************
141500
141600     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
141700          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *
141800          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.
141900
142000     COMPUTE H-OPER-COST-OUTLIER ROUNDED =
142100          H-OPER-FSP-PART + H-OPER-DOLLAR-THRESHOLD.
142200
142300     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
142400          H-CAPI-FSP-PART + H-CAPI-DOLLAR-THRESHOLD.
142500
142600     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE
142700         MOVE 0 TO H-CAPI-COST-OUTLIER.
142800
142900     IF B-REVIEW-CODE = '03'  AND H-PERDIEM-DAYS < H-ALOS
143000        COMPUTE H-OPER-COST-OUTLIER ROUNDED =
143100                (H-OPER-COST-OUTLIER * H-PERDIEM-DAYS / H-ALOS)
143200                ON SIZE ERROR MOVE 0 TO H-OPER-COST-OUTLIER.
143300
143400     IF B-REVIEW-CODE = '03'  AND H-PERDIEM-DAYS < H-ALOS
143500        COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
143600                (H-CAPI-COST-OUTLIER * H-PERDIEM-DAYS / H-ALOS)
143700                ON SIZE ERROR MOVE 0 TO H-CAPI-COST-OUTLIER.
143800
143900***********************************************************
144000***  CAPITAL DSH CALCULATION
144100***  CAPITAL DSH CALCULATION
144200
144300     MOVE 0 TO H-CAPI-DSH.
144400
144500     IF P-BED-SIZE NOT NUMERIC
144600         MOVE 0 TO P-BED-SIZE.
144700
144800     IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99
144900         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **
145000                  (.2025 * (P-SSI-RATIO
145100                          + P-MEDICAID-RATIO)) - 1.
145200
145300***********************************************************
145400***  OPERATING COST CALCULATION
145500***  OPERATING COST CALCULATION
145600
145700     COMPUTE H-OPER-BILL-COSTS ROUNDED =
145800         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO /
145900         (1 + H-OPER-IME-TEACH + H-OPER-DSH)
146000         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
146100
146200     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER
146300         COMPUTE H-OPER-OUTCST-PART =
146400         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -
146500                         H-OPER-COST-OUTLIER).
146600
146700     IF PAY-WITHOUT-COST
146800         MOVE 0 TO H-OPER-OUTCST-PART.
146900
147000***********************************************************
147100***  CAPITAL IME TEACH CALCULATION
147200***  CAPITAL IME TEACH CALCULATION
147300
147400     MOVE 0 TO H-WK-CAPI-IME-TEACH.
147500
147600     IF P-CAPI-IME NUMERIC
147700        COMPUTE H-WK-CAPI-IME-TEACH =
147800          (2.7183 ** (.2822 * P-CAPI-IME)) - 1.
147900
148000***********************************************************
148100***  CAPITAL COST CALCULATION
148200***  CAPITAL COST CALCULATION
148300
148400     COMPUTE H-CAPI-BILL-COSTS ROUNDED =
148500             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO /
148600            (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH)
148700         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.
148800
148900     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER
149000         COMPUTE H-CAPI-OUTCST-PART =
149100         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -
149200                         H-CAPI-COST-OUTLIER).
149300
149400     IF P-CAPI-PPS-PAY-CODE = 'A'
149500       COMPUTE H-CAPI-OUTCST-PART =
149600              (H-CAPI-OUTCST-PART * P-CAPI-NEW-HARM-RATIO).
149700
149800     IF P-CAPI-PPS-PAY-CODE = 'C'
149900        COMPUTE H-CAPI-OUTCST-PART =
150000               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).
150100
150200     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <
150300        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)
150400        MOVE 0 TO H-CAPI-OUTCST-PART
150500                  H-OPER-OUTCST-PART.
150600
150700     IF PAY-WITHOUT-COST
150800         MOVE 0 TO H-CAPI-OUTCST-PART.
150900
151000***********************************************************
151100***  DETERMINES THE BILL TO BE EITHER COST OR DAY OUTLIER
151200***     GREATER OF DAY OR COST OPERATING AND CAPITAL
151300
151400     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE
151500         MOVE 0 TO H-CAPI-OUTDAY-PART
151600                   H-CAPI-OUTCST-PART.
151700
151800      IF (H-OPER-OUTDAY-PART + H-CAPI-OUTDAY-PART) > 0 OR
151900         (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
152000         IF (H-OPER-OUTDAY-PART + H-CAPI-OUTDAY-PART) >
152100            (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART)
152200                 MOVE H-OPER-OUTDAY-PART TO
152300                      H-OPER-OUTLIER-PART
152400                 MOVE H-CAPI-OUTDAY-PART TO
152500                      H-CAPI-OUTLIER-PART
152600                 MOVE 01 TO PPS-RTC
152700             ELSE
152800                 MOVE H-OPER-OUTCST-PART TO
152900                      H-OPER-OUTLIER-PART
153000                 MOVE H-CAPI-OUTCST-PART TO
153100                      H-CAPI-OUTLIER-PART
153200                 MOVE 02 TO PPS-RTC
153300                 IF B-COVERED-DAYS > H-DAYS-CUTOFF
153400                    IF (H-REG-DAYS
153500                            +
153600                        H-LTR-DAYS)   <
153700                       (B-COVERED-DAYS - H-DAYS-CUTOFF)
153800                       MOVE 66 TO PPS-RTC.
153900
154000***********************************************************
154100***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF
154200***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
154300
154400     IF P-CAPI-PPS-PAY-CODE = 'A'
154500        COMPUTE H-CAPI2-B-OUTLIER-PART =
154600                H-CAPI-OUTLIER-PART / P-CAPI-NEW-HARM-RATIO
154700         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
154800
154900     IF P-CAPI-PPS-PAY-CODE = 'B'
155000        COMPUTE H-CAPI2-B-OUTLIER-PART =
155100                H-CAPI-OUTLIER-PART.
155200
155300     IF P-CAPI-PPS-PAY-CODE = 'C'
155400        COMPUTE H-CAPI2-B-OUTLIER-PART =
155500                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1
155600         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
155700***********************************************************
155800
155900 3800-CALC-TOT-AMT.
156000
156100***********************************************************
156200***  CALCULATE FINAL TOTALS FOR OPERATING
156300***  CALCULATE FINAL TOTALS FOR OPERATING
156400
156500     COMPUTE PPS-OPER-HSP-PART ROUNDED =
156600         H-OPER-HSP-PCT * H-OPER-HSP-PART.
156700
156800     COMPUTE PPS-OPER-FSP-PART ROUNDED =
156900         H-OPER-FSP-PCT * H-OPER-FSP-PART.
157000
157100     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =
157200             H-OPER-FSP-PCT * H-OPER-OUTLIER-PART.
157300
157400     MOVE ZERO TO PPS-OPER-DSH-ADJ.
157500
157600     IF  H-OPER-DSH NUMERIC
157700             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
157800             (PPS-OPER-FSP-PART + PPS-OPER-OUTLIER-PART)
157900              * H-OPER-DSH.
158000
158100     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
158200         (PPS-OPER-FSP-PART + PPS-OPER-OUTLIER-PART) *
158300                 H-OPER-IME-TEACH.
158400
158500***********************************************************
158600***  CALCULATE FINAL TOTALS FOR CAPITAL
158700***  CALCULATE FINAL TOTALS FOR CAPITAL
158800
158900     MOVE P-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.
159000
159100     IF P-CAPI-PPS-PAY-CODE = 'A'
159200        MOVE P-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT
159300        MOVE 0.00 TO H-CAPI-HSP-PCT.
159400
159500     IF P-CAPI-PPS-PAY-CODE = 'B'
159600        MOVE 0    TO H-CAPI-OLD-HARMLESS
159700        MOVE 1.00 TO H-CAPI-FSP-PCT
159800        MOVE 0.00 TO H-CAPI-HSP-PCT.
159900
160000     IF P-CAPI-PPS-PAY-CODE = 'C'
160100        MOVE 0    TO H-CAPI-OLD-HARMLESS
160200        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT
160300        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.
160400
160500     COMPUTE H-CAPI-HSP ROUNDED =
160600         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.
160700
160800     COMPUTE H-CAPI-FSP ROUNDED =
160900         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.
161000
161100     MOVE P-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.
161200
161300     COMPUTE H-CAPI-OUTLIER ROUNDED =
161400             1.00 * H-CAPI-OUTLIER-PART.
161500
161600     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =
161700             1.00 * H-CAPI2-B-OUTLIER-PART.
161800
161900     COMPUTE H-CAPI2-B-FSP ROUNDED =
162000             1.00 * H-CAPI2-B-FSP-PART.
162100
162200     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.
162300
162400     COMPUTE H-CAPI-DSH-ADJ ROUNDED =
162500             (H-CAPI-FSP + H-CAPI-OUTLIER-PART)
162600              * H-CAPI-DSH.
162700
162800     COMPUTE H-CAPI-IME-ADJ ROUNDED =
162900         (H-CAPI-FSP + H-CAPI-OUTLIER-PART) *
163000                 H-WK-CAPI-IME-TEACH.
163100
163200***********************************************************
163300***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER
163400***        THIS ZEROES OUT ALL CAPITAL DATA
163500
163600     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE
163700        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.
163800
163900     COMPUTE H-CAPI-TOTAL-PAY =
164000             H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
164100             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
164200             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM.
164300
164400***********************************************************
164500***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
164600***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
164700
164800     COMPUTE PPS-TOTAL-PAYMENT =
164900             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
165000             PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
165100             PPS-OPER-IME-ADJ
165200                           +
165300                  H-CAPI-TOTAL-PAY.
165400
165500 3900-CALC-OPER-DSH.
165600***********************************************************
165700***  OPERATING DSH CALCULATION
165800***  OPERATING DSH CALCULATION
165900
166000      MOVE .00 TO H-OPER-DSH.
166100
166200      COMPUTE H-WK-OPER-DSH = (P-SSI-RATIO
166300                                     + P-MEDICAID-RATIO).
166400
166500      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE < 100
166600                               AND H-WK-OPER-DSH > .3999
166700        MOVE .05 TO H-OPER-DSH.
166800
166900      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99
167000                               AND H-WK-OPER-DSH > .1499
167100                               AND H-WK-OPER-DSH < .2021
167200        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
167300                                      * .65 + .025.
167400
167500      IF W-SIZE = 'R'          AND P-BED-SIZE > 499
167600                               AND H-WK-OPER-DSH > .1499
167700                               AND H-WK-OPER-DSH < .2021
167800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
167900                                 * .65 + .025.
168000
168100      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99
168200                               AND H-WK-OPER-DSH > .202
168300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
168400                                 * .825 + .0588.
168500
168600      IF W-SIZE = 'R'          AND P-BED-SIZE > 499
168700                               AND H-WK-OPER-DSH > .202
168800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
168900                                 * .825 + .0588.
169000
169100      IF W-SIZE = 'R'          AND P-BED-SIZE < 101
169200                               AND H-WK-OPER-DSH > .4499
169300        MOVE .04 TO H-OPER-DSH.
169400
169500      IF W-SIZE = 'R'          AND P-BED-SIZE > 100
169600                               AND P-BED-SIZE < 500
169700                               AND H-WK-OPER-DSH > .2999
169800        MOVE .04 TO H-OPER-DSH.
169900
170000      IF W-SIZE = 'R'
170100         IF (P-PROVIDER-TYPE = '16' OR '21')
170200                               AND H-WK-OPER-DSH > .2999
170300                               AND P-BED-SIZE < 500
170400            MOVE .10 TO H-OPER-DSH.
170500
170600      IF W-SIZE = 'R'
170700         IF (P-PROVIDER-TYPE = '07')
170800                               AND H-WK-OPER-DSH > .2999
170900                               AND P-BED-SIZE > 100
171000                               AND P-BED-SIZE < 500
171100            COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .3)
171200                                 * .6 + .04.
171300
171400      IF W-SIZE = 'R'
171500         IF (P-PROVIDER-TYPE = '17' OR '22')
171600                               AND H-WK-OPER-DSH > .2999
171700                               AND P-BED-SIZE < 500
171800            COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .3)
171900                                 * .6 + .04.
172000
172100      IF W-SIZE = 'R'
172200         IF (P-PROVIDER-TYPE = '17' OR '22')
172300                               AND H-WK-OPER-DSH > .2999
172400                               AND P-BED-SIZE < 500
172500                               AND H-OPER-DSH < .10
172600            MOVE .10 TO H-OPER-DSH.
172700
172800******        L A S T   S O U R C E   S T A T E M E N T   *****
