- 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 Mar 13, 2025@21:25 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 ;
