000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPCAL954.
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     'PPCAL954 - W O R K I N G   S T O R A G E'.
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C95.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
002900***************************************************************
003000*    LAYUP TABLE AREA FOR FY95 RATES                          *
003100***************************************************************
003200 01  RATE-TABLE.
003300     02  RATE-WORK.
003400*RATE   941001 REGION  LABOR AND NON-LABOR RATES
003500*               LARGE URBAN /OTHER URBAN & / ALL RURAL
003600*                           /REFERRAL CTR  /
003700         05  FILLER PIC X(06) VALUE '941001'.
003800         05  NE01   PIC X(45) VALUE
003900            ' 0284062 113784 0279563 111982 0279563 111982'.
004000         05  MA02   PIC X(45) VALUE
004100            ' 0259246 103844 0255142 102200 0255142 102200'.
004200         05  SA03   PIC X(45) VALUE
004300            ' 0265429 106321 0261228 104638 0261228 104638'.
004400         05  ENS04  PIC X(45) VALUE
004500            ' 0289231 115855 0284652 114020 0284652 114020'.
004600         05  ESC05  PIC X(45) VALUE
004700            ' 0250824 100471 0246853 098880 0246853 098880'.
004800         05  WNC06  PIC X(45) VALUE
004900            ' 0271120 108599 0266826 106880 0266826 106880'.
005000         05  WSC07  PIC X(45) VALUE
005100            ' 0263883 105701 0259706 104027 0259706 104027'.
005200         05  MNT08  PIC X(45) VALUE
005300            ' 0262188 105022 0258037 103359 0258037 103359'.
005400         05  PAC09  PIC X(45) VALUE
005500            ' 0268057 107372 0263813 105673 0263813 105673'.
005600         05  NTL10  PIC X(45) VALUE
005700            ' 0270942 108529 0266652 106810 0266652 106810'.
005800         05  PR11   PIC X(45) VALUE
005900            ' 0241627 050353 0237802 049556 0237802 049556'.
006000         05  NPR12  PIC X(45) VALUE
006100            ' 0268296 107469 0268296 107469 0268296 107469'.
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     '941001'.
007700      10  FILLER                  PIC X(56) VALUE
007800     '03156509632135030968098321390303981273512702329207229110'.
007900      10  FILLER                  PIC X(56) VALUE
008000     '01560104426056006339022240320250051013217400918502925047'.
008100      10  FILLER                  PIC X(56) VALUE
008200     '01255306028088012618067290970077340382605500957406328090'.
008300      10  FILLER                  PIC X(56) VALUE
008400     '00781305728072011956064280870069090382604901048805828078'.
008500      10  FILLER                  PIC X(56) VALUE
008600     '00619503526046009126055270720059250372604802082808230117'.
008700      10  FILLER                  PIC X(56) VALUE
008800     '01434206428086007806042260540080040402605600964704827066'.
008900      10  FILLER                  PIC X(56) VALUE
009000     '00551503225041006270028250430134570392607401217005527083'.
009100      10  FILLER                  PIC X(56) VALUE
009200     '00620003225046003687020170200076270402605600463502523034'.
009300      10  FILLER                  PIC X(56) VALUE
009400     '00255901609016010862053270750058660352604900598901508018'.
009500      10  FILLER                  PIC X(56) VALUE
009600     '00808902625039004005020160270050550150901900624102324036'.
009700      10  FILLER                  PIC X(56) VALUE
009800     '00381001607016005687017120220034000302003600575504927060'.
009900      10  FILLER                  PIC X(56) VALUE
010000     '00621103525043007553044260610043310302503900418602925029'.
010100      10  FILLER                  PIC X(56) VALUE
010200     '01710604927068007131019110230068380202203000915202320030'.
010300      10  FILLER                  PIC X(56) VALUE
010400     '00864702224034007176032220320064550182002800768402224031'.
010500      10  FILLER                  PIC X(56) VALUE
010600     '01017403425052003227015040150046020150901900272401504015'.
010700      10  FILLER                  PIC X(56) VALUE
010800     '01001902925051003217013050130110470342505001141905027084'.
010900      10  FILLER                  PIC X(56) VALUE
011000     '00506703022038005076031240390083810382604700710004426054'.
011100      10  FILLER                  PIC X(56) VALUE
011200     '00513303522042005812036240440065080352204200616003125044'.
011300      10  FILLER                  PIC X(56) VALUE
011400     '00761604126055003571021200210305510993212402512610032139'.
011500      10  FILLER                  PIC X(56) VALUE
011600     '01063004026060014211078300920169550833010700925905928074'.
011700      10  FILLER                  PIC X(56) VALUE
011800     '01432305728071013237063280890095300552807200499603225043'.
011900      10  FILLER                  PIC X(56) VALUE
012000     '01189006228082006753038260490133060552707501005305628069'.
012100      10  FILLER                  PIC X(56) VALUE
012200     '01131706529080006924049270570068340382004401208406428081'.
012300      10  FILLER                  PIC X(56) VALUE
012400     '00770004526057012427065280850061460392604900848805227062'.
012500      10  FILLER                  PIC X(56) VALUE
012600     '00612204124049005356031250410070190322504100505102315028'.
012700      10  FILLER                  PIC X(56) VALUE
012800     '00905504627062005339030250401354952544735807607615237180'.
012900      10  FILLER                  PIC X(56) VALUE
013000     '05765611033130056683121341360419740933110406108111433147'.
013100      10  FILLER                  PIC X(56) VALUE
013200     '00000000000000040796091311220230240652807501988103926053'.
013300      10  FILLER                  PIC X(56) VALUE
013400     '02776512735172015385079301090359361043212702451404727065'.
013500      10  FILLER                  PIC X(56) VALUE
013600     '01167103325049015582023240350099490332505601961606328107'.
013700      10  FILLER                  PIC X(56) VALUE
013800     '01602207029086011292049270600142860292505101265704226055'.
013900      10  FILLER                  PIC X(56) VALUE
014000     '00845102423032027724137361840102390552707100782006729075'.
014100      10  FILLER                  PIC X(56) VALUE
014200     '01130802124038009177058280740058890452705600729603626047'.
014300      10  FILLER                  PIC X(56) VALUE
014400     '00534802721035005761035250440085070432605800560002923037'.
014500      10  FILLER                  PIC X(56) VALUE
014600     '00657803325033007964039260520049390262003300625803223040'.
014700      10  FILLER                  PIC X(56) VALUE
014800     '00702503926051005174029210360051690241603001058004527064'.
014900      10  FILLER                  PIC X(56) VALUE
015000     '00615502825037025367107331220154690742808003222012234147'.
015100      10  FILLER                  PIC X(56) VALUE
015200     '01502207626082025652105321280118140552706801782908330097'.
015300      10  FILLER                  PIC X(56) VALUE
015400     '01115106026067041740133351700138980612807200873206028060'.
015500      10  FILLER                  PIC X(56) VALUE
015600     '01032004426061005445023180300110660432605600657402518031'.
015700      10  FILLER                  PIC X(56) VALUE
015800     '00905303225046005156018110220072750392404802164508831102'.
015900      10  FILLER                  PIC X(56) VALUE
016000     '01197605724063013465052270630078280321603701085603525054'.
016100      10  FILLER                  PIC X(56) VALUE
016200     '00614902116027027813098321460106380432605901299006529094'.
016300      10  FILLER                  PIC X(56) VALUE
016400     '00626203225046009726049270620053590331903901043605327069'.
016500      10  FILLER                  PIC X(56) VALUE
016600     '00806204527056005807033190390111430642808200913905227068'.
016700      10  FILLER                  PIC X(56) VALUE
016800     '00497503423042007685043260560053560312203800424002621034'.
016900      10  FILLER                  PIC X(56) VALUE
017000     '00831204126057004282029230290063500282503801020104927068'.
017100      10  FILLER                  PIC X(56) VALUE
017200     '00502702725037006707032250450441761363618201760906929089'.
017300      10  FILLER                  PIC X(56) VALUE
017400     '03149712935157016562073290920245760973211401486106529075'.
017500      10  FILLER                  PIC X(56) VALUE
017600     '02079608130097010930046240530236030993213202969808430131'.
017700      10  FILLER                  PIC X(56) VALUE
017800     '03232212134170013087064280870123840632808901137605728073'.
017900      10  FILLER                  PIC X(56) VALUE
018000     '01228406128084006220034250470100630492706400566102923037'.
018100      10  FILLER                  PIC X(56) VALUE
018200     '02317307729086018427090311060129900702907900908403619041'.
018300      10  FILLER                  PIC X(56) VALUE
018400     '01723408230113019237065280820109770392404802104609331133'.
018500      10  FILLER                  PIC X(56) VALUE
018600     '03008412334189014028057280740091320362304400962605327053'.
018700      10  FILLER                  PIC X(56) VALUE
018800     '01791106729093009852035250470081620251803200693202213027'.
018900      10  FILLER                  PIC X(56) VALUE
019000     '00900603325051013381050270770069990242003200840902324035'.
019100      10  FILLER                  PIC X(56) VALUE
019200     '00596401915025009145035260550112750352505401156003225058'.
019300      10  FILLER                  PIC X(56) VALUE
019400     '01905107429106009529035260480089640572808800777205527076'.
019500      10  FILLER                  PIC X(56) VALUE
019600     '00553503726050014939091311230103380682909001188906428087'.
019700      10  FILLER                  PIC X(56) VALUE
019800     '00583503926052011440070290930071220492706400734604927066'.
019900      10  FILLER                  PIC X(56) VALUE
020000     '00481303425047005529037260480055320332504500711704426058'.
020100      10  FILLER                  PIC X(56) VALUE
020200     '00648603425050006950041260570045100252303400364201815018'.
020300      10  FILLER                  PIC X(56) VALUE
020400     '00761705027070004324032250430048310292502900639703425047'.
020500      10  FILLER                  PIC X(56) VALUE
020600     '00884303520042006989027120310082910282504100584001910022'.
020700      10  FILLER                  PIC X(56) VALUE
020800     '00743202012025006491025250390235401253517601166307129096'.
020900      10  FILLER                  PIC X(56) VALUE
021000     '01395305427083007358029250400069350262504200835602525039'.
021100      10  FILLER                  PIC X(56) VALUE
021200     '01702507429109006610025250360113430763010001007206328082'.
021300      10  FILLER                  PIC X(56) VALUE
021400     '00633904627061011084059280920051320262504100613704026054'.
021500      10  FILLER                  PIC X(56) VALUE
021600     '00880406228076005850048270570067080372204300672904226057'.
021700      10  FILLER                  PIC X(56) VALUE
021800     '00434402925039003566022190220071550482706300434203325043'.
021900      10  FILLER                  PIC X(56) VALUE
022000     '02527012635175022621076300930210351143316401903005828080'.
022100      10  FILLER                  PIC X(56) VALUE
022200     '01006303225046007931024150300051020160902002719710232150'.
022300      10  FILLER                  PIC X(56) VALUE
022400     '01160404727066007463052270650074330392605100917905427074'.
022500      10  FILLER                  PIC X(56) VALUE
022600     '00530503726047005421027250430081180432606101098206328083'.
022700      10  FILLER                  PIC X(56) VALUE
022800     '00600303726049041394126351460257390973211602331308731117'.
022900      10  FILLER                  PIC X(56) VALUE
023000     '01136604526056012101054270730066190301803601446505427081'.
023100      10  FILLER                  PIC X(56) VALUE
023200     '00797102622034009159035250500053950201302500845803526053'.
023300      10  FILLER                  PIC X(56) VALUE
023400     '00477402016026004503023240230203230602810701284005928084'.
023500      10  FILLER                  PIC X(56) VALUE
023600     '00514902825039011196055280810055300242403300945105928074'.
023700      10  FILLER                  PIC X(56) VALUE
023800     '00610904426052005464039250470072210292503900387201912023'.
023900      10  FILLER                  PIC X(56) VALUE
024000     '00647603926052004186026220340072220312503100673203526048'.
024100      10  FILLER                  PIC X(56) VALUE
024200     '00429101915025002903016090160099430512707000601903125043'.
024300      10  FILLER                  PIC X(56) VALUE
024400     '01037704927072017172068240750134470561906100852304023048'.
024500      10  FILLER                  PIC X(56) VALUE
024600     '00613003012033009738037260570082650312504400451602413024'.
024700      10  FILLER                  PIC X(56) VALUE
024800     '01019202924038006689027250410039450170601700994102725036'.
024900      10  FILLER                  PIC X(56) VALUE
025000     '00752103125045009598053270770048990252503700672403726051'.
025100      10  FILLER                  PIC X(56) VALUE
025200     '00409402422032006787045270540034720130501300580703225043'.
025300      10  FILLER                  PIC X(56) VALUE
025400     '01886508030098013747059280690087730401204300716203214036'.
025500      10  FILLER                  PIC X(56) VALUE
025600     '02283408931109011018047200540079870351103800818603522043'.
025700      10  FILLER                  PIC X(56) VALUE
025800     '01104703125048005189014050140064700282103700623902625037'.
025900      10  FILLER                  PIC X(56) VALUE
026000     '01712706328092012111059280910044860232403300970405628073'.
026100      10  FILLER                  PIC X(56) VALUE
026200     '00509502925040008976049240590063400360903800490202717034'.
026300      10  FILLER                  PIC X(56) VALUE
026400     '00338701908022006152024160310071010442604400351302421034'.
026500      10  FILLER                  PIC X(56) VALUE
026600     '00976203425057007052026150300032040211802800348101611021'.
026700      10  FILLER                  PIC X(56) VALUE
026800     '00406301712022001856013050150040600302504000290901915025'.
026900      10  FILLER                  PIC X(56) VALUE
027000     '01274101824018037999179401790190281333513301205308631086'.
027100      10  FILLER                  PIC X(56) VALUE
027200     '01297205628077005385031250480023110311103103202110132132'.
027300      10  FILLER                  PIC X(56) VALUE
027400     '01583909131091015713050270850081180432606000285901713021'.
027500      10  FILLER                  PIC X(56) VALUE
027600     '01249005027069012139058280740067230382604802567407630118'.
027700      10  FILLER                  PIC X(56) VALUE
027800     '02404309231137009212032250480169560742910700757103726052'.
027900      10  FILLER                  PIC X(56) VALUE
028000     '01084004927049026496094311280112620412605301558605027084'.
028100      10  FILLER                  PIC X(56) VALUE
028200     '00978505427077006749027200330044760272503700451502121030'.
028300      10  FILLER                  PIC X(56) VALUE
028400     '01359506829099006704037260540351361343518701492706929095'.
028500      10  FILLER                  PIC X(56) VALUE
028600     '01425005227075009628060280760092930522706600636804026049'.
028700      10  FILLER                  PIC X(56) VALUE
028800     '00686804026051005859034250430158460712910002557313536226'.
028900      10  FILLER                  PIC X(56) VALUE
029000     '00707904126057005960046270650059690442606400752105728094'.
029100      10  FILLER                  PIC X(56) VALUE
029200     '00926907029104008980080301150063160522707600753804627072'.
029300      10  FILLER                  PIC X(56) VALUE
029400     '00335602825041007235049270670043720412605500915614536172'.
029500      10  FILLER                  PIC X(56) VALUE
029600     '00902111534136000000000000000132950562808901749507029112'.
029700      10  FILLER                  PIC X(56) VALUE
029800     '00784002324035020135058280950075470242403300739904627062'.
029900      10  FILLER                  PIC X(56) VALUE
030000     '00464003125040004995024220240046760232003100361402917029'.
030100      10  FILLER                  PIC X(56) VALUE
030200     '00780103526051004168020170270103410211702100857704026056'.
030300      10  FILLER                  PIC X(56) VALUE
030400     '00435502622034008864041260640043790222403202172105227102'.
030500      10  FILLER                  PIC X(56) VALUE
030600     '01630703025056035089140361980175430853012501002305628080'.
030700      10  FILLER                  PIC X(56) VALUE
030800     '00943202524052016623134351670071700452606000474003125041'.
030900      10  FILLER                  PIC X(56) VALUE
031000     '00446402023032005319024240490037220262505103576912434177'.
031100      10  FILLER                  PIC X(56) VALUE
031200     '00000000000000000000000000000374990943111011637515938304'.
031300      10  FILLER                  PIC X(56) VALUE
031400     '03612009331163000000000000000370050953113702232712334156'.
031500      10  FILLER                  PIC X(56) VALUE
031600     '01522105828095022227063280950135030392605118258127149347'.
031700      10  FILLER                  PIC X(56) VALUE
031800     '15307635557394036730130351741687724196454105980712535202'.
031900      10  FILLER                  PIC X(56) VALUE
032000     '03154011433144049514105321680193360692910204385415137215'.
032100      10  FILLER                  PIC X(56) VALUE
032200     '01815808330125010630051270800162350442405303680410733169'.
032300      10  FILLER                  PIC X(56) VALUE
032400     '01581304326061008462017140231283462024226300000000000000'.
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-THRESH                 PIC 9(05)V9(02).
040800         05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).
040900         05  H-BUDG-NUTR94                PIC 9(01)V9(06).
041000         05  H-BUDG-NUTR95                PIC 9(01)V9(06).
041100         05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).
041200         05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).
041300         05  H-FEDERAL-RATE               PIC 9(04)V9(02).
041400         05  H-LABOR-PCT                  PIC 9(01)V9(04).
041500         05  H-NLABOR-PCT                 PIC 9(01)V9(04).
041600         05  H-HSP-RATE                   PIC 9(06)V9(09).
041700         05  H-FSP-RATE                   PIC 9(06)V9(09).
041800         05  H-OUTLIER-FACT               PIC 9(01)V9(06).
041900         05  H-WK-OPER-DSH                PIC 9(01)V9(04).
042000         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).
042100
042200
042300     02  HOLD-ADDITIONAL-VARIABLES.
042400         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).
042500         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).
042600         05  H-NAT-PCT                    PIC 9(01)V9(02).
042700         05  H-REG-PCT                    PIC 9(01)V9(02).
042800         05  H-CMI-ADJ-CPD                PIC 9(05)V9(02).
042900         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).
043000         05  H-DRG-WT                     PIC 9(02)V9(04).
043100         05  H-NAT-LABOR                  PIC 9(05)V9(02).
043200         05  H-NAT-NLABOR                 PIC 9(05)V9(02).
043300         05  H-REG-LABOR                  PIC 9(05)V9(02).
043400         05  H-REG-NLABOR                 PIC 9(05)V9(02).
043500         05  H-OPER-COLA                  PIC 9(01)V9(03).
043600         05  H-INTERN-RATIO               PIC 9(01)V9(04).
043700         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).
043800         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).
043900         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
044000
044100     02  HOLD-CAPITAL-VARIABLES.
044200         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).
044300         05  H-CAPI-HSP                   PIC 9(07)V9(02).
044400         05  H-CAPI-FSP                   PIC 9(07)V9(02).
044500         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).
044600         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).
044700         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).
044800         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).
044900         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).
045000
045100     02  HOLD-CAPITAL2-VARIABLES.
045200         05  H-CAPI2-PAY-CODE             PIC X(1).
045300         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).
045400         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
045500
045600 LINKAGE SECTION.
045700***************************************************************
045800*                 * * * * * * * * *                           *
045900*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *
046000*    IN HOW TO PAY THE BILL.                                  *
046100*         REVIEW-CODE:                                        *
046200*            00 = PAY-WITH-OUTLIER.                           *
046300*                 WILL CALCULATE THE STANDARD PAYMENT.        *
046400*                 WILL ALSO ATTEMPT TO PAY DAY AND COST       *
046500*                 OUTLIERS.                                   *
046600*            03 = PAY-PERDIEM-DAYS.                           *
046700*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
046800*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
046900*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
047000*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
047100*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
047200*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
047300*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
047400*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
047500*                 BILL EXCEED THE COST THRESHOLD.             *
047600*            06 = PAY-XFER-NO-COST                            *
047700*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
047800*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
047900*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
048000*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *
048100*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
048200*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
048300*                 CALCULATE ANY COST OUTLIER PORTION          *
048400*                 OF THE PAYMENT.                             *
048500*            07 = PAY-WITHOUT-COST.                           *
048600*                 WILL CALCULATE THE STANDARD PAYMENT. WILL   *
048700*                 ALSO CALCULATE THE DAY OUTLIER PORTION OF   *
048800*                 THE PAYMENT IF THE COVERED DAYS EXCEED THE  *
048900*                 OUTLIER CUTOFF FOR THE DRG.                 *
049000***************************************************************
049100 01  BILL-DATA.
049200         10  B-PROVIDER-NO          PIC X(06).
049300         10  B-REVIEW-CODE          PIC 9(02).
049400             88  VALID-REVIEW-CODE  VALUE 00 03 06 07.
049500             88  PAY-WITH-OUTLIER   VALUE 00 07.
049600             88  PAY-PERDIEM-DAYS   VALUE 03.
049700             88  PAY-XFER-NO-COST   VALUE 06.
049800             88  PAY-WITHOUT-COST   VALUE 07.
049900         10  B-DRG                  PIC 9(03).
050000         10  B-LOS                  PIC 9(03).
050100         10  B-COVERED-DAYS         PIC 9(03).
050200         10  B-LTR-DAYS             PIC 9(02).
050300         10  B-DISCHARGE-DATE.
050400             15  B-DISCHG-MM        PIC 9(02).
050500             15  B-DISCHG-DD        PIC 9(02).
050600             15  B-DISCHG-YY        PIC 9(02).
050700         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
050800
050900***************************************************************
051000*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
051100*    AND PASSED BACK TO THE CALLING PROGRAM                   *
051200*            RETURN CODE VALUES (PPS-RTC)                     *
051300*                                                             *
051400*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
051500*              00 = PAID NORMAL DRG PAYMENT                   *
051600*                                                             *
051700*              01 = PAID AS A DAY-OUTLIER.                    *
051800*                                                             *
051900*              02 = PAID AS A COST-OUTLIER.                   *
052000*                                                             *
052100*              03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
052200*                   AND INCLUDING THE FULL DRG.               *
052300*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
052400*                   AND INCLUDING THE FULL DRG WHICH ALSO     *
052500*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *
052600*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
052700*                   AND INCLUDING THE FULL DRG. PROVIDER      *
052800*                   REFUSED COST OUTLIER.                     *
052900*                                                             *
053000*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
053100*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
053200*              52 = INVALID MSA # IN PROVIDER FILE            *
053300*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *
053400*              54 = DRG < 001 OR > 495, OR = 109 OR = 438     *
053500*                                       OR = 469 OR = 470     *
053600*                                       OR = 474              *
053700*              55 = DISCHARGE DATE < PROVIDER PPS START DATE  *
053800*              56 = INVALID LENGTH OF STAY                    *
053900*              57 = REVIEW CODE INVALID (NOT 00 03 06 07)     *
054000*              58 = TOTAL CHARGES NOT NUMERIC                 *
054100*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
054200*              62 = INVALID NUMBER OF COVERED DAYS            *
054300*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *
054400*                   SPECIFIC FILE FOR CAPITAL                 *
054500*              66 = THERE ARE NOT AS MANY BENEFIT DAYS        *
054600*                   AVAILABLE ON THE BILL AS THERE ARE OUTLIER*
054700*                   DAYS COMPUTED BY PRICER --BENEFITS ARE    *
054800*                   EXHAUSTED ---                             *
054900*                   APPORTION THE CORRECT COVERED CHARGES     *
055000*                   FOR THE MAXIMUM NUMBER OF COVERED DAYS    *
055100*                   AVAILABLE BEFORE RESUBMITTING THE BILL    *
055200*                   FOR THE COST OUTLIER PAYMENT.             *
055300*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *
055400***************************************************************
055500 01  PPS-DATA.
055600         10  PPS-RTC                PIC 9(02).
055700         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
055800         10  PPS-OUTLIER-DAYS       PIC 9(03).
055900         10  PPS-AVG-LOS            PIC 9(02)V9(01).
056000         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
056100         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
056200         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
056300         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
056400         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
056500         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
056600         10  PPS-REG-DAYS-USED      PIC 9(03).
056700         10  PPS-LTR-DAYS-USED      PIC 9(02).
056800         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
056900         10  PPS-CALC-VERS          PIC X(05).
057000
057100******************************************************************
057200*            THESE ARE THE VERSIONS OF THE PPCAL
057300*           PROGRAMS THAT WILL BE PASSED BACK----
057400*          ASSOCIATED WITH THE BILL BEING PROCESSED
057500******************************************************************
057600 01  PRICER-OPT-VERS-SW.
057700     02  PRICER-OPTION-SW          PIC X(01).
057800         88  ALL-TABLES-PASSED          VALUE 'A'.
057900         88  PROV-RECORD-PASSED         VALUE 'P'.
058000         88  ADDITIONAL-VARIABLES       VALUE 'M'.
058100     02  PPS-VERSIONS.
058200         10  PPDRV-VERSION         PIC X(05).
058300
058400******************************************************************
058500*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
058600*          ASSOCIATED WITH THE BILL BEING PROCESSED
058700******************************************************************
058800 01  PPS-ADDITIONAL-VARIABLES.
058900     05  PPS-HSP-PCT                PIC 9(01)V9(02).
059000     05  PPS-FSP-PCT                PIC 9(01)V9(02).
059100     05  PPS-NAT-PCT                PIC 9(01)V9(02).
059200     05  PPS-REG-PCT                PIC 9(01)V9(02).
059300     05  PPS-CMI-ADJ-CPD            PIC 9(05)V9(02).
059400     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
059500     05  PPS-DRG-WT                 PIC 9(02)V9(04).
059600     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
059700     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
059800     05  PPS-REG-LABOR              PIC 9(05)V9(02).
059900     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
060000     05  PPS-OPER-COLA              PIC 9(01)V9(03).
060100     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
060200     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
060300     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
060400     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
060500     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
060600     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
060700     05  PPS-CAPITAL-VARIABLES.
060800         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).
060900         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).
061000         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).
061100         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).
061200         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).
061300         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).
061400         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).
061500         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).
061600     05  PPS-CAPITAL2-VARIABLES.
061700         10  PPS-CAPI2-PAY-CODE             PIC X(1).
061800         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).
061900         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
062000
062100
062200******************************************************************
062300*               THIS IS THE PROVIDER RECORD
062400*          ASSOCIATED WITH THE BILL BEING PROCESSED
062500******************************************************************
062600 01  PROV-HOLD.
062700     02  PROV-REC-HOLD.
062800         05  P-PROVIDER-NO.
062900             10  P-STATE                PIC 9(02).
063000             10  FILLER                 PIC X(04).
063100         05  P-EFF-DATE.
063200             10  P-EFF-YY               PIC 9(02).
063300             10  P-EFF-MM               PIC 9(02).
063400             10  P-EFF-DD               PIC 9(02).
063500         05  P-WAIVER-CODE              PIC X(01).
063600             88  WAIVER-STATE           VALUE 'Y'.
063700         05  P-PROVIDER-TYPE            PIC X(02).
063800             88  REFERRAL-CENTER        VALUE '07' '15' '17' '22'.
063900             88  INDIAN-HEALTH-SERVICE  VALUE '08'.
064000             88  MDH-REBASED-FY90       VALUE '14' '15'.
064100             88  MDH-RRC-REBASED-FY90   VALUE '15'.
064200             88  SCH-REBASED-FY90       VALUE '16' '17'.
064300             88  SCH-RRC-REBASED-FY90   VALUE '17'.
064400             88  MEDICAL-ASSIST-FACIL   VALUE '18'.
064500             88  OTHER-URB-TO-RURAL     VALUE '19'.
064600             88  LARGE-URB-TO-RURAL     VALUE '20'.
064700             88  EACH                   VALUE '21' '22'.
064800             88  EACH-REFERRAL-CENTER   VALUE '22'.
064900         05  P-CURRENT-CENSUS-DIV       PIC 9(01).
065000             88  NEW-ENGLAND            VALUE  1.
065100             88  MIDDLE-ATLANTIC        VALUE  2.
065200             88  SOUTH-ATLANTIC         VALUE  3.
065300             88  EAST-NORTH-CENTRAL     VALUE  4.
065400             88  EAST-SOUTH-CENTRAL     VALUE  5.
065500             88  WEST-NORTH-CENTRAL     VALUE  6.
065600             88  WEST-SOUTH-CENTRAL     VALUE  7.
065700             88  MOUNTAIN               VALUE  8.
065800             88  PACIFIC                VALUE  9.
065900         05  P-CENSUS-DIV  REDEFINES
066000                    P-CURRENT-CENSUS-DIV       PIC 9(01).
066100             88  VALID-CENSUS-DIV   VALUE 1 THRU 9.
066200         05  P-PPS-BLEND-YEAR           PIC 9(01).
066300             88  VALID-PPS-BLEND-YEAR   VALUE 1 THRU 8.
066400         05  P-MSA-X.
066500             10  P-MSA-9                PIC X(04).
066600         05  P-FISCAL-YEAR-END.
066700             10  P-MM                   PIC 9(02).
066800             10  P-DD                   PIC 9(02).
066900             10  P-YY                   PIC 9(02).
067000         05  P-VARIABLES.
067100             10  P-CMI-ADJ-CPD          PIC S9(05)V9(02).
067200             10  P-COLA                 PIC S9(01)V9(03).
067300             10  P-INTERN-RATIO         PIC S9(01)V9(04).
067400             10  PRUP-UPDT-FACTOR       PIC S9(01)V9(05).
067500             10  P-BED-SIZE             PIC  9(05).
067600             10  P-DSH-PERCENT          PIC V9(04).
067700             10  P-OPER-CSTCHG-RATIO    PIC  9(01)V9(03).
067800             10  P-CMI                  PIC  9(01)V9(04).
067900             10  FILLER                 PIC  9(01).
068000             10  P-REPORT-DATE          PIC  9(06).
068100             10  FILLER                 PIC  9(01).
068200             10  P-INTER-NO             PIC  9(05).
068300     02  PROV-REC-HOLD2.
068400         05  P-FY-BEGIN-DATE.
068500             10  P-FY-BEGIN-MM          PIC 9(2).
068600             10  P-FY-BEGIN-DD          PIC 9(2).
068700             10  P-FY-BEGIN-YY          PIC 9(2).
068800         05  P-PASS-AMT-CAPITAL         PIC 9(4)V99.
068900         05  P-PASS-AMT-DIR-MED-ED      PIC 9(4)V99.
069000         05  P-PASS-AMT-ORGAN-ACQ       PIC 9(4)V99.
069100         05  P-PASS-AMT-INCL-MISC       PIC 9(4)V99.
069200         05  P-SSI-RATIO                PIC V9(4).
069300         05  P-MEDICAID-RATIO           PIC V9(4).
069400         05  P-TERMINATION-DATE         PIC X(6).
069500         05  P-WAGE-INDEX-LOC-MSA       PIC X(4).
069600         05  P-CHG-CODE-INDEX           PIC X.
069700         05  P-STAND-AMT-LOC-MSA.
069800             10  P-RURAL-1ST            PIC XX.
069900                 88  P-RURAL-CHECK        VALUE '  '.
070000             10  P-RURAL-2ND            PIC XX.
070100         05  P-CAPI-SOL-HOSP-RATE       PIC XX.
070200         05  FILLER                     PIC X.
070300         05  FILLER                     PIC X(06).
070400         05  FILLER                     PIC X(18).
070500     02  PROV-REC-HOLD3.
070600         05  P-CAPI-PPS-PAY-CODE        PIC X.
070700         05  P-CAPI-HOSP-SPEC-RATE      PIC 9(4)V99.
070800         05  P-CAPI-OLD-HARM-RATE       PIC 9(4)V99.
070900         05  P-CAPI-NEW-HARM-RATIO      PIC 9(1)V9999.
071000         05  P-CAPI-CSTCHG-RATIO        PIC 9V999.
071100         05  P-CAPI-NEW-HOSP            PIC X.
071200         05  P-CAPI-IME                 PIC 9V9999.
071300         05  P-CAPI-EXCEPTIONS          PIC 9(4)V99.
071400         05  FILLER                     PIC X(46).
071500
071600******************************************************************
071700*                   THIS IS THE WAGE-INDEX
071800*          ASSOCIATED WITH THE BILL BEING PROCESSED
071900******************************************************************
072000 01  WAGE-INDEX-RECORD.
072100     05  W-MSA                         PIC X(4).
072200     05  W-SIZE                        PIC X.
072300         88  LARGE-URBAN       VALUE 'L'.
072400         88  OTHER-URBAN       VALUE 'O'.
072500         88  ALL-RURAL         VALUE 'R'.
072600     05  W-EFF-DATE                    PIC X(6).
072700     05  FILLER                        PIC X.
072800     05  W-INDEX-RECORD                PIC S9(02)V9(04).
072900
073000
073100 PROCEDURE DIVISION  USING BILL-DATA
073200                           PPS-DATA
073300                           PRICER-OPT-VERS-SW
073400                           PPS-ADDITIONAL-VARIABLES
073500                           PROV-HOLD
073600                           WAGE-INDEX-RECORD.
073700
073800***************************************************************
073900*    PROCESSING:                                              *
074000*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
074100*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *
074200*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
074300*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
074400*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
074500*           GOBACK.                                           *
074600*        D. ASSEMBLE PRICING COMPONENTS.                      *
074700*        E. CALCULATE THE BLENDED PRICE.                      *
074800***************************************************************
074900
075000     PERFORM 0200-MAINLINE-CONTROL.
075100
075200     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
075300     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.
075400     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.
075500     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.
075600     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.
075700     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
075800
075900     GOBACK.
076000
076100 0200-MAINLINE-CONTROL.
076200     MOVE ALL '0' TO PPS-DATA
076300                     HOLD-PPS-COMPONENTS
076400                     HOLD-ADDITIONAL-VARIABLES
076500                     HOLD-CAPITAL-VARIABLES
076600                     HOLD-CAPITAL2-VARIABLES.
076700
076800     IF P-CAPI-HOSP-SPEC-RATE NOT NUMERIC
076900        MOVE 0 TO P-CAPI-HOSP-SPEC-RATE.
077000
077100     IF P-CAPI-OLD-HARM-RATE  NOT NUMERIC
077200        MOVE 0 TO P-CAPI-OLD-HARM-RATE.
077300
077400     IF P-CAPI-NEW-HARM-RATIO NOT NUMERIC
077500        MOVE 0 TO P-CAPI-NEW-HARM-RATIO.
077600
077700     IF P-CAPI-CSTCHG-RATIO NOT NUMERIC
077800        MOVE 0 TO P-CAPI-CSTCHG-RATIO.
077900
078000******************************************************************
078100     PERFORM 1000-EDIT-THE-BILL-INFO.
078200
078300     IF  PPS-RTC = 00
078400         PERFORM 2000-ASSEMBLE-PPS-VARIABLES
078500         PERFORM 3000-CALC-BLENDED-PAYMENT.
078600
078700 1000-EDIT-THE-BILL-INFO.
078800***************************************************************
078900*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *
079000*    AND DO NOT ATTEMPT TO PRICE.                             *
079100***************************************************************
079200
079300     MOVE B-DISCHG-YY TO H-BILL-YY.
079400     MOVE B-DISCHG-MM TO H-BILL-MM.
079500     MOVE B-DISCHG-DD TO H-BILL-DD.
079600
079700     MOVE P-FY-BEGIN-YY TO H-FY-BEGIN-YY.
079800     MOVE P-FY-BEGIN-MM TO H-FY-BEGIN-MM.
079900     MOVE P-FY-BEGIN-DD TO H-FY-BEGIN-DD.
080000
080100     IF HOLD-FY-BEGIN-DATE < 941001
080200        MOVE .30 TO H-CAPI-PAYCDE-PCT1
080300        MOVE .70 TO H-CAPI-PAYCDE-PCT2
080400     ELSE
080500        IF (HOLD-FY-BEGIN-DATE < HOLD-BILL-DATE) OR
080600           (HOLD-FY-BEGIN-DATE = HOLD-BILL-DATE)
080700              MOVE .40 TO H-CAPI-PAYCDE-PCT1
080800              MOVE .60 TO H-CAPI-PAYCDE-PCT2
080900        ELSE
081000              MOVE .30 TO H-CAPI-PAYCDE-PCT1
081100              MOVE .70 TO H-CAPI-PAYCDE-PCT2.
081200
081300     IF  PPS-RTC = 00
081400         IF  WAIVER-STATE
081500             MOVE 53 TO PPS-RTC.
081600
081700     IF  PPS-RTC = 00
081800         IF  B-DRG < 001 OR > 495 OR = 109 OR = 438
081900                                  OR = 469 OR = 470
082000                                  OR = 474
082100             MOVE 54 TO PPS-RTC.
082200
082300     IF  PPS-RTC = 00
082400         IF  HOLD-BILL-DATE < P-EFF-DATE
082500             MOVE 55 TO PPS-RTC.
082600
082700     IF  PPS-RTC = 00
082800         IF  B-REVIEW-CODE NOT NUMERIC
082900             MOVE 57 TO PPS-RTC.
083000     IF  PPS-RTC = 00
083100         IF  B-LOS NOT NUMERIC
083200             MOVE 56 TO PPS-RTC
083300         ELSE
083400         IF  B-LOS = 0
083500             IF B-REVIEW-CODE NOT = 03 AND
083600                              NOT = 06
083700             MOVE 56 TO PPS-RTC.
083800
083900     IF  PPS-RTC = 00
084000         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60
084100             MOVE 61 TO PPS-RTC
084200         ELSE
084300             MOVE B-LTR-DAYS TO H-LTR-DAYS.
084400
084500     IF  PPS-RTC = 00
084600         IF  B-COVERED-DAYS NOT NUMERIC
084700             MOVE 62 TO PPS-RTC
084800         ELSE
084900         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
085000             MOVE 62 TO PPS-RTC
085100         ELSE
085200             MOVE B-COVERED-DAYS TO H-COV-DAYS.
085300
085400     IF  PPS-RTC = 00
085500         IF  H-LTR-DAYS  > H-COV-DAYS
085600             MOVE 62 TO PPS-RTC
085700         ELSE
085800             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
085900
086000     IF  PPS-RTC = 00
086100         IF  NOT VALID-REVIEW-CODE
086200             MOVE 57 TO PPS-RTC.
086300
086400     IF  PPS-RTC = 00
086500         IF  B-CHARGES-CLAIMED NOT NUMERIC
086600             MOVE 58 TO PPS-RTC.
086700
086800     IF PPS-RTC = 00
086900        IF NOT INDIAN-HEALTH-SERVICE
087000           IF P-CAPI-NEW-HOSP NOT = 'Y'
087100                 IF P-CAPI-PPS-PAY-CODE NOT = 'A' AND
087200                                        NOT = 'B' AND
087300                                        NOT = 'C'
087400                 MOVE 65 TO PPS-RTC.
087500
087600 2000-ASSEMBLE-PPS-VARIABLES.
087700***************************************************************
087800*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *
087900*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *
088000*    OF THAT VARIABLE.                                        *
088100***************************************************************
088200***  GET THE PROVIDER SPECIFIC VARIABLES.
088300
088400     MOVE P-CMI-ADJ-CPD  TO H-CMI-ADJ-CPD.
088500     MOVE P-INTERN-RATIO TO H-INTERN-RATIO.
088600
088700     IF  NOT (P-STATE = 02 OR 12)
088800         MOVE 1 TO H-OPER-COLA
088900     ELSE
089000         MOVE P-COLA TO H-OPER-COLA.
089100
089200***************************************************************
089300***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
089400
089500     PERFORM 2600-GET-DRG-WEIGHT
089600             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.
089700
089800***************************************************************
089900***  GET THE WAGE-INDEX
090000
090100     MOVE W-INDEX-RECORD TO H-WAGE-INDEX.
090200
090300***************************************************************
090400***  GET THE LABOR, NON-LABOR STANDARD RATES
090500
090600     IF  VALID-CENSUS-DIV
090700         MOVE P-CURRENT-CENSUS-DIV TO R2
090800     ELSE
090900         MOVE 10 TO R2.
091000
091100     MOVE 10 TO R4.
091200
091300     IF  P-STATE = 40
091400         MOVE 11 TO R2
091500         MOVE 12 TO R4.
091600
091700     IF  LARGE-URBAN
091800         MOVE 1 TO R3
091900     ELSE
092000     IF  OTHER-URBAN OR REFERRAL-CENTER
092100         MOVE 2 TO R3
092200     ELSE
092300         MOVE 3 TO R3.
092400
092500     PERFORM 2300-GET-LABOR-NLABOR-RATES
092600             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
092700
092800***************************************************************
092900***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
093000
093100     MOVE 0.00  TO H-OPER-HSP-PCT.
093200     MOVE 1.00  TO H-OPER-FSP-PCT.
093300
093400***************************************************************
093500***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
093600
093700      MOVE 1.00 TO H-NAT-PCT.
093800      MOVE 0.00 TO H-REG-PCT.
093900
094000***************************************************************
094100*    REGIONAL FLOOR
094200
094300     IF  (H-REG-LABOR + H-REG-NLABOR) >
094400         (H-NAT-LABOR + H-NAT-NLABOR)
094500           MOVE 0.85 TO H-NAT-PCT
094600           MOVE 0.15 TO H-REG-PCT.
094700
094800     IF  P-STATE = 40
094900         MOVE 0.25 TO H-NAT-PCT
095000         MOVE 0.75 TO H-REG-PCT.
095100
095200     IF  SCH-REBASED-FY90 OR EACH
095300         MOVE 1.00 TO H-OPER-HSP-PCT.
095400
095500
095600 2300-GET-LABOR-NLABOR-RATES.
095700
095800     IF  HOLD-BILL-DATE NOT < RATE-EFF-DATE (R1)
095900         MOVE REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
096000         MOVE REG-NLABOR (R1 R2 R3) TO H-REG-NLABOR
096100         MOVE REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
096200         MOVE REG-NLABOR (R1 R4 R3) TO H-NAT-NLABOR
096300         IF OTHER-URB-TO-RURAL OR LARGE-URB-TO-RURAL
096400            PERFORM 2350-BLEND-RURAL-RATES.
096500
096600 2350-BLEND-RURAL-RATES.
096700      COMPUTE BLEND-RURAL-PCT ROUNDED = 1 / 3.
096800
096900      IF OTHER-URB-TO-RURAL
097000         COMPUTE H-REG-LABOR  ROUNDED =
097100             (REG-LABOR  (R1 R2 2) - REG-LABOR  (R1 R2 3))
097200               * BLEND-RURAL-PCT   +  REG-LABOR  (R1 R2 3)
097300
097400         COMPUTE H-REG-NLABOR ROUNDED =
097500             (REG-NLABOR (R1 R2 2) - REG-NLABOR (R1 R2 3))
097600               * BLEND-RURAL-PCT   +  REG-NLABOR (R1 R2 3)
097700
097800         COMPUTE H-NAT-LABOR  ROUNDED =
097900             (REG-LABOR  (R1 R4 2) - REG-LABOR  (R1 R4 3))
098000               * BLEND-RURAL-PCT   +  REG-LABOR  (R1 R4 3)
098100
098200         COMPUTE H-NAT-NLABOR ROUNDED =
098300             (REG-NLABOR (R1 R4 2) - REG-NLABOR (R1 R4 3))
098400               * BLEND-RURAL-PCT   +  REG-NLABOR (R1 R4 3).
098500
098600
098700      IF LARGE-URB-TO-RURAL
098800         COMPUTE H-REG-LABOR  ROUNDED =
098900             (REG-LABOR  (R1 R2 1) - REG-LABOR  (R1 R2 3))
099000               * BLEND-RURAL-PCT   +  REG-LABOR  (R1 R2 3)
099100
099200         COMPUTE H-REG-NLABOR ROUNDED =
099300             (REG-NLABOR (R1 R2 1) - REG-NLABOR (R1 R2 3))
099400               * BLEND-RURAL-PCT   +  REG-NLABOR (R1 R2 3)
099500
099600         COMPUTE H-NAT-LABOR  ROUNDED =
099700             (REG-LABOR  (R1 R4 1) - REG-LABOR  (R1 R4 3))
099800               * BLEND-RURAL-PCT   +  REG-LABOR  (R1 R4 3)
099900
100000         COMPUTE H-NAT-NLABOR ROUNDED =
100100             (REG-NLABOR (R1 R4 1) - REG-NLABOR (R1 R4 3))
100200               * BLEND-RURAL-PCT   +  REG-NLABOR (R1 R4 3).
100300
100400 2600-GET-DRG-WEIGHT.
100500     IF  HOLD-BILL-DATE NOT < DRGX-EFF-DATE (DX5)
100600         SET DX6 TO B-DRG
100700         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT
100800         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS
100900         MOVE DRG-DAYS-TRIM (DX5 DX6)  TO H-DAYS-CUTOFF
101000         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.
101100
101200 3000-CALC-BLENDED-PAYMENT.
101300***************************************************************
101400*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *
101500*        CALCULATE COVERED DAYS UTILIZATION.                  *
101600*        CALCULATE THE FEDERAL PORTION.                       *
101700*        CALCULATE THE HOSPITAL PORTION.                      *
101800*        CALCULATE THE DAYS-OUTLIER PORTION.                  *
101900*        CALCULATE THE COST-OUTLIER PORTION.                  *
102000*        CALCULATE THE TOTAL PAYMENT (BLENDED)                *
102100*        CALCULATE THE DSH ADJUSTMENT.                        *
102200***************************************************************
102300     PERFORM 3100-CALC-STAY-UTILIZATION.
102400     PERFORM 3300-CALC-OPER-FSP-AMT.
102500     PERFORM 3900-CALC-OPER-DSH.
102600***********************************************************
102700***  OPERATING IME CALCULATION
102800
102900         COMPUTE H-OPER-IME-TEACH =
103000            1.89 * ((1 + H-INTERN-RATIO) ** .405  - 1).
103100
103200***********************************************************
103300
103400     IF  SCH-REBASED-FY90 OR EACH
103500         PERFORM 3450-CALC-ADDITIONAL-HSP.
103600
103700     MOVE 00                 TO  PPS-RTC.
103800     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.
103900     MOVE H-ALOS             TO  PPS-AVG-LOS.
104000     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.
104100
104200     PERFORM 3600-CALC-OUTLIER.
104300
104400     IF PAY-PERDIEM-DAYS
104500         IF  B-LOS < H-ALOS
104600             IF  NOT (B-DRG = 385 OR 456)
104700                 PERFORM 3500-CALC-PERDIEM-AMT
104800                 MOVE 03 TO PPS-RTC.
104900
105000     IF  PAY-PERDIEM-DAYS
105100         IF  H-OPER-OUTCST-PART > 0
105200             MOVE H-OPER-OUTCST-PART TO
105300                  H-OPER-OUTLIER-PART
105400             MOVE 05 TO PPS-RTC
105500         ELSE
105600         IF  PPS-RTC NOT = 03
105700             MOVE 00 TO PPS-RTC
105800             MOVE 0  TO H-OPER-OUTLIER-PART.
105900
106000     IF  PAY-PERDIEM-DAYS
106100         IF  H-CAPI-OUTCST-PART > 0
106200             MOVE H-CAPI-OUTCST-PART TO
106300                  H-CAPI-OUTLIER-PART
106400             MOVE 05 TO PPS-RTC
106500         ELSE
106600         IF  PPS-RTC NOT = 03
106700             MOVE 0  TO H-CAPI-OUTLIER-PART.
106800
106900     IF  PAY-XFER-NO-COST
107000         MOVE 0  TO H-OPER-OUTLIER-PART
107100                    H-CAPI-OUTLIER-PART
107200         MOVE 00 TO PPS-RTC
107300         IF B-LOS < H-ALOS
107400            IF  NOT (B-DRG = 385 OR 456)
107500                PERFORM 3500-CALC-PERDIEM-AMT
107600                MOVE 06 TO PPS-RTC.
107700
107800     MOVE 1 TO H-DSCHG-FRCTN.
107900
108000     IF  (PAY-PERDIEM-DAYS OR
108100          PAY-XFER-NO-COST)
108200          COMPUTE H-DSCHG-FRCTN = H-COV-DAYS / H-ALOS
108300          IF H-DSCHG-FRCTN > 1
108400             MOVE 1 TO H-DSCHG-FRCTN.
108500
108600     COMPUTE H-DRG-WT-FRCTN = H-DSCHG-FRCTN * H-DRG-WT.
108700
108800***********************************************************
108900***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF
109000***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
109100
109200     COMPUTE H-CAPI2-B-FSP-PART = H-CAPI-FSP-PART.
109300
109400***********************************************************
109500     IF  PPS-RTC < 50
109600         PERFORM 3800-CALC-TOT-AMT
109700     ELSE
109800         MOVE 0 TO PPS-OPER-HSP-PART
109900                   PPS-OPER-FSP-PART
110000                   PPS-OPER-OUTLIER-PART
110100                   PPS-OUTLIER-DAYS
110200                   PPS-REG-DAYS-USED
110300                   PPS-LTR-DAYS-USED
110400                   PPS-TOTAL-PAYMENT
110500                   PPS-OPER-DSH-ADJ
110600                   PPS-OPER-IME-ADJ
110700                   H-DSCHG-FRCTN
110800                   H-DRG-WT-FRCTN
110900                   HOLD-CAPITAL-VARIABLES
111000                   HOLD-CAPITAL2-VARIABLES.
111100
111200 3100-CALC-STAY-UTILIZATION.
111300     IF  H-REG-DAYS > 0
111400         IF  H-REG-DAYS < H-DAYS-CUTOFF
111500             MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
111600             MOVE 0          TO H-REG-DAYS
111700         ELSE
111800             MOVE H-DAYS-CUTOFF TO PPS-REG-DAYS-USED
111900             SUBTRACT H-DAYS-CUTOFF FROM H-REG-DAYS
112000     ELSE
112100     IF  H-LTR-DAYS < H-DAYS-CUTOFF
112200         MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED
112300         MOVE 0          TO H-LTR-DAYS
112400     ELSE
112500         MOVE H-DAYS-CUTOFF TO PPS-LTR-DAYS-USED
112600         SUBTRACT H-DAYS-CUTOFF FROM H-LTR-DAYS.
112700
112800     IF  B-LOS > H-DAYS-CUTOFF
112900         PERFORM 3200-CALC-OUTLIER-UTILIZATION.
113000
113100 3200-CALC-OUTLIER-UTILIZATION.
113200     COMPUTE PPS-OUTLIER-DAYS =
113300         B-LOS - H-DAYS-CUTOFF.
113400
113500     IF  (H-REG-DAYS + H-LTR-DAYS) < PPS-OUTLIER-DAYS
113600         COMPUTE PPS-OUTLIER-DAYS =
113700             H-REG-DAYS + H-LTR-DAYS
113800         ADD H-REG-DAYS TO PPS-REG-DAYS-USED
113900         ADD H-LTR-DAYS TO PPS-LTR-DAYS-USED
114000     ELSE
114100     IF  H-REG-DAYS < PPS-OUTLIER-DAYS
114200         ADD H-REG-DAYS TO PPS-REG-DAYS-USED
114300         COMPUTE PPS-LTR-DAYS-USED =
114400             PPS-LTR-DAYS-USED + (PPS-OUTLIER-DAYS -
114500                                  H-REG-DAYS)
114600     ELSE
114700         ADD PPS-OUTLIER-DAYS TO PPS-REG-DAYS-USED.
114800
114900     IF  B-REVIEW-CODE = 03
115000         IF  PPS-REG-DAYS-USED > 0
115100             MOVE 0 TO PPS-LTR-DAYS-USED.
115200
115300 3300-CALC-OPER-FSP-AMT.
115400***********************************************************
115500***  OPERATING FSP CALCULATION
115600
115700     COMPUTE H-OPER-FSP-PART ROUNDED =
115800         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
115900         H-NAT-NLABOR * H-OPER-COLA) * H-DRG-WT)
116000                           +
116100         (H-REG-PCT * (H-REG-LABOR * H-WAGE-INDEX +
116200         H-REG-NLABOR * H-OPER-COLA) * H-DRG-WT).
116300
116400 3450-CALC-ADDITIONAL-HSP.
116500***********************************************************
116600*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR
116700*    SOLE COMMUNITY
116800*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)
116900*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
117000***********************************************************
117100**** CHANGE ESTIMATED OUTLIER FACTORS WHEN FED RATES CHANGE
117200****    USE ACTUAL FEDERAL REGISTER NUMBER
117300
117400     MOVE 0.948940 TO H-OUTLIER-FACT.
117500***************************************************************
117600***         GET THE UPDATING FACTOR
117700
117800     MOVE 0.999003 TO H-BUDG-NUTR94.
117900     MOVE 0.998050 TO H-BUDG-NUTR95.
118000
118100     COMPUTE H-UPDATE-FACTOR ROUNDED =
118200        (1.014 * H-BUDG-NUTR94 * H-BUDG-NUTR95 * 0.999851).
118300
118400     COMPUTE H-HSP-RATE ROUNDED =
118500         H-CMI-ADJ-CPD * H-UPDATE-FACTOR.
118600
118700     COMPUTE H-FSP-RATE ROUNDED =
118800         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
118900         H-NAT-NLABOR * H-OPER-COLA))
119000                           +
119100          (H-REG-PCT * (H-REG-LABOR * H-WAGE-INDEX +
119200         H-REG-NLABOR * H-OPER-COLA)))
119300                           *
119400       ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-FACT).
119500
119600     IF  H-HSP-RATE > H-FSP-RATE
119700           COMPUTE H-OPER-HSP-PART =
119800             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT
119900     ELSE
120000         MOVE 0 TO H-OPER-HSP-PART.
120100
120200***************************************************************
120300***        IF MDH IS REVIVED --- REPLACE THIS CODE
120400***  IF  H-HSP-RATE > H-FSP-RATE
120500***      IF P-PROVIDER-TYPE = '14' OR '15'
120600***         COMPUTE H-OPER-HSP-PART =
120700***            (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT * .5.
120800***************************************************************
120900
121000 3500-CALC-PERDIEM-AMT.
121100     MOVE B-LOS TO H-COV-DAYS.
121200     IF  H-COV-DAYS = 0
121300         MOVE 1 TO H-COV-DAYS.
121400***********************************************************
121500***  OPERATING PERDIEM-AMT CALCULATION
121600***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
121700
121800     COMPUTE H-OPER-HSP-PART ROUNDED =
121900        H-OPER-HSP-PART / H-ALOS * H-COV-DAYS
122000        ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
122100
122200     COMPUTE H-OPER-FSP-PART ROUNDED =
122300        H-OPER-FSP-PART / H-ALOS * H-COV-DAYS
122400        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
122500
122600***********************************************************
122700***  CAPITAL PERDIEM-AMT CALCULATION
122800***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS
122900
123000     COMPUTE H-CAPI-HSP-PART ROUNDED =
123100        H-CAPI-HSP-PART / H-ALOS * H-COV-DAYS
123200        ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
123300
123400     COMPUTE H-CAPI-FSP-PART ROUNDED =
123500        H-CAPI-FSP-PART / H-ALOS * H-COV-DAYS
123600        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
123700
123800***********************************************************
123900***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
124000
124100     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
124200        H-CAPI-OLD-HARMLESS / H-ALOS * H-COV-DAYS
124300        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
124400
124500 3600-CALC-OUTLIER.
124600     MOVE 0.47 TO H-DAYOUT-PCT.
124700
124800     MOVE 0.80 TO H-CSTOUT-PCT.
124900
125000     IF  B-DRG = 456 OR 457 OR 458 OR 459 OR 460 OR 472
125100             MOVE 0.90 TO H-CSTOUT-PCT.
125200
125300     MOVE 0.7140   TO H-LABOR-PCT.
125400     MOVE 0.2860   TO H-NLABOR-PCT.
125500
125600     IF  P-OPER-CSTCHG-RATIO NUMERIC
125700             MOVE P-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO
125800     ELSE
125900             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.
126000
126100     IF P-CAPI-CSTCHG-RATIO NUMERIC
126200             MOVE P-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO
126300     ELSE
126400             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.
126500
126600***********************************************************
126700***  OPERATING DAY OUTLIER CALCULATION
126800
126900     IF  PPS-OUTLIER-DAYS > 0
127000        COMPUTE H-OPER-OUTDAY-PART =
127100            H-DAYOUT-PCT *  H-OPER-FSP-PART / H-ARITH-ALOS
127200                                       * PPS-OUTLIER-DAYS
127300            ON SIZE ERROR MOVE 0 TO H-OPER-OUTDAY-PART.
127400
127500***********************************************************
127600***********************************************************
127700***  CAPITAL PAYMENT METHOD B
127800
127900     IF W-SIZE = 'L'
128000        MOVE 1.03 TO H-CAPI-LARG-URBAN
128100     ELSE
128200        MOVE 1.00 TO H-CAPI-LARG-URBAN
128300        IF LARGE-URB-TO-RURAL
128400           MOVE 1.01 TO H-CAPI-LARG-URBAN.
128500
128600
128700     COMPUTE H-CAPI-GAF = (H-WAGE-INDEX ** .6848).
128800
128900     COMPUTE H-CAPI-COLA =
129000                     (.3152 * (H-OPER-COLA - 1) + 1).
129100
129200     MOVE 0289.87 TO H-PUERTO-RICO-RATE.
129300     MOVE 0376.83 TO H-FEDERAL-RATE.
129400
129500     IF P-STATE = 40
129600        COMPUTE  H-CAPI-FED-RATE =
129700                      (.75 * H-PUERTO-RICO-RATE) +
129800                      (.25 * H-FEDERAL-RATE)
129900     ELSE
130000        MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.
130100
130200***********************************************************
130300***  CAPITAL HSP CALCULATION
130400
130500     COMPUTE H-ACCUM-TO-HSP = 0.9784 * 1.0005.
130600     COMPUTE H-CAPI-HSP-PART = (H-DRG-WT *
130700                   P-CAPI-HOSP-SPEC-RATE * H-ACCUM-TO-HSP).
130800***********************************************************
130900***  CAPITAL FSP CALCULATION
131000
131100     COMPUTE H-CAPI-FSP-PART = H-DRG-WT * H-CAPI-FED-RATE *
131200                               H-CAPI-COLA * H-CAPI-GAF *
131300                               H-CAPI-LARG-URBAN.
131400
131500***********************************************************
131600***  CAPITAL PAYMENT METHOD A
131700
131800     IF SCH-REBASED-FY90 OR EACH
131900        MOVE 1.00 TO H-CAPI-SCH
132000     ELSE
132100        MOVE 0.85 TO H-CAPI-SCH.
132200
132300***********************************************************
132400***********  CAPITAL OLD-HARMLESS CALCULATION ***********
132500
132600     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
132700                    (P-CAPI-OLD-HARM-RATE *
132800                    H-CAPI-SCH).
132900
133000***********************************************************
133100***********************************************************
133200***  CAPITAL DAY OUTLIER CALCULATION
133300
133400     IF  PPS-OUTLIER-DAYS > 0
133500         COMPUTE H-CAPI-OUTDAY-PART =
133600            H-DAYOUT-PCT * H-CAPI-FSP-PART / H-ARITH-ALOS
133700                                       * PPS-OUTLIER-DAYS
133800            ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.
133900
134000     IF  H-CAPI-OUTDAY-PART  > 0
134100         IF P-CAPI-PPS-PAY-CODE = 'A'
134200             COMPUTE H-CAPI-OUTDAY-PART =
134300                 H-CAPI-OUTDAY-PART * P-CAPI-NEW-HARM-RATIO
134400             ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.
134500
134600     IF  H-CAPI-OUTDAY-PART  > 0
134700         IF P-CAPI-PPS-PAY-CODE = 'C'
134800             COMPUTE H-CAPI-OUTDAY-PART =
134900                    (H-CAPI-OUTDAY-PART * H-CAPI-PAYCDE-PCT1)
135000             ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.
135100
135200***********************************************************
135300***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
135400
135500     IF H-CAPI-CSTCHG-RATIO > 0 OR
135600       H-OPER-CSTCHG-RATIO > 0
135700        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD =
135800                H-OPER-CSTCHG-RATIO /
135900               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
136000        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD =
136100                H-CAPI-CSTCHG-RATIO /
136200               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
136300     ELSE
136400         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD
136500                   H-CAPI-SHARE-DOLL-THRESHOLD.
136600
136700     MOVE 20500.00 TO H-CST-THRESH.
136800     MOVE 18800.00 TO H-PRE-CAPI-THRESH.
136900
137000     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
137100        ((H-CST-THRESH * H-LABOR-PCT  * H-WAGE-INDEX) +
137200         (H-CST-THRESH * H-NLABOR-PCT * H-OPER-COLA)) *
137300          H-OPER-SHARE-DOLL-THRESHOLD.
137400
137500***********************************************************
137600***  DIFFERENT THRESHOLD   PRE-CAPITAL
137700
137800     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE
137900        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
138000        (H-PRE-CAPI-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +
138100        (H-PRE-CAPI-THRESH * H-NLABOR-PCT * H-OPER-COLA).
138200***********************************************************
138300
138400     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
138500          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *
138600          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.
138700
138800     COMPUTE H-OPER-COST-OUTLIER ROUNDED =
138900          H-OPER-FSP-PART + H-OPER-DOLLAR-THRESHOLD.
139000
139100     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
139200          H-CAPI-FSP-PART + H-CAPI-DOLLAR-THRESHOLD.
139300
139400     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE
139500         MOVE 0 TO H-CAPI-COST-OUTLIER.
139600
139700     IF B-REVIEW-CODE = '03'  AND H-COV-DAYS < H-ALOS
139800        COMPUTE H-OPER-COST-OUTLIER ROUNDED =
139900                (H-OPER-COST-OUTLIER * H-COV-DAYS / H-ALOS)
140000                ON SIZE ERROR MOVE 0 TO H-OPER-COST-OUTLIER.
140100
140200     IF B-REVIEW-CODE = '03'  AND H-COV-DAYS < H-ALOS
140300        COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
140400                (H-CAPI-COST-OUTLIER * H-COV-DAYS / H-ALOS)
140500                ON SIZE ERROR MOVE 0 TO H-CAPI-COST-OUTLIER.
140600
140700***********************************************************
140800***  CAPITAL DSH CALCULATION
140900     MOVE 0 TO H-CAPI-DSH.
141000
141100     IF P-BED-SIZE NOT NUMERIC
141200         MOVE 0 TO P-BED-SIZE.
141300
141400     IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99
141500         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **
141600                  (.2025 * (P-SSI-RATIO
141700                          + P-MEDICAID-RATIO)) - 1.
141800
141900     IF W-SIZE = 'R' AND P-BED-SIZE > 99
142000                     AND (OTHER-URB-TO-RURAL OR
142100                          LARGE-URB-TO-RURAL)
142200         COMPUTE H-CAPI-DSH ROUNDED =
142300                 1 / 3 * (2.7183 **
142400                  (.2025 * (P-SSI-RATIO
142500                          + P-MEDICAID-RATIO)) - 1).
142600
142700***********************************************************
142800***  OPERATING COST CALCULATION
142900
143000     COMPUTE H-OPER-BILL-COSTS ROUNDED =
143100         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO /
143200         (1 + H-OPER-IME-TEACH + H-OPER-DSH)
143300         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
143400
143500     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER
143600         COMPUTE H-OPER-OUTCST-PART =
143700         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -
143800                         H-OPER-COST-OUTLIER).
143900
144000     IF PAY-WITHOUT-COST
144100         MOVE 0 TO H-OPER-OUTCST-PART.
144200
144300***********************************************************
144400***  CAPITAL IME TEACH CALCULATION
144500
144600     MOVE 0 TO H-WK-CAPI-IME-TEACH.
144700
144800     IF P-CAPI-IME NUMERIC
144900        COMPUTE H-WK-CAPI-IME-TEACH =
145000          (2.7183 ** (.2822 * P-CAPI-IME)) - 1.
145100
145200***********************************************************
145300***  CAPITAL COST CALCULATION
145400
145500     COMPUTE H-CAPI-BILL-COSTS ROUNDED =
145600             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO /
145700            (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH)
145800         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.
145900
146000     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER
146100         COMPUTE H-CAPI-OUTCST-PART =
146200         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -
146300                         H-CAPI-COST-OUTLIER).
146400
146500     IF P-CAPI-PPS-PAY-CODE = 'A'
146600       COMPUTE H-CAPI-OUTCST-PART =
146700              (H-CAPI-OUTCST-PART * P-CAPI-NEW-HARM-RATIO).
146800
146900     IF P-CAPI-PPS-PAY-CODE = 'C'
147000        COMPUTE H-CAPI-OUTCST-PART =
147100               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).
147200
147300     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <
147400        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)
147500        MOVE 0 TO H-CAPI-OUTCST-PART
147600                  H-OPER-OUTCST-PART.
147700
147800     IF PAY-WITHOUT-COST
147900         MOVE 0 TO H-CAPI-OUTCST-PART.
148000
148100***********************************************************
148200***  DETERMINES THE BILL TO BE EITHER COST OR DAY OUTLIER
148300***     GREATER OF DAY OR COST OPERATING AND CAPITAL
148400
148500     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE
148600         MOVE 0 TO H-CAPI-OUTDAY-PART
148700                   H-CAPI-OUTCST-PART.
148800
148900      IF (H-OPER-OUTDAY-PART + H-CAPI-OUTDAY-PART) > 0 OR
149000         (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
149100         IF (H-OPER-OUTDAY-PART + H-CAPI-OUTDAY-PART) >
149200            (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART)
149300                 MOVE H-OPER-OUTDAY-PART TO
149400                      H-OPER-OUTLIER-PART
149500                 MOVE H-CAPI-OUTDAY-PART TO
149600                      H-CAPI-OUTLIER-PART
149700                 MOVE 01 TO PPS-RTC
149800             ELSE
149900                 MOVE H-OPER-OUTCST-PART TO
150000                      H-OPER-OUTLIER-PART
150100                 MOVE H-CAPI-OUTCST-PART TO
150200                      H-CAPI-OUTLIER-PART
150300                 MOVE 02 TO PPS-RTC
150400                 IF B-COVERED-DAYS > H-DAYS-CUTOFF
150500                    IF (H-REG-DAYS
150600                            +
150700                        H-LTR-DAYS)   <
150800                       (B-COVERED-DAYS - H-DAYS-CUTOFF)
150900                       MOVE 66 TO PPS-RTC.
151000
151100***********************************************************
151200***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF
151300***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
151400
151500     IF P-CAPI-PPS-PAY-CODE = 'A'
151600        COMPUTE H-CAPI2-B-OUTLIER-PART =
151700                H-CAPI-OUTLIER-PART / P-CAPI-NEW-HARM-RATIO
151800         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
151900
152000     IF P-CAPI-PPS-PAY-CODE = 'B'
152100        COMPUTE H-CAPI2-B-OUTLIER-PART =
152200                H-CAPI-OUTLIER-PART.
152300
152400     IF P-CAPI-PPS-PAY-CODE = 'C'
152500        COMPUTE H-CAPI2-B-OUTLIER-PART =
152600                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1
152700         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
152800***********************************************************
152900
153000 3800-CALC-TOT-AMT.
153100
153200***********************************************************
153300***  CALCULATE FINAL TOTALS FOR OPERATING
153400
153500     COMPUTE PPS-OPER-HSP-PART ROUNDED =
153600         H-OPER-HSP-PCT * H-OPER-HSP-PART.
153700
153800     COMPUTE PPS-OPER-FSP-PART ROUNDED =
153900         H-OPER-FSP-PCT * H-OPER-FSP-PART.
154000
154100     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =
154200             H-OPER-FSP-PCT * H-OPER-OUTLIER-PART.
154300
154400     MOVE ZERO TO PPS-OPER-DSH-ADJ.
154500
154600     IF  H-OPER-DSH NUMERIC
154700             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
154800             (PPS-OPER-FSP-PART + PPS-OPER-OUTLIER-PART)
154900              * H-OPER-DSH.
155000
155100     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
155200         (PPS-OPER-FSP-PART + PPS-OPER-OUTLIER-PART) *
155300                 H-OPER-IME-TEACH.
155400
155500***********************************************************
155600***  CALCULATE FINAL TOTALS FOR CAPITAL
155700
155800     MOVE P-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.
155900
156000     IF P-CAPI-PPS-PAY-CODE = 'A'
156100        MOVE P-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT
156200        MOVE 0.00 TO H-CAPI-HSP-PCT.
156300
156400     IF P-CAPI-PPS-PAY-CODE = 'B'
156500        MOVE 0    TO H-CAPI-OLD-HARMLESS
156600        MOVE 1.00 TO H-CAPI-FSP-PCT
156700        MOVE 0.00 TO H-CAPI-HSP-PCT.
156800
156900     IF P-CAPI-PPS-PAY-CODE = 'C'
157000        MOVE 0    TO H-CAPI-OLD-HARMLESS
157100        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT
157200        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.
157300
157400     COMPUTE H-CAPI-HSP ROUNDED =
157500         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.
157600
157700     COMPUTE H-CAPI-FSP ROUNDED =
157800         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.
157900
158000     MOVE P-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.
158100
158200     COMPUTE H-CAPI-OUTLIER ROUNDED =
158300             1.00 * H-CAPI-OUTLIER-PART.
158400
158500     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =
158600             1.00 * H-CAPI2-B-OUTLIER-PART.
158700
158800     COMPUTE H-CAPI2-B-FSP ROUNDED =
158900             1.00 * H-CAPI2-B-FSP-PART.
159000
159100     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.
159200
159300     COMPUTE H-CAPI-DSH-ADJ ROUNDED =
159400             (H-CAPI-FSP + H-CAPI-OUTLIER-PART)
159500              * H-CAPI-DSH.
159600
159700     COMPUTE H-CAPI-IME-ADJ ROUNDED =
159800         (H-CAPI-FSP + H-CAPI-OUTLIER-PART) *
159900                 H-WK-CAPI-IME-TEACH.
160000
160100***********************************************************
160200***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER
160300***        THIS ZEROES OUT ALL CAPITAL DATA
160400
160500     IF (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE
160600        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.
160700
160800     COMPUTE H-CAPI-TOTAL-PAY =
160900             H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
161000             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
161100             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM.
161200
161300***********************************************************
161400***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
161500
161600     COMPUTE PPS-TOTAL-PAYMENT =
161700             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
161800             PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
161900             PPS-OPER-IME-ADJ
162000                           +
162100                  H-CAPI-TOTAL-PAY.
162200
162300 3900-CALC-OPER-DSH.
162400***********************************************************
162500***  OPERATING DSH CALCULATION
162600
162700      MOVE .00 TO H-OPER-DSH.
162800
162900      COMPUTE H-WK-OPER-DSH = (P-SSI-RATIO
163000                                     + P-MEDICAID-RATIO).
163100
163200      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE < 100
163300                               AND H-WK-OPER-DSH > .3999
163400        MOVE .05 TO H-OPER-DSH.
163500
163600      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99
163700                               AND H-WK-OPER-DSH > .1499
163800                               AND H-WK-OPER-DSH < .2021
163900        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
164000                                      * .65 + .025.
164100
164200      IF W-SIZE = 'R'          AND P-BED-SIZE > 499
164300                               AND H-WK-OPER-DSH > .1499
164400                               AND H-WK-OPER-DSH < .2021
164500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
164600                                 * .65 + .025.
164700
164800      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99
164900                               AND H-WK-OPER-DSH > .202
165000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
165100                                 * .825 + .0588.
165200
165300      IF W-SIZE = 'R'          AND P-BED-SIZE > 499
165400                               AND H-WK-OPER-DSH > .202
165500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
165600                                 * .825 + .0588.
165700
165800      IF W-SIZE = 'R'          AND P-BED-SIZE < 101
165900                               AND H-WK-OPER-DSH > .4499
166000        MOVE .04 TO H-OPER-DSH.
166100
166200      IF W-SIZE = 'R'          AND P-BED-SIZE > 100
166300                               AND P-BED-SIZE < 500
166400                               AND H-WK-OPER-DSH > .2999
166500        MOVE .04 TO H-OPER-DSH.
166600
166700      IF W-SIZE = 'R'
166800         IF (P-PROVIDER-TYPE = '16' OR '21')
166900                               AND H-WK-OPER-DSH > .2999
167000                               AND P-BED-SIZE < 500
167100            MOVE .10 TO H-OPER-DSH.
167200
167300      IF W-SIZE = 'R'
167400         IF (P-PROVIDER-TYPE = '07')
167500                               AND H-WK-OPER-DSH > .2999
167600                               AND P-BED-SIZE > 100
167700                               AND P-BED-SIZE < 500
167800            COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .3)
167900                                 * .6 + .04.
168000
168100      IF W-SIZE = 'R'
168200         IF (P-PROVIDER-TYPE = '17' OR '22')
168300                               AND H-WK-OPER-DSH > .2999
168400                               AND P-BED-SIZE < 500
168500            COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .3)
168600                                 * .6 + .04.
168700
168800      IF W-SIZE = 'R'
168900         IF (P-PROVIDER-TYPE = '17' OR '22')
169000                               AND H-WK-OPER-DSH > .2999
169100                               AND P-BED-SIZE < 500
169200                               AND H-OPER-DSH < .10
169300            MOVE .10 TO H-OPER-DSH.
169400
169500      IF (P-PROVIDER-TYPE = '19' OR '20')
169600          IF P-BED-SIZE < 100 AND H-WK-OPER-DSH > .3999
169700             COMPUTE H-OPER-DSH ROUNDED = (2 / 3 * H-OPER-DSH) +
169800                    (1 / 3 * .05).
169900
170000      IF (P-PROVIDER-TYPE = '19' OR '20')
170100          IF P-BED-SIZE > 99
170200                               AND H-WK-OPER-DSH > .1499
170300                               AND H-WK-OPER-DSH < .2021
170400             COMPUTE H-OPER-DSH ROUNDED = (2 / 3 * H-OPER-DSH) +
170500            (1 / 3 * ((H-WK-OPER-DSH - .15) * .65 + .025)).
170600
170700      IF (P-PROVIDER-TYPE = '19' OR '20')
170800          IF P-BED-SIZE > 99
170900                               AND H-WK-OPER-DSH > .202
171000             COMPUTE H-OPER-DSH ROUNDED = (2 / 3 * H-OPER-DSH) +
171100            (1 / 3 * ((H-WK-OPER-DSH - .202) * .825 + .0588)).
171200
171300******        L A S T   S O U R C E   S T A T E M E N T   *****
