| [613] | 1 | IBATEI ;ALB/BGA - TRANSFER PRICING INPATIENT TRACKER ; 02-FEB-99
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**115,210**;21-MAR-94
|
|---|
| 3 | ;; Per VHA Directive 10-93-142, this routine should not be modified
|
|---|
| 4 | ;
|
|---|
| 5 | ; This routine is called from ^IBAMTD and tracks all patient movements
|
|---|
| 6 | ; as they relate to patients who are out of network.
|
|---|
| 7 | ;
|
|---|
| 8 | EN ; Main Entry Point
|
|---|
| 9 | I '$P($G(^IBE(350.9,1,10)),"^",2) Q ; transfer pricing turned off
|
|---|
| 10 | I $G(DGPMA)="",$G(DGPMP)="" Q
|
|---|
| 11 | N DFN,IBATIEN,DA,IBRTYPE,TYPE,IBA,IBIND,IBPTF,IBDISDT,IBDISPT,IBATFILE
|
|---|
| 12 | N IBADMDT,IBSOURCE,IBPREF,PTF,ADMIS,IBDFN,IBREST
|
|---|
| 13 | S IBA=$P($S(DGPMA="":DGPMP,1:DGPMA),U,14) Q:IBA<1 ; iba ptr to the admission
|
|---|
| 14 | S IBIND=IBA_";DGPM("
|
|---|
| 15 | ; $$FINDT checks to see if the entry exist and the entry is not cancelled
|
|---|
| 16 | S IBATIEN=$$FINDT^IBATUTL(IBIND)
|
|---|
| 17 | I IBATIEN D G END
|
|---|
| 18 | . S DFN=$P($G(^IBAT(351.61,+IBATIEN,0)),U,2) Q:DFN<1
|
|---|
| 19 | . ; if the MOVEMENT admission was deleted DELETE entry from 351.61
|
|---|
| 20 | . I DGPMA="",($P(DGPMP,U,2)=1) D Q
|
|---|
| 21 | . . D DEL^IBATFILE(IBATIEN)
|
|---|
| 22 | . ; if the MOVEMENT deleted a discharge reset transaction STATUS="entered"
|
|---|
| 23 | . I DGPMA="",($P(DGPMP,U,2)=3) D Q
|
|---|
| 24 | . . S IBATFILE=$$DISC^IBATFILE(IBATIEN)
|
|---|
| 25 | . ; if the MOVEMENT is adding a *DISCHARGE* add the event
|
|---|
| 26 | . I DGPMP="",($P(DGPMA,U,2)=3) D Q
|
|---|
| 27 | . . ; Look for ptf in the parent event
|
|---|
| 28 | . . Q:'$P(DGPMA,U,14)
|
|---|
| 29 | . . S IBPTF=$P($G(^DGPM($P(DGPMA,U,14),0)),U,16) Q:'IBPTF
|
|---|
| 30 | . . S IBDISDT=$P($G(^DGPT(IBPTF,70)),U)
|
|---|
| 31 | . . Q:IBDISDT']" "
|
|---|
| 32 | . . S IBDISPT=$P($G(^DGPM($P(DGPMA,U,14),0)),U,17) Q:'IBDISPT
|
|---|
| 33 | . . ; PASS IN=ien 351.61,discharge dt in ptf,discharge movement
|
|---|
| 34 | . . S IBATFILE=$$DIS^IBATFILE(IBATIEN,IBDISDT,IBPTF,IBDISPT)
|
|---|
| 35 | . . ; <<end of update existing entry>>
|
|---|
| 36 | . . ; [if new admission not currently being tracked added to 351.61]
|
|---|
| 37 | I DGPMP="",($P(DGPMA,U,2)=1) D G END
|
|---|
| 38 | . ; check to see if this is a tp $$TTP returns '0' if not TP
|
|---|
| 39 | . Q:'$$TPP^IBATUTL($P(DGPMA,U,3))
|
|---|
| 40 | . S IBADMDT=$P(DGPMA,U),IBSOURCE=$P(DGPMA,U,14)
|
|---|
| 41 | . S IBPREF=$$PPF^IBATUTL($P(DGPMA,U,3)) Q:'IBPREF
|
|---|
| 42 | . Q:IBSOURCE=""!($P(DGPMA,U,14)="")
|
|---|
| 43 | . S IBSOURCE=IBSOURCE_";DGPM("
|
|---|
| 44 | . S IBATFILE=$$ADM^IBATFILE($P(DGPMA,U,3),IBADMDT,IBPREF,IBSOURCE)
|
|---|
| 45 | ;
|
|---|
| 46 | ; Case where we have a discharge but the admission was not recorded
|
|---|
| 47 | I DGPMP="",($P(DGPMA,U,2)=3) D G END
|
|---|
| 48 | . Q:'$$TPP^IBATUTL($P(DGPMA,U,3))
|
|---|
| 49 | . ; add the admission and than add the discharge
|
|---|
| 50 | . S IBADMDT=$P(DGPMA,U),IBSOURCE=$P(DGPMA,U,14)
|
|---|
| 51 | . S IBPREF=$$PPF^IBATUTL($P(DGPMA,U,3)) Q:'IBPREF
|
|---|
| 52 | . Q:IBSOURCE=""!($P(DGPMA,U,14)="")
|
|---|
| 53 | . S IBSOURCE=IBSOURCE_";DGPM("
|
|---|
| 54 | . S IBATFILE=$$ADM^IBATFILE($P(DGPMA,U,3),IBADMDT,IBPREF,IBSOURCE)
|
|---|
| 55 | . ; add the discharge
|
|---|
| 56 | . Q:'$P(DGPMA,U,14)!(IBATFILE<1)
|
|---|
| 57 | . S IBATIEN=+IBATFILE,IBPTF=$P($G(^DGPM($P(DGPMA,U,14),0)),U,16) Q:'IBPTF
|
|---|
| 58 | . S IBDISDT=$P($G(^DGPT(IBPTF,70)),U)
|
|---|
| 59 | . Q:IBDISDT']" "
|
|---|
| 60 | . S IBDISPT=$P($G(^DGPM($P(DGPMA,U,14),0)),U,17) Q:'IBDISPT
|
|---|
| 61 | . ; PASS IN=ien 351.61,discharge dt in ptf,discharge movement
|
|---|
| 62 | . S IBATFILE=$$DIS^IBATFILE(IBATIEN,IBDISDT,IBPTF,IBDISPT)
|
|---|
| 63 | Q
|
|---|
| 64 | ;
|
|---|
| 65 | FINDRT(PTF,ADMIS,IBDFN) ; Find the Rate
|
|---|
| 66 | ;
|
|---|
| 67 | ; Input: PTF=ien to PTF
|
|---|
| 68 | ; ADMIS=ien to DGPM Patient Movement
|
|---|
| 69 | ; IBDFN=ien to Patient File
|
|---|
| 70 | ;
|
|---|
| 71 | ; Output:
|
|---|
| 72 | ; IBREST= if 0^ 2nd piece is error message
|
|---|
| 73 | ; = if 1^ the rate has been calculated.
|
|---|
| 74 | N IBATERR,IBRTYPE,IBADMDT,CHARGE,IBPREF,DISSPEC,TYPE,IBCALC,DRG
|
|---|
| 75 | I '$G(PTF)!('$G(ADMIS))!('$G(IBDFN)) S IBREST="0^Parmeter passed in to FINDRT was less than one" Q IBREST
|
|---|
| 76 | S IBATERR=0,IBADMDT=$P($P($G(^DGPM(+ADMIS,0)),U),".")
|
|---|
| 77 | I IBADMDT<1 S IBREST="0^No admission date FOUND for ^dgpm ien="_ADMIS Q IBREST
|
|---|
| 78 | S IBRTYPE=$$TYPRATE(PTF) ; returns bed or drg
|
|---|
| 79 | I IBRTYPE["Could not find" Q IBRTYPE ;no DRG or Rate could be found
|
|---|
| 80 | I $P(IBRTYPE,U,2)["DRG" D Q IBREST
|
|---|
| 81 | . S DRG=$P(IBRTYPE,U)
|
|---|
| 82 | . ; Find the home facility
|
|---|
| 83 | . S IBPREF=$$PPF^IBATUTL(+IBDFN) I 'IBPREF S IBREST="0^No home facility found for DFN="_IBDFN Q
|
|---|
| 84 | . ; Pass in DRG the date of the admission, the pref fac. and return
|
|---|
| 85 | . ; CHARGE=1!0^default rate^nego rate^rate to use^tortliability rate
|
|---|
| 86 | . S CHARGE=$$INPT^IBATCM(DRG,IBADMDT,IBPREF)
|
|---|
| 87 | . I '$P(CHARGE,U)!$P(CHARGE,U,4)<1 S IBREST="0^Could not find a valid charge for the DRG" Q
|
|---|
| 88 | . ; Pass in string "DRG",ien 405,DRG, DOLLAR AMOUNT)
|
|---|
| 89 | . S IBREST=$$CALCRT("DRG",ADMIS,DRG,$P(CHARGE,U,4))
|
|---|
| 90 | . ; if the second piece of IBVALUE is there than we have an
|
|---|
| 91 | . ; error (need to do something) if not file away.
|
|---|
| 92 | . ; if the filing was successful we need to set IBREST=1 and quit
|
|---|
| 93 | . ; otherwise set IBREST="0^give reason for problem
|
|---|
| 94 | I $P(IBRTYPE,U,2)["BED" D Q IBREST ; price and file the claim
|
|---|
| 95 | . S IBREST=$$CALCRT("BED",ADMIS,$P(IBRTYPE,U))
|
|---|
| 96 | ;
|
|---|
| 97 | TYPRATE(X) ; Pass in PTF ien and return either DRG or Bedsection or ERROR
|
|---|
| 98 | ; see if PTF has a DRG
|
|---|
| 99 | I '$G(X) S TYPE="0^Parameter passed into TYPRATE(X) has no value" Q TYPE
|
|---|
| 100 | N IBPTF,IBPTFD,DIC,DA,DR,DIQ,IBDISCH,IBBED
|
|---|
| 101 | S DIC="^DGPT(",DA=X,DR=".01;71;9",DIQ="IBPTF",DIQ(0)="I" D EN^DIQ1
|
|---|
| 102 | K DIQ(0) S DIQ="IBPTFD" D EN^DIQ1 ; i need the computed drg value
|
|---|
| 103 | I '$D(IBPTF),('$D(IBPTFD)) S TYPE="0^Could not find PTF RECORD" Q TYPE
|
|---|
| 104 | I $G(IBPTFD(45,DA,9))="",$G(IBPTF(45,DA,71,"I"))="" S TYPE="0^Could not find a PTF RECORD" Q TYPE
|
|---|
| 105 | S DISSPEC=$G(IBPTF(45,DA,71,"I")) ; used in $$calc when calculating outliers
|
|---|
| 106 | ; Below if i have a drg and the drg can be priced SELECT drg
|
|---|
| 107 | I $G(IBPTFD(45,DA,9)),+$$INPT^IBATCM(IBPTFD(45,DA,9),IBADMDT) S TYPE=$G(IBPTFD(45,DA,9))_U_"DRG"
|
|---|
| 108 | E D
|
|---|
| 109 | . S IBDISCH=$G(IBPTF(45,DA,71,"I")) ;gives you the discharge speciality
|
|---|
| 110 | . S IBBED=$P($G(^DIC(42.4,+IBDISCH,0)),U,5) ; Bedsection 399.1
|
|---|
| 111 | . S TYPE=IBBED_U_"BED"
|
|---|
| 112 | Q TYPE
|
|---|
| 113 | ;
|
|---|
| 114 | CALCRT(Z,Y,V,R) ; Calculate LOS, and price out claim.
|
|---|
| 115 | ; INPUT:
|
|---|
| 116 | ; Z = a string either "BED" or "DRG"
|
|---|
| 117 | ; Y = ien for the admission movement
|
|---|
| 118 | ; V = value either bedsection NAME or the drg NUMBER
|
|---|
| 119 | ; R = used only with DRG and it is the dollar value of the drg.
|
|---|
| 120 | ; OUTPUT:
|
|---|
| 121 | ; IBCALC=" if 0^ 2nd piece is error message
|
|---|
| 122 | ; if 1^ there are 2 possible options that can be returned
|
|---|
| 123 | ; Option 1 - If we are calculating a Bed Section
|
|---|
| 124 | ; 1^calculated amount^"B"
|
|---|
| 125 | ; Option 2 - If we are calculating a DRG
|
|---|
| 126 | ; 1^calculated amt^ien drg^los^hightrim^outlier days
|
|---|
| 127 | ; ^bedsection rate for the outliers
|
|---|
| 128 | ;
|
|---|
| 129 | N X,IBBEDPTR,IBLOS,IBDATE,CALCDATE,DRGHIGH,IBBEDRT,IBDIFF,IBBED,IBOUTDT,IBBEDRT,DGPMIFN
|
|---|
| 130 | I '$D(Z)!('$D(V))!($G(Y)<1) S IBCALC="0^parameter 'Z' is invalid" Q IBCALC
|
|---|
| 131 | S IBCALC=0 I Z'="DRG"&(Z'="BED") S IBCALC="0^parameter is incorrect" Q IBCALC
|
|---|
| 132 | ; calculate the LOS Y=ien for the admission movement
|
|---|
| 133 | I '$D(^DGPM(+Y,0)) S IBCALC="0^ien "_Y_" in 405 does not exist" Q IBCALC
|
|---|
| 134 | I Z["DRG",($G(R)<1) S IBCALC="0^the drg dollar value for ien "_Y_" was not passed in" Q IBCALC
|
|---|
| 135 | S DGPMIFN=Y D ^DGPMLOS
|
|---|
| 136 | I $P(X,U,5)<1 S IBCALC="0^no LOS found FOR movement "_Y Q IBCALC
|
|---|
| 137 | E S IBLOS=$P(X,U,5)
|
|---|
| 138 | S IBDATE=$P($P($G(^DGPM(+Y,0)),U),".") ; Date of patient movement
|
|---|
| 139 | I Z="BED" D Q IBCALC
|
|---|
| 140 | . ;get the pointer to the bedsection
|
|---|
| 141 | . S IBBEDPTR=$$MCCRUTL^IBCRU1(V,5) ; 5 distinguishes bedsection in 399.1
|
|---|
| 142 | . I IBBEDPTR<1 S IBCALC="0^could not find pointer to bedsection for name: "_V Q
|
|---|
| 143 | . S CALCDATE=IBDATE
|
|---|
| 144 | . ; below 1=ien to the charge set = TL-INPT(INCLUSIVE) #363.3
|
|---|
| 145 | . S IBCALC=$$ITCHG^IBCRCI(1,IBBEDPTR,CALCDATE)
|
|---|
| 146 | . S IBCALC=$P(IBCALC,U)
|
|---|
| 147 | . S IBCALC=$S(IBCALC<1:"0^No rate found for bedsect "_Y,1:IBCALC)
|
|---|
| 148 | . I IBCALC<1 Q
|
|---|
| 149 | . S IBCALC="1^"_(IBLOS*(IBCALC*.8))_U_"B"
|
|---|
| 150 | ;
|
|---|
| 151 | ; (***** calculate DRG outliers here ******)
|
|---|
| 152 | I Z="DRG" D Q IBCALC
|
|---|
| 153 | . ; do look up calculate drg value
|
|---|
| 154 | . S DRGHIGH=$P($$DRG^IBACSV(+V,IBDATE),U,4)
|
|---|
| 155 | . S IBDIFF=$S(DRGHIGH:IBLOS-DRGHIGH,1:0)
|
|---|
| 156 | . S IBCALC=R ;==DRG is calculated for the entire los except when there are high trim days
|
|---|
| 157 | . ; if you have an outlier and you have a bedsection calc outlier
|
|---|
| 158 | . ; disspec is the ptr to speciality from ptf set in $$typrate
|
|---|
| 159 | . I IBDIFF>0,(DISSPEC>0) D
|
|---|
| 160 | . . ; DISSPEC ;gives you the discharge speciality
|
|---|
| 161 | . . S IBBED=$P($G(^DIC(42.4,+DISSPEC,0)),U,5) ; Name of Bedsection 399.1
|
|---|
| 162 | . . S IBBEDPTR=$$MCCRUTL^IBCRU1(IBBED,5) ; Ptr to bedsection
|
|---|
| 163 | . . S IBOUTDT=$P($G(^DGPM(+Y,0)),U)
|
|---|
| 164 | . . S IBBEDRT=$$ITCHG^IBCRCI(1,IBBEDPTR,IBOUTDT) ; returns rate for bedsection
|
|---|
| 165 | . . S IBBEDRT=$P(IBBEDRT,U)
|
|---|
| 166 | . . I IBBEDRT>0 S IBBEDRT=(IBBEDRT*.8) ;**BGA-MOD 2/9/2000
|
|---|
| 167 | . S IBCALC="1^"_IBCALC_U_V_U_IBLOS_U_DRGHIGH_U_$S(IBDIFF<1:0,1:IBDIFF)_U_$S($G(IBBEDRT)>0:IBBEDRT,1:0)
|
|---|
| 168 | . ; All bedsections,drgs and outliers are calculated at 80% of there face value
|
|---|
| 169 | Q IBCALC
|
|---|
| 170 | ;
|
|---|
| 171 | END ;
|
|---|
| 172 | W !,"Updating Transfer Pricing has been...completed."
|
|---|
| 173 | Q
|
|---|
