IBATEI ;ALB/BGA - TRANSFER PRICING INPATIENT TRACKER ; 02-FEB-99
;;2.0;INTEGRATED BILLING;**115,210**;21-MAR-94
;; Per VHA Directive 10-93-142, this routine should not be modified
;
; This routine is called from ^IBAMTD and tracks all patient movements
; as they relate to patients who are out of network.
;
EN ; Main Entry Point
I '$P($G(^IBE(350.9,1,10)),"^",2) Q ; transfer pricing turned off
I $G(DGPMA)="",$G(DGPMP)="" Q
N DFN,IBATIEN,DA,IBRTYPE,TYPE,IBA,IBIND,IBPTF,IBDISDT,IBDISPT,IBATFILE
N IBADMDT,IBSOURCE,IBPREF,PTF,ADMIS,IBDFN,IBREST
S IBA=$P($S(DGPMA="":DGPMP,1:DGPMA),U,14) Q:IBA<1 ; iba ptr to the admission
S IBIND=IBA_";DGPM("
; $$FINDT checks to see if the entry exist and the entry is not cancelled
S IBATIEN=$$FINDT^IBATUTL(IBIND)
I IBATIEN D G END
. S DFN=$P($G(^IBAT(351.61,+IBATIEN,0)),U,2) Q:DFN<1
. ; if the MOVEMENT admission was deleted DELETE entry from 351.61
. I DGPMA="",($P(DGPMP,U,2)=1) D Q
. . D DEL^IBATFILE(IBATIEN)
. ; if the MOVEMENT deleted a discharge reset transaction STATUS="entered"
. I DGPMA="",($P(DGPMP,U,2)=3) D Q
. . S IBATFILE=$$DISC^IBATFILE(IBATIEN)
. ; if the MOVEMENT is adding a *DISCHARGE* add the event
. I DGPMP="",($P(DGPMA,U,2)=3) D Q
. . ; Look for ptf in the parent event
. . Q:'$P(DGPMA,U,14)
. . S IBPTF=$P($G(^DGPM($P(DGPMA,U,14),0)),U,16) Q:'IBPTF
. . S IBDISDT=$P($G(^DGPT(IBPTF,70)),U)
. . Q:IBDISDT']" "
. . S IBDISPT=$P($G(^DGPM($P(DGPMA,U,14),0)),U,17) Q:'IBDISPT
. . ; PASS IN=ien 351.61,discharge dt in ptf,discharge movement
. . S IBATFILE=$$DIS^IBATFILE(IBATIEN,IBDISDT,IBPTF,IBDISPT)
. . ; <<end of update existing entry>>
. . ; [if new admission not currently being tracked added to 351.61]
I DGPMP="",($P(DGPMA,U,2)=1) D G END
. ; check to see if this is a tp $$TTP returns '0' if not TP
. Q:'$$TPP^IBATUTL($P(DGPMA,U,3))
. S IBADMDT=$P(DGPMA,U),IBSOURCE=$P(DGPMA,U,14)
. S IBPREF=$$PPF^IBATUTL($P(DGPMA,U,3)) Q:'IBPREF
. Q:IBSOURCE=""!($P(DGPMA,U,14)="")
. S IBSOURCE=IBSOURCE_";DGPM("
. S IBATFILE=$$ADM^IBATFILE($P(DGPMA,U,3),IBADMDT,IBPREF,IBSOURCE)
;
; Case where we have a discharge but the admission was not recorded
I DGPMP="",($P(DGPMA,U,2)=3) D G END
. Q:'$$TPP^IBATUTL($P(DGPMA,U,3))
. ; add the admission and than add the discharge
. S IBADMDT=$P(DGPMA,U),IBSOURCE=$P(DGPMA,U,14)
. S IBPREF=$$PPF^IBATUTL($P(DGPMA,U,3)) Q:'IBPREF
. Q:IBSOURCE=""!($P(DGPMA,U,14)="")
. S IBSOURCE=IBSOURCE_";DGPM("
. S IBATFILE=$$ADM^IBATFILE($P(DGPMA,U,3),IBADMDT,IBPREF,IBSOURCE)
. ; add the discharge
. Q:'$P(DGPMA,U,14)!(IBATFILE<1)
. S IBATIEN=+IBATFILE,IBPTF=$P($G(^DGPM($P(DGPMA,U,14),0)),U,16) Q:'IBPTF
. S IBDISDT=$P($G(^DGPT(IBPTF,70)),U)
. Q:IBDISDT']" "
. S IBDISPT=$P($G(^DGPM($P(DGPMA,U,14),0)),U,17) Q:'IBDISPT
. ; PASS IN=ien 351.61,discharge dt in ptf,discharge movement
. S IBATFILE=$$DIS^IBATFILE(IBATIEN,IBDISDT,IBPTF,IBDISPT)
Q
;
FINDRT(PTF,ADMIS,IBDFN) ; Find the Rate
;
; Input: PTF=ien to PTF
; ADMIS=ien to DGPM Patient Movement
; IBDFN=ien to Patient File
;
; Output:
; IBREST= if 0^ 2nd piece is error message
; = if 1^ the rate has been calculated.
N IBATERR,IBRTYPE,IBADMDT,CHARGE,IBPREF,DISSPEC,TYPE,IBCALC,DRG
I '$G(PTF)!('$G(ADMIS))!('$G(IBDFN)) S IBREST="0^Parmeter passed in to FINDRT was less than one" Q IBREST
S IBATERR=0,IBADMDT=$P($P($G(^DGPM(+ADMIS,0)),U),".")
I IBADMDT<1 S IBREST="0^No admission date FOUND for ^dgpm ien="_ADMIS Q IBREST
S IBRTYPE=$$TYPRATE(PTF) ; returns bed or drg
I IBRTYPE["Could not find" Q IBRTYPE ;no DRG or Rate could be found
I $P(IBRTYPE,U,2)["DRG" D Q IBREST
. S DRG=$P(IBRTYPE,U)
. ; Find the home facility
. S IBPREF=$$PPF^IBATUTL(+IBDFN) I 'IBPREF S IBREST="0^No home facility found for DFN="_IBDFN Q
. ; Pass in DRG the date of the admission, the pref fac. and return
. ; CHARGE=1!0^default rate^nego rate^rate to use^tortliability rate
. S CHARGE=$$INPT^IBATCM(DRG,IBADMDT,IBPREF)
. I '$P(CHARGE,U)!$P(CHARGE,U,4)<1 S IBREST="0^Could not find a valid charge for the DRG" Q
. ; Pass in string "DRG",ien 405,DRG, DOLLAR AMOUNT)
. S IBREST=$$CALCRT("DRG",ADMIS,DRG,$P(CHARGE,U,4))
. ; if the second piece of IBVALUE is there than we have an
. ; error (need to do something) if not file away.
. ; if the filing was successful we need to set IBREST=1 and quit
. ; otherwise set IBREST="0^give reason for problem
I $P(IBRTYPE,U,2)["BED" D Q IBREST ; price and file the claim
. S IBREST=$$CALCRT("BED",ADMIS,$P(IBRTYPE,U))
;
TYPRATE(X) ; Pass in PTF ien and return either DRG or Bedsection or ERROR
; see if PTF has a DRG
I '$G(X) S TYPE="0^Parameter passed into TYPRATE(X) has no value" Q TYPE
N IBPTF,IBPTFD,DIC,DA,DR,DIQ,IBDISCH,IBBED
S DIC="^DGPT(",DA=X,DR=".01;71;9",DIQ="IBPTF",DIQ(0)="I" D EN^DIQ1
K DIQ(0) S DIQ="IBPTFD" D EN^DIQ1 ; i need the computed drg value
I '$D(IBPTF),('$D(IBPTFD)) S TYPE="0^Could not find PTF RECORD" Q TYPE
I $G(IBPTFD(45,DA,9))="",$G(IBPTF(45,DA,71,"I"))="" S TYPE="0^Could not find a PTF RECORD" Q TYPE
S DISSPEC=$G(IBPTF(45,DA,71,"I")) ; used in $$calc when calculating outliers
; Below if i have a drg and the drg can be priced SELECT drg
I $G(IBPTFD(45,DA,9)),+$$INPT^IBATCM(IBPTFD(45,DA,9),IBADMDT) S TYPE=$G(IBPTFD(45,DA,9))_U_"DRG"
E D
. S IBDISCH=$G(IBPTF(45,DA,71,"I")) ;gives you the discharge speciality
. S IBBED=$P($G(^DIC(42.4,+IBDISCH,0)),U,5) ; Bedsection 399.1
. S TYPE=IBBED_U_"BED"
Q TYPE
;
CALCRT(Z,Y,V,R) ; Calculate LOS, and price out claim.
; INPUT:
; Z = a string either "BED" or "DRG"
; Y = ien for the admission movement
; V = value either bedsection NAME or the drg NUMBER
; R = used only with DRG and it is the dollar value of the drg.
; OUTPUT:
; IBCALC=" if 0^ 2nd piece is error message
; if 1^ there are 2 possible options that can be returned
; Option 1 - If we are calculating a Bed Section
; 1^calculated amount^"B"
; Option 2 - If we are calculating a DRG
; 1^calculated amt^ien drg^los^hightrim^outlier days
; ^bedsection rate for the outliers
;
N X,IBBEDPTR,IBLOS,IBDATE,CALCDATE,DRGHIGH,IBBEDRT,IBDIFF,IBBED,IBOUTDT,IBBEDRT,DGPMIFN
I '$D(Z)!('$D(V))!($G(Y)<1) S IBCALC="0^parameter 'Z' is invalid" Q IBCALC
S IBCALC=0 I Z'="DRG"&(Z'="BED") S IBCALC="0^parameter is incorrect" Q IBCALC
; calculate the LOS Y=ien for the admission movement
I '$D(^DGPM(+Y,0)) S IBCALC="0^ien "_Y_" in 405 does not exist" Q IBCALC
I Z["DRG",($G(R)<1) S IBCALC="0^the drg dollar value for ien "_Y_" was not passed in" Q IBCALC
S DGPMIFN=Y D ^DGPMLOS
I $P(X,U,5)<1 S IBCALC="0^no LOS found FOR movement "_Y Q IBCALC
E S IBLOS=$P(X,U,5)
S IBDATE=$P($P($G(^DGPM(+Y,0)),U),".") ; Date of patient movement
I Z="BED" D Q IBCALC
. ;get the pointer to the bedsection
. S IBBEDPTR=$$MCCRUTL^IBCRU1(V,5) ; 5 distinguishes bedsection in 399.1
. I IBBEDPTR<1 S IBCALC="0^could not find pointer to bedsection for name: "_V Q
. S CALCDATE=IBDATE
. ; below 1=ien to the charge set = TL-INPT(INCLUSIVE) #363.3
. S IBCALC=$$ITCHG^IBCRCI(1,IBBEDPTR,CALCDATE)
. S IBCALC=$P(IBCALC,U)
. S IBCALC=$S(IBCALC<1:"0^No rate found for bedsect "_Y,1:IBCALC)
. I IBCALC<1 Q
. S IBCALC="1^"_(IBLOS*(IBCALC*.8))_U_"B"
;
; (***** calculate DRG outliers here ******)
I Z="DRG" D Q IBCALC
. ; do look up calculate drg value
. S DRGHIGH=$P($$DRG^IBACSV(+V,IBDATE),U,4)
. S IBDIFF=$S(DRGHIGH:IBLOS-DRGHIGH,1:0)
. S IBCALC=R ;==DRG is calculated for the entire los except when there are high trim days
. ; if you have an outlier and you have a bedsection calc outlier
. ; disspec is the ptr to speciality from ptf set in $$typrate
. I IBDIFF>0,(DISSPEC>0) D
. . ; DISSPEC ;gives you the discharge speciality
. . S IBBED=$P($G(^DIC(42.4,+DISSPEC,0)),U,5) ; Name of Bedsection 399.1
. . S IBBEDPTR=$$MCCRUTL^IBCRU1(IBBED,5) ; Ptr to bedsection
. . S IBOUTDT=$P($G(^DGPM(+Y,0)),U)
. . S IBBEDRT=$$ITCHG^IBCRCI(1,IBBEDPTR,IBOUTDT) ; returns rate for bedsection
. . S IBBEDRT=$P(IBBEDRT,U)
. . I IBBEDRT>0 S IBBEDRT=(IBBEDRT*.8) ;**BGA-MOD 2/9/2000
. 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)
. ; All bedsections,drgs and outliers are calculated at 80% of there face value
Q IBCALC
;
END ;
W !,"Updating Transfer Pricing has been...completed."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBATEI 8589 printed Apr 09, 2024@21:18:29 Page 2
IBATEI ;ALB/BGA - TRANSFER PRICING INPATIENT TRACKER ; 02-FEB-99
+1 ;;2.0;INTEGRATED BILLING;**115,210**;21-MAR-94
+2 ;; Per VHA Directive 10-93-142, this routine should not be modified
+3 ;
+4 ; This routine is called from ^IBAMTD and tracks all patient movements
+5 ; as they relate to patients who are out of network.
+6 ;
EN ; Main Entry Point
+1 ; transfer pricing turned off
IF '$PIECE($GET(^IBE(350.9,1,10)),"^",2)
QUIT
+2 IF $GET(DGPMA)=""
IF $GET(DGPMP)=""
QUIT
+3 NEW DFN,IBATIEN,DA,IBRTYPE,TYPE,IBA,IBIND,IBPTF,IBDISDT,IBDISPT,IBATFILE
+4 NEW IBADMDT,IBSOURCE,IBPREF,PTF,ADMIS,IBDFN,IBREST
+5 ; iba ptr to the admission
SET IBA=$PIECE($SELECT(DGPMA="":DGPMP,1:DGPMA),U,14)
if IBA<1
QUIT
+6 SET IBIND=IBA_";DGPM("
+7 ; $$FINDT checks to see if the entry exist and the entry is not cancelled
+8 SET IBATIEN=$$FINDT^IBATUTL(IBIND)
+9 IF IBATIEN
Begin DoDot:1
+10 SET DFN=$PIECE($GET(^IBAT(351.61,+IBATIEN,0)),U,2)
if DFN<1
QUIT
+11 ; if the MOVEMENT admission was deleted DELETE entry from 351.61
+12 IF DGPMA=""
IF ($PIECE(DGPMP,U,2)=1)
Begin DoDot:2
+13 DO DEL^IBATFILE(IBATIEN)
End DoDot:2
QUIT
+14 ; if the MOVEMENT deleted a discharge reset transaction STATUS="entered"
+15 IF DGPMA=""
IF ($PIECE(DGPMP,U,2)=3)
Begin DoDot:2
+16 SET IBATFILE=$$DISC^IBATFILE(IBATIEN)
End DoDot:2
QUIT
+17 ; if the MOVEMENT is adding a *DISCHARGE* add the event
+18 IF DGPMP=""
IF ($PIECE(DGPMA,U,2)=3)
Begin DoDot:2
+19 ; Look for ptf in the parent event
+20 if '$PIECE(DGPMA,U,14)
QUIT
+21 SET IBPTF=$PIECE($GET(^DGPM($PIECE(DGPMA,U,14),0)),U,16)
if 'IBPTF
QUIT
+22 SET IBDISDT=$PIECE($GET(^DGPT(IBPTF,70)),U)
+23 if IBDISDT']" "
QUIT
+24 SET IBDISPT=$PIECE($GET(^DGPM($PIECE(DGPMA,U,14),0)),U,17)
if 'IBDISPT
QUIT
+25 ; PASS IN=ien 351.61,discharge dt in ptf,discharge movement
+26 SET IBATFILE=$$DIS^IBATFILE(IBATIEN,IBDISDT,IBPTF,IBDISPT)
+27 ; <<end of update existing entry>>
+28 ; [if new admission not currently being tracked added to 351.61]
End DoDot:2
QUIT
End DoDot:1
GOTO END
+29 IF DGPMP=""
IF ($PIECE(DGPMA,U,2)=1)
Begin DoDot:1
+30 ; check to see if this is a tp $$TTP returns '0' if not TP
+31 if '$$TPP^IBATUTL($PIECE(DGPMA,U,3))
QUIT
+32 SET IBADMDT=$PIECE(DGPMA,U)
SET IBSOURCE=$PIECE(DGPMA,U,14)
+33 SET IBPREF=$$PPF^IBATUTL($PIECE(DGPMA,U,3))
if 'IBPREF
QUIT
+34 if IBSOURCE=""!($PIECE(DGPMA,U,14)="")
QUIT
+35 SET IBSOURCE=IBSOURCE_";DGPM("
+36 SET IBATFILE=$$ADM^IBATFILE($PIECE(DGPMA,U,3),IBADMDT,IBPREF,IBSOURCE)
End DoDot:1
GOTO END
+37 ;
+38 ; Case where we have a discharge but the admission was not recorded
+39 IF DGPMP=""
IF ($PIECE(DGPMA,U,2)=3)
Begin DoDot:1
+40 if '$$TPP^IBATUTL($PIECE(DGPMA,U,3))
QUIT
+41 ; add the admission and than add the discharge
+42 SET IBADMDT=$PIECE(DGPMA,U)
SET IBSOURCE=$PIECE(DGPMA,U,14)
+43 SET IBPREF=$$PPF^IBATUTL($PIECE(DGPMA,U,3))
if 'IBPREF
QUIT
+44 if IBSOURCE=""!($PIECE(DGPMA,U,14)="")
QUIT
+45 SET IBSOURCE=IBSOURCE_";DGPM("
+46 SET IBATFILE=$$ADM^IBATFILE($PIECE(DGPMA,U,3),IBADMDT,IBPREF,IBSOURCE)
+47 ; add the discharge
+48 if '$PIECE(DGPMA,U,14)!(IBATFILE<1)
QUIT
+49 SET IBATIEN=+IBATFILE
SET IBPTF=$PIECE($GET(^DGPM($PIECE(DGPMA,U,14),0)),U,16)
if 'IBPTF
QUIT
+50 SET IBDISDT=$PIECE($GET(^DGPT(IBPTF,70)),U)
+51 if IBDISDT']" "
QUIT
+52 SET IBDISPT=$PIECE($GET(^DGPM($PIECE(DGPMA,U,14),0)),U,17)
if 'IBDISPT
QUIT
+53 ; PASS IN=ien 351.61,discharge dt in ptf,discharge movement
+54 SET IBATFILE=$$DIS^IBATFILE(IBATIEN,IBDISDT,IBPTF,IBDISPT)
End DoDot:1
GOTO END
+55 QUIT
+56 ;
FINDRT(PTF,ADMIS,IBDFN) ; Find the Rate
+1 ;
+2 ; Input: PTF=ien to PTF
+3 ; ADMIS=ien to DGPM Patient Movement
+4 ; IBDFN=ien to Patient File
+5 ;
+6 ; Output:
+7 ; IBREST= if 0^ 2nd piece is error message
+8 ; = if 1^ the rate has been calculated.
+9 NEW IBATERR,IBRTYPE,IBADMDT,CHARGE,IBPREF,DISSPEC,TYPE,IBCALC,DRG
+10 IF '$GET(PTF)!('$GET(ADMIS))!('$GET(IBDFN))
SET IBREST="0^Parmeter passed in to FINDRT was less than one"
QUIT IBREST
+11 SET IBATERR=0
SET IBADMDT=$PIECE($PIECE($GET(^DGPM(+ADMIS,0)),U),".")
+12 IF IBADMDT<1
SET IBREST="0^No admission date FOUND for ^dgpm ien="_ADMIS
QUIT IBREST
+13 ; returns bed or drg
SET IBRTYPE=$$TYPRATE(PTF)
+14 ;no DRG or Rate could be found
IF IBRTYPE["Could not find"
QUIT IBRTYPE
+15 IF $PIECE(IBRTYPE,U,2)["DRG"
Begin DoDot:1
+16 SET DRG=$PIECE(IBRTYPE,U)
+17 ; Find the home facility
+18 SET IBPREF=$$PPF^IBATUTL(+IBDFN)
IF 'IBPREF
SET IBREST="0^No home facility found for DFN="_IBDFN
QUIT
+19 ; Pass in DRG the date of the admission, the pref fac. and return
+20 ; CHARGE=1!0^default rate^nego rate^rate to use^tortliability rate
+21 SET CHARGE=$$INPT^IBATCM(DRG,IBADMDT,IBPREF)
+22 IF '$PIECE(CHARGE,U)!$PIECE(CHARGE,U,4)<1
SET IBREST="0^Could not find a valid charge for the DRG"
QUIT
+23 ; Pass in string "DRG",ien 405,DRG, DOLLAR AMOUNT)
+24 SET IBREST=$$CALCRT("DRG",ADMIS,DRG,$PIECE(CHARGE,U,4))
+25 ; if the second piece of IBVALUE is there than we have an
+26 ; error (need to do something) if not file away.
+27 ; if the filing was successful we need to set IBREST=1 and quit
+28 ; otherwise set IBREST="0^give reason for problem
End DoDot:1
QUIT IBREST
+29 ; price and file the claim
IF $PIECE(IBRTYPE,U,2)["BED"
Begin DoDot:1
+30 SET IBREST=$$CALCRT("BED",ADMIS,$PIECE(IBRTYPE,U))
End DoDot:1
QUIT IBREST
+31 ;
TYPRATE(X) ; Pass in PTF ien and return either DRG or Bedsection or ERROR
+1 ; see if PTF has a DRG
+2 IF '$GET(X)
SET TYPE="0^Parameter passed into TYPRATE(X) has no value"
QUIT TYPE
+3 NEW IBPTF,IBPTFD,DIC,DA,DR,DIQ,IBDISCH,IBBED
+4 SET DIC="^DGPT("
SET DA=X
SET DR=".01;71;9"
SET DIQ="IBPTF"
SET DIQ(0)="I"
DO EN^DIQ1
+5 ; i need the computed drg value
KILL DIQ(0)
SET DIQ="IBPTFD"
DO EN^DIQ1
+6 IF '$DATA(IBPTF)
IF ('$DATA(IBPTFD))
SET TYPE="0^Could not find PTF RECORD"
QUIT TYPE
+7 IF $GET(IBPTFD(45,DA,9))=""
IF $GET(IBPTF(45,DA,71,"I"))=""
SET TYPE="0^Could not find a PTF RECORD"
QUIT TYPE
+8 ; used in $$calc when calculating outliers
SET DISSPEC=$GET(IBPTF(45,DA,71,"I"))
+9 ; Below if i have a drg and the drg can be priced SELECT drg
+10 IF $GET(IBPTFD(45,DA,9))
IF +$$INPT^IBATCM(IBPTFD(45,DA,9),IBADMDT)
SET TYPE=$GET(IBPTFD(45,DA,9))_U_"DRG"
+11 IF '$TEST
Begin DoDot:1
+12 ;gives you the discharge speciality
SET IBDISCH=$GET(IBPTF(45,DA,71,"I"))
+13 ; Bedsection 399.1
SET IBBED=$PIECE($GET(^DIC(42.4,+IBDISCH,0)),U,5)
+14 SET TYPE=IBBED_U_"BED"
End DoDot:1
+15 QUIT TYPE
+16 ;
CALCRT(Z,Y,V,R) ; Calculate LOS, and price out claim.
+1 ; INPUT:
+2 ; Z = a string either "BED" or "DRG"
+3 ; Y = ien for the admission movement
+4 ; V = value either bedsection NAME or the drg NUMBER
+5 ; R = used only with DRG and it is the dollar value of the drg.
+6 ; OUTPUT:
+7 ; IBCALC=" if 0^ 2nd piece is error message
+8 ; if 1^ there are 2 possible options that can be returned
+9 ; Option 1 - If we are calculating a Bed Section
+10 ; 1^calculated amount^"B"
+11 ; Option 2 - If we are calculating a DRG
+12 ; 1^calculated amt^ien drg^los^hightrim^outlier days
+13 ; ^bedsection rate for the outliers
+14 ;
+15 NEW X,IBBEDPTR,IBLOS,IBDATE,CALCDATE,DRGHIGH,IBBEDRT,IBDIFF,IBBED,IBOUTDT,IBBEDRT,DGPMIFN
+16 IF '$DATA(Z)!('$DATA(V))!($GET(Y)<1)
SET IBCALC="0^parameter 'Z' is invalid"
QUIT IBCALC
+17 SET IBCALC=0
IF Z'="DRG"&(Z'="BED")
SET IBCALC="0^parameter is incorrect"
QUIT IBCALC
+18 ; calculate the LOS Y=ien for the admission movement
+19 IF '$DATA(^DGPM(+Y,0))
SET IBCALC="0^ien "_Y_" in 405 does not exist"
QUIT IBCALC
+20 IF Z["DRG"
IF ($GET(R)<1)
SET IBCALC="0^the drg dollar value for ien "_Y_" was not passed in"
QUIT IBCALC
+21 SET DGPMIFN=Y
DO ^DGPMLOS
+22 IF $PIECE(X,U,5)<1
SET IBCALC="0^no LOS found FOR movement "_Y
QUIT IBCALC
+23 IF '$TEST
SET IBLOS=$PIECE(X,U,5)
+24 ; Date of patient movement
SET IBDATE=$PIECE($PIECE($GET(^DGPM(+Y,0)),U),".")
+25 IF Z="BED"
Begin DoDot:1
+26 ;get the pointer to the bedsection
+27 ; 5 distinguishes bedsection in 399.1
SET IBBEDPTR=$$MCCRUTL^IBCRU1(V,5)
+28 IF IBBEDPTR<1
SET IBCALC="0^could not find pointer to bedsection for name: "_V
QUIT
+29 SET CALCDATE=IBDATE
+30 ; below 1=ien to the charge set = TL-INPT(INCLUSIVE) #363.3
+31 SET IBCALC=$$ITCHG^IBCRCI(1,IBBEDPTR,CALCDATE)
+32 SET IBCALC=$PIECE(IBCALC,U)
+33 SET IBCALC=$SELECT(IBCALC<1:"0^No rate found for bedsect "_Y,1:IBCALC)
+34 IF IBCALC<1
QUIT
+35 SET IBCALC="1^"_(IBLOS*(IBCALC*.8))_U_"B"
End DoDot:1
QUIT IBCALC
+36 ;
+37 ; (***** calculate DRG outliers here ******)
+38 IF Z="DRG"
Begin DoDot:1
+39 ; do look up calculate drg value
+40 SET DRGHIGH=$PIECE($$DRG^IBACSV(+V,IBDATE),U,4)
+41 SET IBDIFF=$SELECT(DRGHIGH:IBLOS-DRGHIGH,1:0)
+42 ;==DRG is calculated for the entire los except when there are high trim days
SET IBCALC=R
+43 ; if you have an outlier and you have a bedsection calc outlier
+44 ; disspec is the ptr to speciality from ptf set in $$typrate
+45 IF IBDIFF>0
IF (DISSPEC>0)
Begin DoDot:2
+46 ; DISSPEC ;gives you the discharge speciality
+47 ; Name of Bedsection 399.1
SET IBBED=$PIECE($GET(^DIC(42.4,+DISSPEC,0)),U,5)
+48 ; Ptr to bedsection
SET IBBEDPTR=$$MCCRUTL^IBCRU1(IBBED,5)
+49 SET IBOUTDT=$PIECE($GET(^DGPM(+Y,0)),U)
+50 ; returns rate for bedsection
SET IBBEDRT=$$ITCHG^IBCRCI(1,IBBEDPTR,IBOUTDT)
+51 SET IBBEDRT=$PIECE(IBBEDRT,U)
+52 ;**BGA-MOD 2/9/2000
IF IBBEDRT>0
SET IBBEDRT=(IBBEDRT*.8)
End DoDot:2
+53 SET IBCALC="1^"_IBCALC_U_V_U_IBLOS_U_DRGHIGH_U_$SELECT(IBDIFF<1:0,1:IBDIFF)_U_$SELECT($GET(IBBEDRT)>0:IBBEDRT,1:0)
+54 ; All bedsections,drgs and outliers are calculated at 80% of there face value
End DoDot:1
QUIT IBCALC
+55 QUIT IBCALC
+56 ;
END ;
+1 WRITE !,"Updating Transfer Pricing has been...completed."
+2 QUIT
