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