| 1 | IBCRBH2 ;ALB/ARH - RATES: BILL HELP DISPLAYS - CPT CHARGES ; 01-OCT-03
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**245**;21-MAR-94
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ;
|
|---|
| 6 | BCPTCHG(IBIFN) ; select a CPT code and display potential charges for a specific bill
|
|---|
| 7 | N IB0,IBU,IBBDV,IBCPT,IBCPTN,IBCPT1,IBRS,IBCS,IBCSN,IBEVDT,IBCI,IBLN,IBEFFDT,IBRVCD,IBCHGB,IBFND,CHGARR,ARRCS,DONEARR,IBX
|
|---|
| 8 | ;
|
|---|
| 9 | S IB0=$G(^DGCR(399,+$G(IBIFN),0)) Q:IB0=""
|
|---|
| 10 | S IBU=$G(^DGCR(399,+$G(IBIFN),"U")) Q:'IBU
|
|---|
| 11 | S IBBDV=$P(IB0,U,22)
|
|---|
| 12 | ;
|
|---|
| 13 | 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)
|
|---|
| 14 | W !,"--------------------------------------------------------------------------------",!
|
|---|
| 15 | ;
|
|---|
| 16 | D RT^IBCRU3($P(IB0,U,7),$P(IB0,U,5),$P(IBU,U,1,2),.ARRCS,"PROCEDURE")
|
|---|
| 17 | I '$O(ARRCS(0)) W !,"No Rate Schedules with Procedure charges assigned to this bill.",! H 2 Q
|
|---|
| 18 | ;
|
|---|
| 19 | F S IBCPT=$$GETCPT^IBCRU1() Q:+IBCPT<1 S IBCPTN=$P(IBCPT,U,1),IBCPT=$P(IBCPT,U,2) W ! D
|
|---|
| 20 | . ;
|
|---|
| 21 | . S IBRS=0 F S IBRS=$O(ARRCS(IBRS)) Q:'IBRS S IBFND=0 D I +IBFND W !
|
|---|
| 22 | .. S IBCS=0 F S IBCS=$O(ARRCS(IBRS,IBCS)) Q:'IBCS I +ARRCS(IBRS,IBCS) D K DONEARR
|
|---|
| 23 | ... S IBCSN=$P($G(^IBE(363.1,+IBCS,0)),U,1)
|
|---|
| 24 | ... ;
|
|---|
| 25 | ... I $$CSDV^IBCRU3(IBCS,IBBDV)<0 Q ; check division
|
|---|
| 26 | ... ;
|
|---|
| 27 | ... F IBEVDT=+IBU,+$P(IBU,U,2) I +$$FNDCI^IBCRU4(IBCS,IBCPTN,IBEVDT,.CHGARR) D K CHGARR
|
|---|
| 28 | .... ;
|
|---|
| 29 | .... S IBCI=0 F S IBCI=$O(CHGARR(IBCI)) Q:'IBCI I '$D(DONEARR(IBCI)) D
|
|---|
| 30 | ..... S IBLN=CHGARR(IBCI),DONEARR(IBCI)="",IBFND=1
|
|---|
| 31 | ..... S IBEFFDT=$$FMTE^XLFDT(+$P(IBLN,U,3),2)
|
|---|
| 32 | ..... S IBCPT1=IBCPT I +$P(IBLN,U,7) S IBCPT1=IBCPT1_"-"_$P($$MOD^ICPTMOD(+$P(IBLN,U,7),"I",IBEFFDT),U,2)
|
|---|
| 33 | ..... S IBRVCD=$$RVCPT^IBCROI(+$P(IBLN,U,6),+$P(IBLN,U,1),+$P(IBLN,U,2))
|
|---|
| 34 | ..... S IBCHGB="" I +$P(IBLN,U,8) S IBCHGB="+"_$J($P(IBLN,U,8),0,2)
|
|---|
| 35 | ..... ;
|
|---|
| 36 | ..... W !,?4,IBCPT1,?15,IBEFFDT,?26,IBCSN,?55,$J($P(IBLN,U,5),10,2),IBCHGB,?75,IBRVCD
|
|---|
| 37 | . I 'IBFND W ?60,"no charge found...",!
|
|---|
| 38 | Q
|
|---|
