source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCRBH2.m@ 1000

Last change on this file since 1000 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.9 KB
Line 
1IBCRBH2 ;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 ;
6BCPTCHG(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
Note: See TracBrowser for help on using the repository browser.