000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPCAL08D.
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     'PPCAL08D      - W O R K I N G   S T O R A G E'.
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C08.D'.
002000 01  HMO-FLAG                       PIC X      VALUE 'N'.
002100 01  HMO-TAG                        PIC X      VALUE SPACE.
002200 01  OUTLIER-RECON-FLAG             PIC X      VALUE 'N'.
002300 01  TEMP-RELIEF-FLAG               PIC X      VALUE 'N'.
002400 01  NON-TEMP-RELIEF-PAYMENT        PIC 9(07)V9(02) VALUE ZEROES.
002500 01  WK-H-OPER-DOLLAR-THRESHOLD     PIC 9(07)V9(09) VALUE ZEROES.
002600 01  WK-LOW-VOL25PCT                PIC 99V999 VALUE 01.000.
002700 01  R1                             PIC S9(04) COMP SYNC.
002800 01  R2                             PIC S9(04) COMP SYNC.
002900 01  R3                             PIC S9(04) COMP SYNC.
003000 01  R4                             PIC S9(04) COMP SYNC.
003100 01  H-OPER-DSH-SCH                 PIC 9(01)V9(04).
003200 01  H-OPER-DSH-RRC                 PIC 9(01)V9(04).
003300
003400***************************************************************
003500**************YEARCHANGE***************************************
003600* TABLE 1                                                     *
003700*    (69.7% LABOR SHARE/30.3% NONLABOR SHARE)                 *
003800*    (FULL UPDATE (.697)                                      *
003900*    (QUALITY = 1 WAGE INDEX > 1)                             *
004000***************************************************************
004100**********YEARCHANGE**** 2008.6 *******************************
004200 01  TB1-RATE-TABLE.
004300     02  TB1-RATE-WORK.
004400*RATE 20071001 REGION  LABOR AND NON-LABOR RATES
004500*                  R3=1     /     R3=2
004600*               LARGE URBAN / OTHER URBAN
004700*               LABOR / NON / LABOR / NON
004800*                     /LABOR/       /LABOR
004900*             --------------------------------------------
005000         05  FILLER PIC X(08) VALUE '20071001'.
005100         05  TB1-NAT    PIC X(30) VALUE
005200            ' 0347845 151215 0347845 151215'.
005300         05  TB1-PR     PIC X(30) VALUE
005400            ' 0147110 090164 0147110 090164'.
005500         05  TB1-NATPR  PIC X(30) VALUE
005600            ' 0347845 151215 0347845 151215'.
005700***************************************************************
005800     02  TB1-RATE-TAB REDEFINES TB1-RATE-WORK.
005900         05  TB1-RATE-PERIOD            OCCURS 1.
006000             10  TB1-RATE-EFF-DATE      PIC X(08).
006100             10  TB1-REG-NAT            OCCURS 3.
006200                 15  TB1-LARGE-OTHER    OCCURS 2.
006300                     20  FILLER         PIC X(01).
006400                     20  TB1-REG-LABOR  PIC 9(05)V9(02).
006500                     20  FILLER         PIC X(01).
006600                     20  TB1-REG-NLABOR PIC 9(04)V9(02).
006700
006800***************************************************************
006900************YEARCHANGE*****************************************
007000* TABLE 2                                                     *
007100*    (69.7% LABOR SHARE/30.3% NONLABOR SHARE)                 *
007200*    (REDUCED UPDATE (.697)                                   *
007300*    (QUALITY NOT = 1 WAGE INDEX > 1)                         *
007400***************************************************************
007500**********YEARCHANGE**** 2008.6 *******************************
007600 01  TB2-RATE-TABLE.
007700     02  TB2-RATE-WORK.
007800*RATE 20071001 REGION  LABOR AND NON-LABOR RATES
007900*                  R3=1     /     R3=2
008000*               LARGE URBAN / OTHER URBAN
008100*               LABOR / NON / LABOR / NON
008200*                     /LABOR/       /LABOR
008300*             --------------------------------------------
008400         05  FILLER PIC X(08) VALUE '20071001'.
008500         05  TB2-NAT    PIC X(30) VALUE
008600            ' 0341110 148287 0341110 148287'.
008700         05  TB2-PR     PIC X(30) VALUE
008800            ' 0147110 090164 0147110 090164'.
008900         05  TB2-NATPR  PIC X(30) VALUE
009000            ' 0341110 148287 0341110 148287'.
009100***************************************************************
009200     02  TB2-RATE-TAB REDEFINES TB2-RATE-WORK.
009300         05  TB2-RATE-PERIOD             OCCURS 1.
009400             10  TB2-RATE-EFF-DATE       PIC X(08).
009500             10  TB2-REG-NAT             OCCURS 3.
009600                 15  TB2-LARGE-OTHER     OCCURS 2.
009700                     20  FILLER          PIC X(01).
009800                     20  TB2-REG-LABOR   PIC 9(05)V9(02).
009900                     20  FILLER          PIC X(01).
010000                     20  TB2-REG-NLABOR  PIC 9(04)V9(02).
010100***************************************************************
010200************YEARCHANGE*****************************************
010300* TABLE 3                                                     *
010400*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *
010500*    (FULL UPDATE (.62%)                                      *
010600*    (QUALITY = 1 WAGE INDEX <= 1)                            *
010700***************************************************************
010800**********YEARCHANGE**** 2008.6 *******************************
010900 01  TB3-RATE-TABLE.
011000     02  TB3-RATE-WORK.
011100*RATE 20071001 REGION  LABOR AND NON-LABOR RATES
011200*                  R3=1     /     R3=2
011300*               LARGE URBAN / OTHER URBAN
011400*               LABOR / NON / LABOR / NON
011500*                     /LABOR/       /LABOR
011600*             --------------------------------------------
011700         05  FILLER PIC X(08) VALUE '20071001'.
011800         05  TB3-NAT    PIC X(30) VALUE
011900            ' 0309417 189643 0309417 189643'.
012000         05  TB3-PR     PIC X(30) VALUE
012100            ' 0139280 097994 0139280 097994'.
012200         05  TB3-NATPR  PIC X(30) VALUE
012300            ' 0309417 189643 0309417 189643'.
012400****************************************************************
012500     02  TB3-RATE-TAB REDEFINES TB3-RATE-WORK.
012600         05  TB3-RATE-PERIOD            OCCURS 1.
012700             10  TB3-RATE-EFF-DATE      PIC X(08).
012800             10  TB3-REG-NAT            OCCURS 3.
012900                 15  TB3-LARGE-OTHER    OCCURS 2.
013000                     20  FILLER         PIC X(01).
013100                     20  TB3-REG-LABOR  PIC 9(05)V9(02).
013200                     20  FILLER         PIC X(01).
013300                     20  TB3-REG-NLABOR PIC 9(04)V9(02).
013400
013500***************************************************************
013600**********YEARCHANGE**** 2008.6 *******************************
013700* TABLE 4                                                     *
013800*    (62% LABOR SHARE/38% NONLABOR SHARE)                     *
013900*    (REDUCED UPDATE (.62%)                                   *
014000*    (QUALITY NOT = 1 WAGE INDEX <=1)                         *
014100***************************************************************
014200 01  TB4-RATE-TABLE.
014300     02  TB4-RATE-WORK.
014400*RATE 20071001 REGION  LABOR AND NON-LABOR RATES
014500*                  R3=1     /     R3=2
014600*               LARGE URBAN / OTHER URBAN
014700*               LABOR / NON / LABOR / NON
014800*                     /LABOR/       /LABOR
014900*             --------------------------------------------
015000         05  FILLER PIC X(08) VALUE '20071001'.
015100         05  TB4-NAT    PIC X(30) VALUE
015200            ' 0303426 185971 0303426 185971'.
015300         05  TB4-PR     PIC X(30) VALUE
015400            ' 0139280 097994 0139280 097994'.
015500         05  TB4-NATPR  PIC X(30) VALUE
015600            ' 0303426 185971 0303426 185971'.
015700***************************************************************
015800     02  TB4-RATE-TAB REDEFINES TB4-RATE-WORK.
015900         05  TB4-RATE-PERIOD             OCCURS 1.
016000             10  TB4-RATE-EFF-DATE       PIC X(08).
016100             10  TB4-REG-NAT             OCCURS 3.
016200                 15  TB4-LARGE-OTHER     OCCURS 2.
016300                     20  FILLER          PIC X(01).
016400                     20  TB4-REG-LABOR   PIC 9(05)V9(02).
016500                     20  FILLER          PIC X(01).
016600                     20  TB4-REG-NLABOR  PIC 9(04)V9(02).
016700
016800 01  DRG-TABLE.
016900     05  D-TAB.
017000       10  FILLER                  PIC X(08) VALUE
017100     '20071001'.
017200       10  FILLER                  PIC X(56) VALUE
017300     '23111730800456162735161002281877073340040611421923800293'.
017400       10  FILLER                  PIC X(56) VALUE
017500     '10612017600235072562091001050840021460017305172610100118'.
017600       10  FILLER                  PIC X(56) VALUE
017700     '06484218100217038902092001050414821290016203247208900109'.
017800       10  FILLER                  PIC X(56) VALUE
017900     '02676006100072000000000000000000000000000000000000000000'.
018000       10  FILLER                  PIC X(56) VALUE
018100     '00000000000000000000000000000000000000000007707315200191'.
018200       10  FILLER                  PIC X(56) VALUE
018300     '06702113400155056085078000960470360900012803897806100089'.
018400       10  FILLER                  PIC X(56) VALUE
018500     '04236210300133031582065000820232590350004604233910800147'.
018600       10  FILLER                  PIC X(56) VALUE
018700     '02835605300073017617028000370322260920013201934203800058'.
018800       10  FILLER                  PIC X(56) VALUE
018900     '01428102300031025438048000730189960200002901697701300016'.
019000       10  FILLER                  PIC X(56) VALUE
019100     '02263006000087014686025000370109090150001803255010000136'.
019200       10  FILLER                  PIC X(56) VALUE
019300     '02359505400073018710025000360000000000000000000000000000'.
019400       10  FILLER                  PIC X(56) VALUE
019500     '00000000000000000000000000000000000000000000000000000000'.
019600       10  FILLER                  PIC X(56) VALUE
019700     '00000000000000000000000000000000000000000001432904700070'.
019800       10  FILLER                  PIC X(56) VALUE
019900     '01117203100040014228053000720112130380005001282005800078'.
020000       10  FILLER                  PIC X(56) VALUE
020100     '00895103900049012669058000800092260430005200816003400041'.
020200       10  FILLER                  PIC X(56) VALUE
020300     '02554107300096020886053000630186420390004501547005600076'.
020400       10  FILLER                  PIC X(56) VALUE
020500     '01190104300053010303031000380121940470006200913102800036'.
020600       10  FILLER                  PIC X(56) VALUE
020700     '00733902500031016212060000790125220450005600958602900037'.
020800       10  FILLER                  PIC X(56) VALUE
020900     '01171704800064008954034000440153690600007601143903400042'.
021000       10  FILLER                  PIC X(56) VALUE
021100     '01461105600072010996037000460098390280003400901403600049'.
021200       10  FILLER                  PIC X(56) VALUE
021300     '00716102700034016724039000640133280370005201110602300031'.
021400       10  FILLER                  PIC X(56) VALUE
021500     '01694605700079012337040000510092350260003401296804300061'.
021600       10  FILLER                  PIC X(56) VALUE
021700     '00947903000038007405020000250132420470006600952903500044'.
021800       10  FILLER                  PIC X(56) VALUE
021900     '00771002600032031499097001250256790720009102348204900062'.
022000       10  FILLER                  PIC X(56) VALUE
022100     '02666509300118020568068000850181770510006301250004700063'.
022200       10  FILLER                  PIC X(56) VALUE
022300     '00825802900037008710036000510066770250003200000000000000'.
022400       10  FILLER                  PIC X(56) VALUE
022500     '00000000000000000000000000000000000000000000000000000000'.
022600       10  FILLER                  PIC X(56) VALUE
022700     '00000000000000000000000000000000000000000000000000000000'.
022800       10  FILLER                  PIC X(56) VALUE
022900     '01414103800055010292020000270111850330004500889102200034'.
023000       10  FILLER                  PIC X(56) VALUE
023100     '00709401500019000000000000000000000000000000000000000000'.
023200       10  FILLER                  PIC X(56) VALUE
023300     '00880004600058006608033000410072240240002900930803900053'.
023400       10  FILLER                  PIC X(56) VALUE
023500     '00679202700035000000000000000000000000000000000000000000'.
023600       10  FILLER                  PIC X(56) VALUE
023700     '01799203700051013987024000320163000400005801205402100026'.
023800       10  FILLER                  PIC X(56) VALUE
023900     '01433103700058009474017000210153180430006401109401800026'.
024000       10  FILLER                  PIC X(56) VALUE
024100     '01267703700054008474019000240084700140001800000000000000'.
024200       10  FILLER                  PIC X(56) VALUE
024300     '00000000000000000000000000000000000000000000000000000000'.
024400       10  FILLER                  PIC X(56) VALUE
024500     '00000000000000017734071001030121820420005801007002500035'.
024600       10  FILLER                  PIC X(56) VALUE
024700     '00615402200027009916040000550062270230002900816003700047'.
024800       10  FILLER                  PIC X(56) VALUE
024900     '00620702800034011294048000650086300350004500741202500032'.
025000       10  FILLER                  PIC X(56) VALUE
025100     '01190905000069008653034000440073610240003100000000000000'.
025200       10  FILLER                  PIC X(56) VALUE
025300     '00000000000000000000000000000404521220015002808106900083'.
025400       10  FILLER                  PIC X(56) VALUE
025500     '02410604500054032677101001300241510650008101818104000054'.
025600       10  FILLER                  PIC X(56) VALUE
025700     '00000000000000000000000000000000000000000000000000000000'.
025800       10  FILLER                  PIC X(56) VALUE
025900     '00000000000000000000000000000141520610007401158004700055'.
026000       10  FILLER                  PIC X(56) VALUE
026100     '01844407200092015636060000740127540460005601555006100080'.
026200       10  FILLER                  PIC X(56) VALUE
026300     '01312604500060011455033000430126640570007200961103800046'.
026400       10  FILLER                  PIC X(56) VALUE
026500     '00729802700033014542058000750119470420005500974503200041'.
026600       10  FILLER                  PIC X(56) VALUE
026700     '01366004800062011138051000650094050420005100814503400040'.
026800       10  FILLER                  PIC X(56) VALUE
026900     '01250505500069010235045000530083980350004101378105800073'.
027000       10  FILLER                  PIC X(56) VALUE
027100     '01145804400054009654035000430146990660008501075303900051'.
027200       10  FILLER                  PIC X(56) VALUE
027300     '00858803200041007841036000450062520290003500665802200029'.
027400       10  FILLER                  PIC X(56) VALUE
027500     '01063604200056007848027000350512311260015002246305200073'.
027600       10  FILLER                  PIC X(56) VALUE
027700     '00000000000000000000000000000000000000000000000000000000'.
027800       10  FILLER                  PIC X(56) VALUE
027900     '00000000000000000000000000001200160630012009304015900187'.
028000       10  FILLER                  PIC X(56) VALUE
028100     '07581310900122068595083000910720721170014505727807600086'.
028200       10  FILLER                  PIC X(56) VALUE
028300     '05246306000064080234108001330688090500006607317809200115'.
028400       10  FILLER                  PIC X(56) VALUE
028500     '06295604500057059123062000940504110180002806740012000146'.
028600       10  FILLER                  PIC X(56) VALUE
028700     '05319107900090047847056000660729931080013206194708000090'.
028800       10  FILLER                  PIC X(56) VALUE
028900     '06449612400143049216082000890513810970011503730706100066'.
029000       10  FILLER                  PIC X(56) VALUE
029100     '04495407800112031891034000490394541210015602998308400105'.
029200       10  FILLER                  PIC X(56) VALUE
029300     '02470905700069032586069000890254830380005102136702200029'.
029400       10  FILLER                  PIC X(56) VALUE
029500     '03107302100033029046037000550212550170002202518004300062'.
029600       10  FILLER                  PIC X(56) VALUE
029700     '01812401900025024870053000750174800210003002756405600088'.
029800       10  FILLER                  PIC X(56) VALUE
029900     '02253604100060016786020000280214860730009901684705800075'.
030000       10  FILLER                  PIC X(56) VALUE
030100     '01399003700049022926055000760165530190002602162507200102'.
030200       10  FILLER                  PIC X(56) VALUE
030300     '01321202800039011245019000250149770350005502484005900090'.
030400       10  FILLER                  PIC X(56) VALUE
030500     '00000000000000000000000000000000000000000000000000000000'.
030600       10  FILLER                  PIC X(56) VALUE
030700     '00000000000000000000000000000000000000000000000000000000'.
030800       10  FILLER                  PIC X(56) VALUE
030900     '00000000000000000000000000000000000000000000000000000000'.
031000       10  FILLER                  PIC X(56) VALUE
031100     '00000000000000000000000000000000000000000001739105900075'.
031200       10  FILLER                  PIC X(56) VALUE
031300     '01312604000049010617026000320157870340005501207402300035'.
031400       10  FILLER                  PIC X(56) VALUE
031500     '01042101600022016667052000710114120250003202914309600122'.
031600       10  FILLER                  PIC X(56) VALUE
031700     '02307507100087019733052000660125850510006601013404100050'.
031800       10  FILLER                  PIC X(56) VALUE
031900     '00876503100037008665046000550069500380004401114402000033'.
032000       10  FILLER                  PIC X(56) VALUE
032100     '00849001500019007207012000140122200520006900945104100051'.
032200       10  FILLER                  PIC X(56) VALUE
032300     '00718303100038008236033000440060550210002600831203900052'.
032400       10  FILLER                  PIC X(56) VALUE
032500     '00594202300029012007045000650082240270003501084104300058'.
032600       10  FILLER                  PIC X(56) VALUE
032700     '00823303100039006439023000280051180190002300719702500032'.
032800       10  FILLER                  PIC X(56) VALUE
032900     '00548901700021015606051000710117200350004600907502400030'.
033000       10  FILLER                  PIC X(56) VALUE
033100     '00000000000000000000000000000000000000000000000000000000'.
033200       10  FILLER                  PIC X(56) VALUE
033300     '00000000000000000000000000000000000000000000000000000000'.
033400       10  FILLER                  PIC X(56) VALUE
033500     '00000000000000051660134001720329410810010301801703300044'.
033600       10  FILLER                  PIC X(56) VALUE
033700     '04505912800159028935084000980184150540006003713912200147'.
033800       10  FILLER                  PIC X(56) VALUE
033900     '02578707800089017856049000560347851180014402477607700093'.
034000       10  FILLER                  PIC X(56) VALUE
034100     '01698404400057027254091001090198050610007101384903600043'.
034200       10  FILLER                  PIC X(56) VALUE
034300     '01882405300073013562034000430098870190002302515609400120'.
034400       10  FILLER                  PIC X(56) VALUE
034500     '01702806200072012617044000500176580620008401278104100055'.
034600       10  FILLER                  PIC X(56) VALUE
034700     '00862902400030018330059000810124490340004500896701900024'.
034800       10  FILLER                  PIC X(56) VALUE
034900     '02024106600088014092040000510101470230002903379009600133'.
035000       10  FILLER                  PIC X(56) VALUE
035100     '02494606100080017333034000460000000000000000000000000000'.
035200       10  FILLER                  PIC X(56) VALUE
035300     '00000000000000000000000000000000000000000000000000000000'.
035400       10  FILLER                  PIC X(56) VALUE
035500     '00000000000000000000000000000000000000000001378805100066'.
035600       10  FILLER                  PIC X(56) VALUE
035700     '01083903700046009558028000340162630660008801305905500068'.
035800       10  FILLER                  PIC X(56) VALUE
035900     '01110904200050017229065000880133370460006001026803100041'.
036000       10  FILLER                  PIC X(56) VALUE
036100     '01336705000065010195037000450084760290003401433405500072'.
036200       10  FILLER                  PIC X(56) VALUE
036300     '01130204200051009662030000360110240460005900839903200038'.
036400       10  FILLER                  PIC X(56) VALUE
036500     '01493606700090010766046000570094880360004401286005500074'.
036600       10  FILLER                  PIC X(56) VALUE
036700     '00953304000050007260030000360095650410005500712102800035'.
036800       10  FILLER                  PIC X(56) VALUE
036900     '01323705000070010257038000490078740270003400000000000000'.
037000       10  FILLER                  PIC X(56) VALUE
037100     '00000000000000000000000000000000000000000000000000000000'.
037200       10  FILLER                  PIC X(56) VALUE
037300     '00000000000000000000000000000000000000000000000000000000'.
037400       10  FILLER                  PIC X(56) VALUE
037500     '04827312800173033149071000950224430420005503854012200151'.
037600       10  FILLER                  PIC X(56) VALUE
037700     '02912608200099020794057000680341281090013102638207600088'.
037800       10  FILLER                  PIC X(56) VALUE
037900     '01941205200060030942097001190227490660007701539804100049'.
038000       10  FILLER                  PIC X(56) VALUE
038100     '02136106600084017104045000560124000250003203485110100142'.
038200       10  FILLER                  PIC X(56) VALUE
038300     '02255705600078019432034000450395931140015503010407800102'.
038400       10  FILLER                  PIC X(56) VALUE
038500     '02581204500056000000000000000000000000000000000000000000'.
038600       10  FILLER                  PIC X(56) VALUE
038700     '00000000000000000000000000000000000000000001503305100069'.
038800       10  FILLER                  PIC X(56) VALUE
038900     '01143103800049010125028000360156610580007701290604500059'.
039000       10  FILLER                  PIC X(56) VALUE
039100     '01170903300044014201056000770106090430005400891203200039'.
039200       10  FILLER                  PIC X(56) VALUE
039300     '01397305100070010935040000510090790310003801374405000066'.
039400       10  FILLER                  PIC X(56) VALUE
039500     '01103003800048008521026000330000000000000000000000000000'.
039600       10  FILLER                  PIC X(56) VALUE
039700     '00000000000000000000000000000000000000000000000000000000'.
039800       10  FILLER                  PIC X(56) VALUE
039900     '08431312700159065810068000840570230410004706766912100159'.
040000       10  FILLER                  PIC X(56) VALUE
040100     '05465006400078049437041000460486790780009603487003800043'.
040200       10  FILLER                  PIC X(56) VALUE
040300     '03834506900085030993039000430396151230016902882107800104'.
040400       10  FILLER                  PIC X(56) VALUE
040500     '02341704600062035408076000950275230480005602454503700040'.
040600       10  FILLER                  PIC X(56) VALUE
040700     '02666407100084019871037000400347230700010102481902900043'.
040800       10  FILLER                  PIC X(56) VALUE
040900     '01944601600020028432095001250213080660008601679903800050'.
041000       10  FILLER                  PIC X(56) VALUE
041100     '02655509600125019836048000680167840190002802402708000095'.
041200       10  FILLER                  PIC X(56) VALUE
041300     '01848505400060015644045000490199050350004401737602200025'.
041400       10  FILLER                  PIC X(56) VALUE
041500     '02936210200124023382068000810177710500005801658404100051'.
041600       10  FILLER                  PIC X(56) VALUE
041700     '01451202700031014912033000470100660180002302241306900087'.
041800       10  FILLER                  PIC X(56) VALUE
041900     '01718604400053012752028000340257650830011101779204600060'.
042000       10  FILLER                  PIC X(56) VALUE
042100     '01230102300031017563058000820118870230003102409608100113'.
042200       10  FILLER                  PIC X(56) VALUE
042300     '01559804400059010342023000290175380690008901405805000064'.
042400       10  FILLER                  PIC X(56) VALUE
042500     '01158402600034010877023000320142960360005201133001700020'.
042600       10  FILLER                  PIC X(56) VALUE
042700     '01076901900028016616050000660125120310003900960201700021'.
042800       10  FILLER                  PIC X(56) VALUE
042900     '01174803700051008313020000260248580810010901830704400060'.
043000       10  FILLER                  PIC X(56) VALUE
043100     '01419202000029000000000000000000000000000000000000000000'.
043200       10  FILLER                  PIC X(56) VALUE
043300     '00000000000000000000000000000000000000000000000000000000'.
043400       10  FILLER                  PIC X(56) VALUE
043500     '00000000000000000000000000000000000000000000000000000000'.
043600       10  FILLER                  PIC X(56) VALUE
043700     '00000000000000000000000000000000000000000000000000000000'.
043800       10  FILLER                  PIC X(56) VALUE
043900     '01129405100069007560032000400108360480006400734003400040'.
044000       10  FILLER                  PIC X(56) VALUE
044100     '00752803800047005986026000310176480770010201402605800072'.
044200       10  FILLER                  PIC X(56) VALUE
044300     '01210104400057014877068000870111510480006000939503700045'.
044400       10  FILLER                  PIC X(56) VALUE
044500     '01833006500090012092043000550090540320003901537207000093'.
044600       10  FILLER                  PIC X(56) VALUE
044700     '01152205000062009567036000450116320550007200783903400042'.
044800       10  FILLER                  PIC X(56) VALUE
044900     '00919904800061006475030000370078860360004900595802500032'.
045000       10  FILLER                  PIC X(56) VALUE
045100     '01217105400069008480035000430121040510007300852103600047'.
045200       10  FILLER                  PIC X(56) VALUE
045300     '00675302100027011163050000650069810310003701160605300071'.
045400       10  FILLER                  PIC X(56) VALUE
045500     '00900304000051007790029000370000000000000000000000000000'.
045600       10  FILLER                  PIC X(56) VALUE
045700     '00000000000000000000000000000000000000000000000000000000'.
045800       10  FILLER                  PIC X(56) VALUE
045900     '02748310100138020177072000950142160470005902476607800121'.
046000       10  FILLER                  PIC X(56) VALUE
046100     '01626204100060010742025000340230930810011101425603600055'.
046200       10  FILLER                  PIC X(56) VALUE
046300     '00912401900026009432021000290075230160001801248403700057'.
046400       10  FILLER                  PIC X(56) VALUE
046500     '00906601700022000000000000000000000000000000000000000000'.
046600       10  FILLER                  PIC X(56) VALUE
046700     '00000000000000000000000000000000000000000001455506600089'.
046800       10  FILLER                  PIC X(56) VALUE
046900     '01106005200065009335039000490139970600008200876603800048'.
047000       10  FILLER                  PIC X(56) VALUE
047100     '01403405900082010695042000560072320260003600847104100054'.
047200       10  FILLER                  PIC X(56) VALUE
047300     '00671503100038011522055000700080870390004700968104100054'.
047400       10  FILLER                  PIC X(56) VALUE
047500     '00686302800035009223042000590065050290003800000000000000'.
047600       10  FILLER                  PIC X(56) VALUE
047700     '00000000000000000000000000000000000000000000000000000000'.
047800       10  FILLER                  PIC X(56) VALUE
047900     '00000000000000021978052000730165020280003403144912600156'.
048000       10  FILLER                  PIC X(56) VALUE
048100     '02207107200090017554049000610276250640009301929403400042'.
048200       10  FILLER                  PIC X(56) VALUE
048300     '01687602100024027257097001320200650680008701605604600059'.
048400       10  FILLER                  PIC X(56) VALUE
048500     '01592805000075010183022000330081690130001503060207800118'.
048600       10  FILLER                  PIC X(56) VALUE
048700     '02473007000088017767037000510000000000000000000000000000'.
048800       10  FILLER                  PIC X(56) VALUE
048900     '00000000000000000000000000000000000000000000000000000000'.
049000       10  FILLER                  PIC X(56) VALUE
049100     '01089104600062008021034000430067420250003100979304100056'.
049200       10  FILLER                  PIC X(56) VALUE
049300     '00724803100039010616038000530139260600007801063804300054'.
049400       10  FILLER                  PIC X(56) VALUE
049500     '00831003200039000000000000000000000000000000000000000000'.
049600       10  FILLER                  PIC X(56) VALUE
049700     '00000000000000000000000000000000000000000003065406600079'.
049800       10  FILLER                  PIC X(56) VALUE
049900     '04571013300168031860088001010270750580006602660308400108'.
050000       10  FILLER                  PIC X(56) VALUE
050100     '01899705100061016556033000380281190820011302060504800065'.
050200       10  FILLER                  PIC X(56) VALUE
050300     '01400402600033020375073001050142540360005301038801600021'.
050400       10  FILLER                  PIC X(56) VALUE
050500     '02139309300122014691043000630093350200002701720806300086'.
050600       10  FILLER                  PIC X(56) VALUE
050700     '01207903100044008838019000250128080390005800842201900025'.
050800       10  FILLER                  PIC X(56) VALUE
050900     '02523506000102021024040000660171960140001900000000000000'.
051000       10  FILLER                  PIC X(56) VALUE
051100     '00000000000000000000000000000000000000000000000000000000'.
051200       10  FILLER                  PIC X(56) VALUE
051300     '00000000000000014664053000730119420450005700983503100038'.
051400       10  FILLER                  PIC X(56) VALUE
051500     '00859902400035014513060000810111470400005300857702500032'.
051600       10  FILLER                  PIC X(56) VALUE
051700     '01058705000064008000036000430115080300004200945701800023'.
051800       10  FILLER                  PIC X(56) VALUE
051900     '01045903900052007110020000260094220430005700627602600032'.
052000       10  FILLER                  PIC X(56) VALUE
052100     '00722302400033013017051000680103520380004900823202700035'.
052200       10  FILLER                  PIC X(56) VALUE
052300     '00000000000000000000000000000000000000000000000000000000'.
052400       10  FILLER                  PIC X(56) VALUE
052500     '00000000000000000000000000000155210350004501185802000024'.
052600       10  FILLER                  PIC X(56) VALUE
052700     '01613403600065012986015000190160510530007801084202100030'.
052800       10  FILLER                  PIC X(56) VALUE
052900     '00985002900042006710017000200153000380006101131001300015'.
053000       10  FILLER                  PIC X(56) VALUE
053100     '01565305000075010329021000270000000000000000000000000000'.
053200       10  FILLER                  PIC X(56) VALUE
053300     '00000000000000012827056000740106030420005400767702500033'.
053400       10  FILLER                  PIC X(56) VALUE
053500     '00907104400057006886028000350100830510006500724103300040'.
053600       10  FILLER                  PIC X(56) VALUE
053700     '00954203700051007058024000320000000000000000000000000000'.
053800       10  FILLER                  PIC X(56) VALUE
053900     '00000000000000020185058000760137980300003503210811500139'.
054000       10  FILLER                  PIC X(56) VALUE
054100     '02102206200074016754035000390220810790010201457704400052'.
054200       10  FILLER                  PIC X(56) VALUE
054300     '01030802800031012422035000460086720210002301189604000058'.
054400       10  FILLER                  PIC X(56) VALUE
054500     '00866002100025010488030000410084990170001900791601500018'.
054600       10  FILLER                  PIC X(56) VALUE
054700     '02281307100098014993026000330000000000000000000000000000'.
054800       10  FILLER                  PIC X(56) VALUE
054900     '00000000000000015596064000890116080420005600770202500033'.
055000       10  FILLER                  PIC X(56) VALUE
055100     '01432806800089011147049000610096090370004600691002900038'.
055200       10  FILLER                  PIC X(56) VALUE
055300     '00556902000025000000000000000000000000000000000000000000'.
055400       10  FILLER                  PIC X(56) VALUE
055500     '00994304100053007664030000320072460250002901734804700058'.
055600       10  FILLER                  PIC X(56) VALUE
055700     '01911403200057007336016000260000000000000000000000000000'.
055800       10  FILLER                  PIC X(56) VALUE
055900     '00000000000000005914026000320044610210002300646002600035'.
056000       10  FILLER                  PIC X(56) VALUE
056100     '00708701800021003744020000280060130170002600284501300027'.
056200       10  FILLER                  PIC X(56) VALUE
056300     '00568902700039004297017000280000000000000000000000000000'.
056400       10  FILLER                  PIC X(56) VALUE
056500     '00000000000000000000000000000000000000000000000000000000'.
056600       10  FILLER                  PIC X(56) VALUE
056700     '01425001800018046990179001790320931330013301936408600086'.
056800       10  FILLER                  PIC X(56) VALUE
056900     '03296604700047011668034000340015800310003100000000000000'.
057000       10  FILLER                  PIC X(56) VALUE
057100     '00000000000000000000000000000395131070014302761706400082'.
057200       10  FILLER                  PIC X(56) VALUE
057300     '02325203700048027940091001280182590470006501475402400032'.
057400       10  FILLER                  PIC X(56) VALUE
057500     '00000000000000000000000000000000000000000001617106000080'.
057600       10  FILLER                  PIC X(56) VALUE
057700     '01203103900050010741031000390100060400005500778002800037'.
057800       10  FILLER                  PIC X(56) VALUE
057900     '01342603800052013226053000720102330390004900799002700034'.
058000       10  FILLER                  PIC X(56) VALUE
058100     '00000000000000000000000000000000000000000004497013800184'.
058200       10  FILLER                  PIC X(56) VALUE
058300     '02684705400078015989027000370351881200015402516406600088'.
058400       10  FILLER                  PIC X(56) VALUE
058500     '01620103300047039780130001740242300570007501510902900037'.
058600       10  FILLER                  PIC X(56) VALUE
058700     '02489406900105016396025000350000000000000000000000000000'.
058800       10  FILLER                  PIC X(56) VALUE
058900     '00000000000000036361089001470256260530008202178503400051'.
059000       10  FILLER                  PIC X(56) VALUE
059100     '04778817200227029919062000900239800490006102145406800096'.
059200       10  FILLER                  PIC X(56) VALUE
059300     '01644405000066012188032000430163410630008701240304500060'.
059400       10  FILLER                  PIC X(56) VALUE
059500     '00966403300043016523058000850102960270003300911602300029'.
059600       10  FILLER                  PIC X(56) VALUE
059700     '01266304300060000000000000000000000000000000000000000000'.
059800       10  FILLER                  PIC X(56) VALUE
059900     '05184012800168039291091001120336620560007303925712100162'.
060000       10  FILLER                  PIC X(56) VALUE
060100     '02491906800089020996047000600000000000000000000000000000'.
060200       10  FILLER                  PIC X(56) VALUE
060300     '00000000000000015454062000830105600420005200824003200041'.
060400       10  FILLER                  PIC X(56) VALUE
060500     '01207404900068007527028000350219710720009901525804600059'.
060600       10  FILLER                  PIC X(56) VALUE
060700     '01361103500044057579126001530174840560007701378304700058'.
060800       10  FILLER                  PIC X(56) VALUE
060900     '00000000000000000000000000000000000000000002463206900114'.
061000       10  FILLER                  PIC X(56) VALUE
061100     '00000000000000000000000000000000000000000000608502400032'.
061200       10  FILLER                  PIC X(56) VALUE
061300     '00519803100042005685031000440089990460007400843104000054'.
061400       10  FILLER                  PIC X(56) VALUE
061500     '00778305500076006983040000590083410310004600000000000000'.
061600       10  FILLER                  PIC X(56) VALUE
061700     '00000000000000000000000000000000000000000000000000000000'.
061800       10  FILLER                  PIC X(56) VALUE
061900     '00000000000000003571021000300075570820010501041904800066'.
062000       10  FILLER                  PIC X(56) VALUE
062100     '00614503300041000000000000000000000000000000000000000000'.
062200       10  FILLER                  PIC X(56) VALUE
062300     '02853409300144018611057000790149660350004902524607200122'.
062400       10  FILLER                  PIC X(56) VALUE
062500     '01592603500047009803022000330310300810011702186505000069'.
062600       10  FILLER                  PIC X(56) VALUE
062700     '01411202700036000000000000000000000000000000000000000000'.
062800       10  FILLER                  PIC X(56) VALUE
062900     '01063104600062006890027000340086600330004700498601700021'.
063000       10  FILLER                  PIC X(56) VALUE
063100     '01171703700052006886021000270128300440006200979703200043'.
063200       10  FILLER                  PIC X(56) VALUE
063300     '00710102300029011338041000600070710240003300000000000000'.
063400       10  FILLER                  PIC X(56) VALUE
063500     '00000000000000000000000000001230422300028804395612100162'.
063600       10  FILLER                  PIC X(56) VALUE
063700     '02353305600077000000000000000000000000000000000000000000'.
063800       10  FILLER                  PIC X(56) VALUE
063900     '02662602700059013745047000680116050370005500000000000000'.
064000       10  FILLER                  PIC X(56) VALUE
064100     '00000000000000000000000000000216720750010901682304400064'.
064200       10  FILLER                  PIC X(56) VALUE
064300     '01353102300030000000000000000000000000000000000000000000'.
064400       10  FILLER                  PIC X(56) VALUE
064500     '01100508400103010143070000790087670380005000654202700034'.
064600       10  FILLER                  PIC X(56) VALUE
064700     '00732302500041005948024000340061090210003800000000000000'.
064800       10  FILLER                  PIC X(56) VALUE
064900     '00000000000000000000000000000510280850012203485407600095'.
065000       10  FILLER                  PIC X(56) VALUE
065100     '05796010500160044786079001050369880490006100000000000000'.
065200       10  FILLER                  PIC X(56) VALUE
065300     '00000000000000000000000000000229850630009301701505000063'.
065400       10  FILLER                  PIC X(56) VALUE
065500     '01410803300041000000000000000000000000000000000000000000'.
065600       10  FILLER                  PIC X(56) VALUE
065700     '05139513500187036849066000950000000000000000000000000000'.
065800       10  FILLER                  PIC X(56) VALUE
065900     '00000000000000021382074001040159180530007301335703800049'.
066000       10  FILLER                  PIC X(56) VALUE
066100     '01038703800053000000000000000000000000000000000000000000'.
066200       10  FILLER                  PIC X(56) VALUE
066300     '04516811900153035417078001000297370390005402721711700146'.
066400       10  FILLER                  PIC X(56) VALUE
066500     '02086507400097016706035000510285000990013202013405900080'.
066600       10  FILLER                  PIC X(56) VALUE
066700     '01631002900041000000000000000000000000000000000000000000'.
066800       10  FILLER                  PIC X(56) VALUE
066900     '00000000000000000000000000000000000000000000000000000000'.
067000       10  FILLER                  PIC X(56) VALUE
067100     '00000000000000000000000000000000000000000000000000000000'.
067200     05  DRGX-TAB REDEFINES D-TAB.
067300         10  DRGX-PERIOD               OCCURS 1
067400                                        INDEXED BY DX5.
067500             15  DRGX-EFF-DATE         PIC X(08).
067600             15  DRG-DATA              OCCURS 1000
067700                                        INDEXED BY DX6.
067800                 20  DRG-WT            PIC 9(02)V9(04).
067900                 20  DRG-ALOS          PIC 9(02)V9(01).
068000                 20  DRG-DAYS-TRIM     PIC 9(02).
068100                 20  DRG-ARITH-ALOS    PIC 9(02)V9(01).
068200
068300 01  HOLD-AREA.
068400     02  HOLD-PPS-COMPONENTS.
068500         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
068600         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
068700
068800         05  H-OPER-HSP-PART              PIC 9(06)V9(09).
068900         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).
069000
069100         05  H-OPER-FSP-PART              PIC 9(06)V9(09).
069200         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).
069300         05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).
069400
069500         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).
069600         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).
069700         05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).
069800
069900         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).
070000         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).
070100
070200         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).
070300         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).
070400
070500         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).
070600         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).
070700
070800         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).
070900         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).
071000         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).
071100         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).
071200         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).
071300         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
071400         05  H-CAPI-COLA                  PIC 9(01)V9(03).
071500         05  H-CAPI-SCH                   PIC 9(05)V9(02).
071600         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).
071700         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).
071800         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).
071900         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).
072000         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).
072100         05  H-CAPI-GAF                   PIC 9(05)V9(04).
072200         05  H-PR-CAPI-GAF                PIC 9(05)V9(04).
072300         05  H-BLEND-GAF                  PIC 9(05)V9(04).
072400         05  H-WAGE-INDEX                 PIC 9(02)V9(04).
072500         05  H-COV-DAYS                   PIC 9(3).
072600         05  H-PERDIEM-DAYS               PIC 9(3).
072700         05  H-REG-DAYS                   PIC 9(3).
072800         05  H-LTR-DAYS                   PIC 9(3).
072900         05  H-DSCHG-FRCTN                PIC 9(3)V9999.
073000         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.
073100         05  H-ALOS                       PIC 9(02)V9(01).
073200         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).
073300         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).
073400         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).
073500         05  H-CST-THRESH                 PIC 9(05)V9(02).
073600         05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).
073700         05  H-BUDG-NUTR01                PIC 9(01)V9(06).
073800         05  H-BUDG-NUTR02                PIC 9(01)V9(06).
073900         05  H-BUDG-NUTR03                PIC 9(01)V9(06).
074000         05  H-BUDG-NUTR04                PIC 9(01)V9(06).
074100         05  H-BUDG-NUTR05                PIC 9(01)V9(06).
074200         05  H-BUDG-NUTR06                PIC 9(01)V9(06).
074300         05  H-BUDG-NUTR07                PIC 9(01)V9(06).
074400         05  H-BUDG-NUTR08                PIC 9(01)V9(06).
074500         05  H-CASE-MIX-ADJ               PIC 9(01)V9(03).
074600         05  H-UPDATE-01                  PIC 9(01)V9(04).
074700         05  H-UPDATE-02                  PIC 9(01)V9(04).
074800         05  H-UPDATE-03                  PIC 9(01)V9(04).
074900         05  H-UPDATE-04                  PIC 9(01)V9(04).
075000         05  H-UPDATE-05                  PIC 9(01)V9(04).
075100         05  H-UPDATE-06                  PIC 9(01)V9(04).
075200         05  H-UPDATE-07                  PIC 9(01)V9(04).
075300         05  H-UPDATE-08                  PIC 9(01)V9(04).
075400         05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).
075500         05  H-HSP-UPDATE94               PIC 9(01)V9(04).
075600         05  H-HSP-UPDATE95               PIC 9(01)V9(04).
075700         05  H-HSP-UPDATE96               PIC 9(01)V9(04).
075800         05  H-HSP-UPDATE97               PIC 9(01)V9(04).
075900         05  H-HSP-UPDATE98               PIC 9(01)V9(04).
076000         05  H-HSP-UPDATE99               PIC 9(01)V9(04).
076100         05  H-HSP-UPDATE00               PIC 9(01)V9(04).
076200         05  H-HSP-UPDATE01               PIC 9(01)V9(04).
076300         05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).
076400         05  H-FEDERAL-RATE               PIC 9(04)V9(02).
076500         05  H-LABOR-PCT                  PIC 9(01)V9(04).
076600         05  H-NONLABOR-PCT               PIC 9(01)V9(04).
076700         05  H-PR-LABOR-PCT               PIC 9(01)V9(04).
076800         05  H-PR-NONLABOR-PCT            PIC 9(01)V9(04).
076900         05  H-HSP-RATE                   PIC 9(06)V9(09).
077000         05  H-FSP-RATE                   PIC 9(06)V9(09).
077100         05  H-OUTLIER-OFFSET-NAT         PIC 9(01)V9(06).
077200         05  H-OUTLIER-OFFSET-PR          PIC 9(01)V9(06).
077300         05  H-WK-OPER-DSH                PIC 9(01)V9(04).
077400         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).
077500         05  H-OPER-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
077600         05  H-CAPI-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
077700         05  H-DSH-REDUCT-FACTOR          PIC 9(01)V9(04).
077800         05  H-WK-PASS-AMT-PLUS-MISC      PIC 9(06)V99.
077900         05  H-BASE-DRG-PAYMENT           PIC S9(07)V99.
078000         05  H-NEW-TECH-ADDON-NEURO       PIC S9(07)V99.
078100         05  H-NEW-TECH-ADDON-GRAFT       PIC S9(07)V99.
078200         05  H-NEW-TECH-ADDON-X-STOP      PIC S9(07)V99.
078300         05  H-NEW-TECH-ADDON-ISLET       PIC S9(07)V99.
078400         05  H-TECH-ADDON-ISLET-CNTR      PIC S9(02).
078500         05  H-TECH-ADDON-ISLET-CNTR2     PIC S9(02).
078600
078700         05  H-LESSER-NEURO-1             PIC S9(07)V99.
078800         05  H-LESSER-NEURO-2             PIC S9(07)V99.
078900
079000         05  H-LESSER-GRAFT-1             PIC S9(07)V99.
079100         05  H-LESSER-GRAFT-2             PIC S9(07)V99.
079200
079300         05  H-LESSER-X-STOP-1            PIC S9(07)V99.
079400         05  H-LESSER-X-STOP-2            PIC S9(07)V99.
079500
079600
079700         05  H-CSTMED-NEURO               PIC S9(07)V99.
079800         05  H-CSTMED-GRAFT               PIC S9(07)V99.
079900         05  H-CSTMED-X-STOP              PIC S9(07)V99.
080000
080100
080200     02  HOLD-ADDITIONAL-VARIABLES.
080300         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).
080400         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).
080500         05  H-NAT-PCT                    PIC 9(01)V9(02).
080600         05  H-REG-PCT                    PIC 9(01)V9(02).
080700         05  H-FAC-SPEC-RATE              PIC 9(05)V9(02).
080800         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).
080900         05  H-DRG-WT                     PIC 9(02)V9(04).
081000         05  H-NAT-LABOR                  PIC 9(05)V9(02).
081100         05  H-NAT-NONLABOR               PIC 9(05)V9(02).
081200         05  H-REG-LABOR                  PIC 9(05)V9(02).
081300         05  H-REG-NONLABOR               PIC 9(05)V9(02).
081400         05  H-OPER-COLA                  PIC 9(01)V9(03).
081500         05  H-INTERN-RATIO               PIC 9(01)V9(04).
081600         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).
081700         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).
081800         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
081900
082000     02  HOLD-CAPITAL-VARIABLES.
082100         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).
082200         05  H-CAPI-HSP                   PIC 9(07)V9(02).
082300         05  H-CAPI-FSP                   PIC 9(07)V9(02).
082400         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).
082500         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).
082600         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).
082700         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).
082800         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).
082900
083000     02  HOLD-CAPITAL2-VARIABLES.
083100         05  H-CAPI2-PAY-CODE             PIC X(1).
083200         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).
083300         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
083400
083500     02  HOLD-OTHER-VARIABLES.
083600         05  H-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
083700         05  H-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
083800         05  FILLER                       PIC X(21).
083900
084000     02  HOLD-PC-OTH-VARIABLES.
084100         05  H-OPER-DSH                   PIC 9(01)V9(04).
084200         05  H-CAPI-DSH                   PIC 9(01)V9(04).
084300         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).
084400         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).
084500         05  H-ARITH-ALOS                 PIC 9(02)V9(01).
084600         05  H-PR-WAGE-INDEX              PIC 9(02)V9(04).
084700         05  H-TRANSFER-ADJ               PIC 9(01)V9(05).
084800         05  H-PC-HMO-FLAG                PIC X(01).
084900         05  H-PC-COT-FLAG                PIC X(01).
085000         05  H-FILLER                     PIC X(09).
085100
085200 01  HLD-PPS-DATA.
085300         10  HLD-PPS-RTC                PIC 9(02).
085400         10  HLD-PPS-WAGE-INDX          PIC 9(02)V9(04).
085500         10  HLD-PPS-OUTLIER-DAYS       PIC 9(03).
085600         10  HLD-PPS-AVG-LOS            PIC 9(02)V9(01).
085700         10  HLD-PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
085800         10  HLD-PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
085900         10  HLD-PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
086000         10  HLD-PPS-OPER-HSP-PART      PIC 9(06)V9(02).
086100         10  HLD-PPS-OPER-FSP-PART      PIC 9(06)V9(02).
086200         10  HLD-PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
086300         10  HLD-PPS-REG-DAYS-USED      PIC 9(03).
086400         10  HLD-PPS-LTR-DAYS-USED      PIC 9(02).
086500         10  HLD-PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
086600         10  HLD-PPS-CALC-VERS          PIC X(05).
086700
086800 LINKAGE SECTION.
086900***************************************************************
087000*                 * * * * * * * * *                           *
087100*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *
087200*    IN HOW TO PAY THE BILL.                                  *
087300*                         *****                               *
087400*    COMMENTS  ** CLAIMS RECEIVED WITH CONDITION CODE 66      *
087500*                 SHOULD BE PROCESSED UNDER REVIEW CODE 06,   *
087600*                 07 OR 11 AS APPROPRIATE TO EXCLUDE ANY      *
087700*                 OUTLIER COMPUTATION.                        *
087800*                         *****                               *
087900*         REVIEW-CODE:                                        *
088000*            00 = PAY-WITH-OUTLIER.                           *
088100*                 WILL CALCULATE THE STANDARD PAYMENT.        *
088200*                 WILL ALSO ATTEMPT TO PAY ONLY COST          *
088300*                 OUTLIERS, DAY OUTLIERS EXPIRED 10/01/97     *
088400*            03 = PAY-PERDIEM-DAYS.                           *
088500*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
088600*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
088700*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
088800*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
088900*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
089000*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
089100*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
089200*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
089300*                 BILL EXCEED THE COST THRESHOLD.             *
089400*            06 = PAY-XFER-NO-COST                            *
089500*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
089600*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
089700*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
089800*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *
089900*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
090000*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
090100*                 CALCULATE ANY COST OUTLIER PORTION          *
090200*                 OF THE PAYMENT.                             *
090300*            07 = PAY-WITHOUT-COST.                           *
090400*                 WILL CALCULATE THE STANDARD PAYMENT         *
090500*                 WITHOUT COST PORTION.                       *
090600*            09 = PAY-XFER-SPEC-DRG - POST-ACUTE TRANSFERS    *
090700*                 50-50> 28  29  30  40  41  42  219
090800*                        220 221 477 478 479 480 481
090900*                        482 492 493 494 500 501 502
091000*                        515 516 517 956
091100* =======================================================
091200* THE 50/50 DRG'S DO NOT REPEAT WITH THE FULL PERDIEM DRG'S
091300* =======================================================
091400*
091500*
091600*     FULL PERDIEM >   3   4   25  26  27  28          31
091700*                      32  33              54  55  56  57
091800*                      64  65  66  70  71  72  85  86  87
091900*                      91  92  93  100 101 163 164 165 166
092000*                      167 168 175 176 177 178 179 186 187
092100*                      188 190 191 192 193 194 195 196 197
092200*                      198 205 206 207 216 217 218
092300*                          228 229 230 233 234 235 236 239
092400*                      240 241 242 243 244 255 256 257 264
092500*                      280 281 282 288 289 290 291 292 293
092600*                      299 300 301 314 315 316 326 327 328
092700*                      329 330 331 332 333 334 335 336 337
092800*                      356 357 358 371 372 373 374 375 376
092900*                      377 378 379 380 381 382 388 389 390
093000*                      405 406 407 414 415 416 441 442 443
093100*                      459 460 463 464 465 466 467 468 469
093200*                      470 474 475 476
093300*                          483 484 488 489             495
093400*                      496 497             510 511 512
093500*                              533 534 535 536 539 540 541
093600*                      542 543 544 545 546 547 551 552 557
093700*                      558 559 560 561 562 563 573 574 575
093800*                      579 580 581 592 593 594 602 603 616
093900*                      617 618 622 623 624 628 629 630 637
094000*                      638 639 640 641 643 644 645 653 654
094100*                      655 659 660 661 682 683 684 689 690
094200*                      698 699 700 840 841 842 853 854 855
094300*                      856 857 858 862 863 867 868 869 870
094400*                      871 872 884 896 897 907 908 909 917
094500*                      918 945 946 947 948     981 982 983
094600*                      987 988 989
094700*
094800*                               POST-ACUTE TRANSFERS          *
094900*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
095000*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
095100*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
095200*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
095300*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
095400*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
095500*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
095600*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
095700*                 BILL EXCEED THE COST THRESHOLD.             *
095800*            11 = PAY-XFER-SPEC-DRG-NO-COST                   *
095900*                 POST-ACUTE TRANSFERS                        *
096000*                 50-50> 28  29  30  40  41  42  219
096100*                        220 221 477 478 479 480 481
096200*                        482 492 493 494 500 501 502
096300*                        515 516 517 956
096400*
096500* =======================================================
096600* THE 50/50 DRG'S DO NOT REPEAT WITH THE FULL PERDIEM DRG'S
096700* =======================================================
096800*
096900*     FULL PERDIEM >     3   4   25  26  27              31
097000*                        32  33              54  55  56  57
097100*                        64  65  66  70  71  72  85  86  87
097200*                        91  92  93  100 101 163 164 165 166
097300*                        167 168 175 176 177 178 179 186 187
097400*                        188 190 191 192 193 194 195 196 197
097500*                        198 205 206 207 216 217 218
097600*                            228 229 230 233 234 235 236 239
097700*                        240 241 242 243 244 255 256 257 264
097800*                        280 281 282 288 289 290 291 292 293
097900*                        299 300 301 314 315 316 326 327 328
098000*                        329 330 331 332 333 334 335 336 337
098100*                        356 357 358 371 372 373 374 375 376
098200*                        377 378 379 380 381 382 388 389 390
098300*                        405 406 407 414 415 416 441 442 443
098400*                        459 460 463 464 465 466 467 468 469
098500*                        470 474 475 476
098600*                            483 484 488 489             495
098700*                        496 497             510 511 512
098800*                                533 534 535 536 539 540 541
098900*                        542 543 544 545 546 547 551 552 557
099000*                        558 559 560 561 562 563 573 574 575
099100*                        579 580 581 592 593 594 602 603 616
099200*                        617 618 622 623 624 628 629 630 637
099300*                        638 639 640 641 643 644 645 653 654
099400*                        655 659 660 661 682 683 684 689 690
099500*                        698 699 700 840 841 842 853 854 855
099600*                        856 857 858 862 863 867 868 869 870
099700*                        871 872 884 896 897 907 908 909 917
099800*                        918 945 946 947 948     981 982 983
099900*                        987 988 989
100000*
100100*
100200*                               POST-ACUTE TRANSFERS          *
100300*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
100400*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
100500*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
100600*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
100700*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
100800*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
100900*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
101000*                 PAYMENT.                                    *
101100***************************************************************
101200
101300**************************************************************
101400*      MILLINNIUM COMPATIBLE                                 *
101500*      THIS IS THE BILL-RECORD THAT WILL BE PASSED BACK FROM *
101600*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *
101700*      IN THE NEW FORMAT                                     *
101800**************************************************************
101900 01  BILL-NEW-DATA.
102000         10  B-NPI10.
102100             15  B-NPI8             PIC X(08).
102200             15  B-NPI-FILLER       PIC X(02).
102300         10  B-PROVIDER-NO          PIC X(06).
102400         10  B-REVIEW-CODE          PIC 9(02).
102500             88  VALID-REVIEW-CODE    VALUE 00 03 06 07 09 11.
102600             88  PAY-WITH-OUTLIER     VALUE 00 07.
102700             88  PAY-PERDIEM-DAYS     VALUE 03.
102800             88  PAY-XFER-NO-COST     VALUE 06.
102900             88  PAY-WITHOUT-COST     VALUE 07.
103000             88  PAY-XFER-SPEC-DRG    VALUE 09 11.
103100             88  PAY-XFER-SPEC-DRG-NO-COST VALUE 11.
103200         10  B-DRG                  PIC 9(03).
103300             88  B-DRG-POSTACUTE-50-50
103400                   VALUE 28  29  30  40  41  42  219
103500                         220 221 477 478 479 480 481
103600                         482 492 493 494 500 501 502
103700                         515 516 517 956.
103800
103900* =======================================================
104000* THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE  DRG'S
104100* =======================================================
104200*
104300             88  B-DRG-POSTACUTE-PERDIEM
104400                   VALUE 3   4   25  26  27              31
104500                         32  33              54  55  56  57
104600                         64  65  66  70  71  72  85  86  87
104700                         91  92  93  100 101 163 164 165 166
104800                         167 168 175 176 177 178 179 186 187
104900                         188 190 191 192 193 194 195 196 197
105000                         198 205 206 207 216 217 218
105100                             228 229 230 233 234 235 236 239
105200                         240 241 242 243 244 255 256 257 264
105300                         280 281 282 288 289 290 291 292 293
105400                         299 300 301 314 315 316 326 327 328
105500                         329 330 331 332 333 334 335 336 337
105600                         356 357 358 371 372 373 374 375 376
105700                         377 378 379 380 381 382 388 389 390
105800                         405 406 407 414 415 416 441 442 443
105900                         459 460 463 464 465 466 467 468 469
106000                         470 474 475 476
106100                             483 484 488 489             495
106200                         496 497             510 511 512
106300                                 533 534 535 536 539 540 541
106400                         542 543 544 545 546 547 551 552 557
106500                         558 559 560 561 562 563 573 574 575
106600                         579 580 581 592 593 594 602 603 616
106700                         617 618 622 623 624 628 629 630 637
106800                         638 639 640 641 643 644 645 653 654
106900                         655 659 660 661 682 683 684 689 690
107000                         698 699 700 840 841 842 853 854 855
107100                         856 857 858 862 863 867 868 869 870
107200                         871 872 884 896 897 907 908 909 917
107300                         918 945 946 947 948     981 982 983
107400                         987 988 989.
107500
107600         10  B-LOS                  PIC 9(03).
107700         10  B-COVERED-DAYS         PIC 9(03).
107800         10  B-LTR-DAYS             PIC 9(02).
107900         10  B-DISCHARGE-DATE.
108000             15  B-DISCHG-CC        PIC 9(02).
108100             15  B-DISCHG-YY        PIC 9(02).
108200             15  B-DISCHG-MM        PIC 9(02).
108300             15  B-DISCHG-DD        PIC 9(02).
108400         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
108500         10  B-PRIN-PROC-CODE       PIC X(07).
108600         10  B-OTHER-PROC-CODE1     PIC X(07).
108700         10  B-OTHER-PROC-CODE2     PIC X(07).
108800         10  B-OTHER-PROC-CODE3     PIC X(07).
108900         10  B-OTHER-PROC-CODE4     PIC X(07).
109000         10  B-OTHER-PROC-CODE5     PIC X(07).
109100         10  B-OTHER-PROC-CODE6     PIC X(07).
109200         10  B-OTHER-PROC-CODE7     PIC X(07).
109300         10  B-OTHER-PROC-CODE8     PIC X(07).
109400         10  B-OTHER-PROC-CODE9     PIC X(07).
109500         10  B-OTHER-PROC-CODE10    PIC X(07).
109600         10  B-OTHER-PROC-CODE11    PIC X(07).
109700         10  B-OTHER-PROC-CODE12    PIC X(07).
109800         10  B-OTHER-PROC-CODE13    PIC X(07).
109900         10  B-OTHER-PROC-CODE14    PIC X(07).
110000         10  B-OTHER-PROC-CODE15    PIC X(07).
110100         10  B-OTHER-PROC-CODE16    PIC X(07).
110200         10  B-OTHER-PROC-CODE17    PIC X(07).
110300         10  B-OTHER-PROC-CODE18    PIC X(07).
110400         10  B-OTHER-PROC-CODE19    PIC X(07).
110500         10  B-OTHER-PROC-CODE20    PIC X(07).
110600         10  B-OTHER-PROC-CODE21    PIC X(07).
110700         10  B-OTHER-PROC-CODE22    PIC X(07).
110800         10  B-OTHER-PROC-CODE23    PIC X(07).
110900         10  B-OTHER-PROC-CODE24    PIC X(07).
111000         10  B-OTHER-DIAG-CODE1     PIC X(07).
111100         10  B-OTHER-DIAG-CODE2     PIC X(07).
111200         10  B-OTHER-DIAG-CODE3     PIC X(07).
111300         10  B-OTHER-DIAG-CODE4     PIC X(07).
111400         10  B-OTHER-DIAG-CODE5     PIC X(07).
111500         10  B-OTHER-DIAG-CODE6     PIC X(07).
111600         10  B-OTHER-DIAG-CODE7     PIC X(07).
111700         10  B-OTHER-DIAG-CODE8     PIC X(07).
111800         10  B-OTHER-DIAG-CODE9     PIC X(07).
111900         10  B-OTHER-DIAG-CODE10    PIC X(07).
112000         10  B-OTHER-DIAG-CODE11    PIC X(07).
112100         10  B-OTHER-DIAG-CODE12    PIC X(07).
112200         10  B-OTHER-DIAG-CODE13    PIC X(07).
112300         10  B-OTHER-DIAG-CODE14    PIC X(07).
112400         10  B-OTHER-DIAG-CODE15    PIC X(07).
112500         10  B-OTHER-DIAG-CODE16    PIC X(07).
112600         10  B-OTHER-DIAG-CODE17    PIC X(07).
112700         10  B-OTHER-DIAG-CODE18    PIC X(07).
112800         10  B-OTHER-DIAG-CODE19    PIC X(07).
112900         10  B-OTHER-DIAG-CODE20    PIC X(07).
113000         10  B-OTHER-DIAG-CODE21    PIC X(07).
113100         10  B-OTHER-DIAG-CODE22    PIC X(07).
113200         10  B-OTHER-DIAG-CODE23    PIC X(07).
113300         10  B-OTHER-DIAG-CODE24    PIC X(07).
113400         10  B-OTHER-DIAG-CODE25    PIC X(07).
113500         10  BILL-DEMO-DATA.
113600             15  BILL-DEMO-CODE1        PIC X(02).
113700             15  BILL-DEMO-CODE2        PIC X(02).
113800             15  BILL-DEMO-CODE3        PIC X(02).
113900             15  BILL-DEMO-CODE4        PIC X(02).
114000         10  BILL-NDC-DATA.
114100             15  BILL-NDC-NUMBER        PIC X(11).
114200         10  FILLER                     PIC X(73).
114300
114400
114500
114600***************************************************************
114700*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
114800*    AND PASSED BACK TO THE CALLING PROGRAM                   *
114900*            RETURN CODE VALUES (PPS-RTC)                     *
115000*                                                             *
115100*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
115200*                                                             *
115300*      PPS-RTC 30,33,40,42,44  = OUTLIER RECONCILIATION       *
115400*                                                             *
115500*           30,00 = PAID NORMAL DRG PAYMENT                   *
115600*                                                             *
115700*              01 = PAID AS A DAY-OUTLIER.                    *
115800*                   NOTE:                                     *
115900*                     DAY-OUTLIER NO LONGER BEING PAID        *
116000*                         AS OF 10/01/97                      *
116100*                                                             *
116200*              02 = PAID AS A COST-OUTLIER.                   *
116300*                                                             *
116400*           33,03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
116500*                   AND INCLUDING THE FULL DRG.               *
116600*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
116700*                   AND INCLUDING THE FULL DRG WHICH ALSO     *
116800*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *
116900*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
117000*                   AND INCLUDING THE FULL DRG. PROVIDER      *
117100*                   REFUSED COST OUTLIER.                     *
117200*           40,10 = POST-ACUTE TRANSFER                       *
117300*                   DRG = 28  29  30  40  41  42  219
117400*                         220 221 477 478 479 480 481
117500*                         482 492 493 494 500 501 502
117600*                         515 516 517 956
117700*
117800* =======================================================
117900* THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE  DRG'S
118000* =======================================================
118100*
118200*           42,12 = POST-ACAUTE TRANSFER WITH SPECIFIC DRGS   *
118300*                       THE FOLLOWING DRG'S                   *
118400*                   DRG = 3   4   25  26  27              31
118500*                         32  33              54  55  56  57
118600*                         64  65  66  70  71  72  85  86  87
118700*                         91  92  93  100 101 163 164 165 166
118800*                         167 168 175 176 177 178 179 186 187
118900*                         188 190 191 192 193 194 195 196 197
119000*                         198 205 206 207 216 217 218
119100*                             228 229 230 233 234 235 236 239
119200*                         240 241 242 243 244 255 256 257 264
119300*                         280 281 282 288 289 290 291 292 293
119400*                         299 300 301 314 315 316 326 327 328
119500*                         329 330 331 332 333 334 335 336 337
119600*                         356 357 358 371 372 373 374 375 376
119700*                         377 378 379 380 381 382 388 389 390
119800*                         405 406 407 414 415 416 441 442 443
119900*                         459 460 463 464 465 466 467 468 469
120000*                         470 474 475 476
120100*                             483 484 488 489             495
120200*                         496 497             510 511 512
120300*                                 533 534 535 536 539 540 541
120400*                         542 543 544 545 546 547 551 552 557
120500*                         558 559 560 561 562 563 573 574 575
120600*                         579 580 581 592 593 594 602 603 616
120700*                         617 618 622 623 624 628 629 630 637
120800*                         638 639 640 641 643 644 645 653 654
120900*                         655 659 660 661 682 683 684 689 690
121000*                         698 699 700 840 841 842 853 854 855
121100*                         856 857 858 862 863 867 868 869 870
121200*                         871 872 884 896 897 907 908 909 917
121300*                         918 945 946 947 948     981 982 983
121400*                         987 988 989
121500*
121600*           44,14 = PAID NORMAL DRG PAYMENT WITH              *
121700*                    PERDIEM DAYS = OR > GM  ALOS             *
121800*              16 = PAID AS A COST-OUTLIER WITH               *
121900*                    PERDIEM DAYS = OR > GM  ALOS             *
122000*                                                             *
122100*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
122200*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
122300*              52 = INVALID CBSA# IN PROVIDER FILE            *
122400*                   OR INVALID WAGE INDEX                     *
122500*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *
122600*              54 = INVALID DRG                               *
122700*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *
122800*                                      OR                     *
122900*                   DISCHARGE DATE < CBSA EFF START DATE      *
123000*                   FOR PPS                                   *
123100*                                      OR                     *
123200*                   PROVIDER HAS BEEN TERMINATED ON OR BEFORE *
123300*                   DISCHARGE DATE                            *
123400*              56 = INVALID LENGTH OF STAY                    *
123500*              57 = REVIEW CODE INVALID (NOT 00 03 06 07 09   *
123600*                                        NOT 11)              *
123700*              58 = TOTAL CHARGES NOT NUMERIC                 *
123800*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
123900*                   OR BILL-LTR-DAYS > 60                     *
124000*              62 = INVALID NUMBER OF COVERED DAYS            *
124100*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *
124200*                   SPECIFIC FILE FOR CAPITAL                 *
124300*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *
124400*                   OR COST OUTLIER THRESHOLD CALUCULATION    *
124500*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *
124600***************************************************************
124700 01  PPS-DATA.
124800         10  PPS-RTC                PIC 9(02).
124900         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
125000         10  PPS-OUTLIER-DAYS       PIC 9(03).
125100         10  PPS-AVG-LOS            PIC 9(02)V9(01).
125200         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
125300         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
125400         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
125500         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
125600         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
125700         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
125800         10  PPS-REG-DAYS-USED      PIC 9(03).
125900         10  PPS-LTR-DAYS-USED      PIC 9(02).
126000         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
126100         10  PPS-CALC-VERS          PIC X(05).
126200
126300******************************************************************
126400*            THESE ARE THE VERSIONS OF THE PPCAL
126500*           PROGRAMS THAT WILL BE PASSED BACK----
126600*          ASSOCIATED WITH THE BILL BEING PROCESSED
126700******************************************************************
126800 01  PRICER-OPT-VERS-SW.
126900     02  PRICER-OPTION-SW          PIC X(01).
127000         88  ALL-TABLES-PASSED          VALUE 'A'.
127100         88  PROV-RECORD-PASSED         VALUE 'P'.
127200         88  ADDITIONAL-VARIABLES       VALUE 'M'.
127300         88  PC-PRICER                  VALUE 'C'.
127400     02  PPS-VERSIONS.
127500         10  PPDRV-VERSION         PIC X(05).
127600
127700******************************************************************
127800*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
127900*          ASSOCIATED WITH THE BILL BEING PROCESSED
128000******************************************************************
128100 01  PPS-ADDITIONAL-VARIABLES.
128200     05  PPS-HSP-PCT                PIC 9(01)V9(02).
128300     05  PPS-FSP-PCT                PIC 9(01)V9(02).
128400     05  PPS-NAT-PCT                PIC 9(01)V9(02).
128500     05  PPS-REG-PCT                PIC 9(01)V9(02).
128600     05  PPS-FAC-SPEC-RATE          PIC 9(05)V9(02).
128700     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
128800     05  PPS-DRG-WT                 PIC 9(02)V9(04).
128900     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
129000     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
129100     05  PPS-REG-LABOR              PIC 9(05)V9(02).
129200     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
129300     05  PPS-OPER-COLA              PIC 9(01)V9(03).
129400     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
129500     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
129600     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
129700     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
129800     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
129900     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
130000     05  PPS-CAPITAL-VARIABLES.
130100         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).
130200         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).
130300         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).
130400         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).
130500         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).
130600         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).
130700         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).
130800         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).
130900     05  PPS-CAPITAL2-VARIABLES.
131000         10  PPS-CAPI2-PAY-CODE             PIC X(1).
131100         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).
131200         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
131300
131400     05  PPS-OTHER-VARIABLES.
131500         10  PPS-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
131600         10  PPS-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
131700         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
131800         10  PPS-HVBP-HRR-DATA.
131900             15  PPS-VAL-BASED-PURCH-PARTIPNT PIC X.
132000             15  PPS-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
132100             15  PPS-HOSP-READMISS-REDUCTN    PIC X.
132200             15  PPS-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
132300         10  PPS-OPERATNG-DATA.
132400             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.
132500             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.
132600             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.
132700
132800     05  PPS-PC-OTH-VARIABLES.
132900         10  PPS-OPER-DSH                   PIC 9(01)V9(04).
133000         10  PPS-CAPI-DSH                   PIC 9(01)V9(04).
133100         10  PPS-CAPI-HSP-PCT               PIC 9(01)V9(02).
133200         10  PPS-CAPI-FSP-PCT               PIC 9(01)V9(04).
133300         10  PPS-ARITH-ALOS                 PIC 9(02)V9(01).
133400         10  PPS-PR-WAGE-INDEX              PIC 9(02)V9(04).
133500         10  PPS-TRANSFER-ADJ               PIC 9(01)V9(05).
133600         10  PPS-PC-HMO-FLAG                PIC X(01).
133700         10  PPS-PC-COT-FLAG                PIC X(01).
133800         10  PPS-FILLER                     PIC X(0998).
133900
134000 01  PROV-NEW-HOLD.
134100     02  PROV-NEWREC-HOLD1.
134200         05  P-NEW-NPI10.
134300             10  P-NEW-NPI8             PIC X(08).
134400             10  P-NEW-NPI-FILLER       PIC X(02).
134500         05  P-NEW-PROVIDER-NO.
134600             88  P-NEW-DSH-ADJ-PROVIDERS
134700                             VALUE '180049' '190044' '190144'
134800                                   '190191' '330047' '340085'
134900                                   '370016' '370149' '420043'.
135000             10  P-NEW-STATE            PIC 9(02).
135100             10  FILLER                 PIC X(04).
135200         05  P-NEW-DATE-DATA.
135300             10  P-NEW-EFF-DATE.
135400                 15  P-NEW-EFF-DT-CC    PIC 9(02).
135500                 15  P-NEW-EFF-DT-YY    PIC 9(02).
135600                 15  P-NEW-EFF-DT-MM    PIC 9(02).
135700                 15  P-NEW-EFF-DT-DD    PIC 9(02).
135800             10  P-NEW-FY-BEGIN-DATE.
135900                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
136000                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
136100                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
136200                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
136300             10  P-NEW-REPORT-DATE.
136400                 15  P-NEW-REPORT-DT-CC PIC 9(02).
136500                 15  P-NEW-REPORT-DT-YY PIC 9(02).
136600                 15  P-NEW-REPORT-DT-MM PIC 9(02).
136700                 15  P-NEW-REPORT-DT-DD PIC 9(02).
136800             10  P-NEW-TERMINATION-DATE.
136900                 15  P-NEW-TERM-DT-CC   PIC 9(02).
137000                 15  P-NEW-TERM-DT-YY   PIC 9(02).
137100                 15  P-NEW-TERM-DT-MM   PIC 9(02).
137200                 15  P-NEW-TERM-DT-DD   PIC 9(02).
137300         05  P-NEW-WAIVER-CODE          PIC X(01).
137400             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
137500         05  P-NEW-INTER-NO             PIC 9(05).
137600         05  P-NEW-PROVIDER-TYPE        PIC X(02).
137700             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.
137800             88  P-N-REFERRAL-CENTER        VALUE '07' '11'
137900                                                  '15' '17'
138000                                                  '22'.
138100             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.
138200             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.
138300             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.
138400             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.
138500             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.
138600             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.
138700             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.
138800             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.
138900             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.
139000             88  P-N-EACH                   VALUE '21' '22'.
139100             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.
139200             88  P-N-NHCMQ-II-SNF           VALUE '32'.
139300             88  P-N-NHCMQ-III-SNF          VALUE '33'.
139400         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
139500             88  P-N-NEW-ENGLAND            VALUE  1.
139600             88  P-N-MIDDLE-ATLANTIC        VALUE  2.
139700             88  P-N-SOUTH-ATLANTIC         VALUE  3.
139800             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.
139900             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.
140000             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.
140100             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.
140200             88  P-N-MOUNTAIN               VALUE  8.
140300             88  P-N-PACIFIC                VALUE  9.
140400         05  P-NEW-CURRENT-DIV   REDEFINES
140500                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
140600             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.
140700         05  P-NEW-MSA-DATA.
140800             10  P-NEW-CHG-CODE-INDEX       PIC X.
140900             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
141000             10  P-NEW-GEO-LOC-MSA9   REDEFINES
141100                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
141200             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
141300             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
141400             10  P-NEW-STAND-AMT-LOC-MSA9
141500       REDEFINES P-NEW-STAND-AMT-LOC-MSA.
141600                 15  P-NEW-RURAL-1ST.
141700                     20  P-NEW-STAND-RURAL  PIC XX.
141800                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
141900                 15  P-NEW-RURAL-2ND        PIC XX.
142000         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
142100                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
142200                 88  P-NEW-SCH-YR82       VALUE   '82'.
142300                 88  P-NEW-SCH-YR87       VALUE   '87'.
142400         05  P-NEW-LUGAR                    PIC X.
142500         05  P-NEW-TEMP-RELIEF-IND          PIC X.
142600         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
142700         05  FILLER                         PIC X(05).
142800     02  PROV-NEWREC-HOLD2.
142900         05  P-NEW-VARIABLES.
143000             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).
143100             10  P-NEW-COLA              PIC  9(01)V9(03).
143200             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
143300             10  P-NEW-BED-SIZE          PIC  9(05).
143400             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).
143500             10  P-NEW-CMI               PIC  9(01)V9(04).
143600             10  P-NEW-SSI-RATIO         PIC  V9(04).
143700             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
143800             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).
143900             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).
144000             10  P-NEW-DSH-PERCENT       PIC  V9(04).
144100             10  P-NEW-FYE-DATE          PIC  X(08).
144200         05  P-NEW-CBSA-DATA.
144300             10  FILLER                    PIC X.
144400             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.
144500             10  FILLER                    PIC X(21).
144600     02  PROV-NEWREC-HOLD3.
144700         05  P-NEW-PASS-AMT-DATA.
144800             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
144900             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
145000             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
145100             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
145200         05  P-NEW-CAPI-DATA.
145300             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
145400             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
145500             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
145600             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
145700             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
145800             15  P-NEW-CAPI-NEW-HOSP       PIC X.
145900             15  P-NEW-CAPI-IME            PIC 9V9999.
146000             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
146100         05  P-HVBP-HRR-DATA.
146200             15  P-VAL-BASED-PURCH-PARTIPNT PIC X.
146300             15  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
146400             15  P-HOSP-READMISSION-REDUCTN PIC X.
146500             15  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
146600         05  P-MODEL1-BUNDLE-DATA.
146700             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.
146800             15  P-HAC-REDUC-IND            PIC X.
146900             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.
147000             15  P-EHR-REDUC-IND            PIC X.
147100         05  FILLER                         PIC X(09).
147200
147300************************************************************
147400******************************************************************
147500 01  WAGE-NEW-CBSA-INDEX-RECORD.
147600     05  W-CBSA                        PIC X(5).
147700     05  W-CBSA-SIZE                   PIC X.
147800         88  LARGE-URBAN       VALUE 'L'.
147900         88  OTHER-URBAN       VALUE 'O'.
148000         88  ALL-RURAL         VALUE 'R'.
148100     05  W-CBSA-EFF-DATE               PIC X(8).
148200     05  FILLER                        PIC X.
148300     05  W-CBSA-INDEX-RECORD           PIC S9(02)V9(04).
148400     05  W-CBSA-PR-INDEX-RECORD        PIC S9(02)V9(04).
148500
148600
148700 PROCEDURE DIVISION  USING BILL-NEW-DATA
148800                           PPS-DATA
148900                           PRICER-OPT-VERS-SW
149000                           PPS-ADDITIONAL-VARIABLES
149100                           PROV-NEW-HOLD
149200                           WAGE-NEW-CBSA-INDEX-RECORD.
149300
149400***************************************************************
149500*    PROCESSING:                                              *
149600*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
149700*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *
149800*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
149900*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
150000*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
150100*           GOBACK.                                           *
150200*        D. ASSEMBLE PRICING COMPONENTS.                      *
150300*        E. CALCULATE THE PRICE.                              *
150400***************************************************************
150500
150600     MOVE ZEROES TO NON-TEMP-RELIEF-PAYMENT.
150700     MOVE 'N' TO TEMP-RELIEF-FLAG.
150800     MOVE 'N' TO OUTLIER-RECON-FLAG.
150900
151000     PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT.
151100
151200     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
151300     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.
151400     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.
151500     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.
151600     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.
151700     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
151800     MOVE HOLD-OTHER-VARIABLES      TO  PPS-OTHER-VARIABLES.
151900     MOVE HOLD-PC-OTH-VARIABLES     TO  PPS-PC-OTH-VARIABLES.
152000
152100     IF (PPS-RTC = '00' OR '03' OR '10' OR
152200                   '12' OR '14')
152300        MOVE 'Y' TO OUTLIER-RECON-FLAG
152400        MOVE PPS-DATA TO HLD-PPS-DATA
152500        PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT
152600        MOVE HLD-PPS-DATA TO PPS-DATA.
152700
152800     GOBACK.
152900
153000 0200-MAINLINE-CONTROL.
153100
153200     MOVE 'N' TO HMO-TAG.
153300
153400     IF PPS-PC-HMO-FLAG = 'Y' OR
153500               HMO-FLAG = 'Y'
153600        MOVE 'Y' TO HMO-TAG.
153700
153800     IF P-NEW-STATE NOT = 40
153900        MOVE ZEROES TO W-CBSA-PR-INDEX-RECORD.
154000
154100     MOVE ALL '0' TO PPS-DATA
154200                     H-OPER-DSH-SCH
154300                     H-OPER-DSH-RRC
154400                     HOLD-PPS-COMPONENTS
154500                     HOLD-PPS-COMPONENTS
154600                     HOLD-ADDITIONAL-VARIABLES
154700                     HOLD-CAPITAL-VARIABLES
154800                     HOLD-CAPITAL2-VARIABLES
154900                     HOLD-OTHER-VARIABLES
155000                     HOLD-PC-OTH-VARIABLES.
155100
155200     IF P-NEW-CAPI-HOSP-SPEC-RATE NOT NUMERIC
155300        MOVE 0 TO P-NEW-CAPI-HOSP-SPEC-RATE.
155400
155500     IF P-NEW-CAPI-OLD-HARM-RATE  NOT NUMERIC
155600        MOVE 0 TO P-NEW-CAPI-OLD-HARM-RATE.
155700
155800     IF P-NEW-CAPI-NEW-HARM-RATIO NOT NUMERIC
155900        MOVE 0 TO P-NEW-CAPI-NEW-HARM-RATIO.
156000
156100     IF P-NEW-CAPI-CSTCHG-RATIO NOT NUMERIC
156200        MOVE 0 TO P-NEW-CAPI-CSTCHG-RATIO.
156300
156400
156500     PERFORM 1000-EDIT-THE-BILL-INFO.
156600
156700     IF  PPS-RTC = 00
156800         PERFORM 2000-ASSEMBLE-PPS-VARIABLES
156900         PERFORM 3000-CALC-PAYMENT THRU 3000-EXIT.
157000
157100     IF OUTLIER-RECON-FLAG = 'Y'
157200        MOVE 'N' TO OUTLIER-RECON-FLAG
157300        GO TO 0200-EXIT.
157400
157500     IF PPS-RTC = 00
157600        IF H-PERDIEM-DAYS = H-ALOS OR
157700           H-PERDIEM-DAYS > H-ALOS
157800           MOVE 14 TO PPS-RTC.
157900
158000     IF PPS-RTC = 02
158100        IF H-PERDIEM-DAYS = H-ALOS OR
158200           H-PERDIEM-DAYS > H-ALOS
158300           MOVE 16 TO PPS-RTC.
158400
158500 0200-EXIT.   EXIT.
158600
158700 1000-EDIT-THE-BILL-INFO.
158800
158900     MOVE 1.00 TO H-CAPI-PAYCDE-PCT1.
159000     MOVE 0.00 TO H-CAPI-PAYCDE-PCT2.
159100
159200     IF  PPS-RTC = 00
159300         IF  P-NEW-WAIVER-STATE
159400             MOVE 53 TO PPS-RTC.
159500
159600     IF  PPS-RTC = 00
159700         IF  B-DRG < 001
159800               OR = 014 OR = 015 OR = 016 OR = 017
159900               OR = 018 OR = 019 OR = 043 OR = 044
160000               OR = 045 OR = 046 OR = 047 OR = 048
160100               OR = 049 OR = 050 OR = 051 OR = 104
160200               OR = 105 OR = 106 OR = 107 OR = 108
160300               OR = 109 OR = 110 OR = 111 OR = 112
160400               OR = 118 OR = 119 OR = 120 OR = 126
160500               OR = 127 OR = 128 OR = 140 OR = 141
160600               OR = 142 OR = 143 OR = 144 OR = 145
160700               OR = 160 OR = 161 OR = 162 OR = 169
160800               OR = 170 OR = 171 OR = 172 OR = 173
160900               OR = 174 OR = 209 OR = 210 OR = 211
161000               OR = 212 OR = 213 OR = 214 OR = 265
161100               OR = 266 OR = 267 OR = 268 OR = 269
161200               OR = 270 OR = 271 OR = 272 OR = 273
161300               OR = 274 OR = 275 OR = 276 OR = 277
161400               OR = 278 OR = 279 OR = 317 OR = 318
161500               OR = 319 OR = 320 OR = 321 OR = 322
161600               OR = 323 OR = 324 OR = 325 OR = 359
161700               OR = 360 OR = 361 OR = 362 OR = 363
161800               OR = 364 OR = 365 OR = 366 OR = 367
161900               OR = 396 OR = 397 OR = 398 OR = 399
162000               OR = 400 OR = 401 OR = 402 OR = 403
162100               OR = 404 OR = 426 OR = 427 OR = 428
162200               OR = 429 OR = 430 OR = 431 OR = 447
162300               OR = 448 OR = 449 OR = 450 OR = 451
162400               OR = 452 OR = 518 OR = 519 OR = 520
162500               OR = 521 OR = 522 OR = 523 OR = 524
162600               OR = 525 OR = 526 OR = 527 OR = 528
162700               OR = 529 OR = 530 OR = 531 OR = 532
162800               OR = 567 OR = 568 OR = 569 OR = 570
162900               OR = 571 OR = 572 OR = 586 OR = 587
163000               OR = 588 OR = 589 OR = 590 OR = 591
163100               OR = 608 OR = 609 OR = 610 OR = 611
163200               OR = 612 OR = 613 OR = 631 OR = 632
163300               OR = 633 OR = 634 OR = 635 OR = 636
163400               OR = 646 OR = 647 OR = 648 OR = 649
163500               OR = 650 OR = 651 OR = 676 OR = 677
163600               OR = 678 OR = 679 OR = 680 OR = 681
163700               OR = 701 OR = 702 OR = 703 OR = 704
163800               OR = 705 OR = 706 OR = 719 OR = 720
163900               OR = 721 OR = 731 OR = 732 OR = 733
164000               OR = 751 OR = 752 OR = 753 OR = 762
164100               OR = 763 OR = 764 OR = 771 OR = 772
164200               OR = 773 OR = 783 OR = 784 OR = 785
164300               OR = 786 OR = 787 OR = 788 OR = 796
164400               OR = 797 OR = 798 OR = 805 OR = 806
164500               OR = 807 OR = 817 OR = 818 OR = 819
164600               OR = 831 OR = 832 OR = 833 OR = 850
164700               OR = 851 OR = 852 OR = 859 OR = 860
164800               OR = 861 OR = 873 OR = 874 OR = 875
164900               OR = 877 OR = 878 OR = 879 OR = 891
165000               OR = 891 OR = 892 OR = 892 OR = 893
165100               OR = 893 OR = 898 OR = 899 OR = 900
165200               OR = 910 OR = 911 OR = 912 OR = 924
165300               OR = 925 OR = 926 OR = 930 OR = 931
165400               OR = 932 OR = 936 OR = 937 OR = 938
165500               OR = 942 OR = 943 OR = 944 OR = 952
165600               OR = 953 OR = 954 OR = 960 OR = 961
165700               OR = 962 OR = 966 OR = 967 OR = 968
165800               OR = 971 OR = 972 OR = 973 OR = 978
165900               OR = 979 OR = 980 OR = 990 OR = 991
166000               OR = 992 OR = 993 OR = 994 OR = 995
166100               OR = 996 OR = 997
166200             MOVE 54 TO PPS-RTC.
166300
166400     IF  PPS-RTC = 00
166500            IF  ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR
166600                 (B-DISCHARGE-DATE < W-CBSA-EFF-DATE))
166700                MOVE 55 TO PPS-RTC.
166800
166900     IF  PPS-RTC = 00
167000         IF P-NEW-TERMINATION-DATE > 00000000
167100            IF  ((B-DISCHARGE-DATE = P-NEW-TERMINATION-DATE) OR
167200                 (B-DISCHARGE-DATE > P-NEW-TERMINATION-DATE))
167300                  MOVE 55 TO PPS-RTC.
167400
167500     IF  PPS-RTC = 00
167600         IF  B-LOS NOT NUMERIC
167700             MOVE 56 TO PPS-RTC
167800         ELSE
167900         IF  B-LOS = 0
168000             IF B-REVIEW-CODE NOT = 00 AND
168100                              NOT = 03 AND
168200                              NOT = 06 AND
168300                              NOT = 07 AND
168400                              NOT = 09 AND
168500                              NOT = 11
168600             MOVE 56 TO PPS-RTC.
168700
168800     IF  PPS-RTC = 00
168900         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60
169000             MOVE 61 TO PPS-RTC
169100         ELSE
169200             MOVE B-LTR-DAYS TO H-LTR-DAYS.
169300
169400     IF  PPS-RTC = 00
169500         IF  B-COVERED-DAYS NOT NUMERIC
169600             MOVE 62 TO PPS-RTC
169700         ELSE
169800         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
169900             MOVE 62 TO PPS-RTC
170000         ELSE
170100             MOVE B-COVERED-DAYS TO H-COV-DAYS.
170200
170300     IF  PPS-RTC = 00
170400         IF  H-LTR-DAYS  > H-COV-DAYS
170500             MOVE 62 TO PPS-RTC
170600         ELSE
170700             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
170800
170900     IF  PPS-RTC = 00
171000         IF  NOT VALID-REVIEW-CODE
171100             MOVE 57 TO PPS-RTC.
171200
171300     IF  PPS-RTC = 00
171400         IF  B-CHARGES-CLAIMED NOT NUMERIC
171500             MOVE 58 TO PPS-RTC.
171600
171700     IF PPS-RTC = 00
171800           IF P-NEW-CAPI-NEW-HOSP NOT = 'Y'
171900                 IF P-NEW-CAPI-PPS-PAY-CODE NOT = 'A' AND
172000                                            NOT = 'B' AND
172100                                            NOT = 'C'
172200                 MOVE 65 TO PPS-RTC.
172300
172400 2000-ASSEMBLE-PPS-VARIABLES.
172500***  GET THE PROVIDER SPECIFIC VARIABLES.
172600***  GET THE PROVIDER SPECIFIC VARIABLES.
172700
172800     MOVE P-NEW-FAC-SPEC-RATE TO H-FAC-SPEC-RATE.
172900     MOVE P-NEW-INTERN-RATIO TO H-INTERN-RATIO.
173000
173100     IF  (P-NEW-STATE = 02 OR 12)
173200         MOVE P-NEW-COLA TO H-OPER-COLA
173300     ELSE
173400         MOVE 1.000  TO H-OPER-COLA.
173500
173600***************************************************************
173700***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
173800***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
173900
174000     PERFORM 2600-GET-DRG-WEIGHT
174100             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.
174200
174300***************************************************************
174400***  GET THE WAGE-INDEX
174500***  GET THE WAGE-INDEX
174600
174700     MOVE W-CBSA-INDEX-RECORD TO H-WAGE-INDEX.
174800     MOVE W-CBSA-PR-INDEX-RECORD TO H-PR-WAGE-INDEX.
174900
175000***************************************************************
175100***  GET THE LABOR, NON-LABOR STANDARD RATES
175200
175300     IF  P-NEW-STATE = 40
175400         MOVE 2 TO R2
175500         MOVE 3 TO R4
175600     ELSE
175700         MOVE 1 TO R2
175800         MOVE 1 TO R4.
175900
176000     IF  LARGE-URBAN
176100         MOVE 1 TO R3
176200     ELSE
176300         MOVE 2 TO R3.
176400
176500     IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
176600        (H-WAGE-INDEX > 01.0000))
176700        PERFORM 2300-GET-LAB-NONLAB-TB1-RATES
176800             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
176900
177000     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
177100         (H-WAGE-INDEX > 01.0000))
177200        PERFORM 2300-GET-LAB-NONLAB-TB2-RATES
177300             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
177400
177500     IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
177600         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
177700        PERFORM 2300-GET-LAB-NONLAB-TB3-RATES
177800             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
177900
178000     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
178100         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
178200        PERFORM 2300-GET-LAB-NONLAB-TB4-RATES
178300             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
178400
178500     IF P-NEW-STATE = 40
178600        IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
178700            (H-PR-WAGE-INDEX > 01.0000))
178800             PERFORM 2300-GET-PR-LAB-TB1-RATES
178900             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
179000
179100
179200     IF P-NEW-STATE = 40
179300        IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
179400             (H-PR-WAGE-INDEX > 01.0000))
179500              PERFORM 2300-GET-PR-LAB-TB2-RATES
179600                  VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
179700
179800     IF P-NEW-STATE = 40
179900        IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
180000         (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))
180100          PERFORM 2300-GET-PR-LAB-TB3-RATES
180200              VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
180300
180400     IF P-NEW-STATE = 40
180500        IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
180600         (H-PR-WAGE-INDEX < 01.0000 OR H-PR-WAGE-INDEX = 01.0000))
180700          PERFORM 2300-GET-PR-LAB-TB4-RATES
180800              VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
180900
181000***************************************************************
181100***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
181200***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
181300
181400     MOVE 0.00  TO H-OPER-HSP-PCT.
181500     MOVE 1.00  TO H-OPER-FSP-PCT.
181600
181700***************************************************************
181800***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
181900***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
182000
182100      MOVE 1.00 TO H-NAT-PCT.
182200      MOVE 0.00 TO H-REG-PCT.
182300
182400     IF  P-NEW-STATE = 40
182500         MOVE 0.75 TO H-NAT-PCT
182600         MOVE 0.25 TO H-REG-PCT.
182700
182800     IF  P-N-SCH-REBASED-FY90 OR
182900         P-N-EACH OR
183000         P-N-MDH-REBASED-FY90
183100         MOVE 1.00 TO H-OPER-HSP-PCT.
183200
183300 2300-GET-LAB-NONLAB-TB1-RATES.
183400
183500     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
183600         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
183700         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
183800         MOVE TB1-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
183900         MOVE TB1-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
184000
184100 2300-GET-LAB-NONLAB-TB2-RATES.
184200
184300     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
184400         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
184500         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
184600         MOVE TB2-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
184700         MOVE TB2-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
184800
184900 2300-GET-LAB-NONLAB-TB3-RATES.
185000
185100     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
185200         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
185300         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
185400         MOVE TB3-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
185500         MOVE TB3-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
185600
185700 2300-GET-LAB-NONLAB-TB4-RATES.
185800
185900     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
186000         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
186100         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
186200         MOVE TB4-REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
186300         MOVE TB4-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
186400
186500 2300-GET-PR-LAB-TB1-RATES.
186600
186700     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
186800         MOVE TB1-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
186900         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
187000
187100 2300-GET-PR-LAB-TB2-RATES.
187200
187300     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
187400         MOVE TB2-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
187500         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
187600
187700 2300-GET-PR-LAB-TB3-RATES.
187800
187900     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
188000         MOVE TB3-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
188100         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
188200
188300 2300-GET-PR-LAB-TB4-RATES.
188400
188500     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
188600         MOVE TB4-REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
188700         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR.
188800
188900
189000 2600-GET-DRG-WEIGHT.
189100
189200     IF  B-DISCHARGE-DATE NOT < DRGX-EFF-DATE (DX5)
189300         SET DX6 TO B-DRG
189400         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT
189500         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS
189600         MOVE ZEROES                   TO H-DAYS-CUTOFF
189700         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.
189800
189900 3000-CALC-PAYMENT.
190000***************************************************************
190100
190200     PERFORM 3100-CALC-STAY-UTILIZATION.
190300     PERFORM 3300-CALC-OPER-FSP-AMT.
190400     PERFORM 3900A-CALC-OPER-DSH THRU 3900A-EXIT.
190500
190600***********************************************************
190700***  OPERATING IME CALCULATION
190800***  OPERATING IME CALCULATION
190900
191000     COMPUTE H-OPER-IME-TEACH ROUNDED =
191100            1.35 * ((1 + H-INTERN-RATIO) ** .405  - 1).
191200
191300***********************************************************
191400
191500     IF P-N-SCH-REBASED-FY90 OR
191600        P-N-EACH OR
191700        P-N-MDH-REBASED-FY90
191800         PERFORM 3450-CALC-ADDITIONAL-HSP.
191900
192000     MOVE 00                 TO  PPS-RTC.
192100     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.
192200     MOVE H-ALOS             TO  PPS-AVG-LOS.
192300     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.
192400
192500     MOVE B-LOS TO H-PERDIEM-DAYS.
192600     IF H-PERDIEM-DAYS < 1
192700         MOVE 1 TO H-PERDIEM-DAYS.
192800     ADD 1 TO H-PERDIEM-DAYS.
192900
193000     MOVE 1 TO H-DSCHG-FRCTN.
193100
193200     COMPUTE H-DRG-WT-FRCTN ROUNDED = H-DSCHG-FRCTN * H-DRG-WT.
193300
193400     IF (PAY-PERDIEM-DAYS  OR
193500         PAY-XFER-NO-COST) OR
193600        (PAY-XFER-SPEC-DRG AND
193700         B-DRG-POSTACUTE-PERDIEM)
193800         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
193900         COMPUTE H-DSCHG-FRCTN  ROUNDED = H-PERDIEM-DAYS / H-ALOS
194000         IF H-DSCHG-FRCTN > 1
194100              MOVE 1 TO H-DSCHG-FRCTN
194200              MOVE 1 TO H-TRANSFER-ADJ
194300         ELSE
194400              COMPUTE H-DRG-WT-FRCTN ROUNDED =
194500                  (H-PERDIEM-DAYS / H-ALOS) * H-DRG-WT.
194600
194700     IF (PAY-XFER-SPEC-DRG AND
194800         B-DRG-POSTACUTE-50-50)
194900         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
195000         COMPUTE H-DSCHG-FRCTN  ROUNDED =
195100                        .5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)
195200         IF H-DSCHG-FRCTN > 1
195300              MOVE 1 TO H-DSCHG-FRCTN
195400              MOVE 1 TO H-TRANSFER-ADJ
195500         ELSE
195600              COMPUTE H-DRG-WT-FRCTN ROUNDED =
195700            (.5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)) * H-DRG-WT.
195800
195900
196000***********************************************************
196100***  CAPITAL DSH CALCULATION
196200***  CAPITAL DSH CALCULATION
196300
196400     MOVE 0 TO H-CAPI-DSH.
196500
196600     IF P-NEW-BED-SIZE NOT NUMERIC
196700         MOVE 0 TO P-NEW-BED-SIZE.
196800
196900     IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
197000         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **
197100                  (.2025 * (P-NEW-SSI-RATIO
197200                          + P-NEW-MEDICAID-RATIO)) - 1.
197300
197400***********************************************************
197500***  CAPITAL IME TEACH CALCULATION
197600***  CAPITAL IME TEACH CALCULATION
197700
197800     MOVE 0 TO H-WK-CAPI-IME-TEACH.
197900
198000     IF P-NEW-CAPI-IME NUMERIC
198100        IF P-NEW-CAPI-IME > 1.5000
198200           MOVE 1.5000 TO P-NEW-CAPI-IME.
198300
198400     IF P-NEW-CAPI-IME NUMERIC
198500        COMPUTE H-WK-CAPI-IME-TEACH ROUNDED =
198600          (2.7183 ** (.2822 * P-NEW-CAPI-IME)) - 1.
198700
198800***********************************************************
198900     MOVE 0.00 TO H-DAYOUT-PCT.
199000     MOVE 0.80 TO H-CSTOUT-PCT.
199100
199200******************************************************************
199300**
199400** BURN DRGS FOR FY08 ARE 927, 928, 929, 933, 934 AND 935.
199500**
199600******************************************************************
199700
199800     IF  B-DRG = 927 OR 928 OR 929 OR 933 OR 934 OR 935
199900             MOVE 0.90 TO H-CSTOUT-PCT.
200000
200100***     NATIONAL PERCENTAGE
200200     MOVE 0.6970   TO H-LABOR-PCT.
200300     MOVE 0.3030   TO H-NONLABOR-PCT.
200400
200500***     PUERTO RICO PERCENTAGE
200600     MOVE 0.6200   TO H-PR-LABOR-PCT.
200700     MOVE 0.3800   TO H-PR-NONLABOR-PCT.
200800
200900     IF (H-WAGE-INDEX < 01.0000 OR
201000         H-WAGE-INDEX = 01.0000)
201100        MOVE 0.6200 TO H-LABOR-PCT
201200        MOVE 0.3800 TO H-NONLABOR-PCT.
201300
201400     IF P-NEW-STATE = 40
201500       IF (H-PR-WAGE-INDEX < 01.0000 OR
201600           H-PR-WAGE-INDEX = 01.0000)
201700          MOVE 0.5870 TO H-PR-LABOR-PCT
201800          MOVE 0.4130 TO H-PR-NONLABOR-PCT.
201900
202000
202100     IF  P-NEW-OPER-CSTCHG-RATIO NUMERIC
202200             MOVE P-NEW-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO
202300     ELSE
202400             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.
202500
202600     IF P-NEW-CAPI-CSTCHG-RATIO NUMERIC
202700             MOVE P-NEW-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO
202800     ELSE
202900             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.
203000
203100***********************************************************
203200*****YEARCHANGE* 2008.6 ***********************************
203300***  CAPITAL PAYMENT METHOD B - YEARCHNG
203400***  CAPITAL PAYMENT METHOD B
203500
203600     IF W-CBSA-SIZE = 'L'
203700        MOVE 1.00 TO H-CAPI-LARG-URBAN
203800     ELSE
203900        MOVE 1.00 TO H-CAPI-LARG-URBAN.
204000
204100     COMPUTE H-CAPI-GAF    ROUNDED = (H-WAGE-INDEX ** .6848).
204200     COMPUTE H-PR-CAPI-GAF ROUNDED = (H-PR-WAGE-INDEX ** .6848).
204300
204400     COMPUTE H-FEDERAL-RATE ROUNDED =
204500                                 (0426.14 * H-CAPI-GAF).
204600     COMPUTE H-PUERTO-RICO-RATE ROUNDED =
204700                                 (0202.89 * H-PR-CAPI-GAF).
204800
204900     COMPUTE H-CAPI-COLA ROUNDED =
205000                     (.3152 * (H-OPER-COLA - 1) + 1).
205100
205200     MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.
205300
205400     IF P-NEW-STATE = 40
205500        COMPUTE  H-CAPI-FED-RATE ROUNDED =
205600                 (H-NAT-PCT * H-FEDERAL-RATE) +
205700                 (H-REG-PCT * H-PUERTO-RICO-RATE).
205800***********************************************************
205900***  CAPITAL FSP CALCULATION
206000***  CAPITAL FSP CALCULATION
206100
206200     COMPUTE H-CAPI-FSP-PART ROUNDED =
206300                               H-DRG-WT * H-CAPI-FED-RATE *
206400                               H-CAPI-COLA *
206500                               H-CAPI-LARG-URBAN.
206600
206700***********************************************************
206800***  CAPITAL PAYMENT METHOD A
206900***  CAPITAL PAYMENT METHOD A
207000
207100     IF P-N-SCH-REBASED-FY90 OR P-N-EACH
207200        MOVE 1.00 TO H-CAPI-SCH
207300     ELSE
207400        MOVE 0.85 TO H-CAPI-SCH.
207500
207600***********************************************************
207700***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********
207800***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********
207900
208000     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
208100                    (P-NEW-CAPI-OLD-HARM-RATE *
208200                    H-CAPI-SCH).
208300
208400***********************************************************
208500        IF PAY-PERDIEM-DAYS
208600            IF  H-PERDIEM-DAYS < H-ALOS
208700                IF  NOT (B-DRG = 789)
208800                    PERFORM 3500-CALC-PERDIEM-AMT
208900                    MOVE 03 TO PPS-RTC.
209000
209100        IF PAY-XFER-SPEC-DRG
209200            IF  H-PERDIEM-DAYS < H-ALOS
209300                IF  NOT (B-DRG = 789)
209400                    PERFORM 3550-CALC-PERDIEM-AMT.
209500
209600        IF  PAY-XFER-NO-COST
209700            MOVE 00 TO PPS-RTC
209800            IF H-PERDIEM-DAYS < H-ALOS
209900               IF  NOT (B-DRG = 789)
210000                   PERFORM 3500-CALC-PERDIEM-AMT
210100                   MOVE 06 TO PPS-RTC.
210200
210300     PERFORM 4000-CALC-TECH-ADDON THRU 4000-EXIT.
210400
210500     PERFORM 3600-CALC-OUTLIER THRU 3600-EXIT.
210600
210700     IF OUTLIER-RECON-FLAG = 'Y' GO TO 3000-EXIT.
210800
210900     IF PPS-RTC = 67  GO TO 3000-CONTINUE.
211000
211100        IF PAY-XFER-SPEC-DRG
211200            IF  H-PERDIEM-DAYS < H-ALOS
211300                IF  NOT (B-DRG = 789)
211400                    PERFORM 3560-CHECK-RTN-CODE THRU 3560-EXIT.
211500
211600
211700        IF  PAY-PERDIEM-DAYS
211800            IF  H-OPER-OUTCST-PART > 0
211900                MOVE H-OPER-OUTCST-PART TO
212000                     H-OPER-OUTLIER-PART
212100                MOVE 05 TO PPS-RTC
212200            ELSE
212300            IF  PPS-RTC NOT = 03
212400                MOVE 00 TO PPS-RTC
212500                MOVE 0  TO H-OPER-OUTLIER-PART.
212600
212700        IF  PAY-PERDIEM-DAYS
212800            IF  H-CAPI-OUTCST-PART > 0
212900                MOVE H-CAPI-OUTCST-PART TO
213000                     H-CAPI-OUTLIER-PART
213100                MOVE 05 TO PPS-RTC
213200            ELSE
213300            IF  PPS-RTC NOT = 03
213400                MOVE 0  TO H-CAPI-OUTLIER-PART.
213500
213600
213700 3000-CONTINUE.
213800
213900***********************************************************
214000***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF
214100***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
214200
214300     COMPUTE H-CAPI2-B-FSP-PART ROUNDED = H-CAPI-FSP-PART.
214400
214500***********************************************************
214600
214700     IF  PPS-RTC = 67
214800         MOVE H-OPER-DOLLAR-THRESHOLD TO
214900              WK-H-OPER-DOLLAR-THRESHOLD.
215000
215100     IF  PPS-RTC < 50
215200         PERFORM 3800-CALC-TOT-AMT
215300     ELSE
215400         MOVE ALL '0' TO PPS-OPER-HSP-PART
215500                         PPS-OPER-FSP-PART
215600                         PPS-OPER-OUTLIER-PART
215700                         PPS-OUTLIER-DAYS
215800                         PPS-REG-DAYS-USED
215900                         PPS-LTR-DAYS-USED
216000                         PPS-TOTAL-PAYMENT
216100                         PPS-OPER-DSH-ADJ
216200                         PPS-OPER-IME-ADJ
216300                         H-DSCHG-FRCTN
216400                         H-DRG-WT-FRCTN
216500                         HOLD-ADDITIONAL-VARIABLES
216600                         HOLD-CAPITAL-VARIABLES
216700                         HOLD-CAPITAL2-VARIABLES
216800                         HOLD-OTHER-VARIABLES
216900                         HOLD-PC-OTH-VARIABLES.
217000
217100     IF  PPS-RTC = 67
217200         MOVE WK-H-OPER-DOLLAR-THRESHOLD TO
217300                 H-OPER-DOLLAR-THRESHOLD.
217400
217500 3000-EXIT.  EXIT.
217600
217700 3100-CALC-STAY-UTILIZATION.
217800
217900     MOVE 0 TO PPS-REG-DAYS-USED.
218000     MOVE 0 TO PPS-LTR-DAYS-USED.
218100
218200     IF H-REG-DAYS > 0
218300        IF H-REG-DAYS > B-LOS
218400           MOVE B-LOS TO PPS-REG-DAYS-USED
218500        ELSE
218600           MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
218700     ELSE
218800        IF H-LTR-DAYS > B-LOS
218900           MOVE B-LOS TO PPS-LTR-DAYS-USED
219000        ELSE
219100           MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED.
219200
219300
219400
219500 3300-CALC-OPER-FSP-AMT.
219600***********************************************************
219700***  OPERATING FSP CALCULATION
219800***  OPERATING FSP CALCULATION
219900
220000     COMPUTE H-OPER-FSP-PART ROUNDED =
220100           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
220200            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
220300                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
220400
220500     IF P-NEW-STATE = 40
220600       COMPUTE H-OPER-FSP-PART ROUNDED =
220700           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
220800            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
220900                           +
221000           (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
221100            H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)
221200                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
221300
221400
221500 3450-CALC-ADDITIONAL-HSP.
221600***********************************************************
221700*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR
221800*    SOLE COMMUNITY
221900*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)
222000*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
222100***********************************************************
222200*****YEARCHANGE************************************************
222300***         GET THE UPDATING FACTOR
222400***         GET THE UPDATING FACTOR
222500
222600     MOVE 0.995743 TO H-BUDG-NUTR08.
222700
222800     MOVE 1.0330 TO H-UPDATE-08.
222900
223000     COMPUTE H-UPDATE-FACTOR ROUNDED =
223100                       (H-UPDATE-08 *
223200                        H-BUDG-NUTR08).
223300
223400***************************************************************
223500     IF P-NEW-CBSA-HOSP-QUAL-IND = '1'
223600        COMPUTE H-HSP-RATE ROUNDED =
223700         (H-FAC-SPEC-RATE * 1) * H-UPDATE-FACTOR
223800     ELSE
223900        COMPUTE H-HSP-RATE ROUNDED =
224000         ((H-FAC-SPEC-RATE / 1.033) * 1.013) * H-UPDATE-FACTOR.
224100
224200***************************************************************
224300********YEARCHANGE*********************************************
224400***         CASE MIX ADJUSTMENT - FOR FUTURE USE
224500***         CASE MIX ADJUSTMENT - FOR FUTURE USE
224600***
224700***  MOVE 0.994 TO H-CASE-MIX-ADJ.
224800***
224900***  COMPUTE H-HSP-RATE ROUNDED =
225000***    H-HSP-RATE * H-CASE-MIX-ADJ.
225100***
225200********YEARCHANGE*********************************************
225300***     OUTLIER OFFSETS
225400***     OPERATING NATIONAL
225500***     OPERATING PUERTO RICO BLEND
225600
225700      MOVE 0.948983 TO H-OUTLIER-OFFSET-NAT
225800      MOVE 0.964060 TO H-OUTLIER-OFFSET-PR.
225900
226000***************************************************************
226100     COMPUTE H-FSP-RATE ROUNDED =
226200         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
226300         H-NAT-NONLABOR * H-OPER-COLA))
226400                           *
226500     ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-NAT)
226600                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
226700
226800     IF P-NEW-STATE = 40
226900       COMPUTE H-FSP-RATE ROUNDED =
227000        ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
227100         H-NAT-NONLABOR * H-OPER-COLA))
227200                         *
227300        ((1 + H-OPER-IME-TEACH + H-OPER-DSH) /
227400                                H-OUTLIER-OFFSET-NAT))
227500                           +
227600         ((H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
227700         H-REG-NONLABOR * H-OPER-COLA))
227800                           *
227900      ((1 + H-OPER-IME-TEACH + H-OPER-DSH) /
228000                                       H-OUTLIER-OFFSET-PR))
228100                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
228200
228300
228400     IF  H-HSP-RATE > H-FSP-RATE
228500           COMPUTE H-OPER-HSP-PART ROUNDED =
228600             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT
228700                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART
228800     ELSE
228900         MOVE 0 TO H-OPER-HSP-PART.
229000
229100***************************************************************
229200***         GET THE MDH REBASE
229300
229400     IF  H-HSP-RATE > H-FSP-RATE
229500         IF P-NEW-PROVIDER-TYPE = '14' OR '15'
229600           COMPUTE H-OPER-HSP-PART ROUNDED =
229700             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT * .75
229800                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
229900
230000 3500-CALC-PERDIEM-AMT.
230100***********************************************************
230200***  REVIEW CODE = 03 OR 06
230300***  OPERATING PERDIEM-AMT CALCULATION
230400***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
230500
230600        COMPUTE H-OPER-FSP-PART ROUNDED =
230700        H-OPER-FSP-PART * H-TRANSFER-ADJ
230800        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
230900
231000***********************************************************
231100***********************************************************
231200***  REVIEW CODE = 03 OR 06
231300***  CAPITAL   PERDIEM-AMT CALCULATION
231400***  CAPITAL   HSP AND FSP CALCULATION FOR TRANSFERS
231500
231600        COMPUTE H-CAPI-FSP-PART ROUNDED =
231700        H-CAPI-FSP-PART * H-TRANSFER-ADJ
231800        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
231900
232000***********************************************************
232100***  REVIEW CODE = 03 OR 06
232200***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
232300***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
232400
232500        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
232600        H-CAPI-OLD-HARMLESS * H-TRANSFER-ADJ
232700        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
232800
232900 3550-CALC-PERDIEM-AMT.
233000***********************************************************
233100***  REVIEW CODE = 09  OR 11 TRANSFER WITH SPECIAL DRG
233200***  OPERATING PERDIEM-AMT CALCULATION
233300***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
233400
233500     IF (B-DRG-POSTACUTE-50-50)
233600        MOVE 10 TO PPS-RTC
233700        COMPUTE H-OPER-FSP-PART ROUNDED =
233800        H-OPER-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
233900        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
234000
234100     IF (B-DRG-POSTACUTE-PERDIEM)
234200        MOVE 12 TO PPS-RTC
234300        COMPUTE H-OPER-FSP-PART ROUNDED =
234400        H-OPER-FSP-PART *  H-TRANSFER-ADJ
234500        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
234600
234700***********************************************************
234800***  CAPITAL PERDIEM-AMT CALCULATION
234900***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS
235000
235100     IF (B-DRG-POSTACUTE-50-50)
235200        MOVE 10 TO PPS-RTC
235300        COMPUTE H-CAPI-FSP-PART ROUNDED =
235400        H-CAPI-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
235500        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
235600
235700     IF (B-DRG-POSTACUTE-PERDIEM)
235800        MOVE 12 TO PPS-RTC
235900        COMPUTE H-CAPI-FSP-PART ROUNDED =
236000        H-CAPI-FSP-PART *  H-TRANSFER-ADJ
236100        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
236200
236300***********************************************************
236400***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
236500***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
236600
236700     IF (B-DRG-POSTACUTE-50-50)
236800        MOVE 10 TO PPS-RTC
236900        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
237000        H-CAPI-OLD-HARMLESS * (.5 * (1 + H-TRANSFER-ADJ))
237100        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
237200
237300     IF (B-DRG-POSTACUTE-PERDIEM)
237400        MOVE 12 TO PPS-RTC
237500        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
237600        H-CAPI-OLD-HARMLESS *  H-TRANSFER-ADJ
237700        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
237800
237900 3560-CHECK-RTN-CODE.
238000
238100     IF (B-DRG-POSTACUTE-50-50)
238200        MOVE 10 TO PPS-RTC.
238300     IF (B-DRG-POSTACUTE-PERDIEM)
238400        MOVE 12 TO PPS-RTC.
238500
238600 3560-EXIT.    EXIT.
238700
238800 3600-CALC-OUTLIER.
238900***********************************************************
239000***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
239100***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
239200
239300     IF OUTLIER-RECON-FLAG = 'Y'
239400        COMPUTE H-OPER-CSTCHG-RATIO ROUNDED =
239500               (H-OPER-CSTCHG-RATIO + .2).
239600
239700     IF H-CAPI-CSTCHG-RATIO > 0 OR
239800       H-OPER-CSTCHG-RATIO > 0
239900        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD ROUNDED =
240000                H-OPER-CSTCHG-RATIO /
240100               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
240200        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD ROUNDED =
240300                H-CAPI-CSTCHG-RATIO /
240400               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
240500     ELSE
240600         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD
240700                   H-CAPI-SHARE-DOLL-THRESHOLD.
240800
240900***********************************************************
241000*****YEARCHANGE********************************************
241100***  OUTLIER THRESHOLD AMOUNTS
241200***  OUTLIER THRESHOLD AMOUNTS
241300
241400     MOVE 22185.00 TO H-CST-THRESH.
241500
241600     IF (B-REVIEW-CODE = '03') AND
241700         H-PERDIEM-DAYS < H-ALOS
241800        COMPUTE H-CST-THRESH ROUNDED =
241900                      (H-CST-THRESH * H-TRANSFER-ADJ)
242000                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
242100
242200     IF ((B-REVIEW-CODE = '09') AND
242300         (H-PERDIEM-DAYS < H-ALOS))
242400         IF (B-DRG-POSTACUTE-PERDIEM)
242500            COMPUTE H-CST-THRESH ROUNDED =
242600                      (H-CST-THRESH * H-TRANSFER-ADJ)
242700                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
242800
242900     IF ((B-REVIEW-CODE = '09') AND
243000         (H-PERDIEM-DAYS < H-ALOS))
243100         IF (B-DRG-POSTACUTE-50-50)
243200           COMPUTE H-CST-THRESH ROUNDED =
243300          (H-CST-THRESH * (.5 * (1 + H-TRANSFER-ADJ)))
243400                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
243500
243600     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
243700        ((H-CST-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +
243800         (H-CST-THRESH * H-NONLABOR-PCT * H-OPER-COLA)) *
243900          H-OPER-SHARE-DOLL-THRESHOLD.
244000
244100     IF P-NEW-STATE = 40
244200        COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =
244300           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +
244400            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *
244500             H-OPER-SHARE-DOLL-THRESHOLD
244600        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
244700               (H-OPER-DOLLAR-THRESHOLD * H-NAT-PCT) +
244800               (H-OPER-PR-DOLLAR-THRESHOLD * H-REG-PCT).
244900
245000***********************************************************
245100
245200     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
245300          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *
245400          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.
245500
245600
245700     IF P-NEW-STATE = 40
245800        COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =
245900           H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *
246000           H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA
246100        COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
246200               (H-CAPI-DOLLAR-THRESHOLD * H-NAT-PCT) +
246300               (H-CAPI-PR-DOLLAR-THRESHOLD * H-REG-PCT).
246400
246500
246600     COMPUTE H-OPER-COST-OUTLIER ROUNDED =
246700      (H-OPER-FSP-PART * (1 + H-OPER-IME-TEACH + H-OPER-DSH))
246800                       +
246900             H-OPER-DOLLAR-THRESHOLD
247000                       +
247100                 H-NEW-TECH-PAY-ADD-ON.
247200
247300     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
247400      (H-CAPI-FSP-PART * (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH))
247500                       +
247600             H-CAPI-DOLLAR-THRESHOLD.
247700
247800     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
247900         MOVE 0 TO H-CAPI-COST-OUTLIER.
248000
248100
248200***********************************************************
248300***  OPERATING COST CALCULATION
248400***  OPERATING COST CALCULATION
248500
248600     COMPUTE H-OPER-BILL-COSTS ROUNDED =
248700         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO
248800         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
248900
249000
249100     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER
249200         COMPUTE H-OPER-OUTCST-PART ROUNDED =
249300         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -
249400                         H-OPER-COST-OUTLIER).
249500
249600     IF PAY-WITHOUT-COST OR
249700        PAY-XFER-NO-COST OR
249800        PAY-XFER-SPEC-DRG-NO-COST
249900         MOVE 0 TO H-OPER-OUTCST-PART.
250000
250100***********************************************************
250200***  CAPITAL COST CALCULATION
250300***  CAPITAL COST CALCULATION
250400
250500     COMPUTE H-CAPI-BILL-COSTS ROUNDED =
250600             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO
250700         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.
250800
250900     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER
251000         COMPUTE H-CAPI-OUTCST-PART ROUNDED =
251100         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -
251200                         H-CAPI-COST-OUTLIER).
251300
251400     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
251500       COMPUTE H-CAPI-OUTCST-PART ROUNDED =
251600              (H-CAPI-OUTCST-PART * P-NEW-CAPI-NEW-HARM-RATIO).
251700
251800     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
251900        COMPUTE H-CAPI-OUTCST-PART ROUNDED =
252000               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).
252100
252200     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <
252300        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)
252400        MOVE 0 TO H-CAPI-OUTCST-PART
252500                  H-OPER-OUTCST-PART.
252600
252700     IF PAY-WITHOUT-COST OR
252800        PAY-XFER-NO-COST OR
252900        PAY-XFER-SPEC-DRG-NO-COST
253000         MOVE 0 TO H-CAPI-OUTCST-PART.
253100
253200***********************************************************
253300***  DETERMINES THE BILL TO BE COST  OUTLIER
253400
253500     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
253600         MOVE 0 TO H-CAPI-OUTDAY-PART
253700                   H-CAPI-OUTCST-PART.
253800
253900     IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
254000                 MOVE H-OPER-OUTCST-PART TO
254100                      H-OPER-OUTLIER-PART
254200                 MOVE H-CAPI-OUTCST-PART TO
254300                      H-CAPI-OUTLIER-PART
254400                 MOVE 02 TO PPS-RTC.
254500
254600     IF OUTLIER-RECON-FLAG = 'Y'
254700        IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
254800           COMPUTE HLD-PPS-RTC = HLD-PPS-RTC + 30
254900           GO TO 3600-EXIT
255000        ELSE
255100           GO TO 3600-EXIT
255200     ELSE
255300        NEXT SENTENCE.
255400
255500
255600***********************************************************
255700***  DETERMINES IF COST OUTLIER
255800***  RECOMPUTES DOLLAR THRESHOLD TO BE SENT BACK WITH
255900***         RETURN CODE OF 02
256000
256100     MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
256200
256300     IF PPS-RTC = 02
256400             COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
256500                     (H-CAPI-COST-OUTLIER  +
256600                      H-OPER-COST-OUTLIER)
256700                             /
256800                    (H-CAPI-CSTCHG-RATIO  +
256900                     H-OPER-CSTCHG-RATIO)
257000             ON SIZE ERROR MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
257100
257200***********************************************************
257300***  DETERMINES IF COST OUTLIER WITH LOS IS > COVERED  DAYS
257400***         RETURN CODE OF 67
257500
257600     IF PPS-RTC = 02
257700         IF ((H-REG-DAYS + H-LTR-DAYS) < B-LOS) OR
257800            PPS-PC-COT-FLAG = 'Y'
257900             MOVE 67 TO PPS-RTC.
258000***********************************************************
258100
258200***********************************************************
258300***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF
258400***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
258500
258600     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
258700        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
258800                H-CAPI-OUTLIER-PART / P-NEW-CAPI-NEW-HARM-RATIO
258900         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
259000
259100     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
259200        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
259300                H-CAPI-OUTLIER-PART.
259400
259500     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
259600        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
259700                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1
259800         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
259900
260000 3600-EXIT.   EXIT.
260100
260200***********************************************************
260300 3800-CALC-TOT-AMT.
260400***********************************************************
260500***  CALCULATE TOTALS FOR CAPITAL
260600***  CALCULATE TOTALS FOR CAPITAL
260700
260800     MOVE P-NEW-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.
260900
261000     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
261100        MOVE P-NEW-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT
261200        MOVE 0.00 TO H-CAPI-HSP-PCT.
261300
261400     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
261500        MOVE 0    TO H-CAPI-OLD-HARMLESS
261600        MOVE 1.00 TO H-CAPI-FSP-PCT
261700        MOVE 0.00 TO H-CAPI-HSP-PCT.
261800
261900     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
262000        MOVE 0    TO H-CAPI-OLD-HARMLESS
262100        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT
262200        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.
262300
262400     COMPUTE H-CAPI-HSP ROUNDED =
262500         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.
262600
262700     COMPUTE H-CAPI-FSP ROUNDED =
262800         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.
262900
263000     MOVE P-NEW-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.
263100
263200     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.
263300
263400     COMPUTE H-CAPI-DSH-ADJ ROUNDED =
263500             H-CAPI-FSP
263600              * H-CAPI-DSH.
263700
263800     COMPUTE H-CAPI-IME-ADJ ROUNDED =
263900          H-CAPI-FSP *
264000                 H-WK-CAPI-IME-TEACH.
264100
264200     COMPUTE H-CAPI-OUTLIER ROUNDED =
264300             1.00 * H-CAPI-OUTLIER-PART.
264400
264500     COMPUTE H-CAPI2-B-FSP ROUNDED =
264600             1.00 * H-CAPI2-B-FSP-PART.
264700
264800     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =
264900             1.00 * H-CAPI2-B-OUTLIER-PART.
265000***********************************************************
265100***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER
265200***        THIS ZEROES OUT ALL CAPITAL DATA
265300
265400     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
265500        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.
265600***********************************************************
265700
265800***********************************************************
265900***  CALCULATE FINAL TOTALS FOR OPERATING
266000***  CALCULATE FINAL TOTALS FOR OPERATING
266100
266200     IF (H-CAPI-OUTLIER > 0 AND
266300         PPS-OPER-OUTLIER-PART = 0)
266400            COMPUTE PPS-OPER-OUTLIER-PART =
266500                    PPS-OPER-OUTLIER-PART + .01.
266600
266700     MOVE 01.000 TO WK-LOW-VOL25PCT.
266800
266900     IF P-NEW-TEMP-RELIEF-IND = 'Y'
267000        MOVE 01.250 TO WK-LOW-VOL25PCT.
267100
267200     MOVE ZERO TO PPS-OPER-DSH-ADJ.
267300
267400     IF  H-OPER-DSH NUMERIC
267500         COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
267600       (WK-LOW-VOL25PCT * PPS-OPER-FSP-PART) * H-OPER-DSH.
267700
267800     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
267900      (WK-LOW-VOL25PCT * PPS-OPER-FSP-PART) * H-OPER-IME-TEACH.
268000
268100
268200     COMPUTE PPS-OPER-FSP-PART ROUNDED =
268300        (WK-LOW-VOL25PCT * H-OPER-FSP-PART) * H-OPER-FSP-PCT.
268400
268500     COMPUTE PPS-OPER-HSP-PART ROUNDED =
268600        (WK-LOW-VOL25PCT * H-OPER-HSP-PART) * H-OPER-HSP-PCT.
268700
268800     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =
268900      (WK-LOW-VOL25PCT * H-OPER-OUTLIER-PART) * H-OPER-FSP-PCT.
269000
269100     IF HMO-TAG  = 'Y'
269200        PERFORM 3850-HMO-IME-ADJ.
269300
269400***********************************************************
269500***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
269600***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
269700
269800     COMPUTE H-CAPI-TOTAL-PAY ROUNDED =
269900            (H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
270000             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
270100             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM) * WK-LOW-VOL25PCT.
270200
270300     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
270400             (WK-LOW-VOL25PCT * H-NEW-TECH-PAY-ADD-ON).
270500
270600***********************************************************
270700* PUT NEW CHECK HERE IF H-NEW-TECH ZERO PERFORM
270800
270900     IF   H-NEW-TECH-PAY-ADD-ON = 0
271000
271100     PERFORM 4100-ISLET-ISOLATION-ADD-ON THRU 4100-EXIT.
271200
271300
271400
271500     MOVE H-NEW-TECH-PAY-ADD-ON TO PPS-NEW-TECH-PAY-ADD-ON.
271600
271700     COMPUTE   PPS-TOTAL-PAYMENT ROUNDED =
271800               PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
271900               PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
272000                      PPS-OPER-IME-ADJ
272100                           +
272200                 PPS-NEW-TECH-PAY-ADD-ON
272300                           +
272400                 H-WK-PASS-AMT-PLUS-MISC
272500                           +
272600                   H-CAPI-TOTAL-PAY.
272700
272800 3850-HMO-IME-ADJ.
272900***********************************************************
273000***  HMO CALC FOR PASS-THRU ADDON
273100***  HMO CALC FOR PASS-THRU ADDON
273200
273300     COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =
273400          (P-NEW-PASS-AMT-PLUS-MISC -
273500          (P-NEW-PASS-AMT-ORGAN-ACQ +
273600           P-NEW-PASS-AMT-DIR-MED-ED)) * B-LOS.
273700
273800***********************************************************
273900***  HMO IME ADJUSTMENT --- NO LONGER PAID AS OF 10/01/2002
274000
274100     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
274200                   PPS-OPER-IME-ADJ * .0.
274300
274400***********************************************************
274500
274600
274700 3900A-CALC-OPER-DSH.
274800
274900***  OPERATING DSH CALCULATION
275000***  OPERATING DSH CALCULATION
275100
275200      MOVE 0.0000 TO H-OPER-DSH.
275300
275400      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO
275500                                     + P-NEW-MEDICAID-RATIO).
275600
275700***********************************************************
275800**1**    0-99 BEDS
275900***  NOT TO EXCEED 12%
276000
276100      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
276200                               AND H-WK-OPER-DSH > .1499
276300                               AND H-WK-OPER-DSH < .2020
276400        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
276500                                      * .65 + .025
276600        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
276700
276800      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
276900                               AND H-WK-OPER-DSH > .2019
277000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
277100                                      * .825 + .0588
277200        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
277300
277400***********************************************************
277500**2**   100 + BEDS
277600***  NO CAP >> CAN EXCEED 12%
277700
277800      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
277900                               AND H-WK-OPER-DSH > .1499
278000                               AND H-WK-OPER-DSH < .2020
278100        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
278200                                      * .65 + .025.
278300
278400      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
278500                               AND H-WK-OPER-DSH > .2019
278600        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
278700                                      * .825 + .0588.
278800
278900***********************************************************
279000**3**   OTHER RURAL HOSPITALS LESS THEN 500 BEDS
279100***  NOT TO EXCEED 12%
279200
279300      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
279400                               AND H-WK-OPER-DSH > .1499
279500                               AND H-WK-OPER-DSH < .2020
279600        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
279700                                 * .65 + .025
279800        IF H-OPER-DSH > .1200
279900              MOVE .1200 TO H-OPER-DSH.
280000
280100      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
280200                               AND H-WK-OPER-DSH > .2019
280300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
280400                                 * .825 + .0588
280500        IF H-OPER-DSH > .1200
280600                 MOVE .1200 TO H-OPER-DSH.
280700***********************************************************
280800**4**   OTHER RURAL HOSPITALS 500 BEDS +
280900***  NO CAP >> CAN EXCEED 12%
281000
281100      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
281200                               AND H-WK-OPER-DSH > .1499
281300                               AND H-WK-OPER-DSH < .2020
281400        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
281500                                 * .65 + .025.
281600
281700      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
281800                               AND H-WK-OPER-DSH > .2019
281900        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
282000                                 * .825 + .0588.
282100
282200***********************************************************
282300**7**   RURAL HOSPITALS SCH
282400***  NOT TO EXCEED 12%
282500
282600      IF W-CBSA-SIZE = 'R'
282700         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
282800                               AND H-WK-OPER-DSH > .1499
282900                               AND H-WK-OPER-DSH < .2020
283000         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
283100                                 * .65 + .025
283200        IF H-OPER-DSH > .1200
283300                 MOVE .1200 TO H-OPER-DSH.
283400
283500      IF W-CBSA-SIZE = 'R'
283600         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
283700                               AND H-WK-OPER-DSH > .2019
283800         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
283900                                 * .825 + .0588
284000        IF H-OPER-DSH > .1200
284100                 MOVE .1200 TO H-OPER-DSH.
284200
284300***********************************************************
284400**6**   RURAL HOSPITALS RRC   RULE 5 & 6 SAME
284500***  RRC OVERRIDES SCH CAP
284600***  NO CAP >> CAN EXCEED 12%
284700
284800         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR
284900                                   '17' OR '22')
285000                               AND H-WK-OPER-DSH > .1499
285100                               AND H-WK-OPER-DSH < .2020
285200         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
285300                                 * .65 + .025.
285400         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR
285500                                   '17' OR '22')
285600                               AND H-WK-OPER-DSH > .2019
285700         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
285800                                 * .825 + .0588.
285900
286000      COMPUTE H-OPER-DSH ROUNDED = H-OPER-DSH * 1.0000.
286100
286200 3900A-EXIT.   EXIT.
286300
286400 4000-CALC-TECH-ADDON.
286500
286600***********************************************************
286700***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
286800***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
286900
287000     COMPUTE PPS-OPER-HSP-PART ROUNDED =
287100         H-OPER-HSP-PCT * H-OPER-HSP-PART.
287200
287300     COMPUTE PPS-OPER-FSP-PART ROUNDED =
287400         H-OPER-FSP-PCT * H-OPER-FSP-PART.
287500
287600     MOVE ZERO TO PPS-OPER-DSH-ADJ.
287700
287800     IF  H-OPER-DSH NUMERIC
287900             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
288000              PPS-OPER-FSP-PART
288100              * H-OPER-DSH.
288200
288300     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
288400             PPS-OPER-FSP-PART *
288500             H-OPER-IME-TEACH.
288600
288700     COMPUTE H-BASE-DRG-PAYMENT ROUNDED =
288800             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
288900             PPS-OPER-DSH-ADJ + PPS-OPER-IME-ADJ.
289000
289100***********************************************************
289200****      NEUROSTIMULATOR CASES
289300***********************************************************
289400*
289500*    IF '8698   ' =  B-PRIN-PROC-CODE   OR
289600*                    B-OTHER-PROC-CODE1 OR
289700*                    B-OTHER-PROC-CODE2 OR
289800*                    B-OTHER-PROC-CODE3 OR
289900*                    B-OTHER-PROC-CODE4 OR
290000*                    B-OTHER-PROC-CODE5
290100*          NEXT SENTENCE
290200*    ELSE
290300*          MOVE ZEROES TO H-NEW-TECH-ADDON-NEURO
290400*          GO TO 4000-CHECK-GRAFT-CASES.
290500*
290600*    MOVE 18640.00 TO H-CSTMED-NEURO.
290700*
290800*    COMPUTE H-LESSER-NEURO-1 ROUNDED =
290900*            .5   H-CSTMED-NEURO.
291000*
291100*    COMPUTE H-LESSER-NEURO-2 ROUNDED =
291200*          ((B-CHARGES-CLAIMED   P-NEW-OPER-CSTCHG-RATIO) -
291300*                    H-BASE-DRG-PAYMENT)   .5.
291400*
291500*    IF H-LESSER-NEURO-2 > 0
291600*       IF H-LESSER-NEURO-1 < H-LESSER-NEURO-2
291700*          MOVE H-LESSER-NEURO-1 TO H-NEW-TECH-ADDON-NEURO
291800*       ELSE
291900*          MOVE H-LESSER-NEURO-2 TO H-NEW-TECH-ADDON-NEURO
292000*    ELSE
292100*       MOVE ZEROES          TO H-NEW-TECH-ADDON-NEURO.
292200*
292300*4000-CHECK-GRAFT-CASES.
292400*
292500***********************************************************
292600***      GRAFT*(GORE*TAG)*CASES
292700***********************************************************
292800*
292900*    IF '3973   ' =  B-PRIN-PROC-CODE   OR
293000*                    B-OTHER-PROC-CODE1 OR
293100*                    B-OTHER-PROC-CODE2 OR
293200*                    B-OTHER-PROC-CODE3 OR
293300*                    B-OTHER-PROC-CODE4 OR
293400*                    B-OTHER-PROC-CODE5
293500*          NEXT SENTENCE
293600*    ELSE
293700*          MOVE ZEROES TO H-NEW-TECH-ADDON-GRAFT
293800*          GO TO 4000-CHECK-X-STOP.
293900*
294000*    MOVE 21198.00 TO H-CSTMED-GRAFT.
294100*
294200*    COMPUTE H-LESSER-GRAFT-1 ROUNDED =
294300*            .5   H-CSTMED-GRAFT.
294400*
294500*    COMPUTE H-LESSER-GRAFT-2 ROUNDED =
294600*          ((B-CHARGES-CLAIMED   P-NEW-OPER-CSTCHG-RATIO) -
294700*                    H-BASE-DRG-PAYMENT)   .5.
294800*
294900*    IF H-LESSER-GRAFT-2 > 0
295000*       IF H-LESSER-GRAFT-1 < H-LESSER-GRAFT-2
295100*          MOVE H-LESSER-GRAFT-1 TO H-NEW-TECH-ADDON-GRAFT
295200*       ELSE
295300*          MOVE H-LESSER-GRAFT-2 TO H-NEW-TECH-ADDON-GRAFT
295400*    ELSE
295500*       MOVE ZEROES          TO H-NEW-TECH-ADDON-GRAFT.
295600*
295700*4000-CHECK-X-STOP.
295800*
295900***********************************************************
296000*****    X-STOP INTERSPINOUS PROCESS DECOMPRESSION SYSTEM
296100***********************************************************
296200*
296300*    IF '8458   ' =  B-PRIN-PROC-CODE   OR
296400*                    B-OTHER-PROC-CODE1 OR
296500*                    B-OTHER-PROC-CODE2 OR
296600*                    B-OTHER-PROC-CODE3 OR
296700*                    B-OTHER-PROC-CODE4 OR
296800*                    B-OTHER-PROC-CODE5
296900*          NEXT SENTENCE
297000*    ELSE
297100*          MOVE ZEROES TO H-NEW-TECH-ADDON-X-STOP
297200*          GO TO 4000-ADD-TECH-CASES.
297300*
297400*    MOVE 8800.00 TO H-CSTMED-X-STOP.
297500*
297600*    COMPUTE H-LESSER-X-STOP-1 ROUNDED =
297700*            .5   H-CSTMED-X-STOP.
297800*
297900*    COMPUTE H-LESSER-X-STOP-2 ROUNDED =
298000*          ((B-CHARGES-CLAIMED   P-NEW-OPER-CSTCHG-RATIO) -
298100*                    H-BASE-DRG-PAYMENT)   .5.
298200*
298300*    IF H-LESSER-X-STOP-2 > 0
298400*       IF H-LESSER-X-STOP-1 < H-LESSER-X-STOP-2
298500*        MOVE H-LESSER-X-STOP-1 TO H-NEW-TECH-ADDON-X-STOP
298600*       ELSE
298700*        MOVE H-LESSER-X-STOP-2 TO H-NEW-TECH-ADDON-X-STOP
298800*    ELSE
298900*       MOVE ZEROES          TO H-NEW-TECH-ADDON-X-STOP.
299000*
299100*
299200*4000-ADD-TECH-CASES.
299300*
299400*    COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
299500*            H-NEW-TECH-ADDON-NEURO  +
299600*            H-NEW-TECH-ADDON-GRAFT +
299700*            H-NEW-TECH-ADDON-X-STOP.
299800*
299900 4000-EXIT.    EXIT.
300000***********************************************************
300100
300200 4100-ISLET-ISOLATION-ADD-ON.
300300***********************************************************
300400***  TECHNICAL TRANSPLANTATION OF CELLS
300500***
300600*** CODE 52.85 (ALLTRANSPLANTATION OF CELLS OF ISLETS OF
300700*** ISLETS OF LANGERHAUS) AND
300800*** V70.7 (EXAMINATION OF PARTICIPANT IN CLINICAL TRIAL).
300900*** V70.7 ONE OR MORE TIMES IN PROC-CODES AND 52.85 ONE OR MORE
301000*** TIMES IN ANY OTHER PROC-CODE
301100***********************************************************
301200*** IT WAS DECIDED ON 3/12/07 TO ONLY CHECK FOR 52.85 AND NOT
301300*** V70.7
301400***********************************************************
301500
301600     MOVE 0 TO H-TECH-ADDON-ISLET-CNTR
301700               H-TECH-ADDON-ISLET-CNTR2.
301800
301900*    IF 'V707   ' =  B-PRIN-PROC-CODE   OR
302000*                    B-OTHER-PROC-CODE1 OR
302100*                    B-OTHER-PROC-CODE2 OR
302200*                    B-OTHER-PROC-CODE3 OR
302300*                    B-OTHER-PROC-CODE4 OR
302400*                    B-OTHER-PROC-CODE5
302500*          NEXT SENTENCE
302600*    ELSE
302700*          MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET
302800*          GO TO 4100-ADD-TECH-CASES.
302900
303000     IF '5285   ' =  B-PRIN-PROC-CODE   OR
303100                     B-OTHER-PROC-CODE1 OR
303200                     B-OTHER-PROC-CODE2 OR
303300                     B-OTHER-PROC-CODE3 OR
303400                     B-OTHER-PROC-CODE4 OR
303500                     B-OTHER-PROC-CODE5   OR
303600                     B-OTHER-PROC-CODE6   OR
303700                     B-OTHER-PROC-CODE7   OR
303800                     B-OTHER-PROC-CODE8   OR
303900                     B-OTHER-PROC-CODE9   OR
304000                     B-OTHER-PROC-CODE10  OR
304100                     B-OTHER-PROC-CODE11  OR
304200                     B-OTHER-PROC-CODE12  OR
304300                     B-OTHER-PROC-CODE13  OR
304400                     B-OTHER-PROC-CODE14  OR
304500                     B-OTHER-PROC-CODE15  OR
304600                     B-OTHER-PROC-CODE16  OR
304700                     B-OTHER-PROC-CODE17  OR
304800                     B-OTHER-PROC-CODE18  OR
304900                     B-OTHER-PROC-CODE19  OR
305000                     B-OTHER-PROC-CODE20  OR
305100                     B-OTHER-PROC-CODE21  OR
305200                     B-OTHER-PROC-CODE22  OR
305300                     B-OTHER-PROC-CODE23  OR
305400                     B-OTHER-PROC-CODE24
305500           NEXT SENTENCE
305600     ELSE
305700           MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET
305800           GO TO 4100-ADD-TECH-CASES.
305900
306000     IF '5285   ' =  B-PRIN-PROC-CODE
306100      COMPUTE H-TECH-ADDON-ISLET-CNTR =
306200                       H-TECH-ADDON-ISLET-CNTR + 1.
306300
306400     IF '5285   ' =  B-OTHER-PROC-CODE1
306500      COMPUTE H-TECH-ADDON-ISLET-CNTR =
306600                       H-TECH-ADDON-ISLET-CNTR + 1.
306700
306800     IF '5285   ' =  B-OTHER-PROC-CODE2
306900      COMPUTE H-TECH-ADDON-ISLET-CNTR =
307000                       H-TECH-ADDON-ISLET-CNTR + 1.
307100
307200     IF '5285   ' =  B-OTHER-PROC-CODE3
307300      COMPUTE H-TECH-ADDON-ISLET-CNTR =
307400                       H-TECH-ADDON-ISLET-CNTR + 1.
307500
307600     IF '5285   ' =  B-OTHER-PROC-CODE4
307700      COMPUTE H-TECH-ADDON-ISLET-CNTR =
307800                       H-TECH-ADDON-ISLET-CNTR + 1.
307900
308000     IF '5285   ' =  B-OTHER-PROC-CODE5
308100      COMPUTE H-TECH-ADDON-ISLET-CNTR =
308200                       H-TECH-ADDON-ISLET-CNTR + 1.
308300
308400     IF '5285   ' =  B-OTHER-PROC-CODE6
308500      COMPUTE H-TECH-ADDON-ISLET-CNTR =
308600                       H-TECH-ADDON-ISLET-CNTR + 1.
308700
308800     IF '5285   ' =  B-OTHER-PROC-CODE7
308900      COMPUTE H-TECH-ADDON-ISLET-CNTR =
309000                       H-TECH-ADDON-ISLET-CNTR + 1.
309100
309200     IF '5285   ' =  B-OTHER-PROC-CODE8
309300      COMPUTE H-TECH-ADDON-ISLET-CNTR =
309400                       H-TECH-ADDON-ISLET-CNTR + 1.
309500
309600     IF '5285   ' =  B-OTHER-PROC-CODE9
309700      COMPUTE H-TECH-ADDON-ISLET-CNTR =
309800                       H-TECH-ADDON-ISLET-CNTR + 1.
309900
310000     IF '5285   ' =  B-OTHER-PROC-CODE10
310100      COMPUTE H-TECH-ADDON-ISLET-CNTR =
310200                       H-TECH-ADDON-ISLET-CNTR + 1.
310300
310400     IF '5285   ' =  B-OTHER-PROC-CODE11
310500      COMPUTE H-TECH-ADDON-ISLET-CNTR =
310600                       H-TECH-ADDON-ISLET-CNTR + 1.
310700
310800     IF '5285   ' =  B-OTHER-PROC-CODE12
310900      COMPUTE H-TECH-ADDON-ISLET-CNTR =
311000                       H-TECH-ADDON-ISLET-CNTR + 1.
311100
311200     IF '5285   ' =  B-OTHER-PROC-CODE13
311300      COMPUTE H-TECH-ADDON-ISLET-CNTR =
311400                       H-TECH-ADDON-ISLET-CNTR + 1.
311500
311600     IF '5285   ' =  B-OTHER-PROC-CODE14
311700      COMPUTE H-TECH-ADDON-ISLET-CNTR =
311800                       H-TECH-ADDON-ISLET-CNTR + 1.
311900
312000     IF '5285   ' =  B-OTHER-PROC-CODE15
312100      COMPUTE H-TECH-ADDON-ISLET-CNTR =
312200                       H-TECH-ADDON-ISLET-CNTR + 1.
312300
312400     IF '5285   ' =  B-OTHER-PROC-CODE16
312500      COMPUTE H-TECH-ADDON-ISLET-CNTR =
312600                       H-TECH-ADDON-ISLET-CNTR + 1.
312700
312800     IF '5285   ' =  B-OTHER-PROC-CODE17
312900      COMPUTE H-TECH-ADDON-ISLET-CNTR =
313000                       H-TECH-ADDON-ISLET-CNTR + 1.
313100
313200     IF '5285   ' =  B-OTHER-PROC-CODE18
313300      COMPUTE H-TECH-ADDON-ISLET-CNTR =
313400                       H-TECH-ADDON-ISLET-CNTR + 1.
313500
313600     IF '5285   ' =  B-OTHER-PROC-CODE19
313700      COMPUTE H-TECH-ADDON-ISLET-CNTR =
313800                       H-TECH-ADDON-ISLET-CNTR + 1.
313900
314000     IF '5285   ' =  B-OTHER-PROC-CODE20
314100      COMPUTE H-TECH-ADDON-ISLET-CNTR =
314200                       H-TECH-ADDON-ISLET-CNTR + 1.
314300
314400     IF '5285   ' =  B-OTHER-PROC-CODE21
314500      COMPUTE H-TECH-ADDON-ISLET-CNTR =
314600                       H-TECH-ADDON-ISLET-CNTR + 1.
314700
314800     IF '5285   ' =  B-OTHER-PROC-CODE22
314900      COMPUTE H-TECH-ADDON-ISLET-CNTR =
315000                       H-TECH-ADDON-ISLET-CNTR + 1.
315100
315200     IF '5285   ' =  B-OTHER-PROC-CODE23
315300      COMPUTE H-TECH-ADDON-ISLET-CNTR =
315400                       H-TECH-ADDON-ISLET-CNTR + 1.
315500
315600     IF '5285   ' =  B-OTHER-PROC-CODE24
315700      COMPUTE H-TECH-ADDON-ISLET-CNTR =
315800                       H-TECH-ADDON-ISLET-CNTR + 1.
315900
316000*    IF 'V707   ' =  B-PRIN-PROC-CODE
316100*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
316200*                      H-TECH-ADDON-ISLET-CNTR2 + 1.
316300*
316400*    IF 'V707   ' =  B-OTHER-PROC-CODE1
316500*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
316600*                      H-TECH-ADDON-ISLET-CNTR2 + 1.
316700*
316800*    IF 'V707   ' =  B-OTHER-PROC-CODE2
316900*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
317000*                      H-TECH-ADDON-ISLET-CNTR2 + 1.
317100*
317200*    IF 'V707   ' =  B-OTHER-PROC-CODE3
317300*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
317400*                      H-TECH-ADDON-ISLET-CNTR2 + 1.
317500*
317600*    IF 'V707   ' =  B-OTHER-PROC-CODE4
317700*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
317800*                      H-TECH-ADDON-ISLET-CNTR2 + 1.
317900*
318000*    IF 'V707   ' =  B-OTHER-PROC-CODE5
318100*     COMPUTE H-TECH-ADDON-ISLET-CNTR2 =
318200*                    H-TECH-ADDON-ISLET-CNTR2 + 1.
318300*
318400*    IF  H-TECH-ADDON-ISLET-CNTR2 > 0
318500*          NEXT SENTENCE
318600*    ELSE
318700*          MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET
318800*          GO TO 4100-ADD-TECH-CASES.
318900
319000     IF  H-TECH-ADDON-ISLET-CNTR = 1
319100     MOVE 18848.00 TO H-NEW-TECH-ADDON-ISLET
319200           GO TO 4100-ADD-TECH-CASES.
319300
319400     IF  H-TECH-ADDON-ISLET-CNTR > 1
319500     MOVE 37696.00 TO H-NEW-TECH-ADDON-ISLET
319600           GO TO 4100-ADD-TECH-CASES.
319700
319800     MOVE 0 TO H-NEW-TECH-ADDON-ISLET.
319900
320000
320100 4100-ADD-TECH-CASES.
320200
320300     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
320400             H-NEW-TECH-ADDON-ISLET.
320500
320600 4100-EXIT.    EXIT.
320700
320800******        L A S T   S O U R C E   S T A T E M E N T   *****
