- 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 Jan 18, 2025@03:21:10 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