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 Oct 16, 2024@18:19:34 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
