000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPCAL038.
000300*AUTHOR.            DDS TEAM.
000400*REMARKS.                CMS.
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     'PPCAL038      - W O R K I N G   S T O R A G E'.
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C03.8'.
002000***************************************************************
002100*    IF YOU ARE A HMO, YOU WANT TO PAY CLAIMS AS A HMO         *
002200*     - CHANGE THE > 01 HMO-FLAG < TO THE VALUE OF 'Y'
002300*     - CHANGE ALL PPCAL___ PROGRAMS BACK TO PPCAL983
002400*        BEFORE YOU COMPILE AND LINK THIS PROGRAM
002500*     - THIS WILL ALLOW YOU TO PAY ALL YOUR CLAIMS WITH
002600*        AN HMO ADJUSTMENT
002700***************************************************************
002800 01  HMO-FLAG                       PIC X      VALUE 'N'.
002900 01  HMO-TAG                        PIC X      VALUE SPACE.
003000 01  TEMP-RELIEF-FLAG               PIC X      VALUE 'N'.
003100 01  NON-TEMP-RELIEF-PAYMENT        PIC 9(07)V9(02) VALUE ZEROES.
003200 01  WK-H-OPER-DOLLAR-THRESHOLD     PIC 9(07)V9(09) VALUE ZEROES.
003300 01  R1                             PIC S9(04) COMP SYNC.
003400 01  R2                             PIC S9(04) COMP SYNC.
003500 01  R3                             PIC S9(04) COMP SYNC.
003600 01  R4                             PIC S9(04) COMP SYNC.
003700
003800 01  H-OPER-DSH-SCH               PIC 9(01)V9(04).
003900 01  H-OPER-DSH-RRC               PIC 9(01)V9(04).
004000***************************************************************
004100*    LAYUP TABLE AREA FOR FY2003 RATES                        *
004200***************************************************************
004300***************************************************************
004400 01  RATE-TABLE.
004500     02  RATE-WORK.
004600*RATE 20021001 REGION  LABOR AND NON-LABOR RATES
004700*                  R3=1     /     R3=2
004800*               LARGE URBAN / OTHER URBAN
004900*               LABOR / NON / LABOR / NON
005000*                     /LABOR/       /LABOR
005100*             --------------------------------------------
005200         05  FILLER PIC X(08) VALUE '20021001'.
005300         05  NAT    PIC X(30) VALUE
005400            ' 0302260 122860 0297475 120915'.
005500         05  PR     PIC X(30) VALUE
005600            ' 0146413 058935 0144095 058002'.
005700         05  NATPR  PIC X(30) VALUE
005800            ' 0299676 121810 0299676 121810'.
005900***************************************************************
006000*RATE 20030401 REGION  LABOR AND NON-LABOR RATES
006100*                  R3=1     /     R3=2
006200*               LARGE URBAN / OTHER URBAN
006300*               LABOR / NON / LABOR / NON
006400*                     /LABOR/       /LABOR
006500*             --------------------------------------------
006600         05  FILLER PIC X(08) VALUE '20030401'.
006700         05  NAT    PIC X(30) VALUE
006800            ' 0302231 122848 0302231 122848'.
006900         05  PR     PIC X(30) VALUE
007000            ' 0146428 058941 0144110 058008'.
007100         05  NATPR  PIC X(30) VALUE
007200            ' 0302231 122848 0302231 122848'.
007300*************************************************************
007400     02  RATE-TAB REDEFINES RATE-WORK.
007500         05  RATE-PERIOD            OCCURS 2.
007600             10  RATE-EFF-DATE      PIC X(08).
007700             10  REG-NAT            OCCURS 3.
007800                 15  R-LARGE-OTHER  OCCURS 2.
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 FY2003 DRGS                         *
008700***************************************************************
008800 01  DRG-TABLE.
008900     05  D-TAB.
009000       10  FILLER                  PIC X(08) VALUE
009100     '20021001'.
009200       10  FILLER                  PIC X(56) VALUE
009300     '03739908100112019730040000520195041270012702318404500072'.
009400       10  FILLER                  PIC X(56) VALUE
009500     '01383702100031008242021000290258070650009801496701900028'.
009600       10  FILLER                  PIC X(56) VALUE
009700     '01376904600066012598048000660086890300004000891804400059'.
009800       10  FILLER                  PIC X(56) VALUE
009900     '00796804100050012943048000620098580400005001241304700062'.
010000       10  FILLER                  PIC X(56) VALUE
010100     '00667202500031009727042000540069440280003502815608000107'.
010200       10  FILLER                  PIC X(56) VALUE
010300     '01536905000066010343039000500082200310004300997803600049'.
010400       10  FILLER                  PIC X(56) VALUE
010500     '00608502500032007847025000460131640310005001344704500063'.
010600       10  FILLER                  PIC X(56) VALUE
010700     '00708602700036003299020000200088060300004100533601900024'.
010800       10  FILLER                  PIC X(56) VALUE
010900     '00207201600016009978037000500063850250003200683001200015'.
011000       10  FILLER                  PIC X(56) VALUE
011100     '01056802600038005418019000250059360150001900875602500036'.
011200       10  FILLER                  PIC X(56) VALUE
011300     '00335801600016006593017000240049920240003000640904100051'.
011400       10  FILLER                  PIC X(56) VALUE
011500     '00708002600032007832034000460052090250003200295802900029'.
011600       10  FILLER                  PIC X(56) VALUE
011700     '01779603300046008332015000180094610190003100798301500019'.
011800       10  FILLER                  PIC X(56) VALUE
011900     '01200502100034004795032000320095950190003100966602000030'.
012000       10  FILLER                  PIC X(56) VALUE
012100     '00992702400037002722015000150075280180002600207301500015'.
012200       10  FILLER                  PIC X(56) VALUE
012300     '01306502900048002936013000130143630300004501311904400066'.
012400       10  FILLER                  PIC X(56) VALUE
012500     '00548402300028005653024000310077740280003600669603100038'.
012600       10  FILLER                  PIC X(56) VALUE
012700     '00502502400030004638028000350068950280003400718502600036'.
012800       10  FILLER                  PIC X(56) VALUE
012900     '00796103200044003337021000210310770770010102864708500115'.
013000       10  FILLER                  PIC X(56) VALUE
013100     '01209703500049013022057000670161930670008500875704400055'.
013200       10  FILLER                  PIC X(56) VALUE
013300     '01510706100061013943052000700097280430005500512502600032'.
013400       10  FILLER                  PIC X(56) VALUE
013500     '01214504800064006963029000380136580480006400902804100051'.
013600       10  FILLER                  PIC X(56) VALUE
013700     '01042004800059006262034000400070340320004001227305000064'.
013800       10  FILLER                  PIC X(56) VALUE
013900     '00730603300041011624047000640059400290003700753003700046'.
014000       10  FILLER                  PIC X(56) VALUE
014100     '00559302900035009540037000510070340240003200535001700021'.
014200       10  FILLER                  PIC X(56) VALUE
014300     '00859203300044005467020000262054193050052107991612300144'.
014400       10  FILLER                  PIC X(56) VALUE
014500     '05806308300100074425096001140538500920010505475807800103'.
014600       10  FILLER                  PIC X(56) VALUE
014700     '03979506800077041218065000910245800350004400000000000000'.
014800       10  FILLER                  PIC X(56) VALUE
014900     '03026110400134016551062000850344660590008302307803200045'.
015000       10  FILLER                  PIC X(56) VALUE
015100     '01334502600042015689019000290130450300005102238305300088'.
015200       10  FILLER                  PIC X(56) VALUE
015300     '01621605300066010679030000380155290280004701441503300044'.
015400       10  FILLER                  PIC X(56) VALUE
015500     '01084402100027027280095001220100390410005300723004700055'.
015600       10  FILLER                  PIC X(56) VALUE
015700     '01076701800028009439045000570057060330004100656402300029'.
015800       10  FILLER                  PIC X(56) VALUE
015900     '00535301800023005877025000320090110330004500571102100026'.
016000       10  FILLER                  PIC X(56) VALUE
016100     '00813903300033008274031000400051260200002500538202100026'.
016200       10  FILLER                  PIC X(56) VALUE
016300     '00729602800036005613021000260053910170002101199203800055'.
016400       10  FILLER                  PIC X(56) VALUE
016500     '00589902100027027203088001020155620580006403450310200123'.
016600       10  FILLER                  PIC X(56) VALUE
016700     '01525105900065028484091001120132960450005701950606900083'.
016800       10  FILLER                  PIC X(56) VALUE
016900     '01177004800054041533098001330130820300004000838206000060'.
017000       10  FILLER                  PIC X(56) VALUE
017100     '01261203900056006503020000250136120370005100806502200026'.
017200       10  FILLER                  PIC X(56) VALUE
017300     '01126402800042006325016000190068770210002102296207000083'.
017400       10  FILLER                  PIC X(56) VALUE
017500     '01260904000046014690037000490090880210002501303803300049'.
017600       10  FILLER                  PIC X(56) VALUE
017700     '00744401800023028555076001110120250310004301362405100070'.
017800       10  FILLER                  PIC X(56) VALUE
017900     '00754002700037009952039000480055510250002901082604100053'.
018000       10  FILLER                  PIC X(56) VALUE
018100     '00917003700045006806026000310107860460006000944304100054'.
018200       10  FILLER                  PIC X(56) VALUE
018300     '00533102800034007986033000440057230230002900483602300028'.
018400       10  FILLER                  PIC X(56) VALUE
018500     '00898603300047003195029000290086650310004201098504100056'.
018600       10  FILLER                  PIC X(56) VALUE
018700     '00582502400031007006033000480432820980013801714404700061'.
018800       10  FILLER                  PIC X(56) VALUE
018900     '03424510500128016033055000690300710860010401604604600054'.
019000       10  FILLER                  PIC X(56) VALUE
019100     '02485707300090012250038000440243450700009902974006500105'.
019200       10  FILLER                  PIC X(56) VALUE
019300     '03785810400145012941048000640135550500006801185804400058'.
019400       10  FILLER                  PIC X(56) VALUE
019500     '01200304600062007061030000390114050400005300653102300029'.
019600       10  FILLER                  PIC X(56) VALUE
019700     '02078204500050018622061000700128480460005000841811100111'.
019800       10  FILLER                  PIC X(56) VALUE
019900     '01869406600092000000000000000000000000000002222506600096'.
020000       10  FILLER                  PIC X(56) VALUE
020100     '03027209100135015475043000550102660270003200580705300053'.
020200       10  FILLER                  PIC X(56) VALUE
020300     '00000000000000000000000000000102610210002900785901600019'.
020400       10  FILLER                  PIC X(56) VALUE
020500     '01147603500050015730046000670081520210002701137902600041'.
020600       10  FILLER                  PIC X(56) VALUE
020700     '00700401700022012763033000510140070310004901001101800027'.
020800       10  FILLER                  PIC X(56) VALUE
020900     '02115905100078012428023000320076920380005100735003900049'.
021000       10  FILLER                  PIC X(56) VALUE
021100     '00584002900036014039066000890100650490006301337205000067'.
021200       10  FILLER                  PIC X(56) VALUE
021300     '00651103100039011281051000670074180370004700707203700047'.
021400       10  FILLER                  PIC X(56) VALUE
021500     '00469802700034005658029000380057330260003400835703800049'.
021600       10  FILLER                  PIC X(56) VALUE
021700     '00690202500037006904032000420046230220002800252101800018'.
021800       10  FILLER                  PIC X(56) VALUE
021900     '00739403700047004440026000310029370290002900806903800051'.
022000       10  FILLER                  PIC X(56) VALUE
022100     '00899402100027007101016000180091550170002700682701200014'.
022200       10  FILLER                  PIC X(56) VALUE
022300     '00981701600022009301029000430228540930012501164405500072'.
022400       10  FILLER                  PIC X(56) VALUE
022500     '01603904200068008590022000310093940250004201102602300036'.
022600       10  FILLER                  PIC X(56) VALUE
022700     '01717205800084007693024000340103030560007301005004600061'.
022800       10  FILLER                  PIC X(56) VALUE
022900     '00558703000039011927048000680055260220003000680503500045'.
023000       10  FILLER                  PIC X(56) VALUE
023100     '00859304700058005495036000430066010420004200698103200042'.
023200       10  FILLER                  PIC X(56) VALUE
023300     '00464402300029002553022000220072210350004700431102400031'.
023400       10  FILLER                  PIC X(56) VALUE
023500     '02049908000107020937045000590187220770010602223904300054'.
023600       10  FILLER                  PIC X(56) VALUE
023700     '00977301800028008951017000220063310140001602682607300107'.
023800       10  FILLER                  PIC X(56) VALUE
023900     '01316403400051007571034000450079280300004000847103900051'.
024000       10  FILLER                  PIC X(56) VALUE
024100     '00504302700034005814029000430094200380005401094004700062'.
024200       10  FILLER                  PIC X(56) VALUE
024300     '00631902800037033000074000870242820670008302334306200087'.
024400       10  FILLER                  PIC X(56) VALUE
024500     '01201602900036012709036000550063230180002201638704000063'.
024600       10  FILLER                  PIC X(56) VALUE
024700     '00895901700022011270029000430062620150001801062303000045'.
024800       10  FILLER                  PIC X(56) VALUE
024900     '00670301700021004921023000230210460390007201328404900066'.
025000       10  FILLER                  PIC X(56) VALUE
025100     '00662902000031011868044000610060170210002800855104300053'.
025200       10  FILLER                  PIC X(56) VALUE
025300     '00563803100038004987032000370080410240003100463801500018'.
025400       10  FILLER                  PIC X(56) VALUE
025500     '00651702900038004446022000270036800310003100732102800038'.
025600       10  FILLER                  PIC X(56) VALUE
025700     '00490401700022003170016000160105970420005600602302400032'.
025800       10  FILLER                  PIC X(56) VALUE
025900     '00779503300047015207040000480112550290003200870702600034'.
026000       10  FILLER                  PIC X(56) VALUE
026100     '00603301800021012293035000560110740290004600281702400024'.
026200       10  FILLER                  PIC X(56) VALUE
026300     '01214201900031007922024000320015310170001701265801600024'.
026400       10  FILLER                  PIC X(56) VALUE
026500     '01185202900048010468045000600056490200002700710603200042'.
026600       10  FILLER                  PIC X(56) VALUE
026700     '00397401900025007182036000450023490130001300728302900040'.
026800       10  FILLER                  PIC X(56) VALUE
026900     '01876905000065015499048000580091440300003200765701900022'.
027000       10  FILLER                  PIC X(56) VALUE
027100     '02333006700084012295035000430083450240002600885102300028'.
027200       10  FILLER                  PIC X(56) VALUE
027300     '01109502300036003003014000140088400260003600839102700039'.
027400       10  FILLER                  PIC X(56) VALUE
027500     '01949105200077012885049000690054160230003001203205200067'.
027600       10  FILLER                  PIC X(56) VALUE
027700     '00595002400032009848044000570067450320003600625902600037'.
027800       10  FILLER                  PIC X(56) VALUE
027900     '00393402000023007727025000290057330440004400485102600035'.
028000       10  FILLER                  PIC X(56) VALUE
028100     '01435403000042008368020000250039160210003000363101600020'.
028200       10  FILLER                  PIC X(56) VALUE
028300     '00589601600021001683012000130054740270004000420401800028'.
028400       10  FILLER                  PIC X(56) VALUE
028500     '01368001800018045111179001790308101330013301859008600086'.
028600       10  FILLER                  PIC X(56) VALUE
028700     '03164804700047011201034000340015170310003103166506900095'.
028800       10  FILLER                  PIC X(56) VALUE
028900     '01340009100091018110043000710081560320004400659102400038'.
029000       10  FILLER                  PIC X(56) VALUE
029100     '01242103700052012700046000590068900280003602678705500090'.
029200       10  FILLER                  PIC X(56) VALUE
029300     '02785008000113011248027000390177090570008000858703000042'.
029400       10  FILLER                  PIC X(56) VALUE
029500     '01899804900049028059069000970129050330004102062304700079'.
029600       10  FILLER                  PIC X(56) VALUE
029700     '01207704500061010456031000400038980220002900279201600020'.
029800       10  FILLER                  PIC X(56) VALUE
029900     '01369605300073006931030000400367981040014501598505600075'.
030000       10  FILLER                  PIC X(56) VALUE
030100     '01184704500062010459048000620086740360004700590802800034'.
030200       10  FILLER                  PIC X(56) VALUE
030300     '00706202900038004381024000300178960590008302304808100130'.
030400       10  FILLER                  PIC X(56) VALUE
030500     '00682202900039005167032000450051880310004400740804400074'.
030600       10  FILLER                  PIC X(56) VALUE
030700     '00844804700063007128057000800059400420005900634802900046'.
030800       10  FILLER                  PIC X(56) VALUE
030900     '00275502200030000000000000000000000000000000000000000000'.
031000       10  FILLER                  PIC X(56) VALUE
031100     '00000000000000000000000000000169650540008501915605700091'.
031200       10  FILLER                  PIC X(56) VALUE
031300     '00931402100031024136056000860106790260003500761403200043'.
031400       10  FILLER                  PIC X(56) VALUE
031500     '00488102300029002945024000240049920180002400096902900029'.
031600       10  FILLER                  PIC X(56) VALUE
031700     '00826702600037004260016000200026150210002101043303500050'.
031800       10  FILLER                  PIC X(56) VALUE
031900     '00514602100028008281030000430045820180002400000000000000'.
032000       10  FILLER                  PIC X(56) VALUE
032100     '00000000000000000000000000000000000000000000000000000000'.
032200       10  FILLER                  PIC X(56) VALUE
032300     '01206002200041011298093001150069570320004200495902400030'.
032400       10  FILLER                  PIC X(56) VALUE
032500     '00678601800029007500022000410060120210008503726709200130'.
032600       10  FILLER                  PIC X(56) VALUE
032700     '00000000000000000000000000000310530480005500000000000000'.
032800       10  FILLER                  PIC X(56) VALUE
032900     '03541107300126000000000000000366320800011402259208000113'.
033000       10  FILLER                  PIC X(56) VALUE
033100     '01861805300082023725049000740143210250003310380515700218'.
033200       10  FILLER                  PIC X(56) VALUE
033300     '07130719300221035614097001261705103480042205576808800131'.
033400       10  FILLER                  PIC X(56) VALUE
033500     '03049307700095048153083001230200550550007804655611400169'.
033600       10  FILLER                  PIC X(56) VALUE
033700     '01799706000086010261037000530170370290003503952809200150'.
033800       10  FILLER                  PIC X(56) VALUE
033900     '01815204300059010107019000250920161440017305798807100095'.
034000       10  FILLER                  PIC X(56) VALUE
034100     '03393805400065024738037000410143990330004600948902000025'.
034200       10  FILLER                  PIC X(56) VALUE
034300     '02592208400106015368052000640121280290003914654226700349'.
034400       10  FILLER                  PIC X(56) VALUE
034500     '02017802200037046725127001730172460650009001433005800084'.
034600       10  FILLER                  PIC X(56) VALUE
034700     '00969104100057012301046000670070060300004405861311900145'.
034800       10  FILLER                  PIC X(56) VALUE
034900     '06327109400108063376050000730505620330005502727303700048'.
035000       10  FILLER                  PIC X(56) VALUE
035100     '02178901900026017297023000340235510320005201538901700021'.
035200       10  FILLER                  PIC X(56) VALUE
035300     '00730004300058005818075000950039990330004100723802700034'.
035400       10  FILLER                  PIC X(56) VALUE
035500     '11647909400166031176037000470253420190002600000000000000'.
035600     05  DRGX-TAB REDEFINES D-TAB.
035700         10  DRGX-PERIOD               OCCURS 1
035800                                        INDEXED BY DX5.
035900             15  DRGX-EFF-DATE         PIC X(08).
036000             15  DRG-DATA              OCCURS 528
036100                                        INDEXED BY DX6.
036200                 20  DRG-WT            PIC 9(02)V9(04).
036300                 20  DRG-ALOS          PIC 9(02)V9(01).
036400                 20  DRG-DAYS-TRIM     PIC 9(02).
036500                 20  DRG-ARITH-ALOS    PIC 9(02)V9(01).
036600
036700 01  HOLD-AREA.
036800     02  HOLD-PPS-COMPONENTS.
036900         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
037000         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
037100
037200         05  H-OPER-HSP-PART              PIC 9(06)V9(09).
037300         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).
037400
037500         05  H-OPER-FSP-PART              PIC 9(06)V9(09).
037600         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).
037700         05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).
037800
037900         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).
038000         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).
038100         05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).
038200
038300         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).
038400         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).
038500
038600         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).
038700         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).
038800
038900         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).
039000         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).
039100
039200
039300         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).
039400         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).
039500         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).
039600         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).
039700         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).
039800         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
039900         05  H-CAPI-COLA                  PIC 9(01)V9(03).
040000         05  H-CAPI-SCH                   PIC 9(05)V9(02).
040100         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).
040200         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).
040300         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).
040400         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).
040500         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).
040600         05  H-CAPI-GAF                   PIC 9(05)V9(04).
040700         05  H-PR-CAPI-GAF                PIC 9(05)V9(04).
040800         05  H-BLEND-GAF                  PIC 9(05)V9(04).
040900         05  H-WAGE-INDEX                 PIC 9(02)V9(04).
041000         05  H-COV-DAYS                   PIC 9(3).
041100         05  H-PERDIEM-DAYS               PIC 9(3).
041200         05  H-REG-DAYS                   PIC 9(3).
041300         05  H-LTR-DAYS                   PIC 9(3).
041400         05  H-DSCHG-FRCTN                PIC 9(1)V9999.
041500         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.
041600         05  H-ALOS                       PIC 9(02)V9(01).
041700         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).
041800         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).
041900         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).
042000         05  H-CST-THRESH                 PIC 9(05)V9(02).
042100         05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).
042200         05  H-BUDG-NUTR01                PIC 9(01)V9(06).
042300         05  H-BUDG-NUTR02                PIC 9(01)V9(06).
042400         05  H-BUDG-NUTR03                PIC 9(01)V9(06).
042500         05  H-UPDATE-01                  PIC 9(01)V9(04).
042600         05  H-UPDATE-02                  PIC 9(01)V9(04).
042700         05  H-UPDATE-03                  PIC 9(01)V9(04).
042800         05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).
042900         05  H-HSP-UPDATE94               PIC 9(01)V9(04).
043000         05  H-HSP-UPDATE95               PIC 9(01)V9(04).
043100         05  H-HSP-UPDATE96               PIC 9(01)V9(04).
043200         05  H-HSP-UPDATE97               PIC 9(01)V9(04).
043300         05  H-HSP-UPDATE98               PIC 9(01)V9(04).
043400         05  H-HSP-UPDATE99               PIC 9(01)V9(04).
043500         05  H-HSP-UPDATE00               PIC 9(01)V9(04).
043600         05  H-HSP-UPDATE01               PIC 9(01)V9(04).
043700         05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).
043800         05  H-FEDERAL-RATE               PIC 9(04)V9(02).
043900         05  H-LABOR-PCT                  PIC 9(01)V9(04).
044000         05  H-NONLABOR-PCT               PIC 9(01)V9(04).
044100         05  H-PR-LABOR-PCT               PIC 9(01)V9(04).
044200         05  H-PR-NONLABOR-PCT            PIC 9(01)V9(04).
044300         05  H-HSP-RATE                   PIC 9(06)V9(09).
044400         05  H-FSP-RATE                   PIC 9(06)V9(09).
044500         05  H-OUTLIER-OFFSET-NAT         PIC 9(01)V9(06).
044600         05  H-OUTLIER-OFFSET-PR          PIC 9(01)V9(06).
044700         05  H-WK-OPER-DSH                PIC 9(01)V9(04).
044800         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).
044900         05  H-OPER-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
045000         05  H-CAPI-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
045100         05  H-DSH-REDUCT-FACTOR          PIC 9(01)V9(04).
045200         05  H-WK-PASS-AMT-PLUS-MISC      PIC 9(06)V99.
045300         05  H-BASE-DRG-PAYMENT           PIC S9(07)V99.
045400         05  H-LESSER-TECH-1              PIC S9(07)V99.
045500         05  H-LESSER-TECH-2              PIC S9(07)V99.
045600         05  H-CSTMED-SERV0011            PIC S9(07)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-FAC-SPEC-RATE              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-TOT-REG-AL                 PIC 9(05)V9(02).
046900         05  H-TOT-NAT-AL                 PIC 9(05)V9(02).
047000         05  H-NAT-NONLABOR               PIC 9(05)V9(02).
047100         05  H-REG-LABOR                  PIC 9(05)V9(02).
047200         05  H-REG-NONLABOR               PIC 9(05)V9(02).
047300         05  H-OPER-COLA                  PIC 9(01)V9(03).
047400         05  H-INTERN-RATIO               PIC 9(01)V9(04).
047500         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).
047600         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).
047700         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
047800
047900     02  HOLD-CAPITAL-VARIABLES.
048000         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).
048100         05  H-CAPI-HSP                   PIC 9(07)V9(02).
048200         05  H-CAPI-FSP                   PIC 9(07)V9(02).
048300         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).
048400         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).
048500         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).
048600         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).
048700         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).
048800
048900     02  HOLD-CAPITAL2-VARIABLES.
049000         05  H-CAPI2-PAY-CODE             PIC X(1).
049100         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).
049200         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
049300
049400     02  HOLD-OTHER-VARIABLES.
049500         05  H-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
049600         05  H-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
049700         05  H-LOW-VOL-PAYMENT              PIC 9(07)V9(02).
049800         05  H-HVBP-HRR-DATA.
049900             10  H-VAL-BASED-PURCH-PARTIPNT PIC X.
050000             10  H-VAL-BASED-PURCH-ADJUST     PIC 9V9(11).
050100             10  H-HOSP-READMISS-REDUCTN      PIC X.
050200             10  H-HOSP-HRR-ADJUSTMT          PIC 9V9(4).
050300         05  H-OPERATNG-DATA.
050400             10  H-MODEL1-BUNDLE-DISPRCNT    PIC V999.
050500             10  H-OPER-BASE-DRG-PAY         PIC 9(08)V99.
050600             10  H-OPER-HSP-AMT              PIC 9(08)V99.
050700
050800     02  HOLD-PC-OTH-VARIABLES.
050900         05  H-OPER-DSH                   PIC 9(01)V9(04).
051000         05  H-CAPI-DSH                   PIC 9(01)V9(04).
051100         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).
051200         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).
051300         05  H-ARITH-ALOS                 PIC 9(02)V9(01).
051400         05  H-PR-WAGE-INDEX              PIC 9(02)V9(04).
051500         05  H-TRANSFER-ADJ               PIC 9(01)V9(05).
051600         05  H-PC-HMO-FLAG                PIC X(01).
051700         05  H-PC-COT-FLAG                PIC X(01).
051800         05  H-FILLER                     PIC X(0998).
051900
052000 LINKAGE SECTION.
052100***************************************************************
052200*                 * * * * * * * * *                           *
052300*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *
052400*    IN HOW TO PAY THE BILL.                                  *
052500*                         *****                               *
052600*    COMMENTS  ** CLAIMS RECEIVED WITH CONDITION CODE 66      *
052700*                 SHOULD BE PROCESSED UNDER REVIEW CODE 06,   *
052800*                 07 OR 11 AS APPROPRIATE TO EXCLUDE ANY      *
052900*                 OUTLIER COMPUTATION.                        *
053000*                         *****                               *
053100*         REVIEW-CODE:                                        *
053200*            00 = PAY-WITH-OUTLIER.                           *
053300*                 WILL CALCULATE THE STANDARD PAYMENT.        *
053400*                 WILL ALSO ATTEMPT TO PAY ONLY COST          *
053500*                 OUTLIERS, DAY OUTLIERS EXPIRED 10/01/97     *
053600*            03 = PAY-PERDIEM-DAYS.                           *
053700*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
053800*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
053900*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
054000*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
054100*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
054200*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
054300*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
054400*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
054500*                 BILL EXCEED THE COST THRESHOLD.             *
054600*            06 = PAY-XFER-NO-COST                            *
054700*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
054800*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
054900*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
055000*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *
055100*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
055200*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
055300*                 CALCULATE ANY COST OUTLIER PORTION          *
055400*                 OF THE PAYMENT.                             *
055500*            07 = PAY-WITHOUT-COST.                           *
055600*                 WILL CALCULATE THE STANDARD PAYMENT         *
055700*                 WITHOUT COST PORTION.                       *
055800*            09 = PAY-XFER-SPEC-DRG - POST-ACUTE TRANSFERS    *
055900*                 FOR DRG'S 209,210,211,014,113,236,263,264,  *
056000*                 429,483.      POST-ACUTE TRANSFERS          *
056100*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
056200*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
056300*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
056400*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
056500*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
056600*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
056700*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
056800*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
056900*                 BILL EXCEED THE COST THRESHOLD.             *
057000*            11 = PAY-XFER-SPEC-DRG-NO-COST                   *
057100*                 POST-ACUTE TRANSFERS                        *
057200*                 FOR DRG'S 209,210,211,014,113,236,263,264,  *
057300*                 429,483.      POST-ACUTE TRANSFERS          *
057400*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
057500*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
057600*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
057700*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
057800*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
057900*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
058000*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
058100*                 PAYMENT.                                    *
058200***************************************************************
058300
058400**************************************************************
058500*      MILLINNIUM COMPATIBLE                                 *
058600*      THIS IS THE BILL-RECORD THAT WILL BE PASSED BACK FROM *
058700*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *
058800*      IN THE NEW FORMAT                                     *
058900**************************************************************
059000 01  BILL-NEW-DATA.
059100         10  B-NPI10.
059200             15  B-NPI8             PIC X(08).
059300             15  B-NPI-FILLER       PIC X(02).
059400         10  B-PROVIDER-NO          PIC X(06).
059500             88  SE-AL-PROV           VALUE
059600            '010001' '010005' '010006' '010007' '010008'
059700            '010009' '010010' '010011' '010012' '010015'
059800            '010016' '010018' '010019' '010021' '010022'
059900            '010023' '010024' '010025' '010027' '010029'
060000            '010032' '010033' '010034' '010035' '010038'
060100            '010039' '010040' '010043' '010044' '010045'
060200            '010046' '010049' '010050' '010051' '010053'
060300            '010054' '010055' '010056' '010058' '010059'
060400            '010061' '010062' '010064' '010065' '010066'
060500            '010068' '010072' '010073' '010078' '010079'
060600            '010083' '010084' '010085' '010087' '010089'
060700            '010090' '010091' '010092' '010095' '010098'
060800            '010099' '010100' '010101' '010103' '010104'
060900            '010108' '010109' '010110' '010112' '010113'
061000            '010114' '010115' '010118' '010119' '010120'
061100            '010125' '010126' '010128' '010129' '010130'
061200            '010131' '010137' '010138' '010139' '010143'
061300            '010144' '010145' '010146' '010148' '010149'
061400            '010150' '010152' '010157' '010158' '190013'
061500            '190040' '190045' '190050' '190053' '190060'
061600            '190064' '190086' '190102' '190111' '190113'
061700            '190125' '190242' '250040' '250048' '250050'
061800            '250078' '250082' '250104'.
061900         10  B-REVIEW-CODE          PIC 9(02).
062000             88  VALID-REVIEW-CODE    VALUE 00 03 06 07 09 11.
062100             88  PAY-WITH-OUTLIER     VALUE 00 07.
062200             88  PAY-PERDIEM-DAYS     VALUE 03.
062300             88  PAY-XFER-NO-COST     VALUE 06.
062400             88  PAY-WITHOUT-COST     VALUE 07.
062500             88  PAY-XFER-SPEC-DRG    VALUE 09 11.
062600             88  PAY-XFER-SPEC-DRG-NO-COST VALUE 11.
062700         10  B-DRG                  PIC 9(03).
062800         10  B-LOS                  PIC 9(03).
062900         10  B-COVERED-DAYS         PIC 9(03).
063000         10  B-LTR-DAYS             PIC 9(02).
063100         10  B-DISCHARGE-DATE.
063200             15  B-DISCHG-CC        PIC 9(02).
063300             15  B-DISCHG-YY        PIC 9(02).
063400             15  B-DISCHG-MM        PIC 9(02).
063500             15  B-DISCHG-DD        PIC 9(02).
063600         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
063700         10  B-PRIN-PROC-CODE       PIC X(07).
063800         10  B-OTHER-PROC-CODE1     PIC X(07).
063900         10  B-OTHER-PROC-CODE2     PIC X(07).
064000         10  B-OTHER-PROC-CODE3     PIC X(07).
064100         10  B-OTHER-PROC-CODE4     PIC X(07).
064200         10  B-OTHER-PROC-CODE5     PIC X(07).
064300         10  B-OTHER-PROC-CODE6     PIC X(07).
064400         10  B-OTHER-PROC-CODE7     PIC X(07).
064500         10  B-OTHER-PROC-CODE8     PIC X(07).
064600         10  B-OTHER-PROC-CODE9     PIC X(07).
064700         10  B-OTHER-PROC-CODE10    PIC X(07).
064800         10  B-OTHER-PROC-CODE11    PIC X(07).
064900         10  B-OTHER-PROC-CODE12    PIC X(07).
065000         10  B-OTHER-PROC-CODE13    PIC X(07).
065100         10  B-OTHER-PROC-CODE14    PIC X(07).
065200         10  B-OTHER-PROC-CODE15    PIC X(07).
065300         10  B-OTHER-PROC-CODE16    PIC X(07).
065400         10  B-OTHER-PROC-CODE17    PIC X(07).
065500         10  B-OTHER-PROC-CODE18    PIC X(07).
065600         10  B-OTHER-PROC-CODE19    PIC X(07).
065700         10  B-OTHER-PROC-CODE20    PIC X(07).
065800         10  B-OTHER-PROC-CODE21    PIC X(07).
065900         10  B-OTHER-PROC-CODE22    PIC X(07).
066000         10  B-OTHER-PROC-CODE23    PIC X(07).
066100         10  B-OTHER-PROC-CODE24    PIC X(07).
066200         10  B-OTHER-DIAG-CODE1     PIC X(07).
066300         10  B-OTHER-DIAG-CODE2     PIC X(07).
066400         10  B-OTHER-DIAG-CODE3     PIC X(07).
066500         10  B-OTHER-DIAG-CODE4     PIC X(07).
066600         10  B-OTHER-DIAG-CODE5     PIC X(07).
066700         10  B-OTHER-DIAG-CODE6     PIC X(07).
066800         10  B-OTHER-DIAG-CODE7     PIC X(07).
066900         10  B-OTHER-DIAG-CODE8     PIC X(07).
067000         10  B-OTHER-DIAG-CODE9     PIC X(07).
067100         10  B-OTHER-DIAG-CODE10    PIC X(07).
067200         10  B-OTHER-DIAG-CODE11    PIC X(07).
067300         10  B-OTHER-DIAG-CODE12    PIC X(07).
067400         10  B-OTHER-DIAG-CODE13    PIC X(07).
067500         10  B-OTHER-DIAG-CODE14    PIC X(07).
067600         10  B-OTHER-DIAG-CODE15    PIC X(07).
067700         10  B-OTHER-DIAG-CODE16    PIC X(07).
067800         10  B-OTHER-DIAG-CODE17    PIC X(07).
067900         10  B-OTHER-DIAG-CODE18    PIC X(07).
068000         10  B-OTHER-DIAG-CODE19    PIC X(07).
068100         10  B-OTHER-DIAG-CODE20    PIC X(07).
068200         10  B-OTHER-DIAG-CODE21    PIC X(07).
068300         10  B-OTHER-DIAG-CODE22    PIC X(07).
068400         10  B-OTHER-DIAG-CODE23    PIC X(07).
068500         10  B-OTHER-DIAG-CODE24    PIC X(07).
068600         10  B-OTHER-DIAG-CODE25    PIC X(07).
068700         10  BILL-DEMO-DATA.
068800             15  BILL-DEMO-CODE1        PIC X(02).
068900             15  BILL-DEMO-CODE2        PIC X(02).
069000             15  BILL-DEMO-CODE3        PIC X(02).
069100             15  BILL-DEMO-CODE4        PIC X(02).
069200         10  BILL-NDC-DATA.
069300             15  BILL-NDC-NUMBER        PIC X(11).
069400         10  FILLER                     PIC X(73).
069500
069600
069700
069800***************************************************************
069900*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
070000*    AND PASSED BACK TO THE CALLING PROGRAM                   *
070100*            RETURN CODE VALUES (PPS-RTC)                     *
070200*                                                             *
070300*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
070400*              00 = PAID NORMAL DRG PAYMENT                   *
070500*                                                             *
070600*              01 = PAID AS A DAY-OUTLIER.                    *
070700*                   NOTE:                                     *
070800*                     DAY-OUTLIER NO LONGER BEING PAID        *
070900*                         AS OF 10/01/97                      *
071000*                                                             *
071100*              02 = PAID AS A COST-OUTLIER.                   *
071200*                                                             *
071300*              03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
071400*                   AND INCLUDING THE FULL DRG.               *
071500*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
071600*                   AND INCLUDING THE FULL DRG WHICH ALSO     *
071700*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *
071800*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
071900*                   AND INCLUDING THE FULL DRG. PROVIDER      *
072000*                   REFUSED COST OUTLIER.                     *
072100*              10 = DRG IS 209, 210 OR 211 AND                *
072200*                   POST-ACUTE TRANSFER                       *
072300*              12 = POST-CAUTE TRANSFER WITH SPECIFIC DRGS    *
072400*                       THE FOLLOWING DRG'S                   *
072500*                   14,113,236,263,264,429,483                *
072600*              14 = PAID NORMAL DRG PAYMENT WITH              *
072700*                    PERDIEM DAYS = OR > GM  ALOS             *
072800*              16 = PAID AS A COST-OUTLIER WITH               *
072900*                    PERDIEM DAYS = OR > GM  ALOS             *
073000*                                                             *
073100*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
073200*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
073300*              52 = INVALID MSA # IN PROVIDER FILE            *
073400*                   OR INVALID WAGE INDEX                     *
073500*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *
073600*              54 = DRG < 001 OR > 527, OR = 214 OR = 215     *
073700*                                       OR = 221 OR = 222     *
073800*                                       OR = 112              *
073900*                                       OR = 434 OR = 435     *
074000*                                       OR = 436 OR = 437     *
074100*                                       OR = 438 OR = 456     *
074200*                                       OR = 457 OR = 458     *
074300*                                       OR = 459 OR = 460     *
074400*                                       OR = 469 OR = 470     *
074500*                                       OR = 472 OR = 474     *
074600*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *
074700*                                      OR                     *
074800*                   DISCHARGE DATE < MSA EFF START DATE       *
074900*                   FOR PPS                                   *
075000*                                      OR                     *
075100*                   PROVIDER HAS BEEN TERMINATED ON OR BEFORE *
075200*                   DISCHARGE DATE                            *
075300*              56 = INVALID LENGTH OF STAY                    *
075400*              57 = REVIEW CODE INVALID (NOT 00 03 06 07 09   *
075500*                                        NOT 11)              *
075600*              58 = TOTAL CHARGES NOT NUMERIC                 *
075700*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
075800*                   OR BILL-LTR-DAYS > 60                     *
075900*              62 = INVALID NUMBER OF COVERED DAYS            *
076000*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *
076100*                   SPECIFIC FILE FOR CAPITAL                 *
076200*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *
076300*                   OR COST OUTLIER THRESHOLD CALUCULATION    *
076400*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *
076500***************************************************************
076600 01  PPS-DATA.
076700         10  PPS-RTC                PIC 9(02).
076800         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
076900         10  PPS-OUTLIER-DAYS       PIC 9(03).
077000         10  PPS-AVG-LOS            PIC 9(02)V9(01).
077100         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
077200         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
077300         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
077400         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
077500         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
077600         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
077700         10  PPS-REG-DAYS-USED      PIC 9(03).
077800         10  PPS-LTR-DAYS-USED      PIC 9(02).
077900         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
078000         10  PPS-CALC-VERS          PIC X(05).
078100
078200******************************************************************
078300*            THESE ARE THE VERSIONS OF THE PPCAL
078400*           PROGRAMS THAT WILL BE PASSED BACK----
078500*          ASSOCIATED WITH THE BILL BEING PROCESSED
078600******************************************************************
078700 01  PRICER-OPT-VERS-SW.
078800     02  PRICER-OPTION-SW          PIC X(01).
078900         88  ALL-TABLES-PASSED          VALUE 'A'.
079000         88  PROV-RECORD-PASSED         VALUE 'P'.
079100         88  ADDITIONAL-VARIABLES       VALUE 'M'.
079200         88  PC-PRICER                  VALUE 'C'.
079300     02  PPS-VERSIONS.
079400         10  PPDRV-VERSION         PIC X(05).
079500
079600******************************************************************
079700*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
079800*          ASSOCIATED WITH THE BILL BEING PROCESSED
079900******************************************************************
080000 01  PPS-ADDITIONAL-VARIABLES.
080100     05  PPS-HSP-PCT                PIC 9(01)V9(02).
080200     05  PPS-FSP-PCT                PIC 9(01)V9(02).
080300     05  PPS-NAT-PCT                PIC 9(01)V9(02).
080400     05  PPS-REG-PCT                PIC 9(01)V9(02).
080500     05  PPS-FAC-SPEC-RATE          PIC 9(05)V9(02).
080600     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
080700     05  PPS-DRG-WT                 PIC 9(02)V9(04).
080800     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
080900     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
081000     05  PPS-REG-LABOR              PIC 9(05)V9(02).
081100     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
081200     05  PPS-OPER-COLA              PIC 9(01)V9(03).
081300     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
081400     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
081500     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
081600     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
081700     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
081800     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
081900     05  PPS-CAPITAL-VARIABLES.
082000         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).
082100         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).
082200         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).
082300         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).
082400         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).
082500         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).
082600         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).
082700         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).
082800     05  PPS-CAPITAL2-VARIABLES.
082900         10  PPS-CAPI2-PAY-CODE             PIC X(1).
083000         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).
083100         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
083200
083300     05  PPS-OTHER-VARIABLES.
083400         10  PPS-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
083500         10  PPS-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
083600         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
083700         10  FILLER                         PIC X(21).
083800
083900     05  PPS-PC-OTH-VARIABLES.
084000         10  PPS-OPER-DSH                   PIC 9(01)V9(04).
084100         10  PPS-CAPI-DSH                   PIC 9(01)V9(04).
084200         10  PPS-CAPI-HSP-PCT               PIC 9(01)V9(02).
084300         10  PPS-CAPI-FSP-PCT               PIC 9(01)V9(04).
084400         10  PPS-ARITH-ALOS                 PIC 9(02)V9(01).
084500         10  PPS-PR-WAGE-INDEX              PIC 9(02)V9(04).
084600         10  PPS-TRANSFER-ADJ               PIC 9(01)V9(05).
084700         10  PPS-PC-HMO-FLAG                PIC X(01).
084800         10  PPS-PC-COT-FLAG                PIC X(01).
084900         10  PPS-FILLER                     PIC X(09).
085000
085100**************************************************************
085200*      MILLINNIUM COMPATIBLE                                 *
085300*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BACK FROM *
085400*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *
085500*      IN THE NEW FORMAT                                     *
085600**************************************************************
085700 01  PROV-NEW-HOLD.
085800     02  PROV-NEWREC-HOLD1.
085900         05  P-NEW-NPI10.
086000             10  P-NEW-NPI8             PIC X(08).
086100             10  P-NEW-NPI-FILLER       PIC X(02).
086200         05  P-NEW-PROVIDER-NO.
086300             10  P-NEW-STATE            PIC 9(02).
086400             10  FILLER                 PIC X(04).
086500         05  P-NEW-DATE-DATA.
086600             10  P-NEW-EFF-DATE.
086700                 15  P-NEW-EFF-DT-CC    PIC 9(02).
086800                 15  P-NEW-EFF-DT-YY    PIC 9(02).
086900                 15  P-NEW-EFF-DT-MM    PIC 9(02).
087000                 15  P-NEW-EFF-DT-DD    PIC 9(02).
087100             10  P-NEW-FY-BEGIN-DATE.
087200                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
087300                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
087400                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
087500                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
087600             10  P-NEW-REPORT-DATE.
087700                 15  P-NEW-REPORT-DT-CC PIC 9(02).
087800                 15  P-NEW-REPORT-DT-YY PIC 9(02).
087900                 15  P-NEW-REPORT-DT-MM PIC 9(02).
088000                 15  P-NEW-REPORT-DT-DD PIC 9(02).
088100             10  P-NEW-TERMINATION-DATE.
088200                 15  P-NEW-TERM-DT-CC   PIC 9(02).
088300                 15  P-NEW-TERM-DT-YY   PIC 9(02).
088400                 15  P-NEW-TERM-DT-MM   PIC 9(02).
088500                 15  P-NEW-TERM-DT-DD   PIC 9(02).
088600         05  P-NEW-WAIVER-CODE          PIC X(01).
088700             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
088800         05  P-NEW-INTER-NO             PIC 9(05).
088900         05  P-NEW-PROVIDER-TYPE        PIC X(02).
089000             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.
089100             88  P-N-REFERRAL-CENTER        VALUE '07' '11'
089200                                                  '15' '17'
089300                                                  '22'.
089400             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.
089500             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.
089600             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.
089700             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.
089800             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.
089900             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.
090000             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.
090100             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.
090200             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.
090300             88  P-N-EACH                   VALUE '21' '22'.
090400             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.
090500             88  P-N-NHCMQ-II-SNF           VALUE '32'.
090600             88  P-N-NHCMQ-III-SNF          VALUE '33'.
090700         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
090800             88  P-N-NEW-ENGLAND            VALUE  1.
090900             88  P-N-MIDDLE-ATLANTIC        VALUE  2.
091000             88  P-N-SOUTH-ATLANTIC         VALUE  3.
091100             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.
091200             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.
091300             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.
091400             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.
091500             88  P-N-MOUNTAIN               VALUE  8.
091600             88  P-N-PACIFIC                VALUE  9.
091700         05  P-NEW-CURRENT-DIV   REDEFINES
091800                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
091900             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.
092000         05  P-NEW-MSA-DATA.
092100             10  P-NEW-CHG-CODE-INDEX       PIC X.
092200             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
092300             10  P-NEW-GEO-LOC-MSA9   REDEFINES
092400                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
092500             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
092600             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
092700             10  P-NEW-STAND-AMT-LOC-MSA9
092800       REDEFINES P-NEW-STAND-AMT-LOC-MSA.
092900                 15  P-NEW-RURAL-1ST.
093000                     20  P-NEW-STAND-RURAL  PIC XX.
093100                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
093200                 15  P-NEW-RURAL-2ND        PIC XX.
093300         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
093400                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
093500                 88  P-NEW-SCH-YR82       VALUE   '82'.
093600                 88  P-NEW-SCH-YR87       VALUE   '87'.
093700         05  P-NEW-LUGAR                    PIC X.
093800         05  P-NEW-TEMP-RELIEF-IND          PIC X.
093900         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
094000         05  FILLER                         PIC X(05).
094100     02  PROV-NEWREC-HOLD2.
094200         05  P-NEW-VARIABLES.
094300             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).
094400             10  P-NEW-COLA              PIC  9(01)V9(03).
094500             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
094600             10  P-NEW-BED-SIZE          PIC  9(05).
094700             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).
094800             10  P-NEW-CMI               PIC  9(01)V9(04).
094900             10  P-NEW-SSI-RATIO         PIC  V9(04).
095000             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
095100             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).
095200             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).
095300             10  P-NEW-DSH-PERCENT       PIC  V9(04).
095400             10  P-NEW-FYE-DATE          PIC  X(08).
095500         05  FILLER                      PIC  X(23).
095600     02  PROV-NEWREC-HOLD3.
095700         05  P-NEW-PASS-AMT-DATA.
095800             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
095900             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
096000             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
096100             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
096200         05  P-NEW-CAPI-DATA.
096300             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
096400             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
096500             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
096600             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
096700             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
096800             15  P-NEW-CAPI-NEW-HOSP       PIC X.
096900             15  P-NEW-CAPI-IME            PIC 9V9999.
097000             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
097100         05  P-HVBP-HRR-DATA.
097200             15  P-VAL-BASED-PURCH-PARTIPNT PIC X.
097300             15  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
097400             15  P-HOSP-READMISSION-REDUCTN PIC X.
097500             15  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
097600         05  P-MODEL1-BUNDLE-DATA.
097700             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.
097800             15  P-HAC-REDUC-IND            PIC X.
097900             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.
098000             15  P-EHR-REDUC-IND            PIC X.
098100         05  FILLER                         PIC X(09).
098200
098300************************************************************
098400******************************************************************
098500*      MILLINNIUM COMPATIBLE
098600*                   THIS IS THE WAGE-INDEX
098700*          ASSOCIATED WITH THE BILL BEING PROCESSED
098800******************************************************************
098900 01  WAGE-NEW-INDEX-RECORD.
099000     05  W-MSA                         PIC X(4).
099100     05  W-SIZE                        PIC X.
099200         88  LARGE-URBAN       VALUE 'L'.
099300         88  OTHER-URBAN       VALUE 'O'.
099400         88  ALL-RURAL         VALUE 'R'.
099500     05  W-EFF-DATE                    PIC X(8).
099600     05  FILLER                        PIC X.
099700     05  W-INDEX-RECORD                PIC S9(02)V9(04).
099800     05  W-PR-INDEX-RECORD             PIC S9(02)V9(04).
099900
100000
100100 PROCEDURE DIVISION  USING BILL-NEW-DATA
100200                           PPS-DATA
100300                           PRICER-OPT-VERS-SW
100400                           PPS-ADDITIONAL-VARIABLES
100500                           PROV-NEW-HOLD
100600                           WAGE-NEW-INDEX-RECORD.
100700
100800***************************************************************
100900*    PROCESSING:                                              *
101000*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
101100*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *
101200*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
101300*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
101400*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
101500*           GOBACK.                                           *
101600*        D. ASSEMBLE PRICING COMPONENTS.                      *
101700*        E. CALCULATE THE PRICE.                              *
101800***************************************************************
101900
102000     MOVE ZEROES TO NON-TEMP-RELIEF-PAYMENT.
102100     MOVE 'N' TO TEMP-RELIEF-FLAG.
102200
102300     PERFORM 0200-MAINLINE-CONTROL.
102400
102500     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
102600     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.
102700     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.
102800     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.
102900     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.
103000     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
103100     MOVE HOLD-OTHER-VARIABLES      TO  PPS-OTHER-VARIABLES.
103200     MOVE HOLD-PC-OTH-VARIABLES     TO  PPS-PC-OTH-VARIABLES.
103300
103400     GOBACK.
103500
103600 0200-MAINLINE-CONTROL.
103700
103800     MOVE 'N' TO HMO-TAG.
103900
104000     IF PPS-PC-HMO-FLAG = 'Y' OR
104100               HMO-FLAG = 'Y'
104200        MOVE 'Y' TO HMO-TAG.
104300
104400     IF P-NEW-STATE NOT = 40
104500        MOVE ZEROES TO W-PR-INDEX-RECORD.
104600
104700     MOVE ALL '0' TO PPS-DATA
104800                     H-OPER-DSH-SCH
104900                     H-OPER-DSH-RRC
105000                     HOLD-PPS-COMPONENTS
105100                     HOLD-PPS-COMPONENTS
105200                     HOLD-ADDITIONAL-VARIABLES
105300                     HOLD-CAPITAL-VARIABLES
105400                     HOLD-CAPITAL2-VARIABLES
105500                     HOLD-OTHER-VARIABLES
105600                     HOLD-PC-OTH-VARIABLES.
105700
105800     IF P-NEW-CAPI-HOSP-SPEC-RATE NOT NUMERIC
105900        MOVE 0 TO P-NEW-CAPI-HOSP-SPEC-RATE.
106000
106100     IF P-NEW-CAPI-OLD-HARM-RATE  NOT NUMERIC
106200        MOVE 0 TO P-NEW-CAPI-OLD-HARM-RATE.
106300
106400     IF P-NEW-CAPI-NEW-HARM-RATIO NOT NUMERIC
106500        MOVE 0 TO P-NEW-CAPI-NEW-HARM-RATIO.
106600
106700     IF P-NEW-CAPI-CSTCHG-RATIO NOT NUMERIC
106800        MOVE 0 TO P-NEW-CAPI-CSTCHG-RATIO.
106900
107000     PERFORM 1000-EDIT-THE-BILL-INFO.
107100
107200     IF  PPS-RTC = 00
107300         PERFORM 2000-ASSEMBLE-PPS-VARIABLES
107400         PERFORM 3000-CALC-PAYMENT THRU 3000-EXIT.
107500
107600     IF PPS-RTC = 00
107700        IF H-PERDIEM-DAYS = H-ALOS OR
107800           H-PERDIEM-DAYS > H-ALOS
107900           MOVE 14 TO PPS-RTC.
108000
108100     IF PPS-RTC = 02
108200        IF H-PERDIEM-DAYS = H-ALOS OR
108300           H-PERDIEM-DAYS > H-ALOS
108400           MOVE 16 TO PPS-RTC.
108500
108600 1000-EDIT-THE-BILL-INFO.
108700***************************************************************
108800*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *
108900*    AND DO NOT ATTEMPT TO PRICE.                             *
109000***************************************************************
109100
109200     MOVE 1.00 TO H-CAPI-PAYCDE-PCT1.
109300     MOVE 0.00 TO H-CAPI-PAYCDE-PCT2.
109400
109500     IF  PPS-RTC = 00
109600         IF  P-NEW-WAIVER-STATE
109700             MOVE 53 TO PPS-RTC.
109800
109900     IF  PPS-RTC = 00
110000         IF  B-DRG < 001 OR > 527 OR = 214 OR = 215 OR 112
110100                                  OR = 221 OR = 222
110200                                  OR = 434 OR = 435
110300                                  OR = 436 OR = 437
110400                                  OR = 438 OR = 456
110500                                  OR = 457 OR = 458
110600                                  OR = 459 OR = 460
110700                                  OR = 469 OR = 470
110800                                  OR = 472 OR = 474
110900             MOVE 54 TO PPS-RTC.
111000
111100     IF  PPS-RTC = 00
111200            IF  ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR
111300                 (B-DISCHARGE-DATE < W-EFF-DATE))
111400                MOVE 55 TO PPS-RTC.
111500
111600     IF  PPS-RTC = 00
111700         IF P-NEW-TERMINATION-DATE > 00000000
111800            IF  ((B-DISCHARGE-DATE = P-NEW-TERMINATION-DATE) OR
111900                 (B-DISCHARGE-DATE > P-NEW-TERMINATION-DATE))
112000                  MOVE 55 TO PPS-RTC.
112100
112200     IF  PPS-RTC = 00
112300         IF  B-LOS NOT NUMERIC
112400             MOVE 56 TO PPS-RTC
112500         ELSE
112600         IF  B-LOS = 0
112700             IF B-REVIEW-CODE NOT = 00 AND
112800                              NOT = 03 AND
112900                              NOT = 06 AND
113000                              NOT = 07 AND
113100                              NOT = 09 AND
113200                              NOT = 11
113300             MOVE 56 TO PPS-RTC.
113400
113500     IF  PPS-RTC = 00
113600         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60
113700             MOVE 61 TO PPS-RTC
113800         ELSE
113900             MOVE B-LTR-DAYS TO H-LTR-DAYS.
114000
114100     IF  PPS-RTC = 00
114200         IF  B-COVERED-DAYS NOT NUMERIC
114300             MOVE 62 TO PPS-RTC
114400         ELSE
114500         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
114600             MOVE 62 TO PPS-RTC
114700         ELSE
114800             MOVE B-COVERED-DAYS TO H-COV-DAYS.
114900
115000     IF  PPS-RTC = 00
115100         IF  H-LTR-DAYS  > H-COV-DAYS
115200             MOVE 62 TO PPS-RTC
115300         ELSE
115400             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
115500
115600     IF  PPS-RTC = 00
115700         IF  NOT VALID-REVIEW-CODE
115800             MOVE 57 TO PPS-RTC.
115900
116000     IF  PPS-RTC = 00
116100         IF  B-CHARGES-CLAIMED NOT NUMERIC
116200             MOVE 58 TO PPS-RTC.
116300
116400     IF PPS-RTC = 00
116500           IF P-NEW-CAPI-NEW-HOSP NOT = 'Y'
116600                 IF P-NEW-CAPI-PPS-PAY-CODE NOT = 'A' AND
116700                                            NOT = 'B' AND
116800                                            NOT = 'C'
116900                 MOVE 65 TO PPS-RTC.
117000
117100 2000-ASSEMBLE-PPS-VARIABLES.
117200***************************************************************
117300*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *
117400*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *
117500*    OF THAT VARIABLE.                                        *
117600***************************************************************
117700***  GET THE PROVIDER SPECIFIC VARIABLES.
117800***  GET THE PROVIDER SPECIFIC VARIABLES.
117900
118000     MOVE P-NEW-FAC-SPEC-RATE TO H-FAC-SPEC-RATE.
118100     MOVE P-NEW-INTERN-RATIO TO H-INTERN-RATIO.
118200
118300     IF  (P-NEW-STATE = 02 OR 12)
118400         MOVE P-NEW-COLA TO H-OPER-COLA
118500     ELSE
118600         MOVE 1.000  TO H-OPER-COLA.
118700
118800***************************************************************
118900***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
119000***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
119100
119200     PERFORM 2600-GET-DRG-WEIGHT
119300             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.
119400
119500***************************************************************
119600***  GET THE WAGE-INDEX
119700***  GET THE WAGE-INDEX
119800
119900     MOVE W-INDEX-RECORD TO H-WAGE-INDEX.
120000     MOVE W-PR-INDEX-RECORD TO H-PR-WAGE-INDEX.
120100
120200***************************************************************
120300***  GET THE LABOR, NON-LABOR STANDARD RATES
120400
120500     IF  P-NEW-STATE = 40
120600         MOVE 2 TO R2
120700         MOVE 3 TO R4
120800     ELSE
120900         MOVE 1 TO R2
121000         MOVE 1 TO R4.
121100
121200     IF  LARGE-URBAN
121300         MOVE 1 TO R3
121400     ELSE
121500         MOVE 2 TO R3.
121600
121700     PERFORM 2300-GET-LABOR-NLABOR-RATES
121800             VARYING R1 FROM 1 BY 1 UNTIL R1 > 2.
121900
122000      IF SE-AL-PROV
122100      COMPUTE H-TOT-REG-AL ROUNDED = H-REG-LABOR + H-REG-NONLABOR
122200      COMPUTE H-TOT-NAT-AL ROUNDED = H-NAT-LABOR + H-NAT-NONLABOR
122300      COMPUTE H-REG-LABOR ROUNDED  = H-TOT-REG-AL * 0.7079
122400      COMPUTE H-NAT-LABOR ROUNDED  = H-TOT-NAT-AL * 0.7079
122500      COMPUTE H-REG-NONLABOR ROUNDED = H-TOT-REG-AL * 0.2921
122600      COMPUTE H-NAT-NONLABOR ROUNDED = H-TOT-NAT-AL * 0.2921.
122700
122800***************************************************************
122900***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
123000***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
123100
123200     MOVE 0.00  TO H-OPER-HSP-PCT.
123300     MOVE 1.00  TO H-OPER-FSP-PCT.
123400
123500***************************************************************
123600***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
123700***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
123800
123900      MOVE 1.00 TO H-NAT-PCT.
124000      MOVE 0.00 TO H-REG-PCT.
124100
124200     IF  P-NEW-STATE = 40
124300         MOVE 0.50 TO H-NAT-PCT
124400         MOVE 0.50 TO H-REG-PCT.
124500
124600     IF  P-N-SCH-REBASED-FY90 OR
124700         P-N-EACH OR
124800         P-N-MDH-REBASED-FY90
124900         MOVE 1.00 TO H-OPER-HSP-PCT.
125000
125100 2300-GET-LABOR-NLABOR-RATES.
125200
125300     IF  B-DISCHARGE-DATE NOT < RATE-EFF-DATE (R1)
125400         MOVE REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
125500         MOVE REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
125600         MOVE REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
125700         MOVE REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
125800
125900 2600-GET-DRG-WEIGHT.
126000
126100     IF (B-DISCHARGE-DATE < 20030401 AND
126200         B-DRG = '526') MOVE '516' TO B-DRG.
126300     IF (B-DISCHARGE-DATE < 20030401 AND
126400         B-DRG = '527') MOVE '517' TO B-DRG.
126500
126600     IF  B-DISCHARGE-DATE NOT < DRGX-EFF-DATE (DX5)
126700         SET DX6 TO B-DRG
126800         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT
126900         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS
127000*****    MOVE DRG-DAYS-TRIM (DX5 DX6)  TO H-DAYS-CUTOFF
127100         MOVE ZEROES                   TO H-DAYS-CUTOFF
127200         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.
127300
127400 3000-CALC-PAYMENT.
127500***************************************************************
127600*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *
127700*        CALCULATE THE STAY UTILIZATION.                      *
127800*        CALCULATE THE FEDERAL PORTION.                       *
127900*        CALCULATE THE HOSPITAL PORTION.                      *
128000*        CALCULATE THE COST-OUTLIER PORTION.                  *
128100*        CALCULATE THE TOTAL PAYMENT OPERATING AND CAPITAL    *
128200*        CALCULATE THE DSH ADJUSTMENT.                        *
128300*        CALCULATE THE IME TEACHING.                          *
128400***************************************************************
128500
128600     PERFORM 3100-CALC-STAY-UTILIZATION.
128700     PERFORM 3300-CALC-OPER-FSP-AMT.
128800     PERFORM 3900A-CALC-OPER-DSH.
128900
129000***********************************************************
129100***  OPERATING IME CALCULATION
129200***  OPERATING IME CALCULATION
129300
129400     COMPUTE H-OPER-IME-TEACH ROUNDED =
129500            1.35 * ((1 + H-INTERN-RATIO) ** .405  - 1).
129600
129700***********************************************************
129800
129900     IF P-N-SCH-REBASED-FY90 OR
130000        P-N-EACH OR
130100        P-N-MDH-REBASED-FY90
130200         PERFORM 3450-CALC-ADDITIONAL-HSP.
130300
130400     MOVE 00                 TO  PPS-RTC.
130500     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.
130600     MOVE H-ALOS             TO  PPS-AVG-LOS.
130700     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.
130800
130900     MOVE B-LOS TO H-PERDIEM-DAYS.
131000     IF H-PERDIEM-DAYS < 1
131100         MOVE 1 TO H-PERDIEM-DAYS.
131200     ADD 1 TO H-PERDIEM-DAYS.
131300
131400     MOVE 1 TO H-DSCHG-FRCTN.
131500
131600     IF  (PAY-PERDIEM-DAYS OR
131700          PAY-XFER-NO-COST) OR
131800       (PAY-XFER-SPEC-DRG AND (B-DRG = 014 OR 113 OR 236 OR
131900                                       263 OR 264 OR 429 OR 483))
132000         COMPUTE H-DSCHG-FRCTN ROUNDED = H-PERDIEM-DAYS / H-ALOS
132100         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS.
132200
132300     IF (PAY-XFER-SPEC-DRG AND (B-DRG = 209 OR 210 OR 211))
132400         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
132500         COMPUTE H-DSCHG-FRCTN ROUNDED =
132600                        .5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS).
132700
132800
132900     IF H-DSCHG-FRCTN > 1
133000              MOVE 1 TO H-DSCHG-FRCTN
133100              MOVE 1 TO H-TRANSFER-ADJ.
133200
133300     COMPUTE H-DRG-WT-FRCTN ROUNDED = H-DSCHG-FRCTN * H-DRG-WT.
133400
133500***********************************************************
133600***  CAPITAL DSH CALCULATION
133700***  CAPITAL DSH CALCULATION
133800
133900     MOVE 0 TO H-CAPI-DSH.
134000
134100     IF P-NEW-BED-SIZE NOT NUMERIC
134200         MOVE 0 TO P-NEW-BED-SIZE.
134300
134400     IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
134500         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **
134600                  (.2025 * (P-NEW-SSI-RATIO
134700                          + P-NEW-MEDICAID-RATIO)) - 1.
134800
134900***********************************************************
135000***  CAPITAL IME TEACH CALCULATION
135100***  CAPITAL IME TEACH CALCULATION
135200
135300     MOVE 0 TO H-WK-CAPI-IME-TEACH.
135400
135500     IF P-NEW-CAPI-IME NUMERIC
135600        IF P-NEW-CAPI-IME > 1.5000
135700           MOVE 1.5000 TO P-NEW-CAPI-IME.
135800
135900     IF P-NEW-CAPI-IME NUMERIC
136000        COMPUTE H-WK-CAPI-IME-TEACH ROUNDED =
136100          (2.7183 ** (.2822 * P-NEW-CAPI-IME)) - 1.
136200
136300***********************************************************
136400******************************************************************
136500***  NO LONGER PAYING DAY-OUTLIERS     AS OF 10/01/97
136600***  NO LONGER PAYING DAY-OUTLIERS     AS OF 10/01/97
136700***  ZEROED OUT THE H-DAYOUT-PCT FIELD AS OF 10/01/97
136800
136900     MOVE 0.00 TO H-DAYOUT-PCT.
137000******************************************************************
137100
137200     MOVE 0.80 TO H-CSTOUT-PCT.
137300
137400******************************************************************
137500*****THESE ARE BURNS DRG'S
137600     IF  B-DRG = 504 OR 505 OR 506 OR 507 OR 508 OR
137700                 509 OR 510 OR 511
137800             MOVE 0.90 TO H-CSTOUT-PCT.
137900
138000***     NATIONAL PERCENTAGE
138100     MOVE 0.7110   TO H-LABOR-PCT.
138200     MOVE 0.2890   TO H-NONLABOR-PCT.
138300
138400***     PUERTO RICO PERCENTAGE
138500     MOVE 0.7130   TO H-PR-LABOR-PCT.
138600     MOVE 0.2870   TO H-PR-NONLABOR-PCT.
138700
138800     IF  P-NEW-OPER-CSTCHG-RATIO NUMERIC
138900             MOVE P-NEW-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO
139000     ELSE
139100             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.
139200
139300     IF P-NEW-CAPI-CSTCHG-RATIO NUMERIC
139400             MOVE P-NEW-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO
139500     ELSE
139600             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.
139700
139800     IF SE-AL-PROV
139900     MOVE 0.7079   TO H-LABOR-PCT
140000     MOVE 0.2921   TO H-NONLABOR-PCT.
140100***********************************************************
140200***********************************************************
140300***  CAPITAL PAYMENT METHOD B
140400***  CAPITAL PAYMENT METHOD B
140500
140600     IF W-SIZE = 'L'
140700        MOVE 1.03 TO H-CAPI-LARG-URBAN
140800     ELSE
140900        MOVE 1.00 TO H-CAPI-LARG-URBAN.
141000
141100     COMPUTE H-CAPI-GAF    ROUNDED = (H-WAGE-INDEX ** .6848).
141200     COMPUTE H-PR-CAPI-GAF ROUNDED = (H-PR-WAGE-INDEX ** .6848).
141300
141400     IF B-DISCHARGE-DATE < 20030401
141500        COMPUTE H-FEDERAL-RATE ROUNDED =
141600                                 (0407.01 * H-CAPI-GAF)
141700        COMPUTE H-PUERTO-RICO-RATE ROUNDED =
141800                                 (0198.29 * H-PR-CAPI-GAF)
141900     ELSE
142000        COMPUTE H-FEDERAL-RATE ROUNDED =
142100                                 (0406.93 * H-CAPI-GAF)
142200        COMPUTE H-PUERTO-RICO-RATE ROUNDED =
142300                                 (0198.29 * H-PR-CAPI-GAF).
142400
142500     COMPUTE H-CAPI-COLA ROUNDED =
142600                     (.3152 * (H-OPER-COLA - 1) + 1).
142700
142800     IF P-NEW-STATE = 40
142900        COMPUTE  H-CAPI-FED-RATE ROUNDED =
143000                 (H-NAT-PCT * H-FEDERAL-RATE) +
143100                 (H-REG-PCT * H-PUERTO-RICO-RATE)
143200     ELSE
143300        MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.
143400
143500***********************************************************
143600***  NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001
143700***  CAPITAL HSP CALCULATION
143800***  CAPITAL HSP CALCULATION
143900*
144000*    IF B-DISCHARGE-DATE > 20010331
144100*        MOVE 1.0149 TO H-HSP-UPDATE01
144200*    ELSE
144300*        MOVE 1.0147 TO H-HSP-UPDATE01.
144400*
144500*    COMPUTE H-ACCUM-TO-HSP ROUNDED = H-HSP-UPDATE01.
144600*
144700*    COMPUTE H-CAPI-HSP-PART ROUNDED = (H-DRG-WT *
144800*                  P-NEW-CAPI-HOSP-SPEC-RATE * H-ACCUM-TO-HSP).
144900***********************************************************
145000
145100***********************************************************
145200***  CAPITAL FSP CALCULATION
145300***  CAPITAL FSP CALCULATION
145400
145500     COMPUTE H-CAPI-FSP-PART ROUNDED =
145600                               H-DRG-WT * H-CAPI-FED-RATE *
145700                               H-CAPI-COLA *
145800                               H-CAPI-LARG-URBAN.
145900
146000***********************************************************
146100***  CAPITAL PAYMENT METHOD A
146200***  CAPITAL PAYMENT METHOD A
146300
146400     IF P-N-SCH-REBASED-FY90 OR P-N-EACH
146500        MOVE 1.00 TO H-CAPI-SCH
146600     ELSE
146700        MOVE 0.85 TO H-CAPI-SCH.
146800
146900***********************************************************
147000***********  CAPITAL OLD-HARMLESS CALCULATION ***********
147100***********  CAPITAL OLD-HARMLESS CALCULATION ***********
147200
147300     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
147400                    (P-NEW-CAPI-OLD-HARM-RATE *
147500                    H-CAPI-SCH).
147600
147700***********************************************************
147800        IF PAY-PERDIEM-DAYS
147900            IF  H-PERDIEM-DAYS < H-ALOS
148000                IF  NOT (B-DRG = 385)
148100                    PERFORM 3500-CALC-PERDIEM-AMT
148200                    MOVE 03 TO PPS-RTC.
148300
148400        IF PAY-XFER-SPEC-DRG
148500            IF  H-PERDIEM-DAYS < H-ALOS
148600                IF  NOT (B-DRG = 385)
148700                    PERFORM 3550-CALC-PERDIEM-AMT.
148800
148900        IF  PAY-XFER-NO-COST
149000            MOVE 00 TO PPS-RTC
149100            IF H-PERDIEM-DAYS < H-ALOS
149200               IF  NOT (B-DRG = 385)
149300                   PERFORM 3500-CALC-PERDIEM-AMT
149400                   MOVE 06 TO PPS-RTC.
149500
149600     PERFORM 3700-CALC-TECH-ADDON.
149700     PERFORM 3600-CALC-OUTLIER.
149800
149900     IF PPS-RTC = 67  GO TO 3000-CONTINUE.
150000
150100
150200        IF  PAY-PERDIEM-DAYS
150300            IF  H-OPER-OUTCST-PART > 0
150400                MOVE H-OPER-OUTCST-PART TO
150500                     H-OPER-OUTLIER-PART
150600                MOVE 05 TO PPS-RTC
150700            ELSE
150800            IF  PPS-RTC NOT = 03
150900                MOVE 00 TO PPS-RTC
151000                MOVE 0  TO H-OPER-OUTLIER-PART.
151100
151200        IF  PAY-PERDIEM-DAYS
151300            IF  H-CAPI-OUTCST-PART > 0
151400                MOVE H-CAPI-OUTCST-PART TO
151500                     H-CAPI-OUTLIER-PART
151600                MOVE 05 TO PPS-RTC
151700            ELSE
151800            IF  PPS-RTC NOT = 03
151900                MOVE 0  TO H-CAPI-OUTLIER-PART.
152000
152100
152200 3000-CONTINUE.
152300
152400***********************************************************
152500***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF
152600***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
152700
152800     COMPUTE H-CAPI2-B-FSP-PART ROUNDED = H-CAPI-FSP-PART.
152900
153000***********************************************************
153100
153200     IF  PPS-RTC = 67
153300         MOVE H-OPER-DOLLAR-THRESHOLD TO
153400              WK-H-OPER-DOLLAR-THRESHOLD.
153500
153600     IF  PPS-RTC < 50
153700         PERFORM 3800-CALC-TOT-AMT
153800     ELSE
153900         MOVE ALL '0' TO PPS-OPER-HSP-PART
154000                         PPS-OPER-FSP-PART
154100                         PPS-OPER-OUTLIER-PART
154200                         PPS-OUTLIER-DAYS
154300                         PPS-REG-DAYS-USED
154400                         PPS-LTR-DAYS-USED
154500                         PPS-TOTAL-PAYMENT
154600                         PPS-OPER-DSH-ADJ
154700                         PPS-OPER-IME-ADJ
154800                         H-DSCHG-FRCTN
154900                         H-DRG-WT-FRCTN
155000                         HOLD-ADDITIONAL-VARIABLES
155100                         HOLD-CAPITAL-VARIABLES
155200                         HOLD-CAPITAL2-VARIABLES
155300                         HOLD-OTHER-VARIABLES
155400                         HOLD-PC-OTH-VARIABLES.
155500
155600     IF  PPS-RTC = 67
155700         MOVE WK-H-OPER-DOLLAR-THRESHOLD TO
155800                 H-OPER-DOLLAR-THRESHOLD.
155900
156000 3000-EXIT.  EXIT.
156100
156200 3100-CALC-STAY-UTILIZATION.
156300
156400     MOVE 0 TO PPS-REG-DAYS-USED.
156500     MOVE 0 TO PPS-LTR-DAYS-USED.
156600
156700     IF H-REG-DAYS > 0
156800        IF H-REG-DAYS > B-LOS
156900           MOVE B-LOS TO PPS-REG-DAYS-USED
157000        ELSE
157100           MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
157200     ELSE
157300        IF H-LTR-DAYS > B-LOS
157400           MOVE B-LOS TO PPS-LTR-DAYS-USED
157500        ELSE
157600           MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED.
157700
157800
157900
158000 3300-CALC-OPER-FSP-AMT.
158100***********************************************************
158200***  OPERATING FSP CALCULATION
158300***  OPERATING FSP CALCULATION
158400
158500     IF P-NEW-STATE = 40
158600       COMPUTE H-OPER-FSP-PART ROUNDED =
158700           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
158800            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
158900                           +
159000           (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
159100            H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)
159200                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART
159300     ELSE
159400        COMPUTE H-OPER-FSP-PART ROUNDED =
159500           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
159600            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
159700                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
159800
159900 3450-CALC-ADDITIONAL-HSP.
160000***********************************************************
160100*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR
160200*    SOLE COMMUNITY
160300*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)
160400*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
160500***********************************************************
160600**** CHANGE ESTIMATED OUTLIER FACTORS WHEN FED RATES CHANGE
160700****    USE ACTUAL FEDERAL REGISTER NUMBER
160800
160900***************************************************************
161000***         GET THE UPDATING FACTOR
161100***         GET THE UPDATING FACTOR
161200
161300     MOVE 0.997174 TO H-BUDG-NUTR01.
161400     MOVE 0.995821 TO H-BUDG-NUTR02.
161500
161600     IF B-DISCHARGE-DATE < 20030401
161700        MOVE 0.993209 TO H-BUDG-NUTR03
161800     ELSE
161900        MOVE 0.993012 TO H-BUDG-NUTR03.
162000
162100     MOVE 1.0340 TO H-UPDATE-01.
162200     MOVE 1.0275 TO H-UPDATE-02.
162300     MOVE 1.0295 TO H-UPDATE-03.
162400
162500     COMPUTE H-UPDATE-FACTOR ROUNDED =
162600                       (H-UPDATE-01 * H-UPDATE-02 *
162700                        H-UPDATE-03 *
162800                        H-BUDG-NUTR01 * H-BUDG-NUTR02 *
162900                        H-BUDG-NUTR03).
163000
163100     COMPUTE H-HSP-RATE ROUNDED =
163200         H-FAC-SPEC-RATE * H-UPDATE-FACTOR.
163300***************************************************************
163400
163500***************************************************************
163600***     OUTLIER OFFSETS
163700***     OPERATING NATIONAL
163800***     OPERATING PUERTO RICO BLEND
163900
164000        IF B-DISCHARGE-DATE < 20030401
164100           MOVE 0.948999 TO H-OUTLIER-OFFSET-NAT
164200           MOVE 0.965325 TO H-OUTLIER-OFFSET-PR
164300        ELSE
164400           MOVE 0.948999 TO H-OUTLIER-OFFSET-NAT
164500           MOVE 0.965325 TO H-OUTLIER-OFFSET-PR.
164600
164700***************************************************************
164800     IF P-NEW-STATE = 40
164900       COMPUTE H-FSP-RATE ROUNDED =
165000         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
165100         H-NAT-NONLABOR * H-OPER-COLA))
165200                           +
165300          (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
165400         H-REG-NONLABOR * H-OPER-COLA)))
165500                           *
165600      ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-PR)
165700                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE
165800     ELSE
165900       COMPUTE H-FSP-RATE ROUNDED =
166000         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
166100         H-NAT-NONLABOR * H-OPER-COLA))
166200                           *
166300     ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-NAT)
166400                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
166500
166600     IF  H-HSP-RATE > H-FSP-RATE
166700           COMPUTE H-OPER-HSP-PART ROUNDED =
166800             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT
166900                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART
167000     ELSE
167100         MOVE 0 TO H-OPER-HSP-PART.
167200
167300***************************************************************
167400***         GET THE MDH REBASE
167500***     HAS BEEN REVIVED FOR 10/01/97
167600
167700     IF  H-HSP-RATE > H-FSP-RATE
167800         IF P-NEW-PROVIDER-TYPE = '14' OR '15'
167900           COMPUTE H-OPER-HSP-PART ROUNDED =
168000             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT * .5
168100                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
168200
168300 3500-CALC-PERDIEM-AMT.
168400***********************************************************
168500***  REVIEW CODE = 03 OR 06
168600***  OPERATING PERDIEM-AMT CALCULATION
168700***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
168800
168900        COMPUTE H-OPER-HSP-PART ROUNDED =
169000        H-OPER-HSP-PART * H-TRANSFER-ADJ
169100        ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
169200
169300        COMPUTE H-OPER-FSP-PART ROUNDED =
169400        H-OPER-FSP-PART * H-TRANSFER-ADJ
169500        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
169600
169700***********************************************************
169800***********************************************************
169900***  REVIEW CODE = 03 OR 06
170000***  CAPITAL   PERDIEM-AMT CALCULATION
170100***  CAPITAL   HSP AND FSP CALCULATION FOR TRANSFERS
170200
170300***********************************************************
170400**NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001    **************
170500*       COMPUTE H-CAPI-HSP-PART ROUNDED =
170600*       H-CAPI-HSP-PART * H-TRANSFER-ADJ
170700*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
170800***********************************************************
170900
171000        COMPUTE H-CAPI-FSP-PART ROUNDED =
171100        H-CAPI-FSP-PART * H-TRANSFER-ADJ
171200        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
171300
171400***********************************************************
171500***  REVIEW CODE = 03 OR 06
171600***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
171700***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
171800
171900        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
172000        H-CAPI-OLD-HARMLESS * H-TRANSFER-ADJ
172100        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
172200
172300 3550-CALC-PERDIEM-AMT.
172400***********************************************************
172500***  REVIEW CODE = 09  OR 11 TRANSFER WITH SPECIAL DRG
172600***  OPERATING PERDIEM-AMT CALCULATION
172700***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
172800
172900     IF (B-DRG = 209 OR 210 OR 211)
173000        MOVE 10 TO PPS-RTC
173100        COMPUTE H-OPER-HSP-PART ROUNDED =
173200        H-OPER-HSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
173300        ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
173400
173500     IF (B-DRG = 014 OR 113 OR 236 OR 263 OR
173600                 264 OR 429 OR 483)
173700        MOVE 12 TO PPS-RTC
173800        COMPUTE H-OPER-HSP-PART ROUNDED =
173900        H-OPER-HSP-PART *  H-TRANSFER-ADJ
174000        ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
174100
174200     IF (B-DRG = 209 OR 210 OR 211)
174300        MOVE 10 TO PPS-RTC
174400        COMPUTE H-OPER-FSP-PART ROUNDED =
174500        H-OPER-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
174600        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
174700
174800     IF (B-DRG = 014 OR 113 OR 236 OR 263 OR
174900                 264 OR 429 OR 483)
175000        MOVE 12 TO PPS-RTC
175100        COMPUTE H-OPER-FSP-PART ROUNDED =
175200        H-OPER-FSP-PART *  H-TRANSFER-ADJ
175300        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
175400
175500***********************************************************
175600***  CAPITAL PERDIEM-AMT CALCULATION
175700***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS
175800
175900***********************************************************
176000**NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001    **************
176100*    IF (B-DRG = 209 OR 210 OR 211)
176200*       MOVE 10 TO PPS-RTC
176300*       COMPUTE H-CAPI-HSP-PART ROUNDED =
176400*       H-CAPI-HSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
176500*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
176600*
176700*    IF (B-DRG = 014 OR 113 OR 236 OR 263 OR
176800*                264 OR 429 OR 483)
176900*       MOVE 12 TO PPS-RTC
177000*       COMPUTE H-CAPI-HSP-PART ROUNDED =
177100*       H-CAPI-HSP-PART *  H-TRANSFER-ADJ
177200*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
177300***********************************************************
177400
177500     IF (B-DRG = 209 OR 210 OR 211)
177600        MOVE 10 TO PPS-RTC
177700        COMPUTE H-CAPI-FSP-PART ROUNDED =
177800        H-CAPI-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
177900        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
178000
178100     IF (B-DRG = 014 OR 113 OR 236 OR 263 OR
178200                 264 OR 429 OR 483)
178300        MOVE 12 TO PPS-RTC
178400        COMPUTE H-CAPI-FSP-PART ROUNDED =
178500        H-CAPI-FSP-PART *  H-TRANSFER-ADJ
178600        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
178700
178800***********************************************************
178900***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
179000***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
179100
179200     IF (B-DRG = 209 OR 210 OR 211)
179300        MOVE 10 TO PPS-RTC
179400        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
179500        H-CAPI-OLD-HARMLESS * (.5 * (1 + H-TRANSFER-ADJ))
179600        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
179700
179800     IF (B-DRG = 014 OR 113 OR 236 OR 263 OR
179900                 264 OR 429 OR 483)
180000        MOVE 12 TO PPS-RTC
180100        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
180200        H-CAPI-OLD-HARMLESS *  H-TRANSFER-ADJ
180300        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
180400
180500 3600-CALC-OUTLIER.
180600***********************************************************
180700***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
180800***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
180900
181000     IF H-CAPI-CSTCHG-RATIO > 0 OR
181100       H-OPER-CSTCHG-RATIO > 0
181200        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD ROUNDED =
181300                H-OPER-CSTCHG-RATIO /
181400               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
181500        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD ROUNDED =
181600                H-CAPI-CSTCHG-RATIO /
181700               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
181800     ELSE
181900         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD
182000                   H-CAPI-SHARE-DOLL-THRESHOLD.
182100
182200***********************************************************
182300***********************************************************
182400***********************************************************
182500***********************************************************
182600***********************************************************
182700***NO LONGER PAID PRE-CAPITAL AS OCT 1, 2001***************
182800***  OUTLIER THRESHOLD AND PRE-CAPITAL THRESHOLD AMOUNTS
182900***  OUTLIER THRESHOLD AND PRE-CAPITAL THRESHOLD AMOUNTS
183000
183100***NO LONGER PAID PRE-CAPITAL AS OCT 1, 2001***************
183200***     MOVE 16036.00 TO H-PRE-CAPI-THRESH.
183300***********************************************************
183400***********************************************************
183500***********************************************************
183600***********************************************************
183700
183800
183900
184000***********************************************************
184100***  OUTLIER THRESHOLD AMOUNTS
184200***  OUTLIER THRESHOLD AMOUNTS
184300
184400        MOVE 33560.00 TO H-CST-THRESH.
184500
184600     IF (B-REVIEW-CODE = '03') AND
184700         H-PERDIEM-DAYS < H-ALOS
184800        COMPUTE H-CST-THRESH ROUNDED =
184900                      (H-CST-THRESH * H-TRANSFER-ADJ)
185000                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
185100
185200     IF ((B-REVIEW-CODE = '09') AND
185300         (H-PERDIEM-DAYS < H-ALOS))
185400         IF (B-DRG = 014 OR 113 OR 236 OR 263 OR
185500                     264 OR 429 OR 483)
185600            COMPUTE H-CST-THRESH ROUNDED =
185700                      (H-CST-THRESH * H-TRANSFER-ADJ)
185800                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
185900
186000     IF ((B-REVIEW-CODE = '09') AND
186100         (H-PERDIEM-DAYS < H-ALOS))
186200         IF (B-DRG = 209 OR 210 OR 211)
186300           COMPUTE H-CST-THRESH ROUNDED =
186400          (H-CST-THRESH * (.5 * (1 + H-TRANSFER-ADJ)))
186500                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
186600
186700     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
186800        ((H-CST-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +
186900         (H-CST-THRESH * H-NONLABOR-PCT * H-OPER-COLA)) *
187000          H-OPER-SHARE-DOLL-THRESHOLD.
187100
187200     IF P-NEW-STATE = 40
187300        COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =
187400           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +
187500            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *
187600             H-OPER-SHARE-DOLL-THRESHOLD
187700        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
187800               (H-OPER-DOLLAR-THRESHOLD +
187900                H-OPER-PR-DOLLAR-THRESHOLD) * H-NAT-PCT.
188000
188100***********************************************************
188200
188300     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
188400          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *
188500          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.
188600
188700
188800     IF P-NEW-STATE = 40
188900        COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =
189000           H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *
189100           H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA
189200        COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
189300               (H-CAPI-DOLLAR-THRESHOLD +
189400                H-CAPI-PR-DOLLAR-THRESHOLD) * H-NAT-PCT.
189500
189600     COMPUTE H-OPER-COST-OUTLIER ROUNDED =
189700      (H-OPER-FSP-PART * (1 + H-OPER-IME-TEACH + H-OPER-DSH))
189800                       +
189900             H-OPER-DOLLAR-THRESHOLD
190000                       +
190100                 H-NEW-TECH-PAY-ADD-ON.
190200
190300     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
190400      (H-CAPI-FSP-PART * (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH))
190500                       +
190600             H-CAPI-DOLLAR-THRESHOLD.
190700
190800     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
190900         MOVE 0 TO H-CAPI-COST-OUTLIER.
191000
191100
191200***********************************************************
191300***  OPERATING COST CALCULATION
191400***  OPERATING COST CALCULATION
191500
191600     COMPUTE H-OPER-BILL-COSTS ROUNDED =
191700         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO
191800         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
191900
192000
192100     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER
192200         COMPUTE H-OPER-OUTCST-PART ROUNDED =
192300         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -
192400                         H-OPER-COST-OUTLIER).
192500
192600     IF PAY-WITHOUT-COST OR
192700        PAY-XFER-NO-COST OR
192800        PAY-XFER-SPEC-DRG-NO-COST
192900         MOVE 0 TO H-OPER-OUTCST-PART.
193000
193100***********************************************************
193200***  CAPITAL COST CALCULATION
193300***  CAPITAL COST CALCULATION
193400
193500     COMPUTE H-CAPI-BILL-COSTS ROUNDED =
193600             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO
193700         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.
193800
193900     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER
194000         COMPUTE H-CAPI-OUTCST-PART ROUNDED =
194100         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -
194200                         H-CAPI-COST-OUTLIER).
194300
194400     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
194500       COMPUTE H-CAPI-OUTCST-PART ROUNDED =
194600              (H-CAPI-OUTCST-PART * P-NEW-CAPI-NEW-HARM-RATIO).
194700
194800     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
194900        COMPUTE H-CAPI-OUTCST-PART ROUNDED =
195000               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).
195100
195200     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <
195300        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)
195400        MOVE 0 TO H-CAPI-OUTCST-PART
195500                  H-OPER-OUTCST-PART.
195600
195700     IF PAY-WITHOUT-COST OR
195800        PAY-XFER-NO-COST OR
195900        PAY-XFER-SPEC-DRG-NO-COST
196000         MOVE 0 TO H-CAPI-OUTCST-PART.
196100
196200***********************************************************
196300***  DETERMINES THE BILL TO BE COST  OUTLIER
196400
196500     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
196600         MOVE 0 TO H-CAPI-OUTDAY-PART
196700                   H-CAPI-OUTCST-PART.
196800
196900     IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
197000                 MOVE H-OPER-OUTCST-PART TO
197100                      H-OPER-OUTLIER-PART
197200                 MOVE H-CAPI-OUTCST-PART TO
197300                      H-CAPI-OUTLIER-PART
197400                 MOVE 02 TO PPS-RTC.
197500
197600
197700***********************************************************
197800***  DETERMINES IF COST OUTLIER
197900***  RECOMPUTES DOLLAR THRESHOLD TO BE SENT BACK WITH
198000***         RETURN CODE OF 02
198100
198200     MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
198300
198400     IF PPS-RTC = 02
198500             COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
198600                     (H-CAPI-COST-OUTLIER  +
198700                      H-OPER-COST-OUTLIER)
198800                             /
198900                    (H-CAPI-CSTCHG-RATIO  +
199000                     H-OPER-CSTCHG-RATIO)
199100             ON SIZE ERROR MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
199200
199300***********************************************************
199400***  DETERMINES IF COST OUTLIER WITH LOS IS > COVERED  DAYS
199500***         RETURN CODE OF 67
199600
199700     IF PPS-RTC = 02
199800         IF ((H-REG-DAYS + H-LTR-DAYS) < B-LOS) OR
199900            PPS-PC-COT-FLAG = 'Y'
200000             MOVE 67 TO PPS-RTC.
200100***********************************************************
200200
200300***********************************************************
200400***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF
200500***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
200600
200700     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
200800        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
200900                H-CAPI-OUTLIER-PART / P-NEW-CAPI-NEW-HARM-RATIO
201000         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
201100
201200     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
201300        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
201400                H-CAPI-OUTLIER-PART.
201500
201600     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
201700        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
201800                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1
201900         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
202000***********************************************************
202100
202200 3700-CALC-TECH-ADDON.
202300
202400***********************************************************
202500***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
202600***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
202700***      CALCULATED FOR ADD ON DONE BEFORE OUTLER
202800***      CALCULATED FOR ADD ON DONE BEFORE SPECIAL DRGS
202900
203000     COMPUTE PPS-OPER-HSP-PART ROUNDED =
203100         H-OPER-HSP-PCT * H-OPER-HSP-PART.
203200
203300     COMPUTE PPS-OPER-FSP-PART ROUNDED =
203400         H-OPER-FSP-PCT * H-OPER-FSP-PART.
203500
203600     MOVE ZERO TO PPS-OPER-DSH-ADJ.
203700
203800     IF  H-OPER-DSH NUMERIC
203900             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
204000              PPS-OPER-FSP-PART
204100              * H-OPER-DSH.
204200
204300     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
204400             PPS-OPER-FSP-PART *
204500             H-OPER-IME-TEACH.
204600
204700     PERFORM 4000-CALC-TECH-ADD-ON THRU 4000-EXIT.
204800
204900***********************************************************
205000 3800-CALC-TOT-AMT.
205100***********************************************************
205200***  CALCULATE TOTALS FOR CAPITAL
205300***  CALCULATE TOTALS FOR CAPITAL
205400
205500     MOVE P-NEW-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.
205600
205700     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
205800        MOVE P-NEW-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT
205900        MOVE 0.00 TO H-CAPI-HSP-PCT.
206000
206100     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
206200        MOVE 0    TO H-CAPI-OLD-HARMLESS
206300        MOVE 1.00 TO H-CAPI-FSP-PCT
206400        MOVE 0.00 TO H-CAPI-HSP-PCT.
206500
206600     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
206700        MOVE 0    TO H-CAPI-OLD-HARMLESS
206800        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT
206900        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.
207000
207100     COMPUTE H-CAPI-HSP ROUNDED =
207200         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.
207300
207400     COMPUTE H-CAPI-FSP ROUNDED =
207500         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.
207600
207700     MOVE P-NEW-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.
207800
207900     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.
208000
208100     COMPUTE H-CAPI-DSH-ADJ ROUNDED =
208200             H-CAPI-FSP
208300              * H-CAPI-DSH.
208400
208500     COMPUTE H-CAPI-IME-ADJ ROUNDED =
208600          H-CAPI-FSP *
208700                 H-WK-CAPI-IME-TEACH.
208800
208900     COMPUTE H-CAPI-OUTLIER ROUNDED =
209000             1.00 * H-CAPI-OUTLIER-PART.
209100
209200     COMPUTE H-CAPI2-B-FSP ROUNDED =
209300             1.00 * H-CAPI2-B-FSP-PART.
209400
209500     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =
209600             1.00 * H-CAPI2-B-OUTLIER-PART.
209700***********************************************************
209800***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER
209900***        THIS ZEROES OUT ALL CAPITAL DATA
210000
210100     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
210200        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.
210300***********************************************************
210400
210500***********************************************************
210600***  CALCULATE FINAL TOTALS FOR OPERATING
210700***  CALCULATE FINAL TOTALS FOR OPERATING
210800
210900     IF (H-CAPI-OUTLIER > 0 AND
211000         PPS-OPER-OUTLIER-PART = 0)
211100            COMPUTE PPS-OPER-OUTLIER-PART =
211200                    PPS-OPER-OUTLIER-PART + .01.
211300
211400     COMPUTE PPS-OPER-FSP-PART ROUNDED =
211500             H-OPER-FSP-PCT * H-OPER-FSP-PART.
211600
211700     COMPUTE PPS-OPER-HSP-PART ROUNDED =
211800             H-OPER-HSP-PCT * H-OPER-HSP-PART.
211900
212000     MOVE ZERO TO PPS-OPER-DSH-ADJ.
212100
212200     IF  H-OPER-DSH NUMERIC
212300         COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
212400              PPS-OPER-FSP-PART * H-OPER-DSH.
212500
212600     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
212700             PPS-OPER-FSP-PART * H-OPER-IME-TEACH.
212800
212900     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =
213000             H-OPER-FSP-PCT * H-OPER-OUTLIER-PART.
213100
213200     IF HMO-TAG  = 'Y'
213300        PERFORM 3850-HMO-IME-ADJ.
213400
213500***********************************************************
213600***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
213700***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
213800
213900     COMPUTE H-CAPI-TOTAL-PAY ROUNDED =
214000             H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
214100             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
214200             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM.
214300
214400     MOVE H-NEW-TECH-PAY-ADD-ON TO PPS-NEW-TECH-PAY-ADD-ON.
214500
214600     COMPUTE PPS-TOTAL-PAYMENT ROUNDED =
214700             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
214800             PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
214900                     PPS-OPER-IME-ADJ
215000                           +
215100                 PPS-NEW-TECH-PAY-ADD-ON
215200                           +
215300                H-WK-PASS-AMT-PLUS-MISC
215400                           +
215500                   H-CAPI-TOTAL-PAY.
215600
215700 3850-HMO-IME-ADJ.
215800***********************************************************
215900***  HMO CALC FOR PASS-THRU ADDON
216000***  HMO CALC FOR PASS-THRU ADDON
216100
216200***  HMO DIR-MED-ED  ---- NO LONGER PAID AS OF 10/01/2002
216300
216400     COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =
216500          (P-NEW-PASS-AMT-PLUS-MISC -
216600           P-NEW-PASS-AMT-DIR-MED-ED) * B-LOS.
216700
216800***********************************************************
216900***  HMO IME ADJUSTMENT --- NO LONGER PAID AS OF 10/01/2002
217000
217100     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
217200                   PPS-OPER-IME-ADJ * .0.
217300
217400***********************************************************
217500
217600 3900A-CALC-OPER-DSH.
217700
217800***  OPERATING DSH CALCULATION EFFECTIVE APRIL 1, 2001
217900***  OPERATING DSH CALCULATION EFFECTIVE APRIL 1, 2001
218000
218100      MOVE 0.0000 TO H-OPER-DSH.
218200
218300      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO
218400                                     + P-NEW-MEDICAID-RATIO).
218500
218600***********************************************************
218700*****    0-99 BEDS
218800      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
218900                               AND H-WK-OPER-DSH > .1499
219000                               AND H-WK-OPER-DSH < .1923
219100        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
219200                                      * .65 + .025.
219300
219400      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
219500                               AND H-WK-OPER-DSH > .1922
219600             MOVE .0525 TO H-OPER-DSH.
219700
219800***********************************************************
219900*****   100 + BEDS
220000
220100      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
220200                               AND H-WK-OPER-DSH > .1499
220300                               AND H-WK-OPER-DSH < .2021
220400        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
220500                                      * .65 + .025.
220600
220700      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
220800                               AND H-WK-OPER-DSH > .202
220900        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
221000                                      * .825 + .0588.
221100
221200***********************************************************
221300*****   OTHER RURAL HOSPITALS LESS THEN 500 BEDS
221400
221500      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE < 500
221600                               AND H-WK-OPER-DSH > .1499
221700                               AND H-WK-OPER-DSH < .1923
221800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
221900                                 * .65 + .025.
222000
222100      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE < 500
222200                               AND H-WK-OPER-DSH > .1922
222300        MOVE .0525 TO H-OPER-DSH.
222400
222500***********************************************************
222600*****   OTHER RURAL HOSPITALS 500 BEDS +
222700
222800      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE > 499
222900                               AND H-WK-OPER-DSH > .1499
223000                               AND H-WK-OPER-DSH < .2021
223100        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
223200                                 * .65 + .025.
223300
223400      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE > 499
223500                               AND H-WK-OPER-DSH > .202
223600        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
223700                                 * .825 + .0588.
223800
223900***********************************************************
224000*****   RURAL HOSPITALS SCH
224100
224200      IF W-SIZE = 'R'
224300         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
224400                               AND H-WK-OPER-DSH > .1499
224500                               AND H-WK-OPER-DSH < .1923
224600         COMPUTE H-OPER-DSH-SCH ROUNDED = (H-WK-OPER-DSH - .15)
224700                                 * .65 + .025
224800         MOVE H-OPER-DSH-SCH TO H-OPER-DSH.
224900      IF W-SIZE = 'R'
225000         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
225100                               AND H-WK-OPER-DSH > .1922
225200                               AND H-WK-OPER-DSH < .3000
225300         MOVE .0525 TO H-OPER-DSH-SCH
225400                       H-OPER-DSH.
225500      IF W-SIZE = 'R'
225600         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
225700                               AND H-WK-OPER-DSH > .2999
225800         MOVE .10 TO H-OPER-DSH-SCH
225900                     H-OPER-DSH.
226000***********************************************************
226100*****   RURAL HOSPITALS RRC
226200
226300      IF W-SIZE = 'R'
226400         IF (P-NEW-PROVIDER-TYPE = '07' OR '17' OR '22')
226500                               AND H-WK-OPER-DSH > .1499
226600                               AND H-WK-OPER-DSH < .1923
226700         COMPUTE H-OPER-DSH-RRC ROUNDED = (H-WK-OPER-DSH - .15)
226800                                 * .65 + .025.
226900      IF W-SIZE = 'R'
227000         IF (P-NEW-PROVIDER-TYPE = '07' OR '17' OR '22')
227100                               AND H-WK-OPER-DSH > .1922
227200                               AND H-WK-OPER-DSH < .3000
227300         MOVE .0525 TO H-OPER-DSH-RRC.
227400
227500      IF W-SIZE = 'R'
227600         IF (P-NEW-PROVIDER-TYPE = '07' OR '17' OR '22')
227700                               AND H-WK-OPER-DSH > .2999
227800         COMPUTE H-OPER-DSH-RRC ROUNDED = (H-WK-OPER-DSH - .30)
227900                                 * .60 + .0525.
228000
228100***********************************************************
228200*****   RURAL HOSPITALS BOTH SCH AND RRC
228300
228400      IF W-SIZE = 'R'
228500         IF (P-NEW-PROVIDER-TYPE = '17' OR '22')
228600                MOVE H-OPER-DSH-RRC TO H-OPER-DSH
228700             IF H-OPER-DSH-SCH > H-OPER-DSH-RRC
228800                MOVE H-OPER-DSH-SCH TO H-OPER-DSH.
228900
229000***********************************************************
229100*** RRC ONLY
229200      IF W-SIZE = 'R'
229300         IF (P-NEW-PROVIDER-TYPE = '07')
229400                MOVE H-OPER-DSH-RRC TO H-OPER-DSH.
229500
229600***********************************************************
229700
229800      COMPUTE H-OPER-DSH ROUNDED = H-OPER-DSH * 1.0000.
229900
230000 3900A-EXIT.   EXIT.
230100
230200 4000-CALC-TECH-ADD-ON.
230300
230400     IF '0011   ' =  B-PRIN-PROC-CODE   OR
230500                     B-OTHER-PROC-CODE1 OR
230600                     B-OTHER-PROC-CODE2 OR
230700                     B-OTHER-PROC-CODE3 OR
230800                     B-OTHER-PROC-CODE4 OR
230900                     B-OTHER-PROC-CODE5
231000           MOVE  6800.00 TO H-CSTMED-SERV0011
231100     ELSE
231200           GO TO 4000-EXIT.
231300
231400     COMPUTE H-BASE-DRG-PAYMENT ROUNDED =
231500             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
231600             PPS-OPER-DSH-ADJ + PPS-OPER-IME-ADJ.
231700
231800     COMPUTE H-LESSER-TECH-1 ROUNDED =
231900             .5 * H-CSTMED-SERV0011.
232000
232100     COMPUTE H-LESSER-TECH-2 ROUNDED =
232200           ((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
232300                     H-BASE-DRG-PAYMENT) * .5.
232400
232500     IF H-LESSER-TECH-2 > 0
232600        IF H-LESSER-TECH-1 < H-LESSER-TECH-2
232700           MOVE H-LESSER-TECH-1 TO H-NEW-TECH-PAY-ADD-ON
232800        ELSE
232900           MOVE H-LESSER-TECH-2 TO H-NEW-TECH-PAY-ADD-ON
233000     ELSE
233100        MOVE ZEROES          TO H-NEW-TECH-PAY-ADD-ON.
233200
233300
233400 4000-EXIT.    EXIT.
233500******        L A S T   S O U R C E   S T A T E M E N T   *****
