IBCRU7 ;LL/ELZ - TRANSFER PRICING CHARGE MASTER UTILITIES ; 20-AUG-1999
;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
TPCS(BR,RG) ; finds charge set for billing rate and region
; region in transfer pricing is an institution, not a division
; if RG not passed, looks up national default
;
N BRIFN,CSIFN,X
;
Q:'$D(BR) 0
S BRIFN=$O(^IBE(363.3,"B",BR,0)) Q:'BRIFN 0
;
I $D(RG) S RG=$O(^IBE(363.31,"AB",RG,0)) Q:'RG 0
;
S (X,CSIFN)=0 F S CSIFN=$O(^IBE(363.1,"C",BRIFN,CSIFN)) Q:'CSIFN!(X) I $P(^IBE(363.1,CSIFN,0),U,7)=$G(RG) S X=CSIFN
Q X
;
DISPCS(IBCSFN) ; display charge set data ** copy of same entry from IBCRU5 with items left off
N IBCS0,IBBR0,IBRVCD,IBX S IBCSFN=+$G(IBCSFN)
S IBCS0=$G(^IBE(363.1,IBCSFN,0)),IBBR0=$G(^IBE(363.3,+$P(IBCS0,U,2),0)),IBRVCD=$G(^DGCR(399.2,+$P(IBCS0,U,5),0))
;
W !!!,?4,"Charge Set: ",?19,$E($P(IBCS0,U,1),1,30)
I +$P(IBCS0,U,4) W ?49,"Charge Type: ",?65,$$EXPAND^IBCRU1(363.1,.04,+$P(IBCS0,U,4))
W !,?4,"Billing Event: ",?19,$E($$EMUTL^IBCRU1($P(IBCS0,U,3),1),1,28)
W !,?4,"Billing Rate: ",?19,$E($P(IBBR0,U,1),1,28)
I +$P(IBCS0,U,7) S IBX=$$RGEXT^IBCRU4(+$P(IBCS0,U,7)) I IBX'="" W !,?4,"Region: ",?19,$P(IBX,U,1)
I +$P(IBBR0,U,4) W !,?4,"All items billable to the ",$P(IBBR0,U,2)," Billing Rate must be ",$$EXPAND^IBCRU1(363.3,.04,+$P(IBBR0,U,4)),"s.",!!
I '$P(IBBR0,U,4) W !,?4,"The ",$P(IBBR0,U,2)," Billing Rate charges are calculated, there are no Charge Items.",!!
Q
;
DISPCSL(IBCSFN) ; display one line of charge set data ** copy of same entry from IBCRU5 with items left off
N IBCS0 I '$G(IBCSFN) Q
S IBCS0=$G(^IBE(363.1,IBCSFN,0))
I IBCS0'="" W !!,?4,"Set: ",$E($P(IBCS0,U,1),1,30)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRU7 1768 printed Oct 16, 2024@18:20:41 Page 2
IBCRU7 ;LL/ELZ - TRANSFER PRICING CHARGE MASTER UTILITIES ; 20-AUG-1999
+1 ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
TPCS(BR,RG) ; finds charge set for billing rate and region
+1 ; region in transfer pricing is an institution, not a division
+2 ; if RG not passed, looks up national default
+3 ;
+4 NEW BRIFN,CSIFN,X
+5 ;
+6 if '$DATA(BR)
QUIT 0
+7 SET BRIFN=$ORDER(^IBE(363.3,"B",BR,0))
if 'BRIFN
QUIT 0
+8 ;
+9 IF $DATA(RG)
SET RG=$ORDER(^IBE(363.31,"AB",RG,0))
if 'RG
QUIT 0
+10 ;
+11 SET (X,CSIFN)=0
FOR
SET CSIFN=$ORDER(^IBE(363.1,"C",BRIFN,CSIFN))
if 'CSIFN!(X)
QUIT
IF $PIECE(^IBE(363.1,CSIFN,0),U,7)=$GET(RG)
SET X=CSIFN
+12 QUIT X
+13 ;
DISPCS(IBCSFN) ; display charge set data ** copy of same entry from IBCRU5 with items left off
+1 NEW IBCS0,IBBR0,IBRVCD,IBX
SET IBCSFN=+$GET(IBCSFN)
+2 SET IBCS0=$GET(^IBE(363.1,IBCSFN,0))
SET IBBR0=$GET(^IBE(363.3,+$PIECE(IBCS0,U,2),0))
SET IBRVCD=$GET(^DGCR(399.2,+$PIECE(IBCS0,U,5),0))
+3 ;
+4 WRITE !!!,?4,"Charge Set: ",?19,$EXTRACT($PIECE(IBCS0,U,1),1,30)
+5 IF +$PIECE(IBCS0,U,4)
WRITE ?49,"Charge Type: ",?65,$$EXPAND^IBCRU1(363.1,.04,+$PIECE(IBCS0,U,4))
+6 WRITE !,?4,"Billing Event: ",?19,$EXTRACT($$EMUTL^IBCRU1($PIECE(IBCS0,U,3),1),1,28)
+7 WRITE !,?4,"Billing Rate: ",?19,$EXTRACT($PIECE(IBBR0,U,1),1,28)
+8 IF +$PIECE(IBCS0,U,7)
SET IBX=$$RGEXT^IBCRU4(+$PIECE(IBCS0,U,7))
IF IBX'=""
WRITE !,?4,"Region: ",?19,$PIECE(IBX,U,1)
+9 IF +$PIECE(IBBR0,U,4)
WRITE !,?4,"All items billable to the ",$PIECE(IBBR0,U,2)," Billing Rate must be ",$$EXPAND^IBCRU1(363.3,.04,+$PIECE(IBBR0,U,4)),"s.",!!
+10 IF '$PIECE(IBBR0,U,4)
WRITE !,?4,"The ",$PIECE(IBBR0,U,2)," Billing Rate charges are calculated, there are no Charge Items.",!!
+11 QUIT
+12 ;
DISPCSL(IBCSFN) ; display one line of charge set data ** copy of same entry from IBCRU5 with items left off
+1 NEW IBCS0
IF '$GET(IBCSFN)
QUIT
+2 SET IBCS0=$GET(^IBE(363.1,IBCSFN,0))
+3 IF IBCS0'=""
WRITE !!,?4,"Set: ",$EXTRACT($PIECE(IBCS0,U,1),1,30)
+4 QUIT
+5 ;
