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