IBCRU3 ;ALB/ARH - RATES: UTILITIES (CS/BR) ;22-MAY-1996
;;2.0;INTEGRATED BILLING;**52,106,223**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
CSN(N) ; returns the IFN of the Charge Set name passed in
N X S X="" I $G(N)'="" S X=$O(^IBE(363.1,"B",N,0))
Q X
;
CSBI(CS) ; returns a Charge Set rates Billable Item (363.3,.04): 0 or BI ^ bi name
N IBX,IBCS0,IBBI S IBX=0
S IBCS0=$G(^IBE(363.1,+$G(CS),0)),IBBI=$P($G(^IBE(363.3,+$P(IBCS0,U,2),0)),U,4)
I +IBBI S IBX=IBBI_U_$$EXPAND^IBCRU1(363.3,.04,IBBI)
Q IBX
;
CSBR(CS) ; return data on a charge set: billable event ^ BE IFN ^ billing rate IFN ^ billable item ^ charge method
N IBBRFN,IBBEVNT,IBLN1,IBLN,IBX S IBX=""
S IBLN=$G(^IBE(363.1,+$G(CS),0)),IBBRFN=+$P(IBLN,U,2),IBBEVNT=$$EMUTL^IBCRU1($P(IBLN,U,3))
S IBLN1=$G(^IBE(363.3,IBBRFN,0))
I IBLN'="" S IBX=IBBEVNT_U_$P(IBLN,U,3)_U_IBBRFN_U_$P(IBLN1,U,4)_U_$P(IBLN1,U,5)
Q IBX
;
CSDV(CS,DIV,DDIV) ; check if the division is covered by this charge set
; "" if - Charge Set has no region defined (ie. covers all divisions)
; div if - division passed in and it is one of the divisions of the region defined for the Charge Set
; - no division but default division is one of the divisions of the region defined for the Set
; -1 - otherwise: division not covered by CS
;
N IBX,IBCS0,IBRGFN S IBX=-1,DIV=$G(DIV),DDIV=$G(DDIV)
S IBCS0=$G(^IBE(363.1,+$G(CS),0)),IBRGFN=$P(IBCS0,U,7) I IBCS0="" G CSDVQ
;
I 'IBRGFN S IBX="" G CSDVQ
I +IBRGFN,+DIV,$D(^IBE(363.31,+IBRGFN,11,"B",DIV)) S IBX=DIV G CSDVQ
I +IBRGFN,'DIV,+DDIV,$D(^IBE(363.31,+IBRGFN,11,"B",DDIV)) S IBX=DDIV G CSDVQ
;
CSDVQ Q IBX
;
RT(RT,BT,EFDT,ARR,BE,CT) ; return array of all rate schedules and charge sets for a rate type and bill type and date
; EFDT may be passed as 'begin dt^end dt' to get CSs active within a date range, like a bill's date range
; output ARR = number of rate schedule-charge set combinations found
; ARR(rate sched IFN,charge set IFN) = 1 if charges for set are auto added
N IBBEG,IBEND,IBRSFN,IBRS0,IBCSI,IBBE,IBLN,IBAA K ARR S ARR=0,IBBE=""
S RT=$G(RT),BT=$G(BT),EFDT=$G(EFDT),CT=$G(CT) I +BT S BT=$S(BT<3:1,1:3)
S (IBBEG,IBEND)="" S IBBEG=+EFDT,IBEND=$S(+$P(EFDT,U,2):+$P(EFDT,U,2),1:IBBEG)
I $G(BE)'="" S:+BE BE=$$EMUTL^IBCRU1(BE) S IBBE=$$MCCRUTL^IBCRU1(BE,14)
I IBBE'=0 S IBRSFN=0 F S IBRSFN=$O(^IBE(363,"ARB",+RT,+BT,IBRSFN)) Q:'IBRSFN D
. S IBRS0=$G(^IBE(363,+IBRSFN,0)) I +EFDT I (+$P(IBRS0,U,5)>IBEND)!(+$P(IBRS0,U,6)&(+$P(IBRS0,U,6)<IBBEG)) Q
. S IBCSI=0 F S IBCSI=$O(^IBE(363,IBRSFN,11,IBCSI)) Q:'IBCSI D
.. S IBLN=$G(^IBE(363,IBRSFN,11,IBCSI,0)) Q:'IBLN
.. S IBAA=$P(IBLN,U,2)
.. I +IBBE,+$P($G(^IBE(363.1,+IBLN,0)),U,3)'=IBBE Q
.. I +CT,+$P($G(^IBE(363.1,+IBLN,0)),U,4)'=CT S IBAA=""
.. S ARR=ARR+1,ARR(IBRSFN,+IBLN)=IBAA
Q
;
BILLRATE(RT,BT,EVDT,FNDRATE) ; return true if the bill is a FND rate bill
; - one of the auto add Charge Sets must be a FND Billing Rate
N IBRS,IBCS,IBCS0,IBBR0,IBFND,IBRSARR S IBFND=0
;
D RT(+$G(RT),+$G(BT),$G(EVDT),.IBRSARR)
;
I $G(FNDRATE)'="" S IBRS=0 F S IBRS=$O(IBRSARR(IBRS)) Q:'IBRS D Q:IBFND
. S IBCS=0 F S IBCS=$O(IBRSARR(IBRS,IBCS)) Q:'IBCS I +IBRSARR(IBRS,IBCS) D Q:IBFND
.. S IBCS0=$G(^IBE(363.1,IBCS,0)),IBBR0=$G(^IBE(363.3,+$P(IBCS0,U,2),0))
.. I $P(IBBR0,U,1)[FNDRATE S IBFND=1
;
Q IBFND
;
PERDIEM(RT,BT,EVDT) ; return true (BR ifn) if the charges for the rate and bill type are perdiem charges
; - one of the auto add Charge Sets (except RX or Pros) must be either Tort Liable or Interagency
N IBRS,IBCS,IBCS0,IBBEVNT,IBBR,IBBRN,IBFND,IBRSARR S IBFND=0
;
D RT(+$G(RT),+$G(BT),$G(EVDT),.IBRSARR)
;
S IBRS=0 F S IBRS=$O(IBRSARR(IBRS)) Q:'IBRS D Q:IBFND
. S IBCS=0 F S IBCS=$O(IBRSARR(IBRS,IBCS)) Q:'IBCS I +IBRSARR(IBRS,IBCS) D Q:IBFND
.. S IBCS0=$G(^IBE(363.1,IBCS,0)),IBBR=+$P(IBCS0,U,2),IBBRN=$P($G(^IBE(363.3,+IBBR,0)),U,1)
.. S IBBEVNT=$$EMUTL^IBCRU1(+$P(IBCS0,U,3)) I (IBBEVNT["PRESCRIPTION")!(IBBEVNT["PROSTHETICS") Q
.. I (IBBRN["TORTIOUSLY LIABLE")!(IBBRN["INTERAGENCY") S IBFND=IBBR
;
Q IBFND
;
EVNTITM(RT,BT,BE,EFDT,ARR) ; return the billable item (363.3, .04) for a particular Rate Type and Billable Event (399.1) auto added
; EFDT may be passed as 'begin dt^end dt' to get CSs active within a date range, like a bill's date range
; returns: string of billing items (code;name;quantity) separated by ^ (3;NDC #;3^1;BEDSECTION;1)
; for VA Cost, code = 'VA COST' so returns 'VA COST;VA COST;2'
; output (if ARR passed by reference): ARR(billable item code, rate sched IFN, charge set IFN)=""
N IBRS,IBCS,IBRSARR,IBCS0,IBBR0,IBBI,IBFND K ARR S IBFND=""
;
I $G(BE)'="" D RT(+$G(RT),+$G(BT),$G(EFDT),.IBRSARR,$G(BE))
;
S IBRS=0 F S IBRS=$O(IBRSARR(IBRS)) Q:'IBRS D
. S IBCS=0 F S IBCS=$O(IBRSARR(IBRS,IBCS)) Q:'IBCS I +IBRSARR(IBRS,IBCS) D
.. S IBCS0=$G(^IBE(363.1,IBCS,0)),IBBR0=$G(^IBE(363.3,+$P(IBCS0,U,2),0))
.. S IBBI=$P(IBBR0,U,4) I IBBI="",$P(IBBR0,U,5)=2 S IBBI=$P(IBBR0,U,1)
.. I IBBI'="" S IBFND=IBFND_IBBI_";"_$$EXPAND^IBCRU1(363.3,.04,IBBI)_";"_$P(IBBR0,U,5)_U,ARR(IBBI,IBRS,IBCS)=""
Q IBFND
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRU3 5210 printed Dec 13, 2024@02:19:58 Page 2
IBCRU3 ;ALB/ARH - RATES: UTILITIES (CS/BR) ;22-MAY-1996
+1 ;;2.0;INTEGRATED BILLING;**52,106,223**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
CSN(N) ; returns the IFN of the Charge Set name passed in
+1 NEW X
SET X=""
IF $GET(N)'=""
SET X=$ORDER(^IBE(363.1,"B",N,0))
+2 QUIT X
+3 ;
CSBI(CS) ; returns a Charge Set rates Billable Item (363.3,.04): 0 or BI ^ bi name
+1 NEW IBX,IBCS0,IBBI
SET IBX=0
+2 SET IBCS0=$GET(^IBE(363.1,+$GET(CS),0))
SET IBBI=$PIECE($GET(^IBE(363.3,+$PIECE(IBCS0,U,2),0)),U,4)
+3 IF +IBBI
SET IBX=IBBI_U_$$EXPAND^IBCRU1(363.3,.04,IBBI)
+4 QUIT IBX
+5 ;
CSBR(CS) ; return data on a charge set: billable event ^ BE IFN ^ billing rate IFN ^ billable item ^ charge method
+1 NEW IBBRFN,IBBEVNT,IBLN1,IBLN,IBX
SET IBX=""
+2 SET IBLN=$GET(^IBE(363.1,+$GET(CS),0))
SET IBBRFN=+$PIECE(IBLN,U,2)
SET IBBEVNT=$$EMUTL^IBCRU1($PIECE(IBLN,U,3))
+3 SET IBLN1=$GET(^IBE(363.3,IBBRFN,0))
+4 IF IBLN'=""
SET IBX=IBBEVNT_U_$PIECE(IBLN,U,3)_U_IBBRFN_U_$PIECE(IBLN1,U,4)_U_$PIECE(IBLN1,U,5)
+5 QUIT IBX
+6 ;
CSDV(CS,DIV,DDIV) ; check if the division is covered by this charge set
+1 ; "" if - Charge Set has no region defined (ie. covers all divisions)
+2 ; div if - division passed in and it is one of the divisions of the region defined for the Charge Set
+3 ; - no division but default division is one of the divisions of the region defined for the Set
+4 ; -1 - otherwise: division not covered by CS
+5 ;
+6 NEW IBX,IBCS0,IBRGFN
SET IBX=-1
SET DIV=$GET(DIV)
SET DDIV=$GET(DDIV)
+7 SET IBCS0=$GET(^IBE(363.1,+$GET(CS),0))
SET IBRGFN=$PIECE(IBCS0,U,7)
IF IBCS0=""
GOTO CSDVQ
+8 ;
+9 IF 'IBRGFN
SET IBX=""
GOTO CSDVQ
+10 IF +IBRGFN
IF +DIV
IF $DATA(^IBE(363.31,+IBRGFN,11,"B",DIV))
SET IBX=DIV
GOTO CSDVQ
+11 IF +IBRGFN
IF 'DIV
IF +DDIV
IF $DATA(^IBE(363.31,+IBRGFN,11,"B",DDIV))
SET IBX=DDIV
GOTO CSDVQ
+12 ;
CSDVQ QUIT IBX
+1 ;
RT(RT,BT,EFDT,ARR,BE,CT) ; return array of all rate schedules and charge sets for a rate type and bill type and date
+1 ; EFDT may be passed as 'begin dt^end dt' to get CSs active within a date range, like a bill's date range
+2 ; output ARR = number of rate schedule-charge set combinations found
+3 ; ARR(rate sched IFN,charge set IFN) = 1 if charges for set are auto added
+4 NEW IBBEG,IBEND,IBRSFN,IBRS0,IBCSI,IBBE,IBLN,IBAA
KILL ARR
SET ARR=0
SET IBBE=""
+5 SET RT=$GET(RT)
SET BT=$GET(BT)
SET EFDT=$GET(EFDT)
SET CT=$GET(CT)
IF +BT
SET BT=$SELECT(BT<3:1,1:3)
+6 SET (IBBEG,IBEND)=""
SET IBBEG=+EFDT
SET IBEND=$SELECT(+$PIECE(EFDT,U,2):+$PIECE(EFDT,U,2),1:IBBEG)
+7 IF $GET(BE)'=""
if +BE
SET BE=$$EMUTL^IBCRU1(BE)
SET IBBE=$$MCCRUTL^IBCRU1(BE,14)
+8 IF IBBE'=0
SET IBRSFN=0
FOR
SET IBRSFN=$ORDER(^IBE(363,"ARB",+RT,+BT,IBRSFN))
if 'IBRSFN
QUIT
Begin DoDot:1
+9 SET IBRS0=$GET(^IBE(363,+IBRSFN,0))
IF +EFDT
IF (+$PIECE(IBRS0,U,5)>IBEND)!(+$PIECE(IBRS0,U,6)&(+$PIECE(IBRS0,U,6)<IBBEG))
QUIT
+10 SET IBCSI=0
FOR
SET IBCSI=$ORDER(^IBE(363,IBRSFN,11,IBCSI))
if 'IBCSI
QUIT
Begin DoDot:2
+11 SET IBLN=$GET(^IBE(363,IBRSFN,11,IBCSI,0))
if 'IBLN
QUIT
+12 SET IBAA=$PIECE(IBLN,U,2)
+13 IF +IBBE
IF +$PIECE($GET(^IBE(363.1,+IBLN,0)),U,3)'=IBBE
QUIT
+14 IF +CT
IF +$PIECE($GET(^IBE(363.1,+IBLN,0)),U,4)'=CT
SET IBAA=""
+15 SET ARR=ARR+1
SET ARR(IBRSFN,+IBLN)=IBAA
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
BILLRATE(RT,BT,EVDT,FNDRATE) ; return true if the bill is a FND rate bill
+1 ; - one of the auto add Charge Sets must be a FND Billing Rate
+2 NEW IBRS,IBCS,IBCS0,IBBR0,IBFND,IBRSARR
SET IBFND=0
+3 ;
+4 DO RT(+$GET(RT),+$GET(BT),$GET(EVDT),.IBRSARR)
+5 ;
+6 IF $GET(FNDRATE)'=""
SET IBRS=0
FOR
SET IBRS=$ORDER(IBRSARR(IBRS))
if 'IBRS
QUIT
Begin DoDot:1
+7 SET IBCS=0
FOR
SET IBCS=$ORDER(IBRSARR(IBRS,IBCS))
if 'IBCS
QUIT
IF +IBRSARR(IBRS,IBCS)
Begin DoDot:2
+8 SET IBCS0=$GET(^IBE(363.1,IBCS,0))
SET IBBR0=$GET(^IBE(363.3,+$PIECE(IBCS0,U,2),0))
+9 IF $PIECE(IBBR0,U,1)[FNDRATE
SET IBFND=1
End DoDot:2
if IBFND
QUIT
End DoDot:1
if IBFND
QUIT
+10 ;
+11 QUIT IBFND
+12 ;
PERDIEM(RT,BT,EVDT) ; return true (BR ifn) if the charges for the rate and bill type are perdiem charges
+1 ; - one of the auto add Charge Sets (except RX or Pros) must be either Tort Liable or Interagency
+2 NEW IBRS,IBCS,IBCS0,IBBEVNT,IBBR,IBBRN,IBFND,IBRSARR
SET IBFND=0
+3 ;
+4 DO RT(+$GET(RT),+$GET(BT),$GET(EVDT),.IBRSARR)
+5 ;
+6 SET IBRS=0
FOR
SET IBRS=$ORDER(IBRSARR(IBRS))
if 'IBRS
QUIT
Begin DoDot:1
+7 SET IBCS=0
FOR
SET IBCS=$ORDER(IBRSARR(IBRS,IBCS))
if 'IBCS
QUIT
IF +IBRSARR(IBRS,IBCS)
Begin DoDot:2
+8 SET IBCS0=$GET(^IBE(363.1,IBCS,0))
SET IBBR=+$PIECE(IBCS0,U,2)
SET IBBRN=$PIECE($GET(^IBE(363.3,+IBBR,0)),U,1)
+9 SET IBBEVNT=$$EMUTL^IBCRU1(+$PIECE(IBCS0,U,3))
IF (IBBEVNT["PRESCRIPTION")!(IBBEVNT["PROSTHETICS")
QUIT
+10 IF (IBBRN["TORTIOUSLY LIABLE")!(IBBRN["INTERAGENCY")
SET IBFND=IBBR
End DoDot:2
if IBFND
QUIT
End DoDot:1
if IBFND
QUIT
+11 ;
+12 QUIT IBFND
+13 ;
EVNTITM(RT,BT,BE,EFDT,ARR) ; return the billable item (363.3, .04) for a particular Rate Type and Billable Event (399.1) auto added
+1 ; EFDT may be passed as 'begin dt^end dt' to get CSs active within a date range, like a bill's date range
+2 ; returns: string of billing items (code;name;quantity) separated by ^ (3;NDC #;3^1;BEDSECTION;1)
+3 ; for VA Cost, code = 'VA COST' so returns 'VA COST;VA COST;2'
+4 ; output (if ARR passed by reference): ARR(billable item code, rate sched IFN, charge set IFN)=""
+5 NEW IBRS,IBCS,IBRSARR,IBCS0,IBBR0,IBBI,IBFND
KILL ARR
SET IBFND=""
+6 ;
+7 IF $GET(BE)'=""
DO RT(+$GET(RT),+$GET(BT),$GET(EFDT),.IBRSARR,$GET(BE))
+8 ;
+9 SET IBRS=0
FOR
SET IBRS=$ORDER(IBRSARR(IBRS))
if 'IBRS
QUIT
Begin DoDot:1
+10 SET IBCS=0
FOR
SET IBCS=$ORDER(IBRSARR(IBRS,IBCS))
if 'IBCS
QUIT
IF +IBRSARR(IBRS,IBCS)
Begin DoDot:2
+11 SET IBCS0=$GET(^IBE(363.1,IBCS,0))
SET IBBR0=$GET(^IBE(363.3,+$PIECE(IBCS0,U,2),0))
+12 SET IBBI=$PIECE(IBBR0,U,4)
IF IBBI=""
IF $PIECE(IBBR0,U,5)=2
SET IBBI=$PIECE(IBBR0,U,1)
+13 IF IBBI'=""
SET IBFND=IBFND_IBBI_";"_$$EXPAND^IBCRU1(363.3,.04,IBBI)_";"_$PIECE(IBBR0,U,5)_U
SET ARR(IBBI,IBRS,IBCS)=""
End DoDot:2
End DoDot:1
+14 QUIT IBFND
