- IBCRBH2 ;ALB/ARH - RATES: BILL HELP DISPLAYS - CPT CHARGES ; 01-OCT-03
- ;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;
- BCPTCHG(IBIFN) ; select a CPT code and display potential charges for a specific bill
- N IB0,IBU,IBBDV,IBCPT,IBCPTN,IBCPT1,IBRS,IBCS,IBCSN,IBEVDT,IBCI,IBLN,IBEFFDT,IBRVCD,IBCHGB,IBFND,CHGARR,ARRCS,DONEARR,IBX
- ;
- S IB0=$G(^DGCR(399,+$G(IBIFN),0)) Q:IB0=""
- S IBU=$G(^DGCR(399,+$G(IBIFN),"U")) Q:'IBU
- S IBBDV=$P(IB0,U,22)
- ;
- W @IOF,!,"Search for Procedure Charges for " I +IBBDV S IBX=$G(^DG(40.8,+IBBDV,0)) W $P(IBX,U,2)," - ",$P(IBX,U,1)
- W !,"--------------------------------------------------------------------------------",!
- ;
- D RT^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IBU,U,1,2),.ARRCS,"PROCEDURE")
- I '$O(ARRCS(0)) W !,"No Rate Schedules with Procedure charges assigned to this bill.",! H 2 Q
- ;
- F S IBCPT=$$GETCPT^IBCRU1() Q:+IBCPT<1 S IBCPTN=$P(IBCPT,U,1),IBCPT=$P(IBCPT,U,2) W ! D
- . ;
- . S IBRS=0 F S IBRS=$O(ARRCS(IBRS)) Q:'IBRS S IBFND=0 D I +IBFND W !
- .. S IBCS=0 F S IBCS=$O(ARRCS(IBRS,IBCS)) Q:'IBCS I +ARRCS(IBRS,IBCS) D K DONEARR
- ... S IBCSN=$P($G(^IBE(363.1,+IBCS,0)),U,1)
- ... ;
- ... I $$CSDV^IBCRU3(IBCS,IBBDV)<0 Q ; check division
- ... ;
- ... F IBEVDT=+IBU,+$P(IBU,U,2) I +$$FNDCI^IBCRU4(IBCS,IBCPTN,IBEVDT,.CHGARR) D K CHGARR
- .... ;
- .... S IBCI=0 F S IBCI=$O(CHGARR(IBCI)) Q:'IBCI I '$D(DONEARR(IBCI)) D
- ..... S IBLN=CHGARR(IBCI),DONEARR(IBCI)="",IBFND=1
- ..... S IBEFFDT=$$FMTE^XLFDT(+$P(IBLN,U,3),2)
- ..... S IBCPT1=IBCPT I +$P(IBLN,U,7) S IBCPT1=IBCPT1_"-"_$P($$MOD^ICPTMOD(+$P(IBLN,U,7),"I",IBEFFDT),U,2)
- ..... S IBRVCD=$$RVCPT^IBCROI(+$P(IBLN,U,6),+$P(IBLN,U,1),+$P(IBLN,U,2))
- ..... S IBCHGB="" I +$P(IBLN,U,8) S IBCHGB="+"_$J($P(IBLN,U,8),0,2)
- ..... ;
- ..... W !,?4,IBCPT1,?15,IBEFFDT,?26,IBCSN,?55,$J($P(IBLN,U,5),10,2),IBCHGB,?75,IBRVCD
- . I 'IBFND W ?60,"no charge found...",!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCRBH2 1960 printed Mar 13, 2025@21:23:53 Page 2
- IBCRBH2 ;ALB/ARH - RATES: BILL HELP DISPLAYS - CPT CHARGES ; 01-OCT-03
- +1 ;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- +4 ;
- BCPTCHG(IBIFN) ; select a CPT code and display potential charges for a specific bill
- +1 NEW IB0,IBU,IBBDV,IBCPT,IBCPTN,IBCPT1,IBRS,IBCS,IBCSN,IBEVDT,IBCI,IBLN,IBEFFDT,IBRVCD,IBCHGB,IBFND,CHGARR,ARRCS,DONEARR,IBX
- +2 ;
- +3 SET IB0=$GET(^DGCR(399,+$GET(IBIFN),0))
- if IB0=""
- QUIT
- +4 SET IBU=$GET(^DGCR(399,+$GET(IBIFN),"U"))
- if 'IBU
- QUIT
- +5 SET IBBDV=$PIECE(IB0,U,22)
- +6 ;
- +7 WRITE @IOF,!,"Search for Procedure Charges for "
- IF +IBBDV
- SET IBX=$GET(^DG(40.8,+IBBDV,0))
- WRITE $PIECE(IBX,U,2)," - ",$PIECE(IBX,U,1)
- +8 WRITE !,"--------------------------------------------------------------------------------",!
- +9 ;
- +10 DO RT^IBCRU3($PIECE(IB0,U,7),$PIECE(IB0,U,5),$PIECE(IBU,U,1,2),.ARRCS,"PROCEDURE")
- +11 IF '$ORDER(ARRCS(0))
- WRITE !,"No Rate Schedules with Procedure charges assigned to this bill.",!
- HANG 2
- QUIT
- +12 ;
- +13 FOR
- SET IBCPT=$$GETCPT^IBCRU1()
- if +IBCPT<1
- QUIT
- SET IBCPTN=$PIECE(IBCPT,U,1)
- SET IBCPT=$PIECE(IBCPT,U,2)
- WRITE !
- Begin DoDot:1
- +14 ;
- +15 SET IBRS=0
- FOR
- SET IBRS=$ORDER(ARRCS(IBRS))
- if 'IBRS
- QUIT
- SET IBFND=0
- Begin DoDot:2
- +16 SET IBCS=0
- FOR
- SET IBCS=$ORDER(ARRCS(IBRS,IBCS))
- if 'IBCS
- QUIT
- IF +ARRCS(IBRS,IBCS)
- Begin DoDot:3
- +17 SET IBCSN=$PIECE($GET(^IBE(363.1,+IBCS,0)),U,1)
- +18 ;
- +19 ; check division
- IF $$CSDV^IBCRU3(IBCS,IBBDV)<0
- QUIT
- +20 ;
- +21 FOR IBEVDT=+IBU,+$PIECE(IBU,U,2)
- IF +$$FNDCI^IBCRU4(IBCS,IBCPTN,IBEVDT,.CHGARR)
- Begin DoDot:4
- +22 ;
- +23 SET IBCI=0
- FOR
- SET IBCI=$ORDER(CHGARR(IBCI))
- if 'IBCI
- QUIT
- IF '$DATA(DONEARR(IBCI))
- Begin DoDot:5
- +24 SET IBLN=CHGARR(IBCI)
- SET DONEARR(IBCI)=""
- SET IBFND=1
- +25 SET IBEFFDT=$$FMTE^XLFDT(+$PIECE(IBLN,U,3),2)
- +26 SET IBCPT1=IBCPT
- IF +$PIECE(IBLN,U,7)
- SET IBCPT1=IBCPT1_"-"_$PIECE($$MOD^ICPTMOD(+$PIECE(IBLN,U,7),"I",IBEFFDT),U,2)
- +27 SET IBRVCD=$$RVCPT^IBCROI(+$PIECE(IBLN,U,6),+$PIECE(IBLN,U,1),+$PIECE(IBLN,U,2))
- +28 SET IBCHGB=""
- IF +$PIECE(IBLN,U,8)
- SET IBCHGB="+"_$JUSTIFY($PIECE(IBLN,U,8),0,2)
- +29 ;
- +30 WRITE !,?4,IBCPT1,?15,IBEFFDT,?26,IBCSN,?55,$JUSTIFY($PIECE(IBLN,U,5),10,2),IBCHGB,?75,IBRVCD
- End DoDot:5
- End DoDot:4
- KILL CHGARR
- End DoDot:3
- KILL DONEARR
- End DoDot:2
- IF +IBFND
- WRITE !
- +31 IF 'IBFND
- WRITE ?60,"no charge found...",!
- End DoDot:1
- +32 QUIT
