000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPCAL058.
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     'PPCAL058      - W O R K I N G   S T O R A G E'.
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C05.8'.
002000***************************************************************
002100***************************************************************
002200****ATTENTION******ATTENTION********ATTENTION*******ATTENTION**
002300****ATTENTION******ATTENTION********ATTENTION*******ATTENTION**
002400***************************************************************
002500*    IF YOU ARE A HMO, YOU WANT TO PAY CLAIMS AS A HMO        *
002600*     - CHANGE THE > 01 HMO-FLAG < TO THE VALUE OF 'Y' *
002700*     - CHANGE ALL PPCAL___ PROGRAMS BACK TO PPCAL983 *
002800*        BEFORE YOU COMPILE AND LINK THEM *
002900*     - THIS WILL ALLOW YOU TO PAY ALL YOUR CLAIMS WITH *
003000*        AN HMO ADJUSTMENT *
003100***************************************************************
003200***************************************************************
003300 01  HMO-FLAG                       PIC X      VALUE 'N'.
003400***************************************************************
003500***************************************************************
003600 01  HMO-TAG                        PIC X      VALUE SPACE.
003700 01  OUTLIER-RECON-FLAG             PIC X      VALUE 'N'.
003800 01  TEMP-RELIEF-FLAG               PIC X      VALUE 'N'.
003900 01  NON-TEMP-RELIEF-PAYMENT        PIC 9(07)V9(02) VALUE ZEROES.
004000 01  WK-H-OPER-DOLLAR-THRESHOLD     PIC 9(07)V9(09) VALUE ZEROES.
004100 01  WK-LOW-VOL25PCT                PIC 99V999 VALUE 01.000.
004200 01  R1                             PIC S9(04) COMP SYNC.
004300 01  R2                             PIC S9(04) COMP SYNC.
004400 01  R3                             PIC S9(04) COMP SYNC.
004500 01  R4                             PIC S9(04) COMP SYNC.
004600
004700 01  H-OPER-DSH-SCH               PIC 9(01)V9(04).
004800 01  H-OPER-DSH-RRC               PIC 9(01)V9(04).
004900
005000***************************************************************
005100***************************************************************
005200*    4 SETS OF LABOR AND NONLABOR RATES                       *
005300*    LAYUP TABLES AREA FOR FY2005 RATES                       *
005400***************************************************************
005500***************************************************************
005600* TABLE 1                                                     *
005700*    (71.1% LABOR SHARE/28.9% NONLABOR SHARE)                 *
005800*    (FULL UPDATE (.711)                                      *
005900*    (QUALITY = 1 WAGE INDEX > 1)                             *
006000***************************************************************
006100 01  TB1-RATE-TABLE.
006200     02  TB1-RATE-WORK.
006300*RATE 20041001 REGION  LABOR AND NON-LABOR RATES
006400*                  R3=1     /     R3=2
006500*               LARGE URBAN / OTHER URBAN
006600*               LABOR / NON / LABOR / NON
006700*                     /LABOR/       /LABOR
006800*             --------------------------------------------
006900         05  FILLER PIC X(08) VALUE '20041001'.
007000         05  TB1-NAT    PIC X(30) VALUE
007100            ' 0323807 131618 0323807 131618'.
007200         05  TB1-PR     PIC X(30) VALUE
007300            ' 0155479 062584 0155479 062584'.
007400         05  TB1-NATPR  PIC X(30) VALUE
007500            ' 0323807 131618 0323807 131618'.
007600***************************************************************
007700     02  TB1-RATE-TAB REDEFINES TB1-RATE-WORK.
007800         05  TB1-RATE-PERIOD            OCCURS 1.
007900             10  TB1-RATE-EFF-DATE      PIC X(08).
008000             10  TB1-REG-NAT            OCCURS 3.
008100                 15  TB1-LARGE-OTHER    OCCURS 2.
008200                     20  FILLER         PIC X(01).
008300                     20  TB1-REG-LABOR  PIC 9(05)V9(02).
008400                     20  FILLER         PIC X(01).
008500                     20  TB1-REG-NLABOR PIC 9(04)V9(02).
008600
008700***************************************************************
008800***************************************************************
008900* TABLE 2                                                     *
009000*    (71.1% LABOR SHARE/28.9% NONLABOR SHARE)                 *
009100*    (REDUCED UPDATE (.711)                                   *
009200*    (QUALITY NOT = 1 WAGE INDEX > 1)                         *
009300***************************************************************
009400 01  TB2-RATE-TABLE.
009500     02  TB2-RATE-WORK.
009600*RATE 20041001 REGION  LABOR AND NON-LABOR RATES
009700*                  R3=1     /     R3=2
009800*               LARGE URBAN / OTHER URBAN
009900*               LABOR / NON / LABOR / NON
010000*                     /LABOR/       /LABOR
010100*             --------------------------------------------
010200         05  FILLER PIC X(08) VALUE '20041001'.
010300         05  TB2-NAT    PIC X(30) VALUE
010400            ' 0322553 131108 0322553 131108'.
010500         05  TB2-PR     PIC X(30) VALUE
010600            ' 0154877 062342 0154877 062342'.
010700         05  TB2-NATPR  PIC X(30) VALUE
010800            ' 0322553 131108 0322553 131108'.
010900***************************************************************
011000     02  TB2-RATE-TAB REDEFINES TB2-RATE-WORK.
011100         05  TB2-RATE-PERIOD             OCCURS 1.
011200             10  TB2-RATE-EFF-DATE       PIC X(08).
011300             10  TB2-REG-NAT             OCCURS 3.
011400                 15  TB2-LARGE-OTHER     OCCURS 2.
011500                     20  FILLER          PIC X(01).
011600                     20  TB2-REG-LABOR   PIC 9(05)V9(02).
011700                     20  FILLER          PIC X(01).
011800                     20  TB2-REG-NLABOR  PIC 9(04)V9(02).
011900***************************************************************
012000***************************************************************
012100* TABLE 3                                                     *
012200*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *
012300*    (FULL UPDATE (.62%)                                      *
012400*    (QUALITY = 1 WAGE INDEX <= 1)                            *
012500***************************************************************
012600 01  TB3-RATE-TABLE.
012700     02  TB3-RATE-WORK.
012800*RATE 20041001 REGION  LABOR AND NON-LABOR RATES
012900*                  R3=1     /     R3=2
013000*               LARGE URBAN / OTHER URBAN
013100*               LABOR / NON / LABOR / NON
013200*                     /LABOR/       /LABOR
013300*             --------------------------------------------
013400         05  FILLER PIC X(08) VALUE '20041001'.
013500         05  TB3-NAT    PIC X(30) VALUE
013600            ' 0282364 173062 0282364 173062'.
013700         05  TB3-PR     PIC X(30) VALUE
013800            ' 0135199 082864 0135199 082864'.
013900         05  TB3-NATPR  PIC X(30) VALUE
014000            ' 0282364 173062 0282364 173062'.
014100***************************************************************
014200     02  TB3-RATE-TAB REDEFINES TB3-RATE-WORK.
014300         05  TB3-RATE-PERIOD            OCCURS 1.
014400             10  TB3-RATE-EFF-DATE      PIC X(08).
014500             10  TB3-REG-NAT            OCCURS 3.
014600                 15  TB3-LARGE-OTHER    OCCURS 2.
014700                     20  FILLER         PIC X(01).
014800                     20  TB3-REG-LABOR  PIC 9(05)V9(02).
014900                     20  FILLER         PIC X(01).
015000                     20  TB3-REG-NLABOR PIC 9(04)V9(02).
015100
015200***************************************************************
015300***************************************************************
015400* TABLE 4                                                     *
015500*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *
015600*    (REDUCED UPDATE (.62%)                                   *
015700*    (QUALITY NOT = 1 WAGE INDEX <=1)                         *
015800***************************************************************
015900 01  TB4-RATE-TABLE.
016000     02  TB4-RATE-WORK.
016100*RATE 20041001 REGION  LABOR AND NON-LABOR RATES
016200*                  R3=1     /     R3=2
016300*               LARGE URBAN / OTHER URBAN
016400*               LABOR / NON / LABOR / NON
016500*                     /LABOR/       /LABOR
016600*             --------------------------------------------
016700         05  FILLER PIC X(08) VALUE '20041001'.
016800         05  TB4-NAT    PIC X(30) VALUE
016900            ' 0281270 172391 0281270 172391'.
017000         05  TB4-PR     PIC X(30) VALUE
017100            ' 0134676 082543 0134676 082543'.
017200         05  TB4-NATPR  PIC X(30) VALUE
017300            ' 0281270 172391 0281270 172391'.
017400***************************************************************
017500     02  TB4-RATE-TAB REDEFINES TB4-RATE-WORK.
017600         05  TB4-RATE-PERIOD             OCCURS 1.
017700             10  TB4-RATE-EFF-DATE       PIC X(08).
017800             10  TB4-REG-NAT             OCCURS 3.
017900                 15  TB4-LARGE-OTHER     OCCURS 2.
018000                     20  FILLER          PIC X(01).
018100                     20  TB4-REG-LABOR   PIC 9(05)V9(02).
018200                     20  FILLER          PIC X(01).
018300                     20  TB4-REG-NLABOR  PIC 9(04)V9(02).
018400***************************************************************
018500***************************************************************
018600***************************************************************
018700***************************************************************
018800
018900***************************************************************
019000*    LAYUP TABLE AREA FOR FY2005 DRGS                         *
019100***************************************************************
019200 01  DRG-TABLE.
019300     05  D-TAB.
019400       10  FILLER                  PIC X(08) VALUE
019500      '20041001'.
019600       10  FILLER                  PIC X(56) VALUE
019700     '03334407500100019467036000460197671270012700000000000000'.
019800       10  FILLER                  PIC X(56) VALUE
019900     '00000000000000007850022000340265700660009601558801900027'.
020000       10  FILLER                  PIC X(56) VALUE
020100     '01243504300059012241047000620087710290003900913604300056'.
020200       10  FILLER                  PIC X(56) VALUE
020300     '00817104000049012719046000590094820370004701245404700062'.
020400       10  FILLER                  PIC X(56) VALUE
020500     '00699602500032009919041000540070480280003502831808000104'.
020600       10  FILLER                  PIC X(56) VALUE
020700     '01523805000067011206040000510083650320004201013003600049'.
020800       10  FILLER                  PIC X(56) VALUE
020900     '00614302500032005680024000320134960320005101325404400060'.
021000       10  FILLER                  PIC X(56) VALUE
021100     '00706102600034003343020000200093850300004000597802000025'.
021200       10  FILLER                  PIC X(56) VALUE
021300     '00210001600016009827036000480064360250003100674601300016'.
021400       10  FILLER                  PIC X(56) VALUE
021500     '01154202700039005268017000230062820160002200962102900041'.
021600       10  FILLER                  PIC X(56) VALUE
021700     '00340301600016007373020000280064510270003500659404000049'.
021800       10  FILLER                  PIC X(56) VALUE
021900     '00726802600032007758033000430055020250003200299802900029'.
022000       10  FILLER                  PIC X(56) VALUE
022100     '01748003300046008708015000190079580180002900788201600022'.
022200       10  FILLER                  PIC X(56) VALUE
022300     '01210302200036004860032000320091110190002900908201900028'.
022400       10  FILLER                  PIC X(56) VALUE
022500     '01027502500039002759015000150064200180002500210101500015'.
022600       10  FILLER                  PIC X(56) VALUE
022700     '01531703300058002975013000130138870300004401311704200066'.
022800       10  FILLER                  PIC X(56) VALUE
022900     '00595902300028005861024000310084020280003600665503000037'.
023000       10  FILLER                  PIC X(56) VALUE
023100     '00496002400029004652024000290052150300003600737802700036'.
023200       10  FILLER                  PIC X(56) VALUE
023300     '00834703300045003382021000210303370760009902824008300110'.
023400       10  FILLER                  PIC X(56) VALUE
023500     '01223103500047012478055000650158720660008400849704300054'.
023600       10  FILLER                  PIC X(56) VALUE
023700     '01531106100061013717051000680098060430005300553902600032'.
023800       10  FILLER                  PIC X(56) VALUE
023900     '01230904800064006976028000360135420490006400908904100050'.
024000       10  FILLER                  PIC X(56) VALUE
024100     '01047904800058006172033000390062710290003401193004900062'.
024200       10  FILLER                  PIC X(56) VALUE
024300     '00712303200040011476046000620060130300003700743903600044'.
024400       10  FILLER                  PIC X(56) VALUE
024500     '00542802800034005534027000310071780240003200544501800021'.
024600       10  FILLER                  PIC X(56) VALUE
024700     '00871103300043005473020000251955142570042207918012400146'.
024800       10  FILLER                  PIC X(56) VALUE
024900     '05793708300100073062096001130537570930010605170206900096'.
025000       10  FILLER                  PIC X(56) VALUE
025100     '03945006800078039587061000870244880280003700000000000000'.
025200       10  FILLER                  PIC X(56) VALUE
025300     '03106310700136016955063000870359280460007002356103000043'.
025400       10  FILLER                  PIC X(56) VALUE
025500     '01352902600043016751020000300143220320005402305105600089'.
025600       10  FILLER                  PIC X(56) VALUE
025700     '01620005300066010127029000360154210290004701456403300045'.
025800       10  FILLER                  PIC X(56) VALUE
025900     '01114602200028026051090001150103900410005200747504600055'.
026000       10  FILLER                  PIC X(56) VALUE
026100     '01034601700027009566045000560056550330004000642802300029'.
026200       10  FILLER                  PIC X(56) VALUE
026300     '00541101800022006091025000320092640340004500590202100026'.
026400       10  FILLER                  PIC X(56) VALUE
026500     '00824903300033008413031000400052340200002500527502000025'.
026600       10  FILLER                  PIC X(56) VALUE
026700     '00761702800035005929021000250056430170002101250204000057'.
026800       10  FILLER                  PIC X(56) VALUE
026900     '00585002000026026435086001010151940540006003387110000122'.
027000       10  FILLER                  PIC X(56) VALUE
027100     '01435205600061027489089001100129600430005401881206600080'.
027200       10  FILLER                  PIC X(56) VALUE
027300     '01112904600051040524099001330127080310004100849506000060'.
027400       10  FILLER                  PIC X(56) VALUE
027500     '01291404000056006564021000260138360380005100822502200027'.
027600       10  FILLER                  PIC X(56) VALUE
027700     '01182403000044006643016000200100300350003702292106900083'.
027800       10  FILLER                  PIC X(56) VALUE
027900     '01187803700043014723035000470089560190002301242503200047'.
028000       10  FILLER                  PIC X(56) VALUE
028100     '00748201900025028628075001080118430320004301396805100070'.
028200       10  FILLER                  PIC X(56) VALUE
028300     '00743702700037010109038000480057040250002901114904100053'.
028400       10  FILLER                  PIC X(56) VALUE
028500     '00933903700046006791026000310110590460005900975304200054'.
028600       10  FILLER                  PIC X(56) VALUE
028700     '00553902800034008255034000440058440230002900485102500033'.
028800       10  FILLER                  PIC X(56) VALUE
028900     '00912403400047003238029000290081670310004301113704100056'.
029000       10  FILLER                  PIC X(56) VALUE
029100     '00591802400031005210033000430404970930013301626904200056'.
029200       10  FILLER                  PIC X(56) VALUE
029300     '03416110300127015689054000660288860850010201585004600055'.
029400       10  FILLER                  PIC X(56) VALUE
029500     '02517907400091011761038000440233800680009502960306400103'.
029600       10  FILLER                  PIC X(56) VALUE
029700     '03752210200141013386047000630138250500006701144004300057'.
029800       10  FILLER                  PIC X(56) VALUE
029900     '01212204500061007271030000380118700410005300691702300029'.
030000       10  FILLER                  PIC X(56) VALUE
030100     '02033204300048018817061000700126750440004801416211100111'.
030200       10  FILLER                  PIC X(56) VALUE
030300     '01895206600091000000000000000000000000000001896603800066'.
030400       10  FILLER                  PIC X(56) VALUE
030500     '02933909000130015762043000550101910270003200588505300053'.
030600       10  FILLER                  PIC X(56) VALUE
030700     '00000000000000000000000000000107640220003100797201600019'.
030800       10  FILLER                  PIC X(56) VALUE
030900     '01197903700052015306044000650083390210002701164902800042'.
031000       10  FILLER                  PIC X(56) VALUE
031100     '00735301900025013454037000570000000000000000996401800028'.
031200       10  FILLER                  PIC X(56) VALUE
031300     '01954205400076011643025000340075120370004800754403900047'.
031400       10  FILLER                  PIC X(56) VALUE
031500     '00606303000038013708065000860108110500006301350004900067'.
031600       10  FILLER                  PIC X(56) VALUE
031700     '00667903000037011618053000700077120370004600713703600046'.
031800       10  FILLER                  PIC X(56) VALUE
031900     '00474102600033005977029000360058250260003300841703800048'.
032000       10  FILLER                  PIC X(56) VALUE
032100     '00700602600038006908031000390048300230002800255501800018'.
032200       10  FILLER                  PIC X(56) VALUE
032300     '00766403700046004555025000310029760290002900821803900051'.
032400       10  FILLER                  PIC X(56) VALUE
032500     '00911702100027007155016000180098160180002800698201200014'.
032600       10  FILLER                  PIC X(56) VALUE
032700     '00972501600021009711032000470204130830011301067904900065'.
032800       10  FILLER                  PIC X(56) VALUE
032900     '01598004200068008616023000320090360280004501205202400037'.
033000       10  FILLER                  PIC X(56) VALUE
033100     '01756006100086008173026000370102330550007101021904500059'.
033200       10  FILLER                  PIC X(56) VALUE
033300     '00596802900037011249046000630057350220003000723303700047'.
033400       10  FILLER                  PIC X(56) VALUE
033500     '00887704700057005531035000420077850420004200725903200041'.
033600       10  FILLER                  PIC X(56) VALUE
033700     '00494402300029002588022000220075700350004700429102300030'.
033800       10  FILLER                  PIC X(56) VALUE
033900     '02063707900104019324042000560190920750010102129103500045'.
034000       10  FILLER                  PIC X(56) VALUE
034100     '00962901700026009022016000220069480130001502722207100103'.
034200       10  FILLER                  PIC X(56) VALUE
034300     '01416203300047007809034000450076860290003800842003800049'.
034400       10  FILLER                  PIC X(56) VALUE
034500     '00499202600032005883027000380093550380005301095504600060'.
034600       10  FILLER                  PIC X(56) VALUE
034700     '00644002800035031515070000820232120610007702347906000086'.
034800       10  FILLER                  PIC X(56) VALUE
034900     '01166202700033012609034000540061430170002001590503800060'.
035000       10  FILLER                  PIC X(56) VALUE
035100     '00899501600020011659030000440062870150001801070403100046'.
035200       10  FILLER                  PIC X(56) VALUE
035300     '00657501700022004988023000230208610360006801282304900065'.
035400       10  FILLER                  PIC X(56) VALUE
035500     '00809302300033011486042000580061610210002700877604300053'.
035600       10  FILLER                  PIC X(56) VALUE
035700     '00568103100037005257030000370083310240003200492401600019'.
035800       10  FILLER                  PIC X(56) VALUE
035900     '00663002900038004374021000260037300310003100678302500034'.
036000       10  FILLER                  PIC X(56) VALUE
036100     '00455101600022003212016000160105950410005600603202400032'.
036200       10  FILLER                  PIC X(56) VALUE
036300     '00933603700053014275037000450108710260002900854202500033'.
036400       10  FILLER                  PIC X(56) VALUE
036500     '00582101700020012137034000570121210320005300285502400024'.
036600       10  FILLER                  PIC X(56) VALUE
036700     '01268801900029007945024000320015520170001701298001600025'.
036800       10  FILLER                  PIC X(56) VALUE
036900     '01193203100049010888045000600052680200002700729003200041'.
037000       10  FILLER                  PIC X(56) VALUE
037100     '00447902000025007478036000450023810130001300761503000041'.
037200       10  FILLER                  PIC X(56) VALUE
037300     '01893604800064015316047000580089590290003100741101700020'.
037400       10  FILLER                  PIC X(56) VALUE
037500     '02230206600083011696033000410080290230002500867402100027'.
037600       10  FILLER                  PIC X(56) VALUE
037700     '01125002300036003043014000140097250270003800985003100044'.
037800       10  FILLER                  PIC X(56) VALUE
037900     '02063605200079012628049000670054950230003201197205200068'.
038000       10  FILLER                  PIC X(56) VALUE
038100     '00621302400033008981042000540062210320003500546002700035'.
038200       10  FILLER                  PIC X(56) VALUE
038300     '00360102000022006642027000330058100440004400540002600036'.
038400       10  FILLER                  PIC X(56) VALUE
038500     '01119903200048007809019000220037570200003000353901500019'.
038600       10  FILLER                  PIC X(56) VALUE
038700     '00663301500021002345015000200050700270003800291301600020'.
038800       10  FILLER                  PIC X(56) VALUE
038900     '01386501800018045721179001790312261330013301884108600086'.
039000       10  FILLER                  PIC X(56) VALUE
039100     '03207604700047011352034000340015370310003103238706700094'.
039200       10  FILLER                  PIC X(56) VALUE
039300     '01358109100091018868044000720083990320004402529305300109'.
039400       10  FILLER                  PIC X(56) VALUE
039500     '01228403700051012347046000590065830260003300000000000000'.
039600       10  FILLER                  PIC X(56) VALUE
039700     '02959808000115011533028000410181720570008000892303000041'.
039800       10  FILLER                  PIC X(56) VALUE
039900     '01925504900049027644068000970121580330004002198004900083'.
040000       10  FILLER                  PIC X(56) VALUE
040100     '01309304400060011163031000400039510470004700642401200016'.
040200       10  FILLER                  PIC X(56) VALUE
040300     '01397405400073006494029000380362911020014101598205500074'.
040400       10  FILLER                  PIC X(56) VALUE
040500     '01413203800054010726048000620088980360004600602102700033'.
040600       10  FILLER                  PIC X(56) VALUE
040700     '00810703200042005944026000330178340580008102432707600130'.
040800       10  FILLER                  PIC X(56) VALUE
040900     '00683902800038004845031000420051240320004700776204800075'.
041000       10  FILLER                  PIC X(56) VALUE
041100     '00824804400059006608056000780048250390005600648603100045'.
041200       10  FILLER                  PIC X(56) VALUE
041300     '00283602200029000000000000000000000000000000000000000000'.
041400       10  FILLER                  PIC X(56) VALUE
041500     '00000000000000000000000000000187780520008601841505700088'.
041600       10  FILLER                  PIC X(56) VALUE
041700     '00869402100031024839058000880100740260003400770503100041'.
041800       10  FILLER                  PIC X(56) VALUE
041900     '00512102200028002985024000240054310190002600098202900029'.
042000       10  FILLER                  PIC X(56) VALUE
042100     '00851502600037004314016000200026500210002101041803500050'.
042200       10  FILLER                  PIC X(56) VALUE
042300     '00522602200028008494030000430048040180002400000000000000'.
042400       10  FILLER                  PIC X(56) VALUE
042500     '00000000000000000000000000000000000000000000000000000000'.
042600       10  FILLER                  PIC X(56) VALUE
042700     '01211402200036008865089001100070730310004000512302400030'.
042800       10  FILLER                  PIC X(56) VALUE
042900     '00597602000029006416024000410056040200003203947209600132'.
043000       10  FILLER                  PIC X(56) VALUE
043100     '00000000000000000000000000000305230460005300000000000000'.
043200       10  FILLER                  PIC X(56) VALUE
043300     '03538607600131000000000000000361660800011302248707800108'.
043400       10  FILLER                  PIC X(56) VALUE
043500     '02018105600084023989048000730144020230003009869613200189'.
043600       10  FILLER                  PIC X(56) VALUE
043700     '06485119100225031977093001180000000000000005086908800129'.
043800       10  FILLER                  PIC X(56) VALUE
043900     '03180807900098047311087001270197150530007404889111900170'.
044000       10  FILLER                  PIC X(56) VALUE
044100     '01776405900083010543038000530170280270003303850909400150'.
044200       10  FILLER                  PIC X(56) VALUE
044300     '01836804500061010218021000270884401390016905807206600089'.
044400       10  FILLER                  PIC X(56) VALUE
044500     '03525105200063026527036000390144090320004400943601900023'.
044600       10  FILLER                  PIC X(56) VALUE
044700     '02428508000101014275051000600121670290003813006323100293'.
044800       10  FILLER                  PIC X(56) VALUE
044900     '01872702300044040604116001620186180660009101335805100073'.
045000       10  FILLER                  PIC X(56) VALUE
045100     '00685903400047012739045000680070580290004106020211400139'.
045200       10  FILLER                  PIC X(56) VALUE
045300     '06321208900100000000000000000543390270004702645703700046'.
045400       10  FILLER                  PIC X(56) VALUE
045500     '02110601800025017509023000350241460310004901630001600021'.
045600       10  FILLER                  PIC X(56) VALUE
045700     '00698804200056004947076000950038850320003900741402600033'.
045800       10  FILLER                  PIC X(56) VALUE
045900     '11374908200158029741033000430232820160002106848113800170'.
046000       10  FILLER                  PIC X(56) VALUE
046100     '02216505200082011945025000330309800650009701467602900039'.
046200       10  FILLER                  PIC X(56) VALUE
046300     '01649802600040010515016000190769730620009206241703500054'.
046400       10  FILLER                  PIC X(56) VALUE
046500     '01796104700069009940021000290338090740011401286402900040'.
046600       10  FILLER                  PIC X(56) VALUE
046700     '20041438700459120286275003400445790870012400000000000000'.
046800     05  DRGX-TAB REDEFINES D-TAB.
046900         10  DRGX-PERIOD               OCCURS 1
047000                                        INDEXED BY DX5.
047100             15  DRGX-EFF-DATE         PIC X(08).
047200             15  DRG-DATA              OCCURS 544
047300                                        INDEXED BY DX6.
047400                 20  DRG-WT            PIC 9(02)V9(04).
047500                 20  DRG-ALOS          PIC 9(02)V9(01).
047600                 20  DRG-DAYS-TRIM     PIC 9(02).
047700                 20  DRG-ARITH-ALOS    PIC 9(02)V9(01).
047800
047900 01  HOLD-AREA.
048000     02  HOLD-PPS-COMPONENTS.
048100         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
048200         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
048300
048400         05  H-OPER-HSP-PART              PIC 9(06)V9(09).
048500         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).
048600
048700         05  H-OPER-FSP-PART              PIC 9(06)V9(09).
048800         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).
048900         05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).
049000
049100         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).
049200         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).
049300         05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).
049400
049500         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).
049600         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).
049700
049800         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).
049900         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).
050000
050100         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).
050200         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).
050300
050400         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).
050500         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).
050600         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).
050700         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).
050800         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).
050900         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
051000         05  H-CAPI-COLA                  PIC 9(01)V9(03).
051100         05  H-CAPI-SCH                   PIC 9(05)V9(02).
051200         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).
051300         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).
051400         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).
051500         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).
051600         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).
051700         05  H-CAPI-GAF                   PIC 9(05)V9(04).
051800         05  H-PR-CAPI-GAF                PIC 9(05)V9(04).
051900         05  H-BLEND-GAF                  PIC 9(05)V9(04).
052000         05  H-WAGE-INDEX                 PIC 9(02)V9(04).
052100         05  H-COV-DAYS                   PIC 9(3).
052200         05  H-PERDIEM-DAYS               PIC 9(3).
052300         05  H-REG-DAYS                   PIC 9(3).
052400         05  H-LTR-DAYS                   PIC 9(3).
052500         05  H-DSCHG-FRCTN                PIC 9(1)V9999.
052600         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.
052700         05  H-ALOS                       PIC 9(02)V9(01).
052800         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).
052900         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).
053000         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).
053100         05  H-CST-THRESH                 PIC 9(05)V9(02).
053200         05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).
053300         05  H-BUDG-NUTR01                PIC 9(01)V9(06).
053400         05  H-BUDG-NUTR02                PIC 9(01)V9(06).
053500         05  H-BUDG-NUTR03                PIC 9(01)V9(06).
053600         05  H-BUDG-NUTR04                PIC 9(01)V9(06).
053700         05  H-BUDG-NUTR05                PIC 9(01)V9(06).
053800         05  H-UPDATE-01                  PIC 9(01)V9(04).
053900         05  H-UPDATE-02                  PIC 9(01)V9(04).
054000         05  H-UPDATE-03                  PIC 9(01)V9(04).
054100         05  H-UPDATE-04                  PIC 9(01)V9(04).
054200         05  H-UPDATE-05                  PIC 9(01)V9(04).
054300         05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).
054400         05  H-HSP-UPDATE94               PIC 9(01)V9(04).
054500         05  H-HSP-UPDATE95               PIC 9(01)V9(04).
054600         05  H-HSP-UPDATE96               PIC 9(01)V9(04).
054700         05  H-HSP-UPDATE97               PIC 9(01)V9(04).
054800         05  H-HSP-UPDATE98               PIC 9(01)V9(04).
054900         05  H-HSP-UPDATE99               PIC 9(01)V9(04).
055000         05  H-HSP-UPDATE00               PIC 9(01)V9(04).
055100         05  H-HSP-UPDATE01               PIC 9(01)V9(04).
055200         05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).
055300         05  H-FEDERAL-RATE               PIC 9(04)V9(02).
055400         05  H-LABOR-PCT                  PIC 9(01)V9(04).
055500         05  H-NONLABOR-PCT               PIC 9(01)V9(04).
055600         05  H-PR-LABOR-PCT               PIC 9(01)V9(04).
055700         05  H-PR-NONLABOR-PCT            PIC 9(01)V9(04).
055800         05  H-HSP-RATE                   PIC 9(06)V9(09).
055900         05  H-FSP-RATE                   PIC 9(06)V9(09).
056000         05  H-OUTLIER-OFFSET-NAT         PIC 9(01)V9(06).
056100         05  H-OUTLIER-OFFSET-PR          PIC 9(01)V9(06).
056200         05  H-WK-OPER-DSH                PIC 9(01)V9(04).
056300         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).
056400         05  H-OPER-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
056500         05  H-CAPI-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
056600         05  H-DSH-REDUCT-FACTOR          PIC 9(01)V9(04).
056700         05  H-WK-PASS-AMT-PLUS-MISC      PIC 9(06)V99.
056800         05  H-BASE-DRG-PAYMENT           PIC S9(07)V99.
056900         05  H-NEW-TECH-ADDON-OP-1        PIC S9(07)V99.
057000         05  H-NEW-TECH-ADDON-CRT-D       PIC S9(07)V99.
057100         05  H-NEW-TECH-ADDON-KINETRA     PIC S9(07)V99.
057200         05  H-NEW-TECH-ADDON-INFUSE      PIC S9(07)V99.
057300
057400         05  H-LESSER-OP-1-1              PIC S9(07)V99.
057500         05  H-LESSER-OP-1-2              PIC S9(07)V99.
057600
057700         05  H-LESSER-CRT-D-1             PIC S9(07)V99.
057800         05  H-LESSER-CRT-D-2             PIC S9(07)V99.
057900
058000         05  H-LESSER-KINETRA-1           PIC S9(07)V99.
058100         05  H-LESSER-KINETRA-2           PIC S9(07)V99.
058200
058300         05  H-LESSER-INFUSE-1            PIC S9(07)V99.
058400         05  H-LESSER-INFUSE-2            PIC S9(07)V99.
058500
058600         05  H-CSTMED-OP-1                PIC S9(07)V99.
058700         05  H-CSTMED-CRT-D               PIC S9(07)V99.
058800         05  H-CSTMED-KINETRA             PIC S9(07)V99.
058900         05  H-CSTMED-INFUSE              PIC S9(07)V99.
059000
059100
059200     02  HOLD-ADDITIONAL-VARIABLES.
059300         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).
059400         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).
059500         05  H-NAT-PCT                    PIC 9(01)V9(02).
059600         05  H-REG-PCT                    PIC 9(01)V9(02).
059700         05  H-FAC-SPEC-RATE              PIC 9(05)V9(02).
059800         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).
059900         05  H-DRG-WT                     PIC 9(02)V9(04).
060000         05  H-NAT-LABOR                  PIC 9(05)V9(02).
060100         05  H-NAT-NONLABOR               PIC 9(05)V9(02).
060200         05  H-REG-LABOR                  PIC 9(05)V9(02).
060300         05  H-REG-NONLABOR               PIC 9(05)V9(02).
060400         05  H-OPER-COLA                  PIC 9(01)V9(03).
060500         05  H-INTERN-RATIO               PIC 9(01)V9(04).
060600         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).
060700         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).
060800         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
060900
061000     02  HOLD-CAPITAL-VARIABLES.
061100         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).
061200         05  H-CAPI-HSP                   PIC 9(07)V9(02).
061300         05  H-CAPI-FSP                   PIC 9(07)V9(02).
061400         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).
061500         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).
061600         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).
061700         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).
061800         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).
061900
062000     02  HOLD-CAPITAL2-VARIABLES.
062100         05  H-CAPI2-PAY-CODE             PIC X(1).
062200         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).
062300         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
062400
062500     02  HOLD-OTHER-VARIABLES.
062600         05  H-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
062700         05  H-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
062800         05  H-LOW-VOL-PAYMENT              PIC 9(07)V9(02).
062900         05  H-HVBP-HRR-DATA.
063000             10  H-VAL-BASED-PURCH-PARTIPNT PIC X.
063100             10  H-VAL-BASED-PURCH-ADJUST     PIC 9V9(11).
063200             10  H-HOSP-READMISS-REDUCTN      PIC X.
063300             10  H-HOSP-HRR-ADJUSTMT          PIC 9V9(4).
063400         05  H-OPERATNG-DATA.
063500             10  H-MODEL1-BUNDLE-DISPRCNT    PIC V999.
063600             10  H-OPER-BASE-DRG-PAY         PIC 9(08)V99.
063700             10  H-OPER-HSP-AMT              PIC 9(08)V99.
063800
063900     02  HOLD-PC-OTH-VARIABLES.
064000         05  H-OPER-DSH                   PIC 9(01)V9(04).
064100         05  H-CAPI-DSH                   PIC 9(01)V9(04).
064200         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).
064300         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).
064400         05  H-ARITH-ALOS                 PIC 9(02)V9(01).
064500         05  H-PR-WAGE-INDEX              PIC 9(02)V9(04).
064600         05  H-TRANSFER-ADJ               PIC 9(01)V9(05).
064700         05  H-PC-HMO-FLAG                PIC X(01).
064800         05  H-PC-COT-FLAG                PIC X(01).
064900         05  H-FILLER                        PIC X(0998).
065000
065100 01  HLD-PPS-DATA.
065200         10  HLD-PPS-RTC                PIC 9(02).
065300         10  HLD-PPS-WAGE-INDX          PIC 9(02)V9(04).
065400         10  HLD-PPS-OUTLIER-DAYS       PIC 9(03).
065500         10  HLD-PPS-AVG-LOS            PIC 9(02)V9(01).
065600         10  HLD-PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
065700         10  HLD-PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
065800         10  HLD-PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
065900         10  HLD-PPS-OPER-HSP-PART      PIC 9(06)V9(02).
066000         10  HLD-PPS-OPER-FSP-PART      PIC 9(06)V9(02).
066100         10  HLD-PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
066200         10  HLD-PPS-REG-DAYS-USED      PIC 9(03).
066300         10  HLD-PPS-LTR-DAYS-USED      PIC 9(02).
066400         10  HLD-PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
066500         10  HLD-PPS-CALC-VERS          PIC X(05).
066600
066700 LINKAGE SECTION.
066800***************************************************************
066900*                 * * * * * * * * *                           *
067000*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *
067100*    IN HOW TO PAY THE BILL.                                  *
067200*                         *****                               *
067300*    COMMENTS  ** CLAIMS RECEIVED WITH CONDITION CODE 66      *
067400*                 SHOULD BE PROCESSED UNDER REVIEW CODE 06,   *
067500*                 07 OR 11 AS APPROPRIATE TO EXCLUDE ANY      *
067600*                 OUTLIER COMPUTATION.                        *
067700*                         *****                               *
067800*         REVIEW-CODE:                                        *
067900*            00 = PAY-WITH-OUTLIER.                           *
068000*                 WILL CALCULATE THE STANDARD PAYMENT.        *
068100*                 WILL ALSO ATTEMPT TO PAY ONLY COST          *
068200*                 OUTLIERS, DAY OUTLIERS EXPIRED 10/01/97     *
068300*            03 = PAY-PERDIEM-DAYS.                           *
068400*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
068500*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
068600*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
068700*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
068800*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
068900*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
069000*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
069100*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
069200*                 BILL EXCEED THE COST THRESHOLD.             *
069300*            06 = PAY-XFER-NO-COST                            *
069400*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
069500*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
069600*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
069700*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *
069800*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
069900*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
070000*                 CALCULATE ANY COST OUTLIER PORTION          *
070100*                 OF THE PAYMENT.                             *
070200*            07 = PAY-WITHOUT-COST.                           *
070300*                 WILL CALCULATE THE STANDARD PAYMENT         *
070400*                 WITHOUT COST PORTION.                       *
070500*            09 = PAY-XFER-SPEC-DRG - POST-ACUTE TRANSFERS    *
070600*                 FOR DRG'S 209,210,211,014,113,236,          *
070700*                           012,024,025,088,089,090,          *
070800*                           121,122,127,130,131,239,          *
070900*                           277,278,294,296,297,320,          *
071000*                           321,395,468,429,   ,541,542       *
071100*                               POST-ACUTE TRANSFERS          *
071200*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
071300*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
071400*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
071500*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
071600*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
071700*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
071800*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
071900*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
072000*                 BILL EXCEED THE COST THRESHOLD.             *
072100*            11 = PAY-XFER-SPEC-DRG-NO-COST                   *
072200*                 POST-ACUTE TRANSFERS                        *
072300*                 FOR DRG'S 209,210,211,014,113,236,          *
072400*                           012,024,025,088,089,090,          *
072500*                           121,122,127,130,131,239,          *
072600*                           277,278,294,296,297,320,          *
072700*                           321,395,468,429,   ,541,542       *
072800*                               POST-ACUTE TRANSFERS          *
072900*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
073000*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
073100*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
073200*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
073300*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
073400*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
073500*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
073600*                 PAYMENT.                                    *
073700***************************************************************
073800
073900**************************************************************
074000*      MILLINNIUM COMPATIBLE                                 *
074100*      THIS IS THE BILL-RECORD THAT WILL BE PASSED BACK FROM *
074200*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *
074300*      IN THE NEW FORMAT                                     *
074400**************************************************************
074500 01  BILL-NEW-DATA.
074600         10  B-NPI10.
074700             15  B-NPI8             PIC X(08).
074800             15  B-NPI-FILLER       PIC X(02).
074900         10  B-PROVIDER-NO          PIC X(06).
075000         10  B-REVIEW-CODE          PIC 9(02).
075100             88  VALID-REVIEW-CODE    VALUE 00 03 06 07 09 11.
075200             88  PAY-WITH-OUTLIER     VALUE 00 07.
075300             88  PAY-PERDIEM-DAYS     VALUE 03.
075400             88  PAY-XFER-NO-COST     VALUE 06.
075500             88  PAY-WITHOUT-COST     VALUE 07.
075600             88  PAY-XFER-SPEC-DRG    VALUE 09 11.
075700             88  PAY-XFER-SPEC-DRG-NO-COST VALUE 11.
075800         10  B-DRG                  PIC 9(03).
075900         10  B-LOS                  PIC 9(03).
076000         10  B-COVERED-DAYS         PIC 9(03).
076100         10  B-LTR-DAYS             PIC 9(02).
076200         10  B-DISCHARGE-DATE.
076300             15  B-DISCHG-CC        PIC 9(02).
076400             15  B-DISCHG-YY        PIC 9(02).
076500             15  B-DISCHG-MM        PIC 9(02).
076600             15  B-DISCHG-DD        PIC 9(02).
076700         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
076800         10  B-PRIN-PROC-CODE       PIC X(07).
076900         10  B-OTHER-PROC-CODE1     PIC X(07).
077000         10  B-OTHER-PROC-CODE2     PIC X(07).
077100         10  B-OTHER-PROC-CODE3     PIC X(07).
077200         10  B-OTHER-PROC-CODE4     PIC X(07).
077300         10  B-OTHER-PROC-CODE5     PIC X(07).
077400         10  B-OTHER-PROC-CODE6     PIC X(07).
077500         10  B-OTHER-PROC-CODE7     PIC X(07).
077600         10  B-OTHER-PROC-CODE8     PIC X(07).
077700         10  B-OTHER-PROC-CODE9     PIC X(07).
077800         10  B-OTHER-PROC-CODE10    PIC X(07).
077900         10  B-OTHER-PROC-CODE11    PIC X(07).
078000         10  B-OTHER-PROC-CODE12    PIC X(07).
078100         10  B-OTHER-PROC-CODE13    PIC X(07).
078200         10  B-OTHER-PROC-CODE14    PIC X(07).
078300         10  B-OTHER-PROC-CODE15    PIC X(07).
078400         10  B-OTHER-PROC-CODE16    PIC X(07).
078500         10  B-OTHER-PROC-CODE17    PIC X(07).
078600         10  B-OTHER-PROC-CODE18    PIC X(07).
078700         10  B-OTHER-PROC-CODE19    PIC X(07).
078800         10  B-OTHER-PROC-CODE20    PIC X(07).
078900         10  B-OTHER-PROC-CODE21    PIC X(07).
079000         10  B-OTHER-PROC-CODE22    PIC X(07).
079100         10  B-OTHER-PROC-CODE23    PIC X(07).
079200         10  B-OTHER-PROC-CODE24    PIC X(07).
079300         10  B-OTHER-DIAG-CODE1     PIC X(07).
079400         10  B-OTHER-DIAG-CODE2     PIC X(07).
079500         10  B-OTHER-DIAG-CODE3     PIC X(07).
079600         10  B-OTHER-DIAG-CODE4     PIC X(07).
079700         10  B-OTHER-DIAG-CODE5     PIC X(07).
079800         10  B-OTHER-DIAG-CODE6     PIC X(07).
079900         10  B-OTHER-DIAG-CODE7     PIC X(07).
080000         10  B-OTHER-DIAG-CODE8     PIC X(07).
080100         10  B-OTHER-DIAG-CODE9     PIC X(07).
080200         10  B-OTHER-DIAG-CODE10    PIC X(07).
080300         10  B-OTHER-DIAG-CODE11    PIC X(07).
080400         10  B-OTHER-DIAG-CODE12    PIC X(07).
080500         10  B-OTHER-DIAG-CODE13    PIC X(07).
080600         10  B-OTHER-DIAG-CODE14    PIC X(07).
080700         10  B-OTHER-DIAG-CODE15    PIC X(07).
080800         10  B-OTHER-DIAG-CODE16    PIC X(07).
080900         10  B-OTHER-DIAG-CODE17    PIC X(07).
081000         10  B-OTHER-DIAG-CODE18    PIC X(07).
081100         10  B-OTHER-DIAG-CODE19    PIC X(07).
081200         10  B-OTHER-DIAG-CODE20    PIC X(07).
081300         10  B-OTHER-DIAG-CODE21    PIC X(07).
081400         10  B-OTHER-DIAG-CODE22    PIC X(07).
081500         10  B-OTHER-DIAG-CODE23    PIC X(07).
081600         10  B-OTHER-DIAG-CODE24    PIC X(07).
081700         10  B-OTHER-DIAG-CODE25    PIC X(07).
081800         10  BILL-DEMO-DATA.
081900             15  BILL-DEMO-CODE1        PIC X(02).
082000             15  BILL-DEMO-CODE2        PIC X(02).
082100             15  BILL-DEMO-CODE3        PIC X(02).
082200             15  BILL-DEMO-CODE4        PIC X(02).
082300         10  BILL-NDC-DATA.
082400             15  BILL-NDC-NUMBER        PIC X(11).
082500         10  FILLER                     PIC X(73).
082600
082700
082800
082900***************************************************************
083000*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
083100*    AND PASSED BACK TO THE CALLING PROGRAM                   *
083200*            RETURN CODE VALUES (PPS-RTC)                     *
083300*                                                             *
083400*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
083500*                                                             *
083600*      PPS-RTC 30,33,40,42,44  = OUTLIER RECONCILIATION       *
083700*                                                             *
083800*           30,00 = PAID NORMAL DRG PAYMENT                   *
083900*                                                             *
084000*              01 = PAID AS A DAY-OUTLIER.                    *
084100*                   NOTE:                                     *
084200*                     DAY-OUTLIER NO LONGER BEING PAID        *
084300*                         AS OF 10/01/97                      *
084400*                                                             *
084500*              02 = PAID AS A COST-OUTLIER.                   *
084600*                                                             *
084700*           33,03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
084800*                   AND INCLUDING THE FULL DRG.               *
084900*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
085000*                   AND INCLUDING THE FULL DRG WHICH ALSO     *
085100*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *
085200*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
085300*                   AND INCLUDING THE FULL DRG. PROVIDER      *
085400*                   REFUSED COST OUTLIER.                     *
085500*           40,10 = DRG IS 209, 210 OR 211 AND                *
085600*                   POST-ACUTE TRANSFER                       *
085700*           42,12 = POST-CAUTE TRANSFER WITH SPECIFIC DRGS    *
085800*                       THE FOLLOWING DRG'S                   *
085900*                 FOR DRG'S             014,113,236,          *
086000*                           012,024,025,088,089,090,          *
086100*                           121,122,127,130,131,239,          *
086200*                           277,278,294,296,297,320,          *
086300*                           321,395,468,429,   ,541,542       *
086400*           44,14 = PAID NORMAL DRG PAYMENT WITH              *
086500*                    PERDIEM DAYS = OR > GM  ALOS             *
086600*              16 = PAID AS A COST-OUTLIER WITH               *
086700*                    PERDIEM DAYS = OR > GM  ALOS             *
086800*                                                             *
086900*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
087000*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
087100*              52 = INVALID CBSA# IN PROVIDER FILE            *
087200*                   OR INVALID WAGE INDEX                     *
087300*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *
087400*              54 = DRG < 001 OR > 543,                       *
087500*                                       OR = 004 OR = 005     *
087600*                                       OR = 112              *
087700*                                       OR = 214 OR = 215     *
087800*                                       OR = 221 OR = 222     *
087900*                                       OR = 231 OR = 400     *
088000*                                       OR = 434 OR = 435     *
088100*                                       OR = 436 OR = 437     *
088200*                                       OR = 438 OR = 456     *
088300*                                       OR = 457 OR = 458     *
088400*                                       OR = 459 OR = 460     *
088500*                                       OR = 469 OR = 470     *
088600*                                       OR = 472 OR = 474     *
088700*                                       OR = 514 OR = 483     *
088800*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *
088900*                                      OR                     *
089000*                   DISCHARGE DATE < CBSA EFF START DATE      *
089100*                   FOR PPS                                   *
089200*                                      OR                     *
089300*                   PROVIDER HAS BEEN TERMINATED ON OR BEFORE *
089400*                   DISCHARGE DATE                            *
089500*              56 = INVALID LENGTH OF STAY                    *
089600*              57 = REVIEW CODE INVALID (NOT 00 03 06 07 09   *
089700*                                        NOT 11)              *
089800*              58 = TOTAL CHARGES NOT NUMERIC                 *
089900*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
090000*                   OR BILL-LTR-DAYS > 60                     *
090100*              62 = INVALID NUMBER OF COVERED DAYS            *
090200*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *
090300*                   SPECIFIC FILE FOR CAPITAL                 *
090400*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *
090500*                   OR COST OUTLIER THRESHOLD CALUCULATION    *
090600*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *
090700***************************************************************
090800 01  PPS-DATA.
090900         10  PPS-RTC                PIC 9(02).
091000         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
091100         10  PPS-OUTLIER-DAYS       PIC 9(03).
091200         10  PPS-AVG-LOS            PIC 9(02)V9(01).
091300         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
091400         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
091500         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
091600         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
091700         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
091800         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
091900         10  PPS-REG-DAYS-USED      PIC 9(03).
092000         10  PPS-LTR-DAYS-USED      PIC 9(02).
092100         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
092200         10  PPS-CALC-VERS          PIC X(05).
092300
092400******************************************************************
092500*            THESE ARE THE VERSIONS OF THE PPCAL
092600*           PROGRAMS THAT WILL BE PASSED BACK----
092700*          ASSOCIATED WITH THE BILL BEING PROCESSED
092800******************************************************************
092900 01  PRICER-OPT-VERS-SW.
093000     02  PRICER-OPTION-SW          PIC X(01).
093100         88  ALL-TABLES-PASSED          VALUE 'A'.
093200         88  PROV-RECORD-PASSED         VALUE 'P'.
093300         88  ADDITIONAL-VARIABLES       VALUE 'M'.
093400         88  PC-PRICER                  VALUE 'C'.
093500     02  PPS-VERSIONS.
093600         10  PPDRV-VERSION         PIC X(05).
093700
093800******************************************************************
093900*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
094000*          ASSOCIATED WITH THE BILL BEING PROCESSED
094100******************************************************************
094200 01  PPS-ADDITIONAL-VARIABLES.
094300     05  PPS-HSP-PCT                PIC 9(01)V9(02).
094400     05  PPS-FSP-PCT                PIC 9(01)V9(02).
094500     05  PPS-NAT-PCT                PIC 9(01)V9(02).
094600     05  PPS-REG-PCT                PIC 9(01)V9(02).
094700     05  PPS-FAC-SPEC-RATE          PIC 9(05)V9(02).
094800     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
094900     05  PPS-DRG-WT                 PIC 9(02)V9(04).
095000     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
095100     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
095200     05  PPS-REG-LABOR              PIC 9(05)V9(02).
095300     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
095400     05  PPS-OPER-COLA              PIC 9(01)V9(03).
095500     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
095600     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
095700     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
095800     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
095900     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
096000     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
096100     05  PPS-CAPITAL-VARIABLES.
096200         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).
096300         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).
096400         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).
096500         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).
096600         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).
096700         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).
096800         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).
096900         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).
097000     05  PPS-CAPITAL2-VARIABLES.
097100         10  PPS-CAPI2-PAY-CODE             PIC X(1).
097200         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).
097300         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
097400
097500     05  PPS-OTHER-VARIABLES.
097600         10  PPS-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
097700         10  PPS-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
097800         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
097900         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
098000         10  PPS-HVBP-HRR-DATA.
098100             15  PPS-VAL-BASED-PURCH-PARTIPNT PIC X.
098200             15  PPS-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
098300             15  PPS-HOSP-READMISS-REDUCTN    PIC X.
098400             15  PPS-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
098500         10  PPS-OPERATNG-DATA.
098600             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.
098700             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.
098800             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.
098900
099000     05  PPS-PC-OTH-VARIABLES.
099100         10  PPS-OPER-DSH                   PIC 9(01)V9(04).
099200         10  PPS-CAPI-DSH                   PIC 9(01)V9(04).
099300         10  PPS-CAPI-HSP-PCT               PIC 9(01)V9(02).
099400         10  PPS-CAPI-FSP-PCT               PIC 9(01)V9(04).
099500         10  PPS-ARITH-ALOS                 PIC 9(02)V9(01).
099600         10  PPS-PR-WAGE-INDEX              PIC 9(02)V9(04).
099700         10  PPS-TRANSFER-ADJ               PIC 9(01)V9(05).
099800         10  PPS-PC-HMO-FLAG                PIC X(01).
099900         10  PPS-PC-COT-FLAG                PIC X(01).
100000         10  PPS-FILLER                     PIC X(0998).
100100
100200**************************************************************
100300*      MILLINNIUM COMPATIBLE                                 *
100400*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BACK FROM *
100500*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *
100600*      IN THE NEW FORMAT                                     *
100700**************************************************************
100800 01  PROV-NEW-HOLD.
100900     02  PROV-NEWREC-HOLD1.
101000         05  P-NEW-NPI10.
101100             10  P-NEW-NPI8             PIC X(08).
101200             10  P-NEW-NPI-FILLER       PIC X(02).
101300         05  P-NEW-PROVIDER-NO.
101400             88  P-NEW-DSH-ADJ-PROVIDERS
101500                             VALUE '180049' '190044' '190144'
101600                                   '190191' '330047' '340085'
101700                                   '370016' '370149' '420043'
101800                                   '440081'.
101900             10  P-NEW-STATE            PIC 9(02).
102000             10  FILLER                 PIC X(04).
102100         05  P-NEW-DATE-DATA.
102200             10  P-NEW-EFF-DATE.
102300                 15  P-NEW-EFF-DT-CC    PIC 9(02).
102400                 15  P-NEW-EFF-DT-YY    PIC 9(02).
102500                 15  P-NEW-EFF-DT-MM    PIC 9(02).
102600                 15  P-NEW-EFF-DT-DD    PIC 9(02).
102700             10  P-NEW-FY-BEGIN-DATE.
102800                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
102900                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
103000                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
103100                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
103200             10  P-NEW-REPORT-DATE.
103300                 15  P-NEW-REPORT-DT-CC PIC 9(02).
103400                 15  P-NEW-REPORT-DT-YY PIC 9(02).
103500                 15  P-NEW-REPORT-DT-MM PIC 9(02).
103600                 15  P-NEW-REPORT-DT-DD PIC 9(02).
103700             10  P-NEW-TERMINATION-DATE.
103800                 15  P-NEW-TERM-DT-CC   PIC 9(02).
103900                 15  P-NEW-TERM-DT-YY   PIC 9(02).
104000                 15  P-NEW-TERM-DT-MM   PIC 9(02).
104100                 15  P-NEW-TERM-DT-DD   PIC 9(02).
104200         05  P-NEW-WAIVER-CODE          PIC X(01).
104300             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
104400         05  P-NEW-INTER-NO             PIC 9(05).
104500         05  P-NEW-PROVIDER-TYPE        PIC X(02).
104600             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.
104700             88  P-N-REFERRAL-CENTER        VALUE '07' '11'
104800                                                  '15' '17'
104900                                                  '22'.
105000             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.
105100             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.
105200             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.
105300             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.
105400             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.
105500             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.
105600             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.
105700             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.
105800             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.
105900             88  P-N-EACH                   VALUE '21' '22'.
106000             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.
106100             88  P-N-NHCMQ-II-SNF           VALUE '32'.
106200             88  P-N-NHCMQ-III-SNF          VALUE '33'.
106300         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
106400             88  P-N-NEW-ENGLAND            VALUE  1.
106500             88  P-N-MIDDLE-ATLANTIC        VALUE  2.
106600             88  P-N-SOUTH-ATLANTIC         VALUE  3.
106700             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.
106800             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.
106900             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.
107000             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.
107100             88  P-N-MOUNTAIN               VALUE  8.
107200             88  P-N-PACIFIC                VALUE  9.
107300         05  P-NEW-CURRENT-DIV   REDEFINES
107400                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
107500             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.
107600         05  P-NEW-MSA-DATA.
107700             10  P-NEW-CHG-CODE-INDEX       PIC X.
107800             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
107900             10  P-NEW-GEO-LOC-MSA9   REDEFINES
108000                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
108100             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
108200             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
108300             10  P-NEW-STAND-AMT-LOC-MSA9
108400       REDEFINES P-NEW-STAND-AMT-LOC-MSA.
108500                 15  P-NEW-RURAL-1ST.
108600                     20  P-NEW-STAND-RURAL  PIC XX.
108700                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
108800                 15  P-NEW-RURAL-2ND        PIC XX.
108900         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
109000                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
109100                 88  P-NEW-SCH-YR82       VALUE   '82'.
109200                 88  P-NEW-SCH-YR87       VALUE   '87'.
109300         05  P-NEW-LUGAR                    PIC X.
109400         05  P-NEW-TEMP-RELIEF-IND          PIC X.
109500         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
109600         05  FILLER                         PIC X(05).
109700     02  PROV-NEWREC-HOLD2.
109800         05  P-NEW-VARIABLES.
109900             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).
110000             10  P-NEW-COLA              PIC  9(01)V9(03).
110100             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
110200             10  P-NEW-BED-SIZE          PIC  9(05).
110300             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).
110400             10  P-NEW-CMI               PIC  9(01)V9(04).
110500             10  P-NEW-SSI-RATIO         PIC  V9(04).
110600             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
110700             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).
110800             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).
110900             10  P-NEW-DSH-PERCENT       PIC  V9(04).
111000             10  P-NEW-FYE-DATE          PIC  X(08).
111100         05  P-NEW-CBSA-DATA.
111200             10  FILLER                    PIC X.
111300             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.
111400             10  FILLER                    PIC X(21).
111500     02  PROV-NEWREC-HOLD3.
111600         05  P-NEW-PASS-AMT-DATA.
111700             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
111800             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
111900             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
112000             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
112100         05  P-NEW-CAPI-DATA.
112200             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
112300             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
112400             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
112500             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
112600             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
112700             15  P-NEW-CAPI-NEW-HOSP       PIC X.
112800             15  P-NEW-CAPI-IME            PIC 9V9999.
112900             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
113000         05  P-HVBP-HRR-DATA.
113100             15  P-VAL-BASED-PURCH-PARTIPNT PIC X.
113200             15  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
113300             15  P-HOSP-READMISSION-REDUCTN PIC X.
113400             15  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
113500         05  P-MODEL1-BUNDLE-DATA.
113600             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.
113700             15  P-HAC-REDUC-IND            PIC X.
113800             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.
113900             15  P-EHR-REDUC-IND            PIC X.
114000         05  FILLER                         PIC X(09).
114100
114200******************************************************************
114300*      MILLINNIUM COMPATIBLE
114400*                   THIS IS THE WAGE-INDEX
114500*          ASSOCIATED WITH THE BILL BEING PROCESSED
114600******************************************************************
114700 01  WAGE-NEW-CBSA-INDEX-RECORD.
114800     05  W-CBSA                        PIC X(5).
114900     05  W-CBSA-SIZE                   PIC X.
115000         88  LARGE-URBAN       VALUE 'L'.
115100         88  OTHER-URBAN       VALUE 'O'.
115200         88  ALL-RURAL         VALUE 'R'.
115300     05  W-CBSA-EFF-DATE               PIC X(8).
115400     05  FILLER                        PIC X.
115500     05  W-CBSA-INDEX-RECORD           PIC S9(02)V9(04).
115600     05  W-CBSA-PR-INDEX-RECORD        PIC S9(02)V9(04).
115700
115800
115900 PROCEDURE DIVISION  USING BILL-NEW-DATA
116000                           PPS-DATA
116100                           PRICER-OPT-VERS-SW
116200                           PPS-ADDITIONAL-VARIABLES
116300                           PROV-NEW-HOLD
116400                           WAGE-NEW-CBSA-INDEX-RECORD.
116500
116600***************************************************************
116700*    PROCESSING:                                              *
116800*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
116900*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *
117000*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
117100*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
117200*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
117300*           GOBACK.                                           *
117400*        D. ASSEMBLE PRICING COMPONENTS.                      *
117500*        E. CALCULATE THE PRICE.                              *
117600***************************************************************
117700
117800     MOVE ZEROES TO NON-TEMP-RELIEF-PAYMENT.
117900     MOVE 'N' TO TEMP-RELIEF-FLAG.
118000     MOVE 'N' TO OUTLIER-RECON-FLAG.
118100
118200     PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT.
118300
118400     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
118500     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.
118600     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.
118700     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.
118800     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.
118900     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
119000     MOVE HOLD-OTHER-VARIABLES      TO  PPS-OTHER-VARIABLES.
119100     MOVE HOLD-PC-OTH-VARIABLES     TO  PPS-PC-OTH-VARIABLES.
119200
119300     IF (PPS-RTC = '00' OR '03' OR '10' OR
119400                   '12' OR '14')
119500        MOVE 'Y' TO OUTLIER-RECON-FLAG
119600        MOVE PPS-DATA TO HLD-PPS-DATA
119700        PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT
119800        MOVE HLD-PPS-DATA TO PPS-DATA.
119900
120000     GOBACK.
120100
120200 0200-MAINLINE-CONTROL.
120300
120400     MOVE 'N' TO HMO-TAG.
120500
120600     IF PPS-PC-HMO-FLAG = 'Y' OR
120700               HMO-FLAG = 'Y'
120800        MOVE 'Y' TO HMO-TAG.
120900
121000     IF P-NEW-STATE NOT = 40
121100        MOVE ZEROES TO W-CBSA-PR-INDEX-RECORD.
121200
121300     MOVE ALL '0' TO PPS-DATA
121400                     H-OPER-DSH-SCH
121500                     H-OPER-DSH-RRC
121600                     HOLD-PPS-COMPONENTS
121700                     HOLD-PPS-COMPONENTS
121800                     HOLD-ADDITIONAL-VARIABLES
121900                     HOLD-CAPITAL-VARIABLES
122000                     HOLD-CAPITAL2-VARIABLES
122100                     HOLD-OTHER-VARIABLES
122200                     HOLD-PC-OTH-VARIABLES.
122300
122400     IF P-NEW-CAPI-HOSP-SPEC-RATE NOT NUMERIC
122500        MOVE 0 TO P-NEW-CAPI-HOSP-SPEC-RATE.
122600
122700     IF P-NEW-CAPI-OLD-HARM-RATE  NOT NUMERIC
122800        MOVE 0 TO P-NEW-CAPI-OLD-HARM-RATE.
122900
123000     IF P-NEW-CAPI-NEW-HARM-RATIO NOT NUMERIC
123100        MOVE 0 TO P-NEW-CAPI-NEW-HARM-RATIO.
123200
123300     IF P-NEW-CAPI-CSTCHG-RATIO NOT NUMERIC
123400        MOVE 0 TO P-NEW-CAPI-CSTCHG-RATIO.
123500
123600
123700     PERFORM 1000-EDIT-THE-BILL-INFO.
123800
123900     IF  PPS-RTC = 00
124000         PERFORM 2000-ASSEMBLE-PPS-VARIABLES
124100         PERFORM 3000-CALC-PAYMENT THRU 3000-EXIT.
124200
124300     IF OUTLIER-RECON-FLAG = 'Y'
124400        MOVE 'N' TO OUTLIER-RECON-FLAG
124500        GO TO 0200-EXIT.
124600
124700     IF PPS-RTC = 00
124800        IF H-PERDIEM-DAYS = H-ALOS OR
124900           H-PERDIEM-DAYS > H-ALOS
125000           MOVE 14 TO PPS-RTC.
125100
125200     IF PPS-RTC = 02
125300        IF H-PERDIEM-DAYS = H-ALOS OR
125400           H-PERDIEM-DAYS > H-ALOS
125500           MOVE 16 TO PPS-RTC.
125600
125700 0200-EXIT.   EXIT.
125800
125900 1000-EDIT-THE-BILL-INFO.
126000***************************************************************
126100*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *
126200*    AND DO NOT ATTEMPT TO PRICE.                             *
126300***************************************************************
126400
126500     MOVE 1.00 TO H-CAPI-PAYCDE-PCT1.
126600     MOVE 0.00 TO H-CAPI-PAYCDE-PCT2.
126700
126800     IF  PPS-RTC = 00
126900         IF  P-NEW-WAIVER-STATE
127000             MOVE 53 TO PPS-RTC.
127100
127200     IF  PPS-RTC = 00
127300         IF  B-DRG < 001 OR > 543
127400                                  OR = 004 OR = 005
127500                                  OR = 112
127600                                  OR = 214 OR = 215
127700                                  OR = 221 OR = 222
127800                                  OR = 231 OR = 400
127900                                  OR = 434 OR = 435
128000                                  OR = 436 OR = 437
128100                                  OR = 438 OR = 456
128200                                  OR = 457 OR = 458
128300                                  OR = 459 OR = 460
128400                                  OR = 469 OR = 470
128500                                  OR = 472 OR = 474
128600                                  OR = 514 OR = 483
128700             MOVE 54 TO PPS-RTC.
128800
128900     IF  PPS-RTC = 00
129000            IF  ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR
129100                 (B-DISCHARGE-DATE < W-CBSA-EFF-DATE))
129200                MOVE 55 TO PPS-RTC.
129300
129400     IF  PPS-RTC = 00
129500         IF P-NEW-TERMINATION-DATE > 00000000
129600            IF  ((B-DISCHARGE-DATE = P-NEW-TERMINATION-DATE) OR
129700                 (B-DISCHARGE-DATE > P-NEW-TERMINATION-DATE))
129800                  MOVE 55 TO PPS-RTC.
129900
130000     IF  PPS-RTC = 00
130100         IF  B-LOS NOT NUMERIC
130200             MOVE 56 TO PPS-RTC
130300         ELSE
130400         IF  B-LOS = 0
130500             IF B-REVIEW-CODE NOT = 00 AND
130600                              NOT = 03 AND
130700                              NOT = 06 AND
130800                              NOT = 07 AND
130900                              NOT = 09 AND
131000                              NOT = 11
131100             MOVE 56 TO PPS-RTC.
131200
131300     IF  PPS-RTC = 00
131400         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60
131500             MOVE 61 TO PPS-RTC
131600         ELSE
131700             MOVE B-LTR-DAYS TO H-LTR-DAYS.
131800
131900     IF  PPS-RTC = 00
132000         IF  B-COVERED-DAYS NOT NUMERIC
132100             MOVE 62 TO PPS-RTC
132200         ELSE
132300         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
132400             MOVE 62 TO PPS-RTC
132500         ELSE
132600             MOVE B-COVERED-DAYS TO H-COV-DAYS.
132700
132800     IF  PPS-RTC = 00
132900         IF  H-LTR-DAYS  > H-COV-DAYS
133000             MOVE 62 TO PPS-RTC
133100         ELSE
133200             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
133300
133400     IF  PPS-RTC = 00
133500     IF  B-REVIEW-CODE NOT NUMERIC
133600             MOVE 57 TO PPS-RTC.
133700
133800     IF  PPS-RTC = 00
133900         IF  NOT VALID-REVIEW-CODE
134000             MOVE 57 TO PPS-RTC.
134100
134200     IF  PPS-RTC = 00
134300         IF  B-CHARGES-CLAIMED NOT NUMERIC
134400             MOVE 58 TO PPS-RTC.
134500
134600     IF PPS-RTC = 00
134700           IF P-NEW-CAPI-NEW-HOSP NOT = 'Y'
134800                 IF P-NEW-CAPI-PPS-PAY-CODE NOT = 'A' AND
134900                                            NOT = 'B' AND
135000                                            NOT = 'C'
135100                 MOVE 65 TO PPS-RTC.
135200
135300 2000-ASSEMBLE-PPS-VARIABLES.
135400***************************************************************
135500*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *
135600*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *
135700*    OF THAT VARIABLE.                                        *
135800***************************************************************
135900***  GET THE PROVIDER SPECIFIC VARIABLES.
136000***  GET THE PROVIDER SPECIFIC VARIABLES.
136100
136200     MOVE P-NEW-FAC-SPEC-RATE TO H-FAC-SPEC-RATE.
136300     MOVE P-NEW-INTERN-RATIO TO H-INTERN-RATIO.
136400
136500     IF  (P-NEW-STATE = 02 OR 12)
136600         MOVE P-NEW-COLA TO H-OPER-COLA
136700     ELSE
136800         MOVE 1.000  TO H-OPER-COLA.
136900
137000***************************************************************
137100***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
137200***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
137300
137400     PERFORM 2600-GET-DRG-WEIGHT
137500             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.
137600
137700***************************************************************
137800***  GET THE WAGE-INDEX
137900***  GET THE WAGE-INDEX
138000
138100     MOVE W-CBSA-INDEX-RECORD TO H-WAGE-INDEX.
138200     MOVE W-CBSA-PR-INDEX-RECORD TO H-PR-WAGE-INDEX.
138300
138400***************************************************************
138500***  GET THE LABOR, NON-LABOR STANDARD RATES
138600
138700     IF  P-NEW-STATE = 40
138800         MOVE 2 TO R2
138900         MOVE 3 TO R4
139000     ELSE
139100         MOVE 1 TO R2
139200         MOVE 1 TO R4.
139300
139400     IF  LARGE-URBAN
139500         MOVE 1 TO R3
139600     ELSE
139700         MOVE 2 TO R3.
139800
139900     IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
140000        (H-WAGE-INDEX > 01.0000))
140100        PERFORM 2300-GET-LAB-NONLAB-TB1-RATES
140200             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
140300
140400     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
140500         (H-WAGE-INDEX > 01.0000))
140600        PERFORM 2300-GET-LAB-NONLAB-TB2-RATES
140700             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
140800
140900     IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
141000         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
141100        PERFORM 2300-GET-LAB-NONLAB-TB3-RATES
141200             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
141300
141400     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
141500         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
141600        PERFORM 2300-GET-LAB-NONLAB-TB4-RATES
141700             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
141800
141900     IF P-NEW-STATE = 40
142000        IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
142100            (H-PR-WAGE-INDEX > 01.0000))
142200             PERFORM 2300-GET-PR-LAB-TB1-RATES
142300             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
142400
142500
142600     IF P-NEW-STATE = 40
142700        IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
142800             (H-PR-WAGE-INDEX > 01.0000))
142900              PERFORM 2300-GET-PR-LAB-TB2-RATES
143000                  VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
143100
143200     IF P-NEW-STATE = 40
143300        IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
143400         (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))
143500          PERFORM 2300-GET-PR-LAB-TB3-RATES
143600              VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
143700
143800     IF P-NEW-STATE = 40
143900        IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
144000         (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))
144100          PERFORM 2300-GET-PR-LAB-TB4-RATES
144200              VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
144300
144400***************************************************************
144500***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
144600***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
144700
144800     MOVE 0.00  TO H-OPER-HSP-PCT.
144900     MOVE 1.00  TO H-OPER-FSP-PCT.
145000
145100***************************************************************
145200***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
145300***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
145400
145500      MOVE 1.00 TO H-NAT-PCT.
145600      MOVE 0.00 TO H-REG-PCT.
145700
145800     IF  P-NEW-STATE = 40
145900         MOVE 0.75 TO H-NAT-PCT
146000         MOVE 0.25 TO H-REG-PCT.
146100
146200     IF  P-N-SCH-REBASED-FY90 OR
146300         P-N-EACH OR
146400         P-N-MDH-REBASED-FY90
146500         MOVE 1.00 TO H-OPER-HSP-PCT.
146600
146700 2300-GET-LAB-NONLAB-TB1-RATES.
146800
146900     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
147000         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
147100         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
147200         MOVE TB1-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
147300         MOVE TB1-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
147400
147500 2300-GET-LAB-NONLAB-TB2-RATES.
147600
147700     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
147800         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
147900         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
148000         MOVE TB2-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
148100         MOVE TB2-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
148200
148300 2300-GET-LAB-NONLAB-TB3-RATES.
148400
148500     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
148600         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
148700         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
148800         MOVE TB3-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
148900         MOVE TB3-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
149000
149100 2300-GET-LAB-NONLAB-TB4-RATES.
149200
149300     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
149400         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
149500         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
149600         MOVE TB4-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
149700         MOVE TB4-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
149800
149900 2300-GET-PR-LAB-TB1-RATES.
150000
150100     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
150200         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
150300         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
150400
150500 2300-GET-PR-LAB-TB2-RATES.
150600
150700     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
150800         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
150900         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
151000
151100 2300-GET-PR-LAB-TB3-RATES.
151200
151300     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
151400         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
151500         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
151600
151700 2300-GET-PR-LAB-TB4-RATES.
151800
151900     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
152000         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
152100         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
152200
152300
152400 2600-GET-DRG-WEIGHT.
152500
152600     IF  B-DISCHARGE-DATE NOT < DRGX-EFF-DATE (DX5)
152700         SET DX6 TO B-DRG
152800         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT
152900         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS
153000*****    MOVE DRG-DAYS-TRIM (DX5 DX6)  TO H-DAYS-CUTOFF
153100         MOVE ZEROES                   TO H-DAYS-CUTOFF
153200         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.
153300
153400 3000-CALC-PAYMENT.
153500***************************************************************
153600*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *
153700*        CALCULATE THE STAY UTILIZATION.                      *
153800*        CALCULATE THE FEDERAL PORTION.                       *
153900*        CALCULATE THE HOSPITAL PORTION.                      *
154000*        CALCULATE THE COST-OUTLIER PORTION.                  *
154100*        CALCULATE THE TOTAL PAYMENT OPERATING AND CAPITAL    *
154200*        CALCULATE THE DSH ADJUSTMENT.                        *
154300*        CALCULATE THE IME TEACHING.                          *
154400***************************************************************
154500
154600     PERFORM 3100-CALC-STAY-UTILIZATION.
154700     PERFORM 3300-CALC-OPER-FSP-AMT.
154800
154900     PERFORM 3900A-CALC-OPER-DSH THRU 3900A-EXIT.
155000
155100***********************************************************
155200***  OPERATING IME CALCULATION
155300***  OPERATING IME CALCULATION
155400
155500     COMPUTE H-OPER-IME-TEACH ROUNDED =
155600            1.42 * ((1 + H-INTERN-RATIO) ** .405  - 1).
155700
155800***********************************************************
155900
156000     IF P-N-SCH-REBASED-FY90 OR
156100        P-N-EACH OR
156200        P-N-MDH-REBASED-FY90
156300         PERFORM 3450-CALC-ADDITIONAL-HSP.
156400
156500     MOVE 00                 TO  PPS-RTC.
156600     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.
156700     MOVE H-ALOS             TO  PPS-AVG-LOS.
156800     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.
156900
157000     MOVE B-LOS TO H-PERDIEM-DAYS.
157100     IF H-PERDIEM-DAYS < 1
157200         MOVE 1 TO H-PERDIEM-DAYS.
157300     ADD 1 TO H-PERDIEM-DAYS.
157400
157500     MOVE 1 TO H-DSCHG-FRCTN.
157600
157700     COMPUTE H-DRG-WT-FRCTN ROUNDED = H-DSCHG-FRCTN * H-DRG-WT.
157800
157900     IF  (PAY-PERDIEM-DAYS OR
158000          PAY-XFER-NO-COST) OR
158100       (PAY-XFER-SPEC-DRG AND (B-DRG = 014 OR 113 OR 236 OR
158200                                       012 OR 024 OR 025 OR
158300                                       088 OR 089 OR 090 OR
158400                                       121 OR 122 OR 127 OR
158500                                       130 OR 131 OR 239 OR
158600                                       277 OR 278 OR 294 OR
158700                                       296 OR 297 OR 320 OR
158800                                       321 OR 395 OR 468 OR
158900                                       429 OR 541 OR
159000                                       542))
159100         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
159200         COMPUTE H-DSCHG-FRCTN  ROUNDED = H-PERDIEM-DAYS / H-ALOS
159300         IF H-DSCHG-FRCTN > 1
159400              MOVE 1 TO H-DSCHG-FRCTN
159500              MOVE 1 TO H-TRANSFER-ADJ
159600         ELSE
159700              COMPUTE H-DRG-WT-FRCTN ROUNDED =
159800                  (H-PERDIEM-DAYS / H-ALOS) * H-DRG-WT.
159900
160000     IF (PAY-XFER-SPEC-DRG AND (B-DRG = 209 OR 210 OR 211))
160100         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
160200         COMPUTE H-DSCHG-FRCTN  ROUNDED =
160300                        .5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)
160400         IF H-DSCHG-FRCTN > 1
160500              MOVE 1 TO H-DSCHG-FRCTN
160600              MOVE 1 TO H-TRANSFER-ADJ
160700         ELSE
160800              COMPUTE H-DRG-WT-FRCTN ROUNDED =
160900            (.5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)) * H-DRG-WT.
161000
161100
161200***********************************************************
161300***  CAPITAL DSH CALCULATION
161400***  CAPITAL DSH CALCULATION
161500
161600     MOVE 0 TO H-CAPI-DSH.
161700
161800     IF P-NEW-BED-SIZE NOT NUMERIC
161900         MOVE 0 TO P-NEW-BED-SIZE.
162000
162100     IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
162200         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **
162300                  (.2025 * (P-NEW-SSI-RATIO
162400                          + P-NEW-MEDICAID-RATIO)) - 1.
162500
162600***********************************************************
162700***  CAPITAL IME TEACH CALCULATION
162800***  CAPITAL IME TEACH CALCULATION
162900
163000     MOVE 0 TO H-WK-CAPI-IME-TEACH.
163100
163200     IF P-NEW-CAPI-IME NUMERIC
163300        IF P-NEW-CAPI-IME > 1.5000
163400           MOVE 1.5000 TO P-NEW-CAPI-IME.
163500
163600     IF P-NEW-CAPI-IME NUMERIC
163700        COMPUTE H-WK-CAPI-IME-TEACH ROUNDED =
163800          (2.7183 ** (.2822 * P-NEW-CAPI-IME)) - 1.
163900
164000***********************************************************
164100******************************************************************
164200***  NO LONGER PAYING DAY-OUTLIERS     AS OF 10/01/97
164300***  NO LONGER PAYING DAY-OUTLIERS     AS OF 10/01/97
164400***  ZEROED OUT THE H-DAYOUT-PCT FIELD AS OF 10/01/97
164500
164600     MOVE 0.00 TO H-DAYOUT-PCT.
164700******************************************************************
164800
164900     MOVE 0.80 TO H-CSTOUT-PCT.
165000
165100******************************************************************
165200*****THESE ARE BURNS DRG'S
165300     IF  B-DRG = 504 OR 505 OR 506 OR 507 OR 508 OR
165400                 509 OR 510 OR 511
165500             MOVE 0.90 TO H-CSTOUT-PCT.
165600
165700***     NATIONAL PERCENTAGE
165800     MOVE 0.7110   TO H-LABOR-PCT.
165900     MOVE 0.2890   TO H-NONLABOR-PCT.
166000
166100***     PUERTO RICO PERCENTAGE
166200     MOVE 0.7130   TO H-PR-LABOR-PCT.
166300     MOVE 0.2870   TO H-PR-NONLABOR-PCT.
166400
166500     IF (H-WAGE-INDEX < 01.0000 OR
166600         H-WAGE-INDEX = 01.0000)
166700        MOVE 0.6200 TO H-LABOR-PCT
166800        MOVE 0.3800 TO H-NONLABOR-PCT.
166900
167000     IF P-NEW-STATE = 40
167100       IF (H-PR-WAGE-INDEX < 01.0000 OR
167200           H-PR-WAGE-INDEX = 01.0000)
167300          MOVE 0.6200 TO H-PR-LABOR-PCT
167400          MOVE 0.3800 TO H-PR-NONLABOR-PCT.
167500
167600
167700     IF  P-NEW-OPER-CSTCHG-RATIO NUMERIC
167800             MOVE P-NEW-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO
167900     ELSE
168000             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.
168100
168200     IF P-NEW-CAPI-CSTCHG-RATIO NUMERIC
168300             MOVE P-NEW-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO
168400     ELSE
168500             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.
168600
168700***********************************************************
168800***  CAPITAL PAYMENT METHOD B
168900***  CAPITAL PAYMENT METHOD B
169000
169100     IF W-CBSA-SIZE = 'L'
169200        MOVE 1.03 TO H-CAPI-LARG-URBAN
169300     ELSE
169400        MOVE 1.00 TO H-CAPI-LARG-URBAN.
169500
169600     COMPUTE H-CAPI-GAF    ROUNDED = (H-WAGE-INDEX ** .6848).
169700     COMPUTE H-PR-CAPI-GAF ROUNDED = (H-PR-WAGE-INDEX ** .6848).
169800
169900     COMPUTE H-FEDERAL-RATE ROUNDED =
170000                                 (0416.53 * H-CAPI-GAF).
170100     COMPUTE H-PUERTO-RICO-RATE ROUNDED =
170200                                 (0199.01 * H-PR-CAPI-GAF).
170300
170400     COMPUTE H-CAPI-COLA ROUNDED =
170500                     (.3152 * (H-OPER-COLA - 1) + 1).
170600
170700     MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.
170800
170900     IF P-NEW-STATE = 40
171000        COMPUTE  H-CAPI-FED-RATE ROUNDED =
171100                 (H-NAT-PCT * H-FEDERAL-RATE) +
171200                 (H-REG-PCT * H-PUERTO-RICO-RATE).
171300***********************************************************
171400***  NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001
171500***  CAPITAL HSP CALCULATION
171600***  CAPITAL HSP CALCULATION
171700*
171800*    IF B-DISCHARGE-DATE > 20010331
171900*        MOVE 1.0149 TO H-HSP-UPDATE01
172000*    ELSE
172100*        MOVE 1.0147 TO H-HSP-UPDATE01.
172200*
172300*    COMPUTE H-ACCUM-TO-HSP ROUNDED = H-HSP-UPDATE01.
172400*
172500*    COMPUTE H-CAPI-HSP-PART ROUNDED = (H-DRG-WT *
172600*                  P-NEW-CAPI-HOSP-SPEC-RATE * H-ACCUM-TO-HSP).
172700***********************************************************
172800
172900***********************************************************
173000***  CAPITAL FSP CALCULATION
173100***  CAPITAL FSP CALCULATION
173200
173300     COMPUTE H-CAPI-FSP-PART ROUNDED =
173400                               H-DRG-WT * H-CAPI-FED-RATE *
173500                               H-CAPI-COLA *
173600                               H-CAPI-LARG-URBAN.
173700
173800***********************************************************
173900***  CAPITAL PAYMENT METHOD A
174000***  CAPITAL PAYMENT METHOD A
174100
174200     IF P-N-SCH-REBASED-FY90 OR P-N-EACH
174300        MOVE 1.00 TO H-CAPI-SCH
174400     ELSE
174500        MOVE 0.85 TO H-CAPI-SCH.
174600
174700***********************************************************
174800***********  CAPITAL OLD-HARMLESS CALCULATION ***********
174900***********  CAPITAL OLD-HARMLESS CALCULATION ***********
175000
175100     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
175200                    (P-NEW-CAPI-OLD-HARM-RATE *
175300                    H-CAPI-SCH).
175400
175500***********************************************************
175600        IF PAY-PERDIEM-DAYS
175700            IF  H-PERDIEM-DAYS < H-ALOS
175800                IF  NOT (B-DRG = 385)
175900                    PERFORM 3500-CALC-PERDIEM-AMT
176000                    MOVE 03 TO PPS-RTC.
176100
176200        IF PAY-XFER-SPEC-DRG
176300            IF  H-PERDIEM-DAYS < H-ALOS
176400                IF  NOT (B-DRG = 385)
176500                    PERFORM 3550-CALC-PERDIEM-AMT.
176600
176700        IF  PAY-XFER-NO-COST
176800            MOVE 00 TO PPS-RTC
176900            IF H-PERDIEM-DAYS < H-ALOS
177000               IF  NOT (B-DRG = 385)
177100                   PERFORM 3500-CALC-PERDIEM-AMT
177200                   MOVE 06 TO PPS-RTC.
177300
177400     PERFORM 4000-CALC-TECH-ADDON THRU 4000-EXIT.
177500
177600     PERFORM 3600-CALC-OUTLIER THRU 3600-EXIT.
177700
177800     IF OUTLIER-RECON-FLAG = 'Y' GO TO 3000-EXIT.
177900
178000     IF PPS-RTC = 67  GO TO 3000-CONTINUE.
178100
178200        IF PAY-XFER-SPEC-DRG
178300            IF  H-PERDIEM-DAYS < H-ALOS
178400                IF  NOT (B-DRG = 385)
178500                    PERFORM 3560-CHECK-RTN-CODE THRU 3560-EXIT.
178600
178700
178800        IF  PAY-PERDIEM-DAYS
178900            IF  H-OPER-OUTCST-PART > 0
179000                MOVE H-OPER-OUTCST-PART TO
179100                     H-OPER-OUTLIER-PART
179200                MOVE 05 TO PPS-RTC
179300            ELSE
179400            IF  PPS-RTC NOT = 03
179500                MOVE 00 TO PPS-RTC
179600                MOVE 0  TO H-OPER-OUTLIER-PART.
179700
179800        IF  PAY-PERDIEM-DAYS
179900            IF  H-CAPI-OUTCST-PART > 0
180000                MOVE H-CAPI-OUTCST-PART TO
180100                     H-CAPI-OUTLIER-PART
180200                MOVE 05 TO PPS-RTC
180300            ELSE
180400            IF  PPS-RTC NOT = 03
180500                MOVE 0  TO H-CAPI-OUTLIER-PART.
180600
180700
180800 3000-CONTINUE.
180900
181000***********************************************************
181100***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF
181200***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
181300
181400     COMPUTE H-CAPI2-B-FSP-PART ROUNDED = H-CAPI-FSP-PART.
181500
181600***********************************************************
181700
181800     IF  PPS-RTC = 67
181900         MOVE H-OPER-DOLLAR-THRESHOLD TO
182000              WK-H-OPER-DOLLAR-THRESHOLD.
182100
182200     IF  PPS-RTC < 50
182300         PERFORM 3800-CALC-TOT-AMT
182400     ELSE
182500         MOVE ALL '0' TO PPS-OPER-HSP-PART
182600                         PPS-OPER-FSP-PART
182700                         PPS-OPER-OUTLIER-PART
182800                         PPS-OUTLIER-DAYS
182900                         PPS-REG-DAYS-USED
183000                         PPS-LTR-DAYS-USED
183100                         PPS-TOTAL-PAYMENT
183200                         PPS-OPER-DSH-ADJ
183300                         PPS-OPER-IME-ADJ
183400                         H-DSCHG-FRCTN
183500                         H-DRG-WT-FRCTN
183600                         HOLD-ADDITIONAL-VARIABLES
183700                         HOLD-CAPITAL-VARIABLES
183800                         HOLD-CAPITAL2-VARIABLES
183900                         HOLD-OTHER-VARIABLES
184000                         HOLD-PC-OTH-VARIABLES.
184100
184200     IF  PPS-RTC = 67
184300         MOVE WK-H-OPER-DOLLAR-THRESHOLD TO
184400                 H-OPER-DOLLAR-THRESHOLD.
184500
184600 3000-EXIT.  EXIT.
184700
184800 3100-CALC-STAY-UTILIZATION.
184900
185000     MOVE 0 TO PPS-REG-DAYS-USED.
185100     MOVE 0 TO PPS-LTR-DAYS-USED.
185200
185300     IF H-REG-DAYS > 0
185400        IF H-REG-DAYS > B-LOS
185500           MOVE B-LOS TO PPS-REG-DAYS-USED
185600        ELSE
185700           MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
185800     ELSE
185900        IF H-LTR-DAYS > B-LOS
186000           MOVE B-LOS TO PPS-LTR-DAYS-USED
186100        ELSE
186200           MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED.
186300
186400
186500
186600 3300-CALC-OPER-FSP-AMT.
186700***********************************************************
186800***  OPERATING FSP CALCULATION
186900***  OPERATING FSP CALCULATION
187000
187100     COMPUTE H-OPER-FSP-PART ROUNDED =
187200           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
187300            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
187400                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
187500
187600****CHECK FOR PUERTO RICO
187700     IF P-NEW-STATE = 40
187800       COMPUTE H-OPER-FSP-PART ROUNDED =
187900           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
188000            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
188100                           +
188200           (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
188300            H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)
188400                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
188500
188600
188700 3450-CALC-ADDITIONAL-HSP.
188800***********************************************************
188900*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR
189000*    SOLE COMMUNITY
189100*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)
189200*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
189300***********************************************************
189400**** CHANGE ESTIMATED OUTLIER FACTORS WHEN FED RATES CHANGE
189500****    USE ACTUAL FEDERAL REGISTER NUMBER
189600
189700***************************************************************
189800***         GET THE UPDATING FACTOR
189900***         GET THE UPDATING FACTOR
190000
190100     MOVE 0.997174 TO H-BUDG-NUTR01.
190200     MOVE 0.995821 TO H-BUDG-NUTR02.
190300     MOVE 0.993111 TO H-BUDG-NUTR03.
190400     MOVE 1.002608 TO H-BUDG-NUTR04.
190500     MOVE 0.999876 TO H-BUDG-NUTR05.
190600
190700     MOVE 1.0340 TO H-UPDATE-01.
190800     MOVE 1.0275 TO H-UPDATE-02.
190900     MOVE 1.0295 TO H-UPDATE-03.
191000     MOVE 1.0340 TO H-UPDATE-04.
191100     MOVE 1.0330 TO H-UPDATE-05.
191200
191300     COMPUTE H-UPDATE-FACTOR ROUNDED =
191400                       (H-UPDATE-01 * H-UPDATE-02 *
191500                        H-UPDATE-03 * H-UPDATE-04 *
191600                        H-UPDATE-05 *
191700                        H-BUDG-NUTR01 * H-BUDG-NUTR02 *
191800                        H-BUDG-NUTR03 * H-BUDG-NUTR04 *
191900                        H-BUDG-NUTR05).
192000
192100     COMPUTE H-HSP-RATE ROUNDED =
192200         H-FAC-SPEC-RATE * H-UPDATE-FACTOR.
192300***************************************************************
192400
192500***************************************************************
192600***     OUTLIER OFFSETS
192700***     OPERATING NATIONAL
192800***     OPERATING PUERTO RICO BLEND
192900
193000      MOVE 0.948978 TO H-OUTLIER-OFFSET-NAT
193100      MOVE 0.955029 TO H-OUTLIER-OFFSET-PR.
193200
193300***************************************************************
193400     COMPUTE H-FSP-RATE ROUNDED =
193500         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
193600         H-NAT-NONLABOR * H-OPER-COLA))
193700                           *
193800     ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-NAT)
193900                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
194000
194100     IF P-NEW-STATE = 40
194200       COMPUTE H-FSP-RATE ROUNDED =
194300         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
194400         H-NAT-NONLABOR * H-OPER-COLA))
194500                           +
194600          (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
194700         H-REG-NONLABOR * H-OPER-COLA)))
194800                           *
194900      ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-PR)
195000                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
195100
195200
195300     IF  H-HSP-RATE > H-FSP-RATE
195400           COMPUTE H-OPER-HSP-PART ROUNDED =
195500             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT
195600                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART
195700     ELSE
195800         MOVE 0 TO H-OPER-HSP-PART.
195900
196000***************************************************************
196100***         GET THE MDH REBASE
196200***     HAS BEEN REVIVED FOR 10/01/97
196300
196400     IF  H-HSP-RATE > H-FSP-RATE
196500         IF P-NEW-PROVIDER-TYPE = '14' OR '15'
196600           COMPUTE H-OPER-HSP-PART ROUNDED =
196700             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT * .5
196800                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
196900
197000 3500-CALC-PERDIEM-AMT.
197100***********************************************************
197200***  REVIEW CODE = 03 OR 06
197300***  OPERATING PERDIEM-AMT CALCULATION
197400***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
197500
197600**    REMOVED AS OF APR 1 2004
197700***     COMPUTE H-OPER-HSP-PART ROUNDED =
197800***     H-OPER-HSP-PART * H-TRANSFER-ADJ
197900***     ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
198000***********************************************************
198100
198200        COMPUTE H-OPER-FSP-PART ROUNDED =
198300        H-OPER-FSP-PART * H-TRANSFER-ADJ
198400        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
198500
198600***********************************************************
198700***********************************************************
198800***  REVIEW CODE = 03 OR 06
198900***  CAPITAL   PERDIEM-AMT CALCULATION
199000***  CAPITAL   HSP AND FSP CALCULATION FOR TRANSFERS
199100
199200***********************************************************
199300**NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001    **************
199400*       COMPUTE H-CAPI-HSP-PART ROUNDED =
199500*       H-CAPI-HSP-PART * H-TRANSFER-ADJ
199600*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
199700***********************************************************
199800
199900        COMPUTE H-CAPI-FSP-PART ROUNDED =
200000        H-CAPI-FSP-PART * H-TRANSFER-ADJ
200100        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
200200
200300***********************************************************
200400***  REVIEW CODE = 03 OR 06
200500***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
200600***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
200700
200800        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
200900        H-CAPI-OLD-HARMLESS * H-TRANSFER-ADJ
201000        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
201100
201200 3550-CALC-PERDIEM-AMT.
201300***********************************************************
201400***  REVIEW CODE = 09  OR 11 TRANSFER WITH SPECIAL DRG
201500***  OPERATING PERDIEM-AMT CALCULATION
201600***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
201700**    REMOVED AS OF APR 1 2004
201800*    IF (B-DRG = 209 OR 210 OR 211)
201900*       MOVE 10 TO PPS-RTC
202000*       COMPUTE H-OPER-HSP-PART ROUNDED =
202100*       H-OPER-HSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
202200*       ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
202300
202400*    IF (B-DRG = 014 OR 113 OR 236 OR
202500*                012 OR 024 OR 025 OR
202600*                088 OR 089 OR 090 OR
202700*                121 OR 122 OR 127 OR
202800*                130 OR 131 OR 239 OR
202900*                277 OR 278 OR 294 OR
203000*                296 OR 297 OR 320 OR
203100*                321 OR 395 OR 468 OR
203200*                429 OR 541 OR 542)
203300*       MOVE 12 TO PPS-RTC
203400*       COMPUTE H-OPER-HSP-PART ROUNDED =
203500*       H-OPER-HSP-PART *  H-TRANSFER-ADJ
203600*       ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
203700***********************************************************
203800
203900     IF (B-DRG = 209 OR 210 OR 211)
204000        MOVE 10 TO PPS-RTC
204100        COMPUTE H-OPER-FSP-PART ROUNDED =
204200        H-OPER-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
204300        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
204400
204500     IF (B-DRG = 014 OR 113 OR 236 OR
204600                 012 OR 024 OR 025 OR
204700                 088 OR 089 OR 090 OR
204800                 121 OR 122 OR 127 OR
204900                 130 OR 131 OR 239 OR
205000                 277 OR 278 OR 294 OR
205100                 296 OR 297 OR 320 OR
205200                 321 OR 395 OR 468 OR
205300                 429 OR 541 OR 542)
205400        MOVE 12 TO PPS-RTC
205500        COMPUTE H-OPER-FSP-PART ROUNDED =
205600        H-OPER-FSP-PART *  H-TRANSFER-ADJ
205700        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
205800
205900***********************************************************
206000***  CAPITAL PERDIEM-AMT CALCULATION
206100***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS
206200
206300***********************************************************
206400**NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001    **************
206500*    IF (B-DRG = 209 OR 210 OR 211)
206600*       MOVE 10 TO PPS-RTC
206700*       COMPUTE H-CAPI-HSP-PART ROUNDED =
206800*       H-CAPI-HSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
206900*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
207000*
207100*    IF (B-DRG = 014 OR 113 OR 236 OR 263 OR
207200*                264 OR 429 OR 483)
207300*       MOVE 12 TO PPS-RTC
207400*       COMPUTE H-CAPI-HSP-PART ROUNDED =
207500*       H-CAPI-HSP-PART *  H-TRANSFER-ADJ
207600*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
207700***********************************************************
207800
207900     IF (B-DRG = 209 OR 210 OR 211)
208000        MOVE 10 TO PPS-RTC
208100        COMPUTE H-CAPI-FSP-PART ROUNDED =
208200        H-CAPI-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
208300        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
208400
208500     IF (B-DRG = 014 OR 113 OR 236 OR
208600                 012 OR 024 OR 025 OR
208700                 088 OR 089 OR 090 OR
208800                 121 OR 122 OR 127 OR
208900                 130 OR 131 OR 239 OR
209000                 277 OR 278 OR 294 OR
209100                 296 OR 297 OR 320 OR
209200                 321 OR 395 OR 468 OR
209300                 429 OR 541 OR 542)
209400        MOVE 12 TO PPS-RTC
209500        COMPUTE H-CAPI-FSP-PART ROUNDED =
209600        H-CAPI-FSP-PART *  H-TRANSFER-ADJ
209700        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
209800
209900***********************************************************
210000***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
210100***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
210200
210300     IF (B-DRG = 209 OR 210 OR 211)
210400        MOVE 10 TO PPS-RTC
210500        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
210600        H-CAPI-OLD-HARMLESS * (.5 * (1 + H-TRANSFER-ADJ))
210700        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
210800
210900     IF (B-DRG = 014 OR 113 OR 236 OR
211000                 012 OR 024 OR 025 OR
211100                 088 OR 089 OR 090 OR
211200                 121 OR 122 OR 127 OR
211300                 130 OR 131 OR 239 OR
211400                 277 OR 278 OR 294 OR
211500                 296 OR 297 OR 320 OR
211600                 321 OR 395 OR 468 OR
211700                 429 OR 541 OR 542)
211800        MOVE 12 TO PPS-RTC
211900        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
212000        H-CAPI-OLD-HARMLESS *  H-TRANSFER-ADJ
212100        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
212200
212300 3560-CHECK-RTN-CODE.
212400
212500     IF (B-DRG = 209 OR 210 OR 211)
212600        MOVE 10 TO PPS-RTC.
212700     IF (B-DRG = 014 OR 113 OR 236 OR
212800                 012 OR 024 OR 025 OR
212900                 088 OR 089 OR 090 OR
213000                 121 OR 122 OR 127 OR
213100                 130 OR 131 OR 239 OR
213200                 277 OR 278 OR 294 OR
213300                 296 OR 297 OR 320 OR
213400                 321 OR 395 OR 468 OR
213500                 429 OR 541 OR 542)
213600        MOVE 12 TO PPS-RTC.
213700
213800 3560-EXIT.    EXIT.
213900
214000 3600-CALC-OUTLIER.
214100***********************************************************
214200***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
214300***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
214400
214500     IF OUTLIER-RECON-FLAG = 'Y'
214600        COMPUTE H-OPER-CSTCHG-RATIO ROUNDED =
214700               (H-OPER-CSTCHG-RATIO + .2).
214800
214900     IF H-CAPI-CSTCHG-RATIO > 0 OR
215000       H-OPER-CSTCHG-RATIO > 0
215100        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD ROUNDED =
215200                H-OPER-CSTCHG-RATIO /
215300               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
215400        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD ROUNDED =
215500                H-CAPI-CSTCHG-RATIO /
215600               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
215700     ELSE
215800         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD
215900                   H-CAPI-SHARE-DOLL-THRESHOLD.
216000
216100***********************************************************
216200***********************************************************
216300***********************************************************
216400***********************************************************
216500***********************************************************
216600***NO LONGER PAID PRE-CAPITAL AS OCT 1, 2001***************
216700***  OUTLIER THRESHOLD AND PRE-CAPITAL THRESHOLD AMOUNTS
216800***  OUTLIER THRESHOLD AND PRE-CAPITAL THRESHOLD AMOUNTS
216900
217000***NO LONGER PAID PRE-CAPITAL AS OCT 1, 2001***************
217100***     MOVE 16036.00 TO H-PRE-CAPI-THRESH.
217200***********************************************************
217300***********************************************************
217400***********************************************************
217500***********************************************************
217600
217700
217800
217900***********************************************************
218000***  OUTLIER THRESHOLD AMOUNTS
218100***  OUTLIER THRESHOLD AMOUNTS
218200
218300     MOVE 25800.00 TO H-CST-THRESH.
218400
218500     IF (B-REVIEW-CODE = '03') AND
218600         H-PERDIEM-DAYS < H-ALOS
218700        COMPUTE H-CST-THRESH ROUNDED =
218800                      (H-CST-THRESH * H-TRANSFER-ADJ)
218900                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
219000
219100     IF ((B-REVIEW-CODE = '09') AND
219200         (H-PERDIEM-DAYS < H-ALOS))
219300         IF (B-DRG = 014 OR 113 OR 236 OR
219400                     012 OR 024 OR 025 OR
219500                     088 OR 089 OR 090 OR
219600                     121 OR 122 OR 127 OR
219700                     130 OR 131 OR 239 OR
219800                     277 OR 278 OR 294 OR
219900                     296 OR 297 OR 320 OR
220000                     321 OR 395 OR 468 OR
220100                     429 OR 541 OR 542)
220200            COMPUTE H-CST-THRESH ROUNDED =
220300                      (H-CST-THRESH * H-TRANSFER-ADJ)
220400                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
220500
220600     IF ((B-REVIEW-CODE = '09') AND
220700         (H-PERDIEM-DAYS < H-ALOS))
220800         IF (B-DRG = 209 OR 210 OR 211)
220900           COMPUTE H-CST-THRESH ROUNDED =
221000          (H-CST-THRESH * (.5 * (1 + H-TRANSFER-ADJ)))
221100                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
221200
221300     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
221400        ((H-CST-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +
221500         (H-CST-THRESH * H-NONLABOR-PCT * H-OPER-COLA)) *
221600          H-OPER-SHARE-DOLL-THRESHOLD.
221700
221800     IF P-NEW-STATE = 40
221900        COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =
222000           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +
222100            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *
222200             H-OPER-SHARE-DOLL-THRESHOLD
222300        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
222400               (H-OPER-DOLLAR-THRESHOLD * H-NAT-PCT) +
222500               (H-OPER-PR-DOLLAR-THRESHOLD * H-REG-PCT).
222600
222700***********************************************************
222800
222900     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
223000          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *
223100          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.
223200
223300
223400     IF P-NEW-STATE = 40
223500        COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =
223600           H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *
223700           H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA
223800        COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
223900               (H-CAPI-DOLLAR-THRESHOLD * H-NAT-PCT) +
224000               (H-CAPI-PR-DOLLAR-THRESHOLD * H-REG-PCT).
224100
224200
224300     COMPUTE H-OPER-COST-OUTLIER ROUNDED =
224400      (H-OPER-FSP-PART * (1 + H-OPER-IME-TEACH + H-OPER-DSH))
224500                       +
224600             H-OPER-DOLLAR-THRESHOLD
224700                       +
224800                 H-NEW-TECH-PAY-ADD-ON.
224900
225000     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
225100      (H-CAPI-FSP-PART * (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH))
225200                       +
225300             H-CAPI-DOLLAR-THRESHOLD.
225400
225500     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
225600         MOVE 0 TO H-CAPI-COST-OUTLIER.
225700
225800
225900***********************************************************
226000***  OPERATING COST CALCULATION
226100***  OPERATING COST CALCULATION
226200
226300     COMPUTE H-OPER-BILL-COSTS ROUNDED =
226400         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO
226500         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
226600
226700
226800     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER
226900         COMPUTE H-OPER-OUTCST-PART ROUNDED =
227000         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -
227100                         H-OPER-COST-OUTLIER).
227200
227300     IF PAY-WITHOUT-COST OR
227400        PAY-XFER-NO-COST OR
227500        PAY-XFER-SPEC-DRG-NO-COST
227600         MOVE 0 TO H-OPER-OUTCST-PART.
227700
227800***********************************************************
227900***  CAPITAL COST CALCULATION
228000***  CAPITAL COST CALCULATION
228100
228200     COMPUTE H-CAPI-BILL-COSTS ROUNDED =
228300             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO
228400         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.
228500
228600     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER
228700         COMPUTE H-CAPI-OUTCST-PART ROUNDED =
228800         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -
228900                         H-CAPI-COST-OUTLIER).
229000
229100     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
229200       COMPUTE H-CAPI-OUTCST-PART ROUNDED =
229300              (H-CAPI-OUTCST-PART * P-NEW-CAPI-NEW-HARM-RATIO).
229400
229500     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
229600        COMPUTE H-CAPI-OUTCST-PART ROUNDED =
229700               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).
229800
229900     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <
230000        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)
230100        MOVE 0 TO H-CAPI-OUTCST-PART
230200                  H-OPER-OUTCST-PART.
230300
230400     IF PAY-WITHOUT-COST OR
230500        PAY-XFER-NO-COST OR
230600        PAY-XFER-SPEC-DRG-NO-COST
230700         MOVE 0 TO H-CAPI-OUTCST-PART.
230800
230900***********************************************************
231000***  DETERMINES THE BILL TO BE COST  OUTLIER
231100
231200     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
231300         MOVE 0 TO H-CAPI-OUTDAY-PART
231400                   H-CAPI-OUTCST-PART.
231500
231600     IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
231700                 MOVE H-OPER-OUTCST-PART TO
231800                      H-OPER-OUTLIER-PART
231900                 MOVE H-CAPI-OUTCST-PART TO
232000                      H-CAPI-OUTLIER-PART
232100                 MOVE 02 TO PPS-RTC.
232200
232300     IF OUTLIER-RECON-FLAG = 'Y'
232400        IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
232500           COMPUTE HLD-PPS-RTC = HLD-PPS-RTC + 30
232600           GO TO 3600-EXIT
232700        ELSE
232800           GO TO 3600-EXIT
232900     ELSE
233000        NEXT SENTENCE.
233100
233200
233300***********************************************************
233400***  DETERMINES IF COST OUTLIER
233500***  RECOMPUTES DOLLAR THRESHOLD TO BE SENT BACK WITH
233600***         RETURN CODE OF 02
233700
233800     MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
233900
234000     IF PPS-RTC = 02
234100             COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
234200                     (H-CAPI-COST-OUTLIER  +
234300                      H-OPER-COST-OUTLIER)
234400                             /
234500                    (H-CAPI-CSTCHG-RATIO  +
234600                     H-OPER-CSTCHG-RATIO)
234700             ON SIZE ERROR MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
234800
234900***********************************************************
235000***  DETERMINES IF COST OUTLIER WITH LOS IS > COVERED  DAYS
235100***         RETURN CODE OF 67
235200
235300     IF PPS-RTC = 02
235400         IF ((H-REG-DAYS + H-LTR-DAYS) < B-LOS) OR
235500            PPS-PC-COT-FLAG = 'Y'
235600             MOVE 67 TO PPS-RTC.
235700***********************************************************
235800
235900***********************************************************
236000***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF
236100***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
236200
236300     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
236400        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
236500                H-CAPI-OUTLIER-PART / P-NEW-CAPI-NEW-HARM-RATIO
236600         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
236700
236800     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
236900        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
237000                H-CAPI-OUTLIER-PART.
237100
237200     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
237300        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
237400                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1
237500         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
237600
237700 3600-EXIT.   EXIT.
237800***********************************************************
237900***********************************************************
238000
238100***********************************************************
238200 3800-CALC-TOT-AMT.
238300***********************************************************
238400***  CALCULATE TOTALS FOR CAPITAL
238500***  CALCULATE TOTALS FOR CAPITAL
238600
238700     MOVE P-NEW-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.
238800
238900     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
239000        MOVE P-NEW-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT
239100        MOVE 0.00 TO H-CAPI-HSP-PCT.
239200
239300     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
239400        MOVE 0    TO H-CAPI-OLD-HARMLESS
239500        MOVE 1.00 TO H-CAPI-FSP-PCT
239600        MOVE 0.00 TO H-CAPI-HSP-PCT.
239700
239800     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
239900        MOVE 0    TO H-CAPI-OLD-HARMLESS
240000        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT
240100        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.
240200
240300     COMPUTE H-CAPI-HSP ROUNDED =
240400         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.
240500
240600     COMPUTE H-CAPI-FSP ROUNDED =
240700         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.
240800
240900     MOVE P-NEW-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.
241000
241100     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.
241200
241300     COMPUTE H-CAPI-DSH-ADJ ROUNDED =
241400             H-CAPI-FSP
241500              * H-CAPI-DSH.
241600
241700     COMPUTE H-CAPI-IME-ADJ ROUNDED =
241800          H-CAPI-FSP *
241900                 H-WK-CAPI-IME-TEACH.
242000
242100     COMPUTE H-CAPI-OUTLIER ROUNDED =
242200             1.00 * H-CAPI-OUTLIER-PART.
242300
242400     COMPUTE H-CAPI2-B-FSP ROUNDED =
242500             1.00 * H-CAPI2-B-FSP-PART.
242600
242700     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =
242800             1.00 * H-CAPI2-B-OUTLIER-PART.
242900***********************************************************
243000***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER
243100***        THIS ZEROES OUT ALL CAPITAL DATA
243200
243300     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
243400        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.
243500***********************************************************
243600
243700***********************************************************
243800***  CALCULATE FINAL TOTALS FOR OPERATING
243900***  CALCULATE FINAL TOTALS FOR OPERATING
244000
244100     IF (H-CAPI-OUTLIER > 0 AND
244200         PPS-OPER-OUTLIER-PART = 0)
244300            COMPUTE PPS-OPER-OUTLIER-PART =
244400                    PPS-OPER-OUTLIER-PART + .01.
244500
244600     MOVE 01.000 TO WK-LOW-VOL25PCT.
244700
244800     IF P-NEW-TEMP-RELIEF-IND = 'Y'
244900        MOVE 01.250 TO WK-LOW-VOL25PCT.
245000
245100     MOVE ZERO TO PPS-OPER-DSH-ADJ.
245200
245300     IF  H-OPER-DSH NUMERIC
245400         COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
245500       (WK-LOW-VOL25PCT * PPS-OPER-FSP-PART) * H-OPER-DSH.
245600
245700     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
245800      (WK-LOW-VOL25PCT * PPS-OPER-FSP-PART) * H-OPER-IME-TEACH.
245900
246000
246100     COMPUTE PPS-OPER-FSP-PART ROUNDED =
246200        (WK-LOW-VOL25PCT * H-OPER-FSP-PART) * H-OPER-FSP-PCT.
246300
246400     COMPUTE PPS-OPER-HSP-PART ROUNDED =
246500        (WK-LOW-VOL25PCT * H-OPER-HSP-PART) * H-OPER-HSP-PCT.
246600
246700     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =
246800      (WK-LOW-VOL25PCT * H-OPER-OUTLIER-PART) * H-OPER-FSP-PCT.
246900
247000     IF HMO-TAG  = 'Y'
247100        PERFORM 3850-HMO-IME-ADJ.
247200
247300***********************************************************
247400***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
247500***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
247600
247700     COMPUTE H-CAPI-TOTAL-PAY ROUNDED =
247800            (H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
247900             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
248000             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM) * WK-LOW-VOL25PCT.
248100
248200     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
248300             (WK-LOW-VOL25PCT * H-NEW-TECH-PAY-ADD-ON).
248400
248500     MOVE H-NEW-TECH-PAY-ADD-ON TO PPS-NEW-TECH-PAY-ADD-ON.
248600
248700     COMPUTE   PPS-TOTAL-PAYMENT ROUNDED =
248800               PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
248900               PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
249000                      PPS-OPER-IME-ADJ
249100                           +
249200                 PPS-NEW-TECH-PAY-ADD-ON
249300                           +
249400                 H-WK-PASS-AMT-PLUS-MISC
249500                           +
249600                   H-CAPI-TOTAL-PAY.
249700
249800 3850-HMO-IME-ADJ.
249900***********************************************************
250000***  HMO CALC FOR PASS-THRU ADDON
250100***  HMO CALC FOR PASS-THRU ADDON
250200
250300***  HMO DIR-MED-ED  ---- NO LONGER PAID AS OF 10/01/2002
250400
250500     COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =
250600          (P-NEW-PASS-AMT-PLUS-MISC -
250700           P-NEW-PASS-AMT-DIR-MED-ED) * B-LOS.
250800
250900***********************************************************
251000***  HMO IME ADJUSTMENT --- NO LONGER PAID AS OF 10/01/2002
251100
251200     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
251300                   PPS-OPER-IME-ADJ * .0.
251400
251500***********************************************************
251600
251700
251800 3900A-CALC-OPER-DSH.
251900
252000***  OPERATING DSH CALCULATION EFFECTIVE APRIL 1, 2004
252100***  OPERATING DSH CALCULATION EFFECTIVE APRIL 1, 2004
252200
252300      MOVE 0.0000 TO H-OPER-DSH.
252400
252500      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO
252600                                     + P-NEW-MEDICAID-RATIO).
252700
252800***********************************************************
252900**1**    0-99 BEDS
253000***  NOT TO EXCEED 12%
253100
253200      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
253300                               AND H-WK-OPER-DSH > .1499
253400                               AND H-WK-OPER-DSH < .2020
253500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
253600                                      * .65 + .025
253700        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
253800
253900      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
254000                               AND H-WK-OPER-DSH > .2019
254100        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
254200                                      * .825 + .0588
254300        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
254400
254500***********************************************************
254600**2**   100 + BEDS
254700***  NO CAP >> CAN EXCEED 12%
254800
254900      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
255000                               AND H-WK-OPER-DSH > .1499
255100                               AND H-WK-OPER-DSH < .2020
255200        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
255300                                      * .65 + .025.
255400
255500      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
255600                               AND H-WK-OPER-DSH > .2019
255700        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
255800                                      * .825 + .0588.
255900
256000***********************************************************
256100**3**   OTHER RURAL HOSPITALS LESS THEN 500 BEDS
256200***  NOT TO EXCEED 12%
256300***  EXCEPT FOR URBAN TO RURAL HOSPITALS CR3459
256400
256500      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
256600                               AND H-WK-OPER-DSH > .1499
256700                               AND H-WK-OPER-DSH < .2020
256800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
256900                                 * .65 + .025
257000        IF H-OPER-DSH > .1200
257100           IF P-NEW-DSH-ADJ-PROVIDERS
257200              IF P-NEW-BED-SIZE > 99
257300                 COMPUTE H-OPER-DSH ROUNDED =
257400                 (.1200 + ((H-OPER-DSH - .1200) * .6667))
257500              ELSE
257600                 MOVE .1200 TO H-OPER-DSH
257700           ELSE
257800              MOVE .1200 TO H-OPER-DSH
257900        ELSE
258000           NEXT SENTENCE
258100      ELSE
258200         NEXT SENTENCE.
258300
258400      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
258500                               AND H-WK-OPER-DSH > .2019
258600        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
258700                                 * .825 + .0588
258800        IF H-OPER-DSH > .1200
258900           IF P-NEW-DSH-ADJ-PROVIDERS
259000              IF P-NEW-BED-SIZE > 99
259100                 COMPUTE H-OPER-DSH ROUNDED =
259200                 (.1200 + ((H-OPER-DSH - .1200) * .6667))
259300              ELSE
259400                 MOVE .1200 TO H-OPER-DSH
259500           ELSE
259600              MOVE .1200 TO H-OPER-DSH
259700        ELSE
259800           NEXT SENTENCE
259900      ELSE
260000         NEXT SENTENCE.
260100***********************************************************
260200**4**   OTHER RURAL HOSPITALS 500 BEDS +
260300***  NO CAP >> CAN EXCEED 12%
260400
260500      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
260600                               AND H-WK-OPER-DSH > .1499
260700                               AND H-WK-OPER-DSH < .2020
260800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
260900                                 * .65 + .025.
261000
261100      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
261200                               AND H-WK-OPER-DSH > .2019
261300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
261400                                 * .825 + .0588.
261500
261600***********************************************************
261700**7**   RURAL HOSPITALS SCH
261800***  NOT TO EXCEED 12%
261900***  EXCEPT FOR URBAN TO RURAL HOSPITALS CR3459
262000
262100      IF W-CBSA-SIZE = 'R'
262200         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
262300                               AND H-WK-OPER-DSH > .1499
262400                               AND H-WK-OPER-DSH < .2020
262500         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
262600                                 * .65 + .025
262700        IF H-OPER-DSH > .1200
262800           IF P-NEW-DSH-ADJ-PROVIDERS
262900              IF P-NEW-BED-SIZE > 99
263000                 COMPUTE H-OPER-DSH ROUNDED =
263100                 (.1200 + ((H-OPER-DSH - .1200) * .6667))
263200              ELSE
263300                 MOVE .1200 TO H-OPER-DSH
263400           ELSE
263500              MOVE .1200 TO H-OPER-DSH
263600        ELSE
263700           NEXT SENTENCE
263800      ELSE
263900         NEXT SENTENCE.
264000
264100      IF W-CBSA-SIZE = 'R'
264200         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
264300                               AND H-WK-OPER-DSH > .2019
264400         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
264500                                 * .825 + .0588
264600        IF H-OPER-DSH > .1200
264700           IF P-NEW-DSH-ADJ-PROVIDERS
264800              IF P-NEW-BED-SIZE > 99
264900                 COMPUTE H-OPER-DSH ROUNDED =
265000                 (.1200 + ((H-OPER-DSH - .1200) * .6667))
265100              ELSE
265200                 MOVE .1200 TO H-OPER-DSH
265300           ELSE
265400              MOVE .1200 TO H-OPER-DSH
265500        ELSE
265600           NEXT SENTENCE
265700      ELSE
265800         NEXT SENTENCE.
265900***********************************************************
266000**6**   RURAL HOSPITALS RRC   RULE 5 & 6 SAME
266100***  RRC OVERRIDES SCH CAP
266200***  REMOVED CHECK FOR RURAL ON RRC'S CR3784H1
266300***     MADE THIS CHG ON 03/06/2006
266400***  NO CAP >> CAN EXCEED 12%
266500
266600***   IF W-CBSA-SIZE = 'R'
266700         IF (P-NEW-PROVIDER-TYPE = '07' OR '15' OR
266800                                   '17' OR '22')
266900                               AND H-WK-OPER-DSH > .1499
267000                               AND H-WK-OPER-DSH < .2020
267100         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
267200                                 * .65 + .025.
267300***   IF W-CBSA-SIZE = 'R'
267400         IF (P-NEW-PROVIDER-TYPE = '07' OR '15' OR
267500                                   '17' OR '22')
267600                               AND H-WK-OPER-DSH > .2019
267700         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
267800                                 * .825 + .0588.
267900
268000***********************************************************
268100
268200***********************************************************
268300***********************************************************
268400
268500      COMPUTE H-OPER-DSH ROUNDED = H-OPER-DSH * 1.0000.
268600
268700 3900A-EXIT.   EXIT.
268800
268900***********************************************************
269000***********************************************************
269100***********************************************************
269200***********************************************************
269300
269400 4000-CALC-TECH-ADDON.
269500
269600***********************************************************
269700***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
269800***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
269900***      CALCULATED FOR ADD ON DONE BEFORE OUTLER
270000***      CALCULATED FOR ADD ON DONE BEFORE SPECIAL DRGS
270100
270200     COMPUTE PPS-OPER-HSP-PART ROUNDED =
270300         H-OPER-HSP-PCT * H-OPER-HSP-PART.
270400
270500     COMPUTE PPS-OPER-FSP-PART ROUNDED =
270600         H-OPER-FSP-PCT * H-OPER-FSP-PART.
270700
270800     MOVE ZERO TO PPS-OPER-DSH-ADJ.
270900
271000     IF  H-OPER-DSH NUMERIC
271100             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
271200              PPS-OPER-FSP-PART
271300              * H-OPER-DSH.
271400
271500     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
271600             PPS-OPER-FSP-PART *
271700             H-OPER-IME-TEACH.
271800
271900     COMPUTE H-BASE-DRG-PAYMENT ROUNDED =
272000             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
272100             PPS-OPER-DSH-ADJ + PPS-OPER-IME-ADJ.
272200
272300***********************************************************
272400***       OP-1 CASES
272500***********************************************************
272600     IF B-DRG = 497 OR 498
272700        NEXT SENTENCE
272800     ELSE
272900        MOVE ZEROES TO H-NEW-TECH-ADDON-OP-1
273000        GO TO 4000-CHECK-CRT-D-CASES.
273100
273200     IF '8452   ' =  B-PRIN-PROC-CODE   OR
273300                     B-OTHER-PROC-CODE1 OR
273400                     B-OTHER-PROC-CODE2 OR
273500                     B-OTHER-PROC-CODE3 OR
273600                     B-OTHER-PROC-CODE4 OR
273700                     B-OTHER-PROC-CODE5
273800           NEXT SENTENCE
273900     ELSE
274000           MOVE ZEROES TO H-NEW-TECH-ADDON-OP-1
274100           GO TO 4000-CHECK-CRT-D-CASES.
274200
274300     IF B-DISCHARGE-DATE > 20050331
274400        GO TO 4000-APRIL-2005.
274500
274600     IF '8138   ' =  B-PRIN-PROC-CODE   OR
274700                     B-OTHER-PROC-CODE1 OR
274800                     B-OTHER-PROC-CODE2 OR
274900                     B-OTHER-PROC-CODE3 OR
275000                     B-OTHER-PROC-CODE4 OR
275100                     B-OTHER-PROC-CODE5 OR
275200        '8108   ' =  B-PRIN-PROC-CODE   OR
275300                     B-OTHER-PROC-CODE1 OR
275400                     B-OTHER-PROC-CODE2 OR
275500                     B-OTHER-PROC-CODE3 OR
275600                     B-OTHER-PROC-CODE4 OR
275700                     B-OTHER-PROC-CODE5 OR
275800        '8105   ' =  B-PRIN-PROC-CODE   OR
275900                     B-OTHER-PROC-CODE1 OR
276000                     B-OTHER-PROC-CODE2 OR
276100                     B-OTHER-PROC-CODE3 OR
276200                     B-OTHER-PROC-CODE4 OR
276300                     B-OTHER-PROC-CODE5 OR
276400        '8135   ' =  B-PRIN-PROC-CODE   OR
276500                     B-OTHER-PROC-CODE1 OR
276600                     B-OTHER-PROC-CODE2 OR
276700                     B-OTHER-PROC-CODE3 OR
276800                     B-OTHER-PROC-CODE4 OR
276900                     B-OTHER-PROC-CODE5
277000           NEXT SENTENCE
277100     ELSE
277200           MOVE ZEROES TO H-NEW-TECH-ADDON-OP-1
277300           GO TO 4000-CHECK-CRT-D-CASES.
277400
277500     GO TO 4000-CALCULATE-OP-1.
277600
277700 4000-APRIL-2005.
277800
277900     IF '8138   ' =  B-PRIN-PROC-CODE   OR
278000                     B-OTHER-PROC-CODE1 OR
278100                     B-OTHER-PROC-CODE2 OR
278200                     B-OTHER-PROC-CODE3 OR
278300                     B-OTHER-PROC-CODE4 OR
278400                     B-OTHER-PROC-CODE5 OR
278500        '8135   ' =  B-PRIN-PROC-CODE   OR
278600                     B-OTHER-PROC-CODE1 OR
278700                     B-OTHER-PROC-CODE2 OR
278800                     B-OTHER-PROC-CODE3 OR
278900                     B-OTHER-PROC-CODE4 OR
279000                     B-OTHER-PROC-CODE5
279100           NEXT SENTENCE
279200     ELSE
279300           MOVE ZEROES TO H-NEW-TECH-ADDON-OP-1
279400           GO TO 4000-CHECK-CRT-D-CASES.
279500
279600 4000-CALCULATE-OP-1.
279700
279800     MOVE  3910.00 TO H-CSTMED-OP-1.
279900
280000     COMPUTE H-LESSER-OP-1-1 ROUNDED =
280100             .5 * H-CSTMED-OP-1.
280200
280300     COMPUTE H-LESSER-OP-1-2 ROUNDED =
280400           ((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
280500                     H-BASE-DRG-PAYMENT) * .5.
280600
280700     IF H-LESSER-OP-1-2 > 0
280800        IF H-LESSER-OP-1-1 < H-LESSER-OP-1-2
280900           MOVE H-LESSER-OP-1-1 TO H-NEW-TECH-ADDON-OP-1
281000        ELSE
281100           MOVE H-LESSER-OP-1-2 TO H-NEW-TECH-ADDON-OP-1
281200     ELSE
281300        MOVE ZEROES          TO H-NEW-TECH-ADDON-OP-1.
281400
281500 4000-CHECK-CRT-D-CASES.
281600***********************************************************
281700***      CRT-D CASES
281800***********************************************************
281900
282000     IF '0051   ' =  B-PRIN-PROC-CODE   OR
282100                     B-OTHER-PROC-CODE1 OR
282200                     B-OTHER-PROC-CODE2 OR
282300                     B-OTHER-PROC-CODE3 OR
282400                     B-OTHER-PROC-CODE4 OR
282500                     B-OTHER-PROC-CODE5 OR
282600        '0054   ' =  B-PRIN-PROC-CODE   OR
282700                     B-OTHER-PROC-CODE1 OR
282800                     B-OTHER-PROC-CODE2 OR
282900                     B-OTHER-PROC-CODE3 OR
283000                     B-OTHER-PROC-CODE4 OR
283100                     B-OTHER-PROC-CODE5
283200           NEXT SENTENCE
283300     ELSE
283400           MOVE ZEROES TO H-NEW-TECH-ADDON-CRT-D
283500           GO TO 4000-CHECK-KINETRA-CASES.
283600
283700     MOVE 32525.00 TO H-CSTMED-CRT-D.
283800
283900     COMPUTE H-LESSER-CRT-D-1 ROUNDED =
284000             .5 * H-CSTMED-CRT-D.
284100
284200     COMPUTE H-LESSER-CRT-D-2 ROUNDED =
284300           ((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
284400                     H-BASE-DRG-PAYMENT) * .5.
284500
284600     IF H-LESSER-CRT-D-2 > 0
284700        IF H-LESSER-CRT-D-1 < H-LESSER-CRT-D-2
284800           MOVE H-LESSER-CRT-D-1 TO H-NEW-TECH-ADDON-CRT-D
284900        ELSE
285000           MOVE H-LESSER-CRT-D-2 TO H-NEW-TECH-ADDON-CRT-D
285100     ELSE
285200        MOVE ZEROES          TO H-NEW-TECH-ADDON-CRT-D.
285300
285400 4000-CHECK-KINETRA-CASES.
285500***********************************************************
285600***      KINETRA CASES
285700***********************************************************
285800
285900     IF '0293   ' =  B-PRIN-PROC-CODE   OR
286000                     B-OTHER-PROC-CODE1 OR
286100                     B-OTHER-PROC-CODE2 OR
286200                     B-OTHER-PROC-CODE3 OR
286300                     B-OTHER-PROC-CODE4 OR
286400                     B-OTHER-PROC-CODE5
286500           NEXT SENTENCE
286600     ELSE
286700           MOVE ZEROES TO H-NEW-TECH-ADDON-KINETRA
286800           GO TO 4000-CHECK-INFUSE-CASES.
286900
287000     IF '8695   ' =  B-PRIN-PROC-CODE   OR
287100                     B-OTHER-PROC-CODE1 OR
287200                     B-OTHER-PROC-CODE2 OR
287300                     B-OTHER-PROC-CODE3 OR
287400                     B-OTHER-PROC-CODE4 OR
287500                     B-OTHER-PROC-CODE5
287600           NEXT SENTENCE
287700     ELSE
287800           MOVE ZEROES TO H-NEW-TECH-ADDON-KINETRA
287900           GO TO 4000-CHECK-INFUSE-CASES.
288000
288100     MOVE 16570.00 TO H-CSTMED-KINETRA.
288200
288300     COMPUTE H-LESSER-KINETRA-1 ROUNDED =
288400             .5 * H-CSTMED-KINETRA.
288500
288600     COMPUTE H-LESSER-KINETRA-2 ROUNDED =
288700           ((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
288800                     H-BASE-DRG-PAYMENT) * .5.
288900
289000     IF H-LESSER-KINETRA-2 > 0
289100        IF H-LESSER-KINETRA-1 < H-LESSER-KINETRA-2
289200         MOVE H-LESSER-KINETRA-1 TO H-NEW-TECH-ADDON-KINETRA
289300        ELSE
289400         MOVE H-LESSER-KINETRA-2 TO H-NEW-TECH-ADDON-KINETRA
289500     ELSE
289600        MOVE ZEROES          TO H-NEW-TECH-ADDON-KINETRA.
289700
289800 4000-CHECK-INFUSE-CASES.
289900***********************************************************
290000***       INFUSE CASES
290100***********************************************************
290200     IF B-DRG = 497 OR 498
290300        NEXT SENTENCE
290400     ELSE
290500        MOVE ZEROES TO H-NEW-TECH-ADDON-INFUSE
290600        GO TO 4000-ADD-TECH-CASES.
290700
290800     IF '8451   ' =  B-PRIN-PROC-CODE   OR
290900                     B-OTHER-PROC-CODE1 OR
291000                     B-OTHER-PROC-CODE2 OR
291100                     B-OTHER-PROC-CODE3 OR
291200                     B-OTHER-PROC-CODE4 OR
291300                     B-OTHER-PROC-CODE5
291400           NEXT SENTENCE
291500     ELSE
291600           MOVE ZEROES TO H-NEW-TECH-ADDON-INFUSE
291700           GO TO 4000-ADD-TECH-CASES.
291800
291900     IF '8452   ' =  B-PRIN-PROC-CODE   OR
292000                     B-OTHER-PROC-CODE1 OR
292100                     B-OTHER-PROC-CODE2 OR
292200                     B-OTHER-PROC-CODE3 OR
292300                     B-OTHER-PROC-CODE4 OR
292400                     B-OTHER-PROC-CODE5
292500           NEXT SENTENCE
292600     ELSE
292700           MOVE ZEROES TO H-NEW-TECH-ADDON-INFUSE
292800           GO TO 4000-ADD-TECH-CASES.
292900
293000     IF '8138   ' =  B-PRIN-PROC-CODE   OR
293100                     B-OTHER-PROC-CODE1 OR
293200                     B-OTHER-PROC-CODE2 OR
293300                     B-OTHER-PROC-CODE3 OR
293400                     B-OTHER-PROC-CODE4 OR
293500                     B-OTHER-PROC-CODE5 OR
293600        '8108   ' =  B-PRIN-PROC-CODE   OR
293700                     B-OTHER-PROC-CODE1 OR
293800                     B-OTHER-PROC-CODE2 OR
293900                     B-OTHER-PROC-CODE3 OR
294000                     B-OTHER-PROC-CODE4 OR
294100                     B-OTHER-PROC-CODE5 OR
294200        '8105   ' =  B-PRIN-PROC-CODE   OR
294300                     B-OTHER-PROC-CODE1 OR
294400                     B-OTHER-PROC-CODE2 OR
294500                     B-OTHER-PROC-CODE3 OR
294600                     B-OTHER-PROC-CODE4 OR
294700                     B-OTHER-PROC-CODE5 OR
294800        '8135   ' =  B-PRIN-PROC-CODE   OR
294900                     B-OTHER-PROC-CODE1 OR
295000                     B-OTHER-PROC-CODE2 OR
295100                     B-OTHER-PROC-CODE3 OR
295200                     B-OTHER-PROC-CODE4 OR
295300                     B-OTHER-PROC-CODE5
295400           MOVE ZEROES TO H-NEW-TECH-ADDON-INFUSE
295500           GO TO 4000-ADD-TECH-CASES.
295600
295700     MOVE 3910.00 TO H-CSTMED-INFUSE.
295800
295900     COMPUTE H-LESSER-INFUSE-1 ROUNDED =
296000             .5 * H-CSTMED-INFUSE.
296100
296200     COMPUTE H-LESSER-INFUSE-2 ROUNDED =
296300           ((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
296400                     H-BASE-DRG-PAYMENT) * .5.
296500
296600     IF H-LESSER-INFUSE-2 > 0
296700        IF H-LESSER-INFUSE-1 < H-LESSER-INFUSE-2
296800           MOVE H-LESSER-INFUSE-1 TO H-NEW-TECH-ADDON-INFUSE
296900        ELSE
297000           MOVE H-LESSER-INFUSE-2 TO H-NEW-TECH-ADDON-INFUSE
297100     ELSE
297200        MOVE ZEROES          TO H-NEW-TECH-ADDON-INFUSE.
297300
297400 4000-ADD-TECH-CASES.
297500
297600     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
297700             H-NEW-TECH-ADDON-OP-1  +
297800             H-NEW-TECH-ADDON-CRT-D +
297900             H-NEW-TECH-ADDON-KINETRA +
298000             H-NEW-TECH-ADDON-INFUSE.
298100
298200 4000-EXIT.    EXIT.
298300
298400******        L A S T   S O U R C E   S T A T E M E N T   *****
