000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPCAL935.
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 77  PAN-VALET PICTURE X(24) VALUE '003PPCAL935  09/04/96'.
001800 01  W-STORAGE-REF                  PIC X(46)  VALUE
001900     'PPCAL935 - WORKING   STORAGE'.
002000 01  CAL-VERSION                    PIC X(05)  VALUE 'C93.5'.
002100 01  R1                             PIC S9(04) COMP SYNC.
002200 01  R2                             PIC S9(04) COMP SYNC.
002300 01  R3                             PIC S9(04) COMP SYNC.
002400 01  R4                             PIC S9(04) COMP SYNC.
002500 01  U1                             PIC S9(04) COMP SYNC.
002600 01  U2                             PIC S9(04) COMP SYNC.
002700 01  U3                             PIC S9(04) COMP SYNC.
002800 01  BLEND-RURAL-PCT                PIC V9(09) COMP SYNC.
002900 01  MO-DIFF                        PIC  9(03).
003000
003100***************************************************************
003200*    LAYUP TABLE AREA                                         *
003300***************************************************************
003400 01  RATE-TABLE.
003500     02  RATE-WORK.
003600*RATE 921001 REGION-NATION/LURBAN-OURBAN-RURAL/LABOR-NLABOR
003700         05  FILLER PIC X(06) VALUE '921001'.
003800         05  NE01   PIC X(45) VALUE
003900            ' 0271822 111353 0267518 109589 0290621 100229'.
004000         05  MA02   PIC X(45) VALUE
004100            ' 0244207 105494 0240341 103824 0278327 094750'.
004200         05  SA03   PIC X(45) VALUE
004300            ' 0260683 097359 0256555 095818 0266069 082162'.
004400         05  ENS04  PIC X(45) VALUE
004500            ' 0274957 115192 0270604 113368 0269430 091315'.
004600         05  ESC05  PIC X(45) VALUE
004700            ' 0250184 088157 0246222 086762 0263701 076617'.
004800         05  WNC06  PIC X(45) VALUE
004900            ' 0260757 104959 0256629 103298 0256299 081854'.
005000         05  WSC07  PIC X(45) VALUE
005100            ' 0259257 096700 0255151 095170 0245800 075276'.
005200         05  MNT08  PIC X(45) VALUE
005300            ' 0250091 103578 0246131 101939 0248570 086578'.
005400         05  PAC09  PIC X(45) VALUE
005500            ' 0243268 118317 0239418 116444 0241756 097534'.
005600         05  NTL10  PIC X(45) VALUE
005700            ' 0258838 106639 0254740 104951 0262130 084454'.
005800         05  PR11   PIC X(45) VALUE
005900            ' 0232798 048416 0229112 047650 0178674 038518'.
006000         05  NPR12  PIC X(45) VALUE
006100            ' 0258180 100412 0258180 100412 0258180 100412'.
006200     02  RATE-TAB REDEFINES RATE-WORK.
006300         05  RATE-PERIOD            OCCURS 1.
006400             10  RATE-EFF-DATE      PIC X(06).
006500             10  REG-NAT            OCCURS 12.
006600                 15  R-URBAN-RURAL  OCCURS 3.
006700                     20  FILLER     PIC X(01).
006800                     20  REG-LABOR  PIC 9(05)V9(02).
006900                     20  FILLER     PIC X(01).
007000                     20  REG-NLABOR PIC 9(04)V9(02).
007100
007200 01  UPDT-TABLE.
007300     02  UPDT-WORK.
007400*UPDT 900101 UPDATING FACTORS EFFECTIVE DATE
007500*     LURBAN=1.0562 OURBAN=1.0497 RURAL=1.0972 (JAN - SEP)
007600     05  FILLER PIC X(06) VALUE '900101'.
007700     05  FILLER PIC X(27) VALUE '830131 134318 132191 142277'.
007800     05  FILLER PIC X(27) VALUE '830228 134453 132325 142422'.
007900     05  FILLER PIC X(27) VALUE '830331 134587 132456 142564'.
008000     05  FILLER PIC X(27) VALUE '830430 134725 132592 142710'.
008100     05  FILLER PIC X(27) VALUE '830531 134861 132725 142853'.
008200     05  FILLER PIC X(27) VALUE '830630 134998 132861 142999'.
008300     05  FILLER PIC X(27) VALUE '830731 135134 132995 143143'.
008400     05  FILLER PIC X(27) VALUE '830831 135270 133128 143288'.
008500     05  FILLER PIC X(27) VALUE '820930 135106 132968 143113'.
008600     05  FILLER PIC X(27) VALUE '821031 134799 132664 142787'.
008700     05  FILLER PIC X(27) VALUE '821130 134488 132359 142459'.
008800     05  FILLER PIC X(27) VALUE '821231 134180 132054 142131'.
008900     02  UPDATE-TABLE REDEFINES UPDT-WORK.
009000     05  UPDT-PERIOD             OCCURS 1.
009100         10  UPDT-EFF-DATE       PIC X(06).
009200         10  UPDT-MONTH          OCCURS 12.
009300             15  UP-BASE-DATE    PIC X(06).
009400             15  UP-L-O-R        OCCURS 3.
009500                 20  FILLER           PIC X(01).
009600                 20  UPDATE-FACTOR   PIC 9(01)V9(05).
009700
009800 01  DRG-TABLE.
009900     05  D-TAB.
010000        10  FILLER                  PIC X(06) VALUE
010100       '921001'.
010200        10  FILLER                  PIC X(56) VALUE
010300       '03232411334158031311108341510296271273612702361208832128'.
010400        10  FILLER                  PIC X(56) VALUE
010500       '01550405228065005437020220300263631113421500794402926045'.
010600        10  FILLER                  PIC X(56) VALUE
010700       '01278606429100012884074301090076490432706200955006930099'.
010800        10  FILLER                  PIC X(56) VALUE
010900       '00833606530082012160070300980066620412705201108606630090'.
011000        10  FILLER                  PIC X(56) VALUE
011100       '00642404427057009170058290770059580392705402004208632126'.
011200        10  FILLER                  PIC X(56) VALUE
011300       '01450507230095007261042270540082020422706000971405228072'.
011400        10  FILLER                  PIC X(56) VALUE
011500       '00528203426043010516040270590137440432708201220805929093'.
011600        10  FILLER                  PIC X(56) VALUE
011700       '00588503326046003593020170200077070442706400445402725036'.
011800        10  FILLER                  PIC X(56) VALUE
011900       '00249401609016011442059290850055900362704900623801911023'.
012000        10  FILLER                  PIC X(56) VALUE
012100       '00788302826042003584021160280048580150801900515002025032'.
012200        10  FILLER                  PIC X(56) VALUE
012300       '00371301607016005968019140250040260362704800576705228062'.
012400        10  FILLER                  PIC X(56) VALUE
012500       '00598903526044007217043270630041560292604100407902926029'.
012600        10  FILLER                  PIC X(56) VALUE
012700       '01602905028073006594020120250062780211902900785902219029'.
012800        10  FILLER                  PIC X(56) VALUE
012900       '00723702024031006994032220320054690171502400616801917026'.
013000        10  FILLER                  PIC X(56) VALUE
013100       '00884503326051003145015040150042730151002000265501504015'.
013200        10  FILLER                  PIC X(56) VALUE
013300       '00861302526046003136013050130104290372705501103905128088'.
013400        10  FILLER                  PIC X(56) VALUE
013500       '00492203323041004885033250430084240412705200721604728058'.
013600        10  FILLER                  PIC X(56) VALUE
013700       '00500003622043006126032260440076640402705100584403326050'.
013800        10  FILLER                  PIC X(56) VALUE
013900       '00752204127059003480021200210304001123413602397310534146'.
014000        10  FILLER                  PIC X(56) VALUE
014100       '01020804327065014350085311000175100903211800961706429079'.
014200        10  FILLER                  PIC X(56) VALUE
014300       '01120006129061012809067300960094900602907900478303426043'.
014400        10  FILLER                  PIC X(56) VALUE
014500       '01196906830090006711040270530135970582908000994105829072'.
014600        10  FILLER                  PIC X(56) VALUE
014700       '01158107030086007090052280610079850472805801197506830087'.
014800        10  FILLER                  PIC X(56) VALUE
014900       '00772304828060012774071300930059730432705300936905829070'.
015000        10  FILLER                  PIC X(56) VALUE
015100       '00619104324051008924047280630076230382705000504902517031'.
015200        10  FILLER                  PIC X(56) VALUE
015300       '00913505028067005426033260431255682374732307752117240201'.
015400        10  FILLER                  PIC X(56) VALUE
015500       '05829111935143056583133361490423481023311405872512335151'.
015600        10  FILLER                  PIC X(56) VALUE
015700       '00000000000   040823099331330229790733008401987404528060'.
015800        10  FILLER                  PIC X(56) VALUE
015900       '02778914037188015957089321230360921133413602460405328071'.
016000        10  FILLER                  PIC X(56) VALUE
016100       '01226403727054015858025260390096500352606001990607230123'.
016200        10  FILLER                  PIC X(56) VALUE
016300       '01611407831095011532057290680140900292605301202904227057'.
016400        10  FILLER                  PIC X(56) VALUE
016500       '00758702222031028464155392030101500592907600787307230082'.
016600        10  FILLER                  PIC X(56) VALUE
016700       '01283102425047009106061290790058610472806000759104027054'.
016800        10  FILLER                  PIC X(56) VALUE
016900       '00531202924038005655038270480086250462806400526603124042'.
017000        10  FILLER                  PIC X(56) VALUE
017100       '00641103326033008110043270570050200292103600621903624044'.
017200        10  FILLER                  PIC X(56) VALUE
017300       '00699804227055005048031220380051640271803301065005028070'.
017400        10  FILLER                  PIC X(56) VALUE
017500       '00624003126041025394119351360151920823109003135313036156'.
017600        10  FILLER                  PIC X(56) VALUE
017700       '01494808328090025484113341370118850632907701773608832104'.
017800        10  FILLER                  PIC X(56) VALUE
017900       '01042606525071040491140371790146170723008500851006029060'.
018000        10  FILLER                  PIC X(56) VALUE
018100       '00957504527062004975023170300107470472806100616802719033'.
018200        10  FILLER                  PIC X(56) VALUE
018300       '00782003226044004651018110220048430231402702160709532112'.
018400        10  FILLER                  PIC X(56) VALUE
018500       '01208006325070013251059290700074950361504100990203426055'.
018600        10  FILLER                  PIC X(56) VALUE
018700       '00578802118028027310107341560108980502806701299007130104'.
018800        10  FILLER                  PIC X(56) VALUE
018900       '00634603527052009794053280680055060362204301033105829075'.
019000        10  FILLER                  PIC X(56) VALUE
019100       '00793105028061005720037220440110440703009100927905729074'.
019200        10  FILLER                  PIC X(56) VALUE
019300       '00500703825045007721048280610052960342404200562503025041'.
019400        10  FILLER                  PIC X(56) VALUE
019500       '00785404427062004174029230290056500262603800997105228073'.
019600        10  FILLER                  PIC X(56) VALUE
019700       '00480402826038006796041270530446521533819901705107731095'.
019800        10  FILLER                  PIC X(56) VALUE
019900       '03037613737164016333079310980227441043312001403907230080'.
020000        10  FILLER                  PIC X(56) VALUE
020100       '01691606229083008757026260360233761103414302720509032134'.
020200        10  FILLER                  PIC X(56) VALUE
020300       '02522110033144012996070300960121580683009701115806029078'.
020400        10  FILLER                  PIC X(56) VALUE
020500       '01224906530091006113036270500098140532806900556403125040'.
020600        10  FILLER                  PIC X(56) VALUE
020700       '02368609432104019077107341250133070833109301034504227061'.
020800        10  FILLER                  PIC X(56) VALUE
020900       '01768609232128018686081311010109050512806002042910033145'.
021000        10  FILLER                  PIC X(56) VALUE
021100       '03060113637213014186068300880089560422605100938205328053'.
021200        10  FILLER                  PIC X(56) VALUE
021300       '01782807330106009544037270520080870302203800653802414029'.
021400        10  FILLER                  PIC X(56) VALUE
021500       '00821203326050013241057290870067670282303800796102525035'.
021600        10  FILLER                  PIC X(56) VALUE
021700       '00553901915026009179039270600110440392706301179203627066'.
021800        10  FILLER                  PIC X(56) VALUE
021900       '01857908331116008957039270530102090683011200812806229086'.
022000        10  FILLER                  PIC X(56) VALUE
022100       '00549604227055015435102331370104150743009901146806830092'.
022200        10  FILLER                  PIC X(56) VALUE
022300       '00578204327056011864078311030068340502806700735305228070'.
022400        10  FILLER                  PIC X(56) VALUE
022500       '00504303827053005706042270530056820372705000675004528060'.
022600        10  FILLER                  PIC X(56) VALUE
022700       '00696504127062007047045280650043950262503500354901815018'.
022800        10  FILLER                  PIC X(56) VALUE
022900       '00777405529078004231034260460047090292602900650503727052'.
023000        10  FILLER                  PIC X(56) VALUE
023100       '00895004223049007002032140360087740362705400565902112025'.
023200        10  FILLER                  PIC X(56) VALUE
023300       '00718302214028005345021220310254031433720201266208231113'.
023400        10  FILLER                  PIC X(56) VALUE
023500       '01393906029095006978030260430062450272604100751902626044'.
023600        10  FILLER                  PIC X(56) VALUE
023700       '01695608031120006343028260390119700843111201047707130092'.
023800        10  FILLER                  PIC X(56) VALUE
023900       '00658305228067011572067301080059570302604800608504027054'.
024000        10  FILLER                  PIC X(56) VALUE
024100       '00903606830082005941051280600074790422404200680704628063'.
024200        10  FILLER                  PIC X(56) VALUE
024300       '00427003126041003476022190220075580522807100445003526047'.
024400        10  FILLER                  PIC X(56) VALUE
024500       '02751914738211023944090321110217441253618302037806930101'.
024600        10  FILLER                  PIC X(56) VALUE
024700       '01025203727053007448026160320048960170902002842812035177'.
024800        10  FILLER                  PIC X(56) VALUE
024900       '01128405328075007491056290710077210432705700941005929081'.
025000        10  FILLER                  PIC X(56) VALUE
025100       '00527103927050004777026210340083920452806701125106930092'.
025200        10  FILLER                  PIC X(56) VALUE
025300       '00581103927053038885135371570265321093413102410309933133'.
025400        10  FILLER                  PIC X(56) VALUE
025500       '01154805028064012744065300860068890372004501431506029089'.
025600        10  FILLER                  PIC X(56) VALUE
025700       '00728702926039008880038270540051530211402700808203727052'.
025800        10  FILLER                  PIC X(56) VALUE
025900       '00462302117027004389023250230203620663012001289606229091'.
026000        10  FILLER                  PIC X(56) VALUE
026100       '00507502826039011244060290900050690252603700980706529081'.
026200        10  FILLER                  PIC X(56) VALUE
026300       '00625204827057006389046280560073810312604200385802113025'.
026400        10  FILLER                  PIC X(56) VALUE
026500       '00655104227057004152028220360070380492806500636303627048'.
026600        10  FILLER                  PIC X(56) VALUE
026700       '00411302118029002830016090160097650532807400534703026044'.
026800        10  FILLER                  PIC X(56) VALUE
026900       '00959005228076017728082280890135970691907300870404624055'.
027000        10  FILLER                  PIC X(56) VALUE
027100       '00606603412038009386039270610075720312604500440102413024'.
027200        10  FILLER                  PIC X(56) VALUE
027300       '00968103325042005766025250370038450170601701056803927052'.
027400        10  FILLER                  PIC X(56) VALUE
027500       '00752103226046009906057290850051200292604400681504027055'.
027600        10  FILLER                  PIC X(56) VALUE
027700       '00395202320030006707048280580033840130501300580103226047'.
027800        10  FILLER                  PIC X(56) VALUE
027900       '01903109232111013686068300780084930471205000703003815042'.
028000        10  FILLER                  PIC X(56) VALUE
028100       '02309710033123011066056220630077230421104500802404027050'.
028200        10  FILLER                  PIC X(56) VALUE
028300       '00976703527055005057014050140062510302404100565902626038'.
028400        10  FILLER                  PIC X(56) VALUE
028500       '01709307130104012158065291010048080272603800882005829073'.
028600        10  FILLER                  PIC X(56) VALUE
028700       '00532103126045008916053270680064610401104200461902919036'.
028800        10  FILLER                  PIC X(56) VALUE
028900       '00318202108024006297028240400069210442704400324702317029'.
029000        10  FILLER                  PIC X(56) VALUE
029100       '00839203627051007694033130370027430202002900343001920028'.
029200        10  FILLER                  PIC X(56) VALUE
029300       '00432601714024001486013050140039470322604300270102018027'.
029400        10  FILLER                  PIC X(56) VALUE
029500       '01241801825018037035179411790185451333613301174708632086'.
029600        10  FILLER                  PIC X(56) VALUE
029700       '01422904728047011340038270610022520311103103128711034140'.
029800        10  FILLER                  PIC X(56) VALUE
029900       '01543709132091015966056291000078810462806300680202024032'.
030000        10  FILLER                  PIC X(56) VALUE
030100       '01190505328074012091064290820067350402705202557208932133'.
030200        10  FILLER                  PIC X(56) VALUE
030300       '02349710233150008536035270510168270813112000742804027056'.
030400        10  FILLER                  PIC X(56) VALUE
030500       '01056504928049027669110341530119990502806501327904928084'.
030600        10  FILLER                  PIC X(56) VALUE
030700       '00988606129089006095028200350042560242303300425702020029'.
030800        10  FILLER                  PIC X(56) VALUE
030900       '01333507330107006857041270600351621463820501522207430103'.
031000        10  FILLER                  PIC X(56) VALUE
031100       '00897404427055009679064290810095000572907300651004427053'.
031200        10  FILLER                  PIC X(56) VALUE
031300       '00688204327054007629048280620159760793111002405813837234'.
031400        10  FILLER                  PIC X(56) VALUE
031500       '00704504527062006023051280720063220512807600770306429105'.
031600        10  FILLER                  PIC X(56) VALUE
031700       '00946007631114009040086321230059800512807300711304527069'.
031800        10  FILLER                  PIC X(56) VALUE
031900       '00354502926044007494054280740048180452706300986914838179'.
032000        10  FILLER                  PIC X(56) VALUE
032100       '0108881423716700000000000   0121260562909201835908131129'.
032200        10  FILLER                  PIC X(56) VALUE
032300       '00732102325035019106059290970075180262603700764305228072'.
032400        10  FILLER                  PIC X(56) VALUE
032500       '00464903326043004869024220240049190252403400352302917029'.
032600        10  FILLER                  PIC X(56) VALUE
032700       '00788904027057004325023220320052680211702100855004227061'.
032800        10  FILLER                  PIC X(56) VALUE
032900       '00417502723035008873043270680041300232103101728504628088'.
033000        10  FILLER                  PIC X(56) VALUE
033100       '02014703627088038787160392270189061023314901003206329091'.
033200        10  FILLER                  PIC X(56) VALUE
033300       '00880802526051017805139371790072770482806600456703126041'.
033400        10  FILLER                  PIC X(56) VALUE
033500       '00353101920028005328024250440044690272605403419513136190'.
033600        10  FILLER                  PIC X(56) VALUE
033700       '000000000  000000000000  0000389761193513711709316139299'.
033800        10  FILLER                  PIC X(56) VALUE
033900       '0344020973317100000000000   0359650963314102201413637169'.
034000        10  FILLER                  PIC X(56) VALUE
034100       '01433706029102021645068301020127180412705520161426950403'.
034200        10  FILLER                  PIC X(56) VALUE
034300       '15224441264457034826137371801665904396757206570614938233'.
034400        10  FILLER                  PIC X(56) VALUE
034500       '03166913036164048231106341740194060753111304153916539231'.
034600        10  FILLER                  PIC X(56) VALUE
034700       '01915109332141011285054280880156760532806302781508532143'.
034800     05  DRGX-TAB REDEFINES D-TAB.
034900         10  DRGX-PERIOD               OCCURS 1
035000                                        INDEXED BY DX5.
035100             15  DRGX-EFF-DATE         PIC X(06).
035200             15  DRG-DATA              OCCURS 492
035300                                        INDEXED BY DX6.
035400                 20  DRG-WT            PIC 9(02)V9(04).
035500                 20  DRG-ALOS          PIC 9(02)V9(01).
035600                 20  DRG-DAYS-TRIM     PIC 9(02).
035700                 20  DRG-ARITH-ALOS    PIC 9(02)V9(01).
035800
035900 01  HOLD-AREA.
036000     02  HOLD-DATES.
036100         05  HOLD-BILL-DATE.
036200             10  H-BILL-YY                PIC 9(02).
036300             10  H-BILL-MM                PIC 9(02).
036400             10  H-BILL-DD                PIC 9(02).
036500
036600         05  HOLD-FY-BEGIN-DATE.
036700             10  H-FY-BEGIN-YY            PIC 9(02).
036800             10  H-FY-BEGIN-MM            PIC 9(02).
036900             10  H-FY-BEGIN-DD            PIC 9(02).
037000
037100         05  HOLD-PROV-FYE-DATE.
037200             10  H-FYE-YY                 PIC 9(02).
037300             10  H-FYE-MMDD.
037400                 15  H-FYE-MM             PIC 9(02).
037500                 15  H-FYE-DD             PIC 9(02).
037600
037700     02  HOLD-PPS-COMPONENTS.
037800         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
037900         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
038000
038100         05  H-OPER-HSP-PART              PIC 9(06)V9(09).
038200         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).
038300
038400         05  H-OPER-FSP-PART              PIC 9(06)V9(09).
038500         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).
038600         05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).
038700
038800         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).
038900         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).
039000         05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).
039100
039200         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).
039300         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).
039400
039500         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).
039600         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).
039700
039800         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).
039900         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).
040000
040100         05  H-OPER-DSH                   PIC 9(01)V9(04).
040200         05  H-CAPI-DSH                   PIC 9(01)V9(04).
040300
040400         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).
040500         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).
040600         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).
040700         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).
040800         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).
040900         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).
041000         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).
041100         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
041200         05  H-CAPI-COLA                  PIC 9(01)V9(03).
041300         05  H-CAPI-SCH                   PIC 9(05)V9(02).
041400         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).
041500         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).
041600         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).
041700         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).
041800         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).
041900         05  H-CAPI-GAF                   PIC 9(05)V9(04).
042000         05  H-WAGE-INDEX                 PIC 9(02)V9(04).
042100         05  H-COV-DAYS                   PIC 9(3).
042200         05  H-REG-DAYS                   PIC 9(3).
042300         05  H-LTR-DAYS                   PIC 9(3).
042400         05  H-DSCHG-FRCTN                PIC 9(1)V9999.
042500         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.
042600         05  H-ALOS                       PIC 9(02)V9(01).
042700         05  H-ARITH-ALOS                 PIC 9(02)V9(01).
042800         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).
042900         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).
043000         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).
043100         05  H-CST-MULTIPLE               PIC 9(01)V9(03).
043200         05  H-CST-THRESH                 PIC 9(05)V9(02).
043300         05  H-LABOR-PCT                  PIC 9(01)V9(04).
043400         05  H-NLABOR-PCT                 PIC 9(01)V9(04).
043500         05  H-HSP-RATE                   PIC 9(06)V9(09).
043600         05  H-FSP-RATE                   PIC 9(06)V9(09).
043700         05  H-OUTLIER-FACT               PIC 9(01)V9(06).
043800         05  H-WK-OPER-DSH                PIC 9(01)V9(04).
043900         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).
044000
044100
044200     02  HOLD-ADDITIONAL-VARIABLES.
044300         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).
044400         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).
044500         05  H-NAT-PCT                    PIC 9(01)V9(02).
044600         05  H-REG-PCT                    PIC 9(01)V9(02).
044700         05  H-CMI-ADJ-CPD                PIC 9(05)V9(02).
044800         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).
044900         05  H-DRG-WT                     PIC 9(02)V9(04).
045000         05  H-NAT-LABOR                  PIC 9(05)V9(02).
045100         05  H-NAT-NLABOR                 PIC 9(05)V9(02).
045200         05  H-REG-LABOR                  PIC 9(05)V9(02).
045300         05  H-REG-NLABOR                 PIC 9(05)V9(02).
045400         05  H-OPER-COLA                  PIC 9(01)V9(03).
045500         05  H-INTERN-RATIO               PIC 9(01)V9(04).
045600         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).
045700         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).
045800         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
045900
046000     02  HOLD-CAPITAL-VARIABLES.
046100         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).
046200         05  H-CAPI-HSP                   PIC 9(07)V9(02).
046300         05  H-CAPI-FSP                   PIC 9(07)V9(02).
046400         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).
046500         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).
046600         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).
046700         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).
046800         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).
046900
047000     02  HOLD-CAPITAL2-VARIABLES.
047100         05  H-CAPI2-PAY-CODE             PIC X(1).
047200         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).
047300         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
047400
047500 LINKAGE SECTION.
047600***************************************************************
047700*                 * * * * * * * * *                           *
047800*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *
047900*    IN HOW TO PAY THE BILL.                                  *
048000*         REVIEW-CODE:                                        *
048100*            00 = PAY-WITH-OUTLIER.                           *
048200*                 WILL CALCULATE THE STANDARD PAYMENT.        *
048300*                 WILL ALSO ATTEMPT TO PAY DAY AND COST       *
048400*                 OUTLIERS.                                   *
048500*            03 = PAY-PERDIEM-DAYS.                           *
048600*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
048700*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
048800*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
048900*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
049000*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
049100*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
049200*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
049300*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
049400*                 BILL EXCEED THE COST THRESHOLD.             *
049500*            06 = PAY-XFER-NO-COST                            *
049600*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
049700*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
049800*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
049900*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *
050000*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
050100*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
050200*                 CALCULATE ANY COST OUTLIER PORTION          *
050300*                 OF THE PAYMENT.                             *
050400*            07 = PAY-WITHOUT-COST.                           *
050500*                 WILL CALCULATE THE STANDARD PAYMENT. WILL   *
050600*                 ALSO CALCULATE THE DAY OUTLIER PORTION OF   *
050700*                 THE PAYMENT IF THE COVERED DAYS EXCEED THE  *
050800*                 OUTLIER CUTOFF FOR THE DRG.                 *
050900***************************************************************
051000 01  BILL-DATA.
051100         10  B-PROVIDER-NO          PIC X(06).
051200         10  B-REVIEW-CODE          PIC 9(02).
051300             88  VALID-REVIEW-CODE  VALUE 00 03 06 07.
051400             88  PAY-WITH-OUTLIER   VALUE 00 07.
051500             88  PAY-PERDIEM-DAYS   VALUE 03.
051600             88  PAY-XFER-NO-COST   VALUE 06.
051700             88  PAY-WITHOUT-COST   VALUE 07.
051800         10  B-DRG                  PIC 9(03).
051900         10  B-LOS                  PIC 9(03).
052000         10  B-COVERED-DAYS         PIC 9(03).
052100         10  B-LTR-DAYS             PIC 9(02).
052200         10  B-DISCHARGE-DATE.
052300             15  B-DISCHG-MM        PIC 9(02).
052400             15  B-DISCHG-DD        PIC 9(02).
052500             15  B-DISCHG-YY        PIC 9(02).
052600         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
052700
052800***************************************************************
052900*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
053000*    AND PASSED BACK TO THE CALLING PROGRAM                   *
053100*            RETURN CODE VALUES (PPS-RTC)                     *
053200*                                                             *
053300*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
053400*              00 = PAID NORMAL DRG PAYMENT                   *
053500*                                                             *
053600*              01 = PAID AS A DAY-OUTLIER.                    *
053700*                                                             *
053800*              02 = PAID AS A COST-OUTLIER.                   *
053900*                                                             *
054000*              03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
054100*                   AND INCLUDING THE FULL DRG.               *
054200*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
054300*                   AND INCLUDING THE FULL DRG WHICH ALSO     *
054400*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *
054500*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
054600*                   AND INCLUDING THE FULL DRG. PROVIDER      *
054700*                   REFUSED COST OUTLIER.                     *
054800*                                                             *
054900*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
055000*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
055100*              52 = INVALID MSA # IN PROVIDER FILE            *
055200*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *
055300*              54 = DRG < 001 OR > 492, OR = 109 OR = 438     *
055400*                                       OR = 469 OR = 470     *
055500*                                       OR = 474              *
055600*              55 = DISCHARGE DATE < PROVIDER PPS START DATE  *
055700*              56 = INVALID LENGTH OF STAY                    *
055800*              57 = REVIEW CODE INVALID (NOT 00 03 06 07)     *
055900*              58 = TOTAL CHARGES NOT NUMERIC                 *
056000*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
056100*              62 = INVALID NUMBER OF COVERED DAYS            *
056200*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *
056300*                   SPECIFIC FILE FOR CAPITAL                 *
056400*              66 = THERE ARE NOT AS MANY BENEFIT DAYS        *
056500*                   AVAILABLE ON THE BILL AS THERE ARE OUTLIER*
056600*                   DAYS COMPUTED BY PRICER --BENEFITS ARE    *
056700*                   EXHAUSTED ---                             *
056800*                   APPORTION THE CORRECT COVERED CHARGES     *
056900*                   FOR THE MAXIMUM NUMBER OF COVERED DAYS    *
057000*                   AVAILABLE BEFORE RESUBMITTING THE BILL    *
057100*                   FOR THE COST OUTLIER PAYMENT.             *
057200*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *
057300***************************************************************
057400 01  PPS-DATA.
057500         10  PPS-RTC                PIC 9(02).
057600         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
057700         10  PPS-OUTLIER-DAYS       PIC 9(03).
057800         10  PPS-AVG-LOS            PIC 9(02)V9(01).
057900         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
058000         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
058100         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
058200         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
058300         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
058400         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
058500         10  PPS-REG-DAYS-USED      PIC 9(03).
058600         10  PPS-LTR-DAYS-USED      PIC 9(02).
058700         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
058800         10  PPS-CALC-VERS          PIC X(05).
058900
059000******************************************************************
059100*            THESE ARE THE VERSIONS OF THE PPCAL
059200*           PROGRAMS THAT WILL BE PASSED BACK----
059300*          ASSOCIATED WITH THE BILL BEING PROCESSED
059400******************************************************************
059500 01  PRICER-OPT-VERS-SW.
059600     02  PRICER-OPTION-SW          PIC X(01).
059700         88  ALL-TABLES-PASSED          VALUE 'A'.
059800         88  PROV-RECORD-PASSED         VALUE 'P'.
059900         88  ADDITIONAL-VARIABLES       VALUE 'M'.
060000     02  PPS-VERSIONS.
060100         10  PPDRV-VERSION         PIC X(05).
060200
060300******************************************************************
060400*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
060500*          ASSOCIATED WITH THE BILL BEING PROCESSED
060600******************************************************************
060700 01  PPS-ADDITIONAL-VARIABLES.
060800     05  PPS-HSP-PCT                PIC 9(01)V9(02).
060900     05  PPS-FSP-PCT                PIC 9(01)V9(02).
061000     05  PPS-NAT-PCT                PIC 9(01)V9(02).
061100     05  PPS-REG-PCT                PIC 9(01)V9(02).
061200     05  PPS-CMI-ADJ-CPD            PIC 9(05)V9(02).
061300     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
061400     05  PPS-DRG-WT                 PIC 9(02)V9(04).
061500     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
061600     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
061700     05  PPS-REG-LABOR              PIC 9(05)V9(02).
061800     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
061900     05  PPS-OPER-COLA              PIC 9(01)V9(03).
062000     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
062100     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
062200     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
062300     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
062400     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
062500     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
062600     05  PPS-CAPITAL-VARIABLES.
062700         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).
062800         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).
062900         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).
063000         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).
063100         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).
063200         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).
063300         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).
063400         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).
063500     05  PPS-CAPITAL2-VARIABLES.
063600         10  PPS-CAPI2-PAY-CODE             PIC X(1).
063700         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).
063800         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
063900
064000
064100******************************************************************
064200*               THIS IS THE PROVIDER RECORD
064300*          ASSOCIATED WITH THE BILL BEING PROCESSED
064400******************************************************************
064500 01  PROV-HOLD.
064600     02  PROV-REC-HOLD.
064700         05  P-PROVIDER-NO.
064800             10  P-STATE                PIC 9(02).
064900             10  FILLER                 PIC X(04).
065000         05  P-EFF-DATE.
065100             10  P-EFF-YY               PIC 9(02).
065200             10  P-EFF-MM               PIC 9(02).
065300             10  P-EFF-DD               PIC 9(02).
065400         05  P-WAIVER-CODE              PIC X(01).
065500             88  WAIVER-STATE           VALUE 'Y'.
065600         05  P-PROVIDER-TYPE            PIC X(02).
065700             88  SOLE-COMMUNITY-PROV    VALUE '01' '11'.
065800             88  REFERRAL-CENTER        VALUE '07' '11' '15' '17'.
065900             88  INDIAN-HEALTH-SERVICE  VALUE '08'.
066000             88  REDESIGNATED-RURAL-YR1 VALUE '09'.
066100             88  REDESIGNATED-RURAL-YR2 VALUE '10'.
066200             88  SOLE-COM-REF-CENT      VALUE '11'.
066300             88  MDH-REBASED-FY90       VALUE '14' '15'.
066400             88  MDH-RRC-REBASED-FY90   VALUE '15'.
066500             88  SCH-REBASED-FY90       VALUE '16' '17'.
066600             88  SCH-RRC-REBASED-FY90   VALUE '17'.
066700             88  MEDICAL-ASSIST-FACIL   VALUE '18'.
066800         05  P-CURRENT-CENSUS-DIV       PIC 9(01).
066900             88  NEW-ENGLAND            VALUE  1.
067000             88  MIDDLE-ATLANTIC        VALUE  2.
067100             88  SOUTH-ATLANTIC         VALUE  3.
067200             88  EAST-NORTH-CENTRAL     VALUE  4.
067300             88  EAST-SOUTH-CENTRAL     VALUE  5.
067400             88  WEST-NORTH-CENTRAL     VALUE  6.
067500             88  WEST-SOUTH-CENTRAL     VALUE  7.
067600             88  MOUNTAIN               VALUE  8.
067700             88  PACIFIC                VALUE  9.
067800         05  P-CENSUS-DIV  REDEFINES
067900                    P-CURRENT-CENSUS-DIV       PIC 9(01).
068000             88  VALID-CENSUS-DIV   VALUE 1 THRU 9.
068100         05  P-PPS-BLEND-YEAR           PIC 9(01).
068200             88  VALID-PPS-BLEND-YEAR   VALUE 1 THRU 8.
068300         05  P-MSA-X.
068400             10  P-MSA-9                PIC X(04).
068500         05  P-FISCAL-YEAR-END.
068600             10  P-MM                   PIC 9(02).
068700             10  P-DD                   PIC 9(02).
068800             10  P-YY                   PIC 9(02).
068900         05  P-VARIABLES.
069000             10  P-CMI-ADJ-CPD          PIC S9(05)V9(02).
069100             10  P-COLA                 PIC S9(01)V9(03).
069200             10  P-INTERN-RATIO         PIC S9(01)V9(04).
069300             10  PRUP-UPDT-FACTOR       PIC S9(01)V9(05).
069400             10  P-BED-SIZE             PIC  9(05).
069500             10  P-DSH-PERCENT          PIC V9(04).
069600             10  P-OPER-CSTCHG-RATIO    PIC  9(01)V9(03).
069700             10  P-CMI                  PIC  9(01)V9(04).
069800             10  FILLER                 PIC  9(01).
069900             10  P-REPORT-DATE          PIC  9(06).
070000             10  FILLER                 PIC  9(01).
070100             10  P-INTER-NO             PIC  9(05).
070200     02  PROV-REC-HOLD2.
070300         05  P-FY-BEGIN-DATE.
070400             10  P-FY-BEGIN-MM          PIC 9(2).
070500             10  P-FY-BEGIN-DD          PIC 9(2).
070600             10  P-FY-BEGIN-YY          PIC 9(2).
070700         05  P-PASS-AMT-CAPITAL         PIC 9(4)V99.
070800         05  P-PASS-AMT-DIR-MED-ED      PIC 9(4)V99.
070900         05  P-PASS-AMT-ORGAN-ACQ       PIC 9(4)V99.
071000         05  P-PASS-AMT-INCL-MISC       PIC 9(4)V99.
071100         05  P-SSI-RATIO                PIC V9(4).
071200         05  P-MEDICAID-RATIO           PIC V9(4).
071300         05  P-TERMINATION-DATE         PIC X(6).
071400         05  P-WAGE-INDEX-LOC-MSA       PIC X(4).
071500         05  P-CHG-CODE-INDEX           PIC X.
071600         05  P-STAND-AMT-LOC-MSA.
071700             10  P-RURAL-1ST            PIC XX.
071800                 88  P-RURAL-CHECK        VALUE '  '.
071900             10  P-RURAL-2ND            PIC XX.
072000         05  P-CAPI-SOL-HOSP-RATE       PIC XX.
072100         05  FILLER                     PIC X.
072200         05  FILLER                     PIC X(06).
072300         05  FILLER                     PIC X(18).
072400     02  PROV-REC-HOLD3.
072500         05  P-CAPI-PPS-PAY-CODE        PIC X.
072600         05  P-CAPI-HOSP-SPEC-RATE      PIC 9(4)V99.
072700         05  P-CAPI-OLD-HARM-RATE       PIC 9(4)V99.
072800         05  P-CAPI-NEW-HARM-RATIO      PIC 9(1)V9999.
072900         05  P-CAPI-CSTCHG-RATIO        PIC 9V999.
073000         05  P-CAPI-NEW-HOSP            PIC X.
073100         05  P-CAPI-IME                 PIC 9V9999.
073200         05  P-CAPI-EXCEPTIONS          PIC 9(4)V99.
073300         05  FILLER                     PIC X(46).
073400
073500******************************************************************
073600*                   THIS IS THE WAGE-INDEX
073700*          ASSOCIATED WITH THE BILL BEING PROCESSED
073800******************************************************************
073900 01  WAGE-INDEX-RECORD.
074000     05  W-MSA                         PIC X(4).
074100     05  W-SIZE                        PIC X.
074200         88  LARGE-URBAN       VALUE 'L'.
074300         88  OTHER-URBAN       VALUE 'O'.
074400         88  ALL-RURAL         VALUE 'R'.
074500     05  W-EFF-DATE                    PIC X(6).
074600     05  FILLER                        PIC X.
074700     05  W-INDEX-RECORD                PIC S9(02)V9(04).
074800
074900
075000 PROCEDURE DIVISION  USING BILL-DATA
075100                           PPS-DATA
075200                           PRICER-OPT-VERS-SW
075300                           PPS-ADDITIONAL-VARIABLES
075400                           PROV-HOLD
075500                           WAGE-INDEX-RECORD.
075600
075700***************************************************************
075800*    PROCESSING:                                              *
075900*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
076000*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *
076100*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
076200*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
076300*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
076400*           GOBACK.                                           *
076500*        D. ASSEMBLE PRICING COMPONENTS.                      *
076600*        E. CALCULATE THE BLENDED PRICE.                      *
076700***************************************************************
076800
076900     PERFORM 0200-MAINLINE-CONTROL.
077000
077100     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
077200     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.
077300     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.
077400     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.
077500     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.
077600     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
077700
077800     GOBACK.
077900
078000 0200-MAINLINE-CONTROL.
078100     MOVE ALL '0' TO PPS-DATA
078200                     HOLD-PPS-COMPONENTS
078300                     HOLD-ADDITIONAL-VARIABLES
078400                     HOLD-CAPITAL-VARIABLES
078500                     HOLD-CAPITAL2-VARIABLES.
078600
078700     IF P-CAPI-HOSP-SPEC-RATE NOT NUMERIC
078800        MOVE 0 TO P-CAPI-HOSP-SPEC-RATE.
078900
079000     IF P-CAPI-OLD-HARM-RATE  NOT NUMERIC
079100        MOVE 0 TO P-CAPI-OLD-HARM-RATE.
079200
079300     IF P-CAPI-NEW-HARM-RATIO NOT NUMERIC
079400        MOVE 0 TO P-CAPI-NEW-HARM-RATIO.
079500
079600     IF P-CAPI-CSTCHG-RATIO NOT NUMERIC
079700        MOVE 0 TO P-CAPI-CSTCHG-RATIO.
079800
079900******************************************************************
080000     PERFORM 1000-EDIT-THE-BILL-INFO.
080100
080200     IF  PPS-RTC = 00
080300         PERFORM 2000-ASSEMBLE-PPS-VARIABLES
080400         PERFORM 3000-CALC-BLENDED-PAYMENT.
080500
080600 1000-EDIT-THE-BILL-INFO.
080700***************************************************************
080800*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *
080900*    AND DO NOT ATTEMPT TO PRICE.                             *
081000***************************************************************
081100
081200     MOVE P-YY TO H-FYE-YY.
081300     MOVE P-MM TO H-FYE-MM.
081400     MOVE P-DD TO H-FYE-DD.
081500
081600     IF  H-FYE-MMDD > '0929'
081700         MOVE 83 TO H-FYE-YY
081800     ELSE
081900         MOVE 84 TO H-FYE-YY.
082000
082100     IF  (H-FYE-MM = 04 OR 06 OR 09 OR 11) AND H-FYE-DD = 30
082200         MOVE 31 TO H-FYE-DD
082300     ELSE
082400         IF  H-FYE-MM = 02 AND H-FYE-DD > 27
082500             MOVE 31 TO H-FYE-DD.
082600
082700     MOVE B-DISCHG-YY TO H-BILL-YY.
082800     MOVE B-DISCHG-MM TO H-BILL-MM.
082900     MOVE B-DISCHG-DD TO H-BILL-DD.
083000
083100     MOVE P-FY-BEGIN-YY TO H-FY-BEGIN-YY.
083200     MOVE P-FY-BEGIN-MM TO H-FY-BEGIN-MM.
083300     MOVE P-FY-BEGIN-DD TO H-FY-BEGIN-DD.
083400
083500     IF  HOLD-FY-BEGIN-DATE < 921001
083600           MOVE .10 TO H-CAPI-PAYCDE-PCT1
083700           MOVE .90 TO H-CAPI-PAYCDE-PCT2
083800     ELSE
083900        IF (HOLD-FY-BEGIN-DATE < HOLD-BILL-DATE) OR
084000           (HOLD-FY-BEGIN-DATE = HOLD-BILL-DATE)
084100              MOVE .20 TO H-CAPI-PAYCDE-PCT1
084200              MOVE .80 TO H-CAPI-PAYCDE-PCT2
084300        ELSE
084400              MOVE .10 TO H-CAPI-PAYCDE-PCT1
084500              MOVE .90 TO H-CAPI-PAYCDE-PCT2.
084600
084700     IF  PPS-RTC = 00
084800         IF  WAIVER-STATE
084900             MOVE 53 TO PPS-RTC.
085000
085100     IF  PPS-RTC = 00
085200         IF  B-DRG < 001 OR > 492 OR = 109 OR = 438
085300                                  OR = 469 OR = 470
085400                                  OR = 474
085500             MOVE 54 TO PPS-RTC.
085600
085700     IF  PPS-RTC = 00
085800         IF  HOLD-BILL-DATE < P-EFF-DATE
085900             MOVE 55 TO PPS-RTC.
086000     IF  PPS-RTC = 00
086100         IF  B-REVIEW-CODE NOT NUMERIC
086200             MOVE 57 TO PPS-RTC.
086300
086400     IF  PPS-RTC = 00
086500         IF  B-LOS NOT NUMERIC
086600             MOVE 56 TO PPS-RTC
086700         ELSE
086800         IF  B-LOS = 0
086900             IF B-REVIEW-CODE NOT = 03 AND
087000                              NOT = 06
087100             MOVE 56 TO PPS-RTC.
087200
087300     IF  PPS-RTC = 00
087400         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60
087500             MOVE 61 TO PPS-RTC
087600         ELSE
087700             MOVE B-LTR-DAYS TO H-LTR-DAYS.
087800
087900     IF  PPS-RTC = 00
088000         IF  B-COVERED-DAYS NOT NUMERIC
088100             MOVE 62 TO PPS-RTC
088200         ELSE
088300         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
088400             MOVE 62 TO PPS-RTC
088500         ELSE
088600             MOVE B-COVERED-DAYS TO H-COV-DAYS.
088700
088800     IF  PPS-RTC = 00
088900         IF  H-LTR-DAYS  > H-COV-DAYS
089000             MOVE 62 TO PPS-RTC
089100         ELSE
089200             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
089300
089400     IF  PPS-RTC = 00
089500         IF  NOT VALID-REVIEW-CODE
089600             MOVE 57 TO PPS-RTC.
089700
089800     IF  PPS-RTC = 00
089900         IF  B-CHARGES-CLAIMED NOT NUMERIC
090000             MOVE 58 TO PPS-RTC.
090100
090200     IF PPS-RTC = 00
090300        IF NOT INDIAN-HEALTH-SERVICE
090400           IF P-CAPI-NEW-HOSP NOT = 'Y'
090500                 IF P-CAPI-PPS-PAY-CODE NOT = 'A' AND
090600                                        NOT = 'B' AND
090700                                        NOT = 'C'
090800                 MOVE 65 TO PPS-RTC.
090900
091000 2000-ASSEMBLE-PPS-VARIABLES.
091100***************************************************************
091200*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *
091300*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *
091400*    OF THAT VARIABLE.                                        *
091500***************************************************************
091600***  GET THE PROVIDER SPECIFIC VARIABLES.
091700
091800     MOVE P-CMI-ADJ-CPD  TO H-CMI-ADJ-CPD.
091900     MOVE P-INTERN-RATIO TO H-INTERN-RATIO.
092000
092100     IF  NOT (P-STATE = 02 OR 12)
092200         MOVE 1 TO H-OPER-COLA
092300     ELSE
092400         MOVE P-COLA TO H-OPER-COLA.
092500
092600***************************************************************
092700***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
092800
092900     PERFORM 2600-GET-DRG-WEIGHT
093000             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.
093100
093200***************************************************************
093300***  GET THE WAGE-INDEX
093400
093500     MOVE W-INDEX-RECORD TO H-WAGE-INDEX.
093600
093700***************************************************************
093800***  GET THE LABOR, NON-LABOR STANDARD RATES
093900
094000     IF  VALID-CENSUS-DIV
094100         MOVE P-CURRENT-CENSUS-DIV TO R2
094200     ELSE
094300         MOVE 10 TO R2.
094400
094500     MOVE 10 TO R4.
094600
094700     IF  P-STATE = 40
094800         MOVE 11 TO R2
094900         MOVE 12 TO R4.
095000
095100     IF  LARGE-URBAN
095200         MOVE 1 TO R3
095300     ELSE
095400     IF  OTHER-URBAN OR REFERRAL-CENTER
095500         MOVE 2 TO R3
095600     ELSE
095700         MOVE 3 TO R3.
095800
095900     PERFORM 2300-GET-LABOR-NLABOR-RATES
096000             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
096100
096200***************************************************************
096300***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
096400
096500     MOVE 0.00  TO H-OPER-HSP-PCT.
096600     MOVE 1.00  TO H-OPER-FSP-PCT.
096700
096800***************************************************************
096900***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
097000
097100      MOVE 1.00 TO H-NAT-PCT.
097200      MOVE 0.00 TO H-REG-PCT.
097300
097400***************************************************************
097500*    REGIONAL FLOOR
097600
097700     IF  (H-REG-LABOR + H-REG-NLABOR) >
097800         (H-NAT-LABOR + H-NAT-NLABOR)
097900           MOVE 0.85 TO H-NAT-PCT
098000           MOVE 0.15 TO H-REG-PCT.
098100
098200     IF  P-STATE = 40
098300         MOVE 0.00 TO H-OPER-HSP-PCT
098400         MOVE 1.00 TO H-OPER-FSP-PCT
098500         MOVE 0.25 TO H-NAT-PCT
098600         MOVE 0.75 TO H-REG-PCT.
098700
098800     IF  SOLE-COMMUNITY-PROV
098900         MOVE 0.75 TO H-OPER-HSP-PCT
099000         MOVE 0.25 TO H-OPER-FSP-PCT
099100         MOVE 0.00 TO H-NAT-PCT
099200         MOVE 1.00 TO H-REG-PCT.
099300
099400     IF  SCH-REBASED-FY90 OR MDH-REBASED-FY90
099500         MOVE 1.00 TO H-OPER-HSP-PCT
099600                      H-OPER-FSP-PCT.
099700
099800***************************************************************
099900***  GET THE STANDARD UPDATING FACTOR
100000
100100     MOVE 1 TO  U1.
100200
100300     MOVE P-MM TO U2.
100400
100500     IF  H-FYE-MM = 01 AND H-FYE-DD < 16
100600         MOVE 12 TO U2
100700     ELSE
100800     IF  H-FYE-MM = 02 AND H-FYE-DD < 15
100900         MOVE 01 TO U2
101000     ELSE
101100     IF  H-FYE-MM > 02 AND H-FYE-DD < 16
101200         COMPUTE U2 = U2 - 1.
101300
101400     MOVE R3 TO U3.
101500
101600     IF  REFERRAL-CENTER
101700         MOVE 3 TO U3.
101800
101900     MOVE UPDATE-FACTOR (U1 U2 U3) TO H-UPDATE-FACTOR.
102000
102100***************************************************************
102200***  GET THE SPECIAL UPDATING FACTOR IF APPLICABLE
102300
102400     IF  PRUP-UPDT-FACTOR NUMERIC
102500         IF  PRUP-UPDT-FACTOR > 0
102600             MOVE PRUP-UPDT-FACTOR TO H-UPDATE-FACTOR.
102700
102800 2300-GET-LABOR-NLABOR-RATES.
102900
103000     IF  HOLD-BILL-DATE NOT < RATE-EFF-DATE (R1)
103100         MOVE REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
103200         MOVE REG-NLABOR (R1 R2 R3) TO H-REG-NLABOR
103300         MOVE REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
103400         MOVE REG-NLABOR (R1 R4 R3) TO H-NAT-NLABOR
103500         IF REDESIGNATED-RURAL-YR1 OR
103600                   REDESIGNATED-RURAL-YR2
103700            PERFORM 2350-BLEND-RURAL-RATES.
103800
103900 2350-BLEND-RURAL-RATES.
104000      IF  REDESIGNATED-RURAL-YR1
104100          COMPUTE BLEND-RURAL-PCT ROUNDED = 2 / 3
104200      ELSE
104300          COMPUTE BLEND-RURAL-PCT ROUNDED = 1 / 3.
104400
104500      COMPUTE H-REG-LABOR  ROUNDED =
104600          (REG-LABOR  (R1 R2 2) - REG-LABOR  (R1 R2 3))
104700            * BLEND-RURAL-PCT   +  REG-LABOR  (R1 R2 3).
104800
104900      COMPUTE H-REG-NLABOR ROUNDED =
105000          (REG-NLABOR (R1 R2 2) - REG-NLABOR (R1 R2 3))
105100            * BLEND-RURAL-PCT   +  REG-NLABOR (R1 R2 3).
105200
105300      COMPUTE H-NAT-LABOR  ROUNDED =
105400          (REG-LABOR  (R1 R4 2) - REG-LABOR  (R1 R4 3))
105500            * BLEND-RURAL-PCT   +  REG-LABOR  (R1 R4 3).
105600
105700      COMPUTE H-NAT-NLABOR ROUNDED =
105800          (REG-NLABOR (R1 R4 2) - REG-NLABOR (R1 R4 3))
105900            * BLEND-RURAL-PCT   +  REG-NLABOR (R1 R4 3).
106000
106100 2600-GET-DRG-WEIGHT.
106200     IF  HOLD-BILL-DATE NOT < DRGX-EFF-DATE (DX5)
106300         SET DX6 TO B-DRG
106400         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT
106500         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS
106600         MOVE DRG-DAYS-TRIM (DX5 DX6)  TO H-DAYS-CUTOFF
106700         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.
106800
106900 3000-CALC-BLENDED-PAYMENT.
107000***************************************************************
107100*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *
107200*        CALCULATE COVERED DAYS UTILIZATION.                  *
107300*        CALCULATE THE FEDERAL PORTION.                       *
107400*        CALCULATE THE HOSPITAL PORTION.                      *
107500*        CALCULATE THE DAYS-OUTLIER PORTION.                  *
107600*        CALCULATE THE COST-OUTLIER PORTION.                  *
107700*        CALCULATE THE TOTAL PAYMENT (BLENDED)                *
107800*        CALCULATE THE DSH ADJUSTMENT.                        *
107900***************************************************************
108000     PERFORM 3100-CALC-STAY-UTILIZATION.
108100     PERFORM 3300-CALC-OPER-FSP-AMT.
108200     PERFORM 3400-CALC-OPER-HSP-AMT.
108300     PERFORM 3900-CALC-OPER-DSH.
108400***********************************************************
108500***  OPERATING IME CALCULATION
108600
108700         COMPUTE H-OPER-IME-TEACH =
108800            1.89 * ((1 + H-INTERN-RATIO) ** .405  - 1).
108900
109000***********************************************************
109100
109200     IF  SCH-REBASED-FY90 OR MDH-REBASED-FY90
109300         PERFORM 3450-CALC-ADDITIONAL-HSP.
109400
109500     MOVE 00                 TO  PPS-RTC.
109600     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.
109700     MOVE H-ALOS             TO  PPS-AVG-LOS.
109800     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.
109900
110000     PERFORM 3600-CALC-OUTLIER.
110100
110200     IF PAY-PERDIEM-DAYS
110300         IF  B-LOS < H-ALOS
110400             IF  NOT (B-DRG = 385 OR 456)
110500                 PERFORM 3500-CALC-PERDIEM-AMT
110600                 MOVE 03 TO PPS-RTC.
110700
110800     IF  PAY-PERDIEM-DAYS
110900         IF  H-OPER-OUTCST-PART > 0
111000             MOVE H-OPER-OUTCST-PART TO
111100                  H-OPER-OUTLIER-PART
111200             MOVE 05 TO PPS-RTC
111300         ELSE
111400         IF  PPS-RTC NOT = 03
111500             MOVE 00 TO PPS-RTC
111600             MOVE 0  TO H-OPER-OUTLIER-PART.
111700
111800     IF  PAY-PERDIEM-DAYS
111900         IF  H-CAPI-OUTCST-PART > 0
112000             MOVE H-CAPI-OUTCST-PART TO
112100                  H-CAPI-OUTLIER-PART
112200             MOVE 05 TO PPS-RTC
112300         ELSE
112400         IF  PPS-RTC NOT = 03
112500             MOVE 0  TO H-CAPI-OUTLIER-PART.
112600
112700     IF  PAY-XFER-NO-COST
112800         MOVE 0  TO H-OPER-OUTLIER-PART
112900                    H-CAPI-OUTLIER-PART
113000         MOVE 00 TO PPS-RTC
113100         IF B-LOS < H-ALOS
113200            IF  NOT (B-DRG = 385 OR 456)
113300                PERFORM 3500-CALC-PERDIEM-AMT
113400                MOVE 06 TO PPS-RTC.
113500
113600     MOVE 1 TO H-DSCHG-FRCTN.
113700
113800     IF  (PAY-PERDIEM-DAYS OR
113900          PAY-XFER-NO-COST)
114000          COMPUTE H-DSCHG-FRCTN = H-COV-DAYS / H-ALOS
114100          IF H-DSCHG-FRCTN > 1
114200             MOVE 1 TO H-DSCHG-FRCTN.
114300
114400     COMPUTE H-DRG-WT-FRCTN = H-DSCHG-FRCTN * H-DRG-WT.
114500
114600***********************************************************
114700***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF
114800***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
114900
115000     COMPUTE H-CAPI2-B-FSP-PART = H-CAPI-FSP-PART.
115100
115200***********************************************************
115300     IF  PPS-RTC < 50
115400         PERFORM 3800-CALC-TOT-AMT
115500     ELSE
115600         MOVE 0 TO PPS-OPER-HSP-PART
115700                   PPS-OPER-FSP-PART
115800                   PPS-OPER-OUTLIER-PART
115900                   PPS-OUTLIER-DAYS
116000                   PPS-REG-DAYS-USED
116100                   PPS-LTR-DAYS-USED
116200                   PPS-TOTAL-PAYMENT
116300                   PPS-OPER-DSH-ADJ
116400                   PPS-OPER-IME-ADJ
116500                   H-DSCHG-FRCTN
116600                   H-DRG-WT-FRCTN
116700                   HOLD-CAPITAL-VARIABLES
116800                   HOLD-CAPITAL2-VARIABLES.
116900
117000 3100-CALC-STAY-UTILIZATION.
117100     IF  H-REG-DAYS > 0
117200         IF  H-REG-DAYS < H-DAYS-CUTOFF
117300             MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
117400             MOVE 0          TO H-REG-DAYS
117500         ELSE
117600             MOVE H-DAYS-CUTOFF TO PPS-REG-DAYS-USED
117700             SUBTRACT H-DAYS-CUTOFF FROM H-REG-DAYS
117800     ELSE
117900     IF  H-LTR-DAYS < H-DAYS-CUTOFF
118000         MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED
118100         MOVE 0          TO H-LTR-DAYS
118200     ELSE
118300         MOVE H-DAYS-CUTOFF TO PPS-LTR-DAYS-USED
118400         SUBTRACT H-DAYS-CUTOFF FROM H-LTR-DAYS.
118500
118600     IF  B-LOS > H-DAYS-CUTOFF
118700         PERFORM 3200-CALC-OUTLIER-UTILIZATION.
118800
118900 3200-CALC-OUTLIER-UTILIZATION.
119000     COMPUTE PPS-OUTLIER-DAYS =
119100         B-LOS - H-DAYS-CUTOFF.
119200
119300     IF  (H-REG-DAYS + H-LTR-DAYS) < PPS-OUTLIER-DAYS
119400         COMPUTE PPS-OUTLIER-DAYS =
119500             H-REG-DAYS + H-LTR-DAYS
119600         ADD H-REG-DAYS TO PPS-REG-DAYS-USED
119700         ADD H-LTR-DAYS TO PPS-LTR-DAYS-USED
119800     ELSE
119900     IF  H-REG-DAYS < PPS-OUTLIER-DAYS
120000         ADD H-REG-DAYS TO PPS-REG-DAYS-USED
120100         COMPUTE PPS-LTR-DAYS-USED =
120200             PPS-LTR-DAYS-USED + (PPS-OUTLIER-DAYS -
120300                                  H-REG-DAYS)
120400     ELSE
120500         ADD PPS-OUTLIER-DAYS TO PPS-REG-DAYS-USED.
120600
120700     IF  B-REVIEW-CODE = 03
120800         IF  PPS-REG-DAYS-USED > 0
120900             MOVE 0 TO PPS-LTR-DAYS-USED.
121000
121100 3300-CALC-OPER-FSP-AMT.
121200***********************************************************
121300***  OPERATING FSP CALCULATION
121400
121500     COMPUTE H-OPER-FSP-PART ROUNDED =
121600         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
121700         H-NAT-NLABOR * H-OPER-COLA) * H-DRG-WT)
121800                           +
121900         (H-REG-PCT * (H-REG-LABOR * H-WAGE-INDEX +
122000         H-REG-NLABOR * H-OPER-COLA) * H-DRG-WT).
122100
122200 3400-CALC-OPER-HSP-AMT.
122300***********************************************************
122400***  OPERATING HSP CALCULATION
122500
122600     COMPUTE H-OPER-HSP-PART ROUNDED =
122700         H-CMI-ADJ-CPD * H-UPDATE-FACTOR * H-DRG-WT.
122800
122900 3450-CALC-ADDITIONAL-HSP.
123000***********************************************************
123100*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR
123200*    SOLE COMMUNITY AND MEDICARE DEPENDENT HOSPITALS
123300*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
123400***********************************************************
123500**** CHANGE ESTIMATED OUTLIER FACTORS WHEN FED RATES CHANGE
123600
123700         IF  P-RURAL-CHECK AND NOT REFERRAL-CENTER
123800             MOVE 1.022056 TO H-OUTLIER-FACT
123900         ELSE
124000             MOVE 1.058651 TO H-OUTLIER-FACT.
124100
124200***********************************************************
124300**** CHANGE HSP UPDATE FACTORS WHEN HOSPITAL PERIOD CHANGES
124400**** FORCE FYE SO THAT NEW CALC STARTS ON OR AFTER 04/01/90
124500
124600     MOVE 1.00000 TO H-UPDATE-FACTOR.
124700
124800***********************************************************
124900**** INCREASE THIS ADD BY 1 EVERY  NEW FISCAL YEAR
125000     ADD 9 TO H-FYE-YY.
125100
125200     IF  HOLD-BILL-DATE > HOLD-PROV-FYE-DATE
125300         COMPUTE H-UPDATE-FACTOR ROUNDED =
125400            (1.052 * 1.044 * 1.041 * .999851).
125500
125600     IF  (HOLD-BILL-DATE < HOLD-PROV-FYE-DATE) OR
125700         (HOLD-BILL-DATE = HOLD-PROV-FYE-DATE)
125800          COMPUTE H-UPDATE-FACTOR ROUNDED =
125900            (1.044 * .999757 * 1.052).
126000
126100     COMPUTE H-HSP-RATE ROUNDED =
126200         H-CMI-ADJ-CPD * H-UPDATE-FACTOR.
126300
126400     COMPUTE H-FSP-RATE ROUNDED =
126500         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
126600         H-NAT-NLABOR * H-OPER-COLA))
126700                           +
126800          (H-REG-PCT * (H-REG-LABOR * H-WAGE-INDEX +
126900         H-REG-NLABOR * H-OPER-COLA)))
127000                           *
127100         H-OUTLIER-FACT * (1 + H-OPER-IME-TEACH +
127200                         H-OPER-DSH).
127300     IF  H-HSP-RATE > H-FSP-RATE
127400         COMPUTE H-OPER-HSP-PART =
127500             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT
127600     ELSE
127700         MOVE 0 TO H-OPER-HSP-PART.
127800
127900 3500-CALC-PERDIEM-AMT.
128000     MOVE B-LOS TO H-COV-DAYS.
128100     IF  H-COV-DAYS = 0
128200         MOVE 1 TO H-COV-DAYS.
128300***********************************************************
128400***  OPERATING PERDIEM-AMT CALCULATION
128500
128600     COMPUTE H-OPER-HSP-PART ROUNDED =
128700        H-OPER-HSP-PART / H-ALOS * H-COV-DAYS
128800        ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
128900
129000     COMPUTE H-OPER-FSP-PART ROUNDED =
129100        H-OPER-FSP-PART / H-ALOS * H-COV-DAYS
129200        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
129300
129400***********************************************************
129500***  CAPITAL PERDIEM-AMT CALCULATION
129600
129700     COMPUTE H-CAPI-HSP-PART ROUNDED =
129800        H-CAPI-HSP-PART / H-ALOS * H-COV-DAYS
129900        ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
130000
130100     COMPUTE H-CAPI-FSP-PART ROUNDED =
130200        H-CAPI-FSP-PART / H-ALOS * H-COV-DAYS
130300        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
130400
130500***********************************************************
130600***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
130700
130800     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
130900        H-CAPI-OLD-HARMLESS / H-ALOS * H-COV-DAYS
131000        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
131100
131200 3600-CALC-OUTLIER.
131300     MOVE 0.55 TO H-DAYOUT-PCT.
131400
131500     MOVE 0.75 TO H-CSTOUT-PCT.
131600
131700     IF  B-DRG = 456 OR 457 OR 458 OR 459 OR 460 OR 472
131800             MOVE 0.90 TO H-CSTOUT-PCT.
131900
132000     MOVE 0.7140   TO H-LABOR-PCT.
132100     MOVE 0.2860   TO H-NLABOR-PCT.
132200
132300     IF  P-OPER-CSTCHG-RATIO NUMERIC
132400             MOVE P-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO
132500     ELSE
132600             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.
132700
132800     IF P-CAPI-CSTCHG-RATIO NUMERIC
132900             MOVE P-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO
133000     ELSE
133100             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.
133200
133300     MOVE 2.000    TO H-CST-MULTIPLE.
133400     MOVE 35500.00 TO H-CST-THRESH.
133500
133600***********************************************************
133700***  OPERATING DAY OUTLIER CALCULATION
133800
133900     IF  PPS-OUTLIER-DAYS > 0
134000        COMPUTE H-OPER-OUTDAY-PART =
134100            H-DAYOUT-PCT *  H-OPER-FSP-PART / H-ARITH-ALOS
134200                                       * PPS-OUTLIER-DAYS
134300            ON SIZE ERROR MOVE 0 TO H-OPER-OUTDAY-PART.
134400
134500***********************************************************
134600***********************************************************
134700***  CAPITAL PAYMENT METHOD B
134800
134900     IF W-SIZE = 'L'
135000        MOVE 1.03 TO H-CAPI-LARG-URBAN
135100     ELSE
135200        MOVE 1.00 TO H-CAPI-LARG-URBAN.
135300
135400     COMPUTE H-CAPI-GAF = (H-WAGE-INDEX ** .6848).
135500
135600     COMPUTE H-CAPI-COLA =
135700                     (.3152 * (H-OPER-COLA - 1) + 1).
135800
135900     IF P-STATE = 40
136000        COMPUTE  H-CAPI-FED-RATE = (.75 * 320.99) +
136100                                   (.25 * 417.29)
136200     ELSE
136300        MOVE 417.29 TO H-CAPI-FED-RATE.
136400
136500***********************************************************
136600***  CAPITAL HSP CALCULATION
136700
136800     COMPUTE H-CAPI-HSP-PART = (H-DRG-WT *
136900                                P-CAPI-HOSP-SPEC-RATE).
137000***********************************************************
137100***  CAPITAL FSP CALCULATION
137200
137300     COMPUTE H-CAPI-FSP-PART = H-DRG-WT * H-CAPI-FED-RATE *
137400                               H-CAPI-COLA * H-CAPI-GAF *
137500                               H-CAPI-LARG-URBAN.
137600
137700***********************************************************
137800***  CAPITAL PAYMENT METHOD A
137900
138000     IF SOLE-COMMUNITY-PROV OR SCH-REBASED-FY90
138100        MOVE 1.00 TO H-CAPI-SCH
138200     ELSE
138300        MOVE 0.85 TO H-CAPI-SCH.
138400
138500***********  CAPITAL OLD-HARMLESS CALCULATION ***********
138600
138700     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
138800                    (P-CAPI-OLD-HARM-RATE *
138900                    H-CAPI-SCH).
139000
139100***********************************************************
139200***********************************************************
139300***  CAPITAL DAY OUTLIER CALCULATION
139400
139500     IF  PPS-OUTLIER-DAYS > 0
139600         COMPUTE H-CAPI-OUTDAY-PART =
139700            H-DAYOUT-PCT * H-CAPI-FSP-PART / H-ARITH-ALOS
139800                                       * PPS-OUTLIER-DAYS
139900            ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.
140000
140100     IF  H-CAPI-OUTDAY-PART  > 0
140200         IF P-CAPI-PPS-PAY-CODE = 'A'
140300             COMPUTE H-CAPI-OUTDAY-PART =
140400                 H-CAPI-OUTDAY-PART * P-CAPI-NEW-HARM-RATIO
140500             ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.
140600
140700     IF  H-CAPI-OUTDAY-PART  > 0
140800         IF P-CAPI-PPS-PAY-CODE = 'C'
140900             COMPUTE H-CAPI-OUTDAY-PART =
141000                    (H-CAPI-OUTDAY-PART * H-CAPI-PAYCDE-PCT1)
141100             ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.
141200
141300***********************************************************
141400***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
141500
141600     IF H-CAPI-CSTCHG-RATIO > 0 OR
141700       H-OPER-CSTCHG-RATIO > 0
141800        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD =
141900                H-OPER-CSTCHG-RATIO /
142000               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
142100        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD =
142200                H-CAPI-CSTCHG-RATIO /
142300               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
142400     ELSE
142500         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD
142600                   H-CAPI-SHARE-DOLL-THRESHOLD.
142700
142800     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
142900        ((H-CST-THRESH * H-LABOR-PCT  * H-WAGE-INDEX) +
143000         (H-CST-THRESH * H-NLABOR-PCT * H-OPER-COLA)) *
143100          H-OPER-SHARE-DOLL-THRESHOLD.
143200
143300***********************************************************
143400***  DIFFERENT THRESHOLD   PRE-CAPITAL
143500
143600     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE
143700        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
143800                (32500 * H-LABOR-PCT * H-WAGE-INDEX) +
143900                (32500 * H-NLABOR-PCT * H-OPER-COLA).
144000***********************************************************
144100
144200     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
144300          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *
144400          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.
144500
144600     COMPUTE H-OPER-COST-OUTLIER ROUNDED =
144700         H-CST-MULTIPLE * H-OPER-FSP-PART.
144800
144900     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
145000         H-CST-MULTIPLE * H-CAPI-FSP-PART.
145100
145200     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE
145300         MOVE 0 TO H-CAPI-DOLLAR-THRESHOLD
145400                   H-CAPI-COST-OUTLIER.
145500
145600     IF (H-OPER-DOLLAR-THRESHOLD + H-CAPI-DOLLAR-THRESHOLD)
145700        > (H-OPER-COST-OUTLIER + H-CAPI-COST-OUTLIER)
145800      MOVE H-OPER-DOLLAR-THRESHOLD TO H-OPER-COST-OUTLIER
145900      MOVE H-CAPI-DOLLAR-THRESHOLD TO H-CAPI-COST-OUTLIER.
146000
146100***********************************************************
146200***  CAPITAL DSH CALCULATION
146300     MOVE 0 TO H-CAPI-DSH.
146400
146500     IF P-BED-SIZE NOT NUMERIC
146600         MOVE 0 TO P-BED-SIZE.
146700
146800     IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99
146900         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **
147000                  (.2025 * (P-SSI-RATIO
147100                          + P-MEDICAID-RATIO)) - 1.
147200
147300***********************************************************
147400***  OPERATING COST CALCULATION
147500
147600     COMPUTE H-OPER-BILL-COSTS ROUNDED =
147700         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO /
147800         (1 + H-OPER-IME-TEACH + H-OPER-DSH)
147900         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
148000
148100     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER
148200         COMPUTE H-OPER-OUTCST-PART =
148300         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -
148400                         H-OPER-COST-OUTLIER).
148500
148600     IF PAY-WITHOUT-COST
148700         MOVE 0 TO H-OPER-OUTCST-PART.
148800
148900***********************************************************
149000***  CAPITAL IME TEACH CALCULATION
149100
149200     MOVE 0 TO H-WK-CAPI-IME-TEACH.
149300
149400     IF P-CAPI-IME NUMERIC
149500        COMPUTE H-WK-CAPI-IME-TEACH =
149600          (2.7183 ** (.2822 * P-CAPI-IME)) - 1.
149700
149800***********************************************************
149900***  CAPITAL COST CALCULATION
150000
150100     COMPUTE H-CAPI-BILL-COSTS ROUNDED =
150200             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO /
150300            (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH)
150400         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.
150500
150600     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER
150700         COMPUTE H-CAPI-OUTCST-PART =
150800         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -
150900                         H-CAPI-COST-OUTLIER).
151000
151100     IF P-CAPI-PPS-PAY-CODE = 'A'
151200       COMPUTE H-CAPI-OUTCST-PART =
151300              (H-CAPI-OUTCST-PART * P-CAPI-NEW-HARM-RATIO).
151400
151500     IF P-CAPI-PPS-PAY-CODE = 'C'
151600        COMPUTE H-CAPI-OUTCST-PART =
151700               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).
151800
151900     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <
152000        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)
152100        MOVE 0 TO H-CAPI-OUTCST-PART
152200                  H-OPER-OUTCST-PART.
152300
152400     IF PAY-WITHOUT-COST
152500         MOVE 0 TO H-CAPI-OUTCST-PART.
152600
152700***********************************************************
152800***  DETERMINES THE BILL TO BE EITHER COST OR DAY OUTLIER
152900***     GREATER OF DAY OR COST OPERATING AND CAPITAL
153000
153100     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE
153200         MOVE 0 TO H-CAPI-OUTDAY-PART
153300                   H-CAPI-OUTCST-PART.
153400
153500      IF (H-OPER-OUTDAY-PART + H-CAPI-OUTDAY-PART) > 0 OR
153600         (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
153700         IF (H-OPER-OUTDAY-PART + H-CAPI-OUTDAY-PART) >
153800            (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART)
153900                 MOVE H-OPER-OUTDAY-PART TO
154000                      H-OPER-OUTLIER-PART
154100                 MOVE H-CAPI-OUTDAY-PART TO
154200                      H-CAPI-OUTLIER-PART
154300                 MOVE 01 TO PPS-RTC
154400             ELSE
154500                 MOVE H-OPER-OUTCST-PART TO
154600                      H-OPER-OUTLIER-PART
154700                 MOVE H-CAPI-OUTCST-PART TO
154800                      H-CAPI-OUTLIER-PART
154900                 MOVE 02 TO PPS-RTC
155000                 IF B-COVERED-DAYS > H-DAYS-CUTOFF
155100                    IF (H-REG-DAYS
155200                            +
155300                        H-LTR-DAYS)   <
155400                       (B-COVERED-DAYS - H-DAYS-CUTOFF)
155500                       MOVE 66 TO PPS-RTC.
155600
155700***********************************************************
155800***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF
155900***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
156000
156100     IF P-CAPI-PPS-PAY-CODE = 'A'
156200        COMPUTE H-CAPI2-B-OUTLIER-PART =
156300                H-CAPI-OUTLIER-PART / P-CAPI-NEW-HARM-RATIO
156400         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
156500
156600     IF P-CAPI-PPS-PAY-CODE = 'B'
156700        COMPUTE H-CAPI2-B-OUTLIER-PART =
156800                H-CAPI-OUTLIER-PART.
156900
157000     IF P-CAPI-PPS-PAY-CODE = 'C'
157100        COMPUTE H-CAPI2-B-OUTLIER-PART =
157200                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1
157300         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
157400***********************************************************
157500
157600 3800-CALC-TOT-AMT.
157700     IF  H-CMI-ADJ-CPD = 0
157800         MOVE 0.00 TO H-OPER-HSP-PCT
157900         MOVE 1.00 TO H-OPER-FSP-PCT.
158000
158100***********************************************************
158200***  CALCULATE FINAL TOTALS FOR OPERATING
158300
158400     COMPUTE PPS-OPER-HSP-PART ROUNDED =
158500         H-OPER-HSP-PCT * H-OPER-HSP-PART.
158600
158700     COMPUTE PPS-OPER-FSP-PART ROUNDED =
158800         H-OPER-FSP-PCT * H-OPER-FSP-PART.
158900
159000     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =
159100             H-OPER-FSP-PCT * H-OPER-OUTLIER-PART.
159200
159300     MOVE ZERO TO PPS-OPER-DSH-ADJ.
159400
159500     IF  H-OPER-DSH NUMERIC
159600             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
159700             (PPS-OPER-FSP-PART + PPS-OPER-OUTLIER-PART)
159800              * H-OPER-DSH.
159900
160000     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
160100         (PPS-OPER-FSP-PART + PPS-OPER-OUTLIER-PART) *
160200                 H-OPER-IME-TEACH.
160300
160400***********************************************************
160500***  CALCULATE FINAL TOTALS FOR CAPITAL
160600
160700     MOVE P-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.
160800
160900     IF P-CAPI-PPS-PAY-CODE = 'A'
161000        MOVE P-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT
161100        MOVE 0.00 TO H-CAPI-HSP-PCT.
161200
161300     IF P-CAPI-PPS-PAY-CODE = 'B'
161400        MOVE 0    TO H-CAPI-OLD-HARMLESS
161500        MOVE 1.00 TO H-CAPI-FSP-PCT
161600        MOVE 0.00 TO H-CAPI-HSP-PCT.
161700
161800     IF P-CAPI-PPS-PAY-CODE = 'C'
161900        MOVE 0    TO H-CAPI-OLD-HARMLESS
162000        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT
162100        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.
162200
162300     COMPUTE H-CAPI-HSP ROUNDED =
162400         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.
162500
162600     COMPUTE H-CAPI-FSP ROUNDED =
162700         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.
162800
162900     MOVE P-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.
163000
163100     COMPUTE H-CAPI-OUTLIER ROUNDED =
163200             1.00 * H-CAPI-OUTLIER-PART.
163300
163400     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =
163500             1.00 * H-CAPI2-B-OUTLIER-PART.
163600
163700     COMPUTE H-CAPI2-B-FSP ROUNDED =
163800             1.00 * H-CAPI2-B-FSP-PART.
163900
164000     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.
164100
164200     COMPUTE H-CAPI-DSH-ADJ ROUNDED =
164300             (H-CAPI-FSP + H-CAPI-OUTLIER-PART)
164400              * H-CAPI-DSH.
164500
164600     COMPUTE H-CAPI-IME-ADJ ROUNDED =
164700         (H-CAPI-FSP + H-CAPI-OUTLIER-PART) *
164800                 H-WK-CAPI-IME-TEACH.
164900
165000***********************************************************
165100***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER
165200***        THIS ZEROES OUT ALL CAPITAL DATA
165300
165400     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE
165500        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.
165600
165700     COMPUTE H-CAPI-TOTAL-PAY =
165800             H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
165900             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
166000             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM.
166100
166200***********************************************************
166300***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
166400
166500     COMPUTE PPS-TOTAL-PAYMENT =
166600             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
166700             PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
166800             PPS-OPER-IME-ADJ
166900                           +
167000                  H-CAPI-TOTAL-PAY.
167100
167200 3900-CALC-OPER-DSH.
167300***********************************************************
167400***  OPERATING DSH CALCULATION
167500
167600      MOVE .00 TO H-OPER-DSH.
167700
167800      COMPUTE H-WK-OPER-DSH = (P-SSI-RATIO
167900                                     + P-MEDICAID-RATIO).
168000
168100      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE < 100
168200                               AND H-WK-OPER-DSH > .3999
168300        MOVE .05 TO H-OPER-DSH.
168400
168500      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99
168600                               AND H-WK-OPER-DSH > .1499
168700                               AND H-WK-OPER-DSH < .2021
168800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
168900                                      * .6 + .025.
169000
169100      IF W-SIZE = 'R'          AND P-BED-SIZE > 499
169200                               AND H-WK-OPER-DSH > .1499
169300                               AND H-WK-OPER-DSH < .2021
169400        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
169500                                 * .6 + .025.
169600
169700      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99
169800                               AND H-WK-OPER-DSH > .202
169900        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
170000                                 * .7 + .0562.
170100
170200      IF W-SIZE = 'R'          AND P-BED-SIZE > 499
170300                               AND H-WK-OPER-DSH > .202
170400        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
170500                                 * .7 + .0562.
170600
170700      IF W-SIZE = 'R'          AND P-BED-SIZE < 101
170800                               AND H-WK-OPER-DSH > .4499
170900        MOVE .04 TO H-OPER-DSH.
171000
171100      IF W-SIZE = 'R'          AND P-BED-SIZE > 100
171200                               AND P-BED-SIZE < 500
171300                               AND H-WK-OPER-DSH > .2999
171400        MOVE .04 TO H-OPER-DSH.
171500
171600      IF W-SIZE = 'R'
171700         IF (P-PROVIDER-TYPE = '01' OR '16')
171800                               AND H-WK-OPER-DSH > .2999
171900                               AND P-BED-SIZE < 500
172000            MOVE .10 TO H-OPER-DSH.
172100
172200      IF W-SIZE = 'R'
172300         IF (P-PROVIDER-TYPE = '07')
172400                               AND H-WK-OPER-DSH > .2999
172500                               AND P-BED-SIZE > 100
172600                               AND P-BED-SIZE < 500
172700            COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .3)
172800                                 * .6 + .04.
172900
173000      IF W-SIZE = 'R'
173100         IF (P-PROVIDER-TYPE = '11' OR '17')
173200                               AND H-WK-OPER-DSH > .2999
173300                               AND P-BED-SIZE < 500
173400            COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .3)
173500                                 * .6 + .04.
173600
173700      IF W-SIZE = 'R'
173800         IF (P-PROVIDER-TYPE = '11' OR '17')
173900                               AND H-WK-OPER-DSH > .2999
174000                               AND P-BED-SIZE < 500
174100                               AND H-OPER-DSH < .10
174200            MOVE .10 TO H-OPER-DSH.
174300
174400******        L A S T   S O U R C E   S T A T E M E N T   *****
