source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCU65.m@ 1751

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

initial load of FOIAVistA 6/30/08 version
File size: 6.1 KB
Line 
1IBCU65 ;ALB/ARH - BILL CHARGE UTILITY: COMBINE E&M ; 12/01/04
2 ;;2.0;INTEGRATED BILLING;**287**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; Combine (E&M) Charges on one bill:
6 ; 90801-90815, 90845-90899, 99201-99215, 99241-99245, 99271-99288, 99385-99387, 99395-99429, 99499
7 ; For each of the procedures update the first line item to include both the professional and facility charge
8 ; If there is another line item for the procedure then delete it (no bill CT)
9 ;
10ASKCMB(IBIFN) ; if the user requests, combine (E&M) charges on the bill
11 N DIR,DIRUT,DTOUT,DUOUT,X,Y S IBIFN=+$G(IBIFN) Q:'IBIFN
12 ;
13 I '$$CHKBILL(IBIFN) Q ; provider based bill with combinable procedures
14 ;
15 W !! S DIR("?")="Enter Yes to add both Institutional and Professional charge for E&M codes"
16 S DIR("?",1)="The Professional and Facility charges of certain E&M codes may be combined onto"
17 S DIR("?",2)="one line item on this bill.",DIR("?",3)=" "
18 S DIR("B")="NO",DIR("A")="Combine Institutional and Professional Charges for E&M Procedures"
19 S DIR(0)="Y" D ^DIR Q:$D(DIRUT) Q:'Y
20 ;
21 I Y=1 D CHGCMB(IBIFN)
22 Q
23 ;
24CHGCMB(IBIFN) ; combine certain E&M codes on the bill
25 N IBRC,IBRC0,IBCPT,IBRCCT,IBMATCH,IBCHGS,IBTCHG,IBDONE,IBX K ^TMP($J,"IBCU65 CMB") Q:'$G(IBIFN)
26 ;
27 D BILLCHG(IBIFN) I '$D(^TMP($J,"IBCU65 CMB")) Q
28 ;
29 S IBRC=0 F S IBRC=$O(^DGCR(399,IBIFN,"RC",IBRC)) Q:'IBRC D
30 . S IBRC0=$G(^DGCR(399,IBIFN,"RC",IBRC,0))
31 . ;
32 . S IBCPT=$P(IBRC0,U,6) Q:'IBCPT I '$$CHKCODE(IBCPT) Q ; charge must be for a combinable cpt
33 . S IBRCCT=$P(IBRC0,U,12) I IBRCCT'=1,IBRCCT'=2 Q ; must be a component charge
34 . I '$P(IBRC0,U,8) Q ; charge must be auto created
35 . ;
36 . S IBMATCH=$P(IBRC0,U,3)_U_IBCPT_U_$P(IBRC0,U,7)_U_$P(IBRC0,U,10)_U_$P(IBRC0,U,11)
37 . ;
38 . S IBCHGS=$G(^TMP($J,"IBCU65 CMB",IBMATCH)) Q:IBCHGS="" ; find match
39 . ;
40 . I +$G(IBDONE(IBMATCH)) I $$RVDEL(IBIFN,IBRC) D Q ; if already combined delete line item
41 .. S IBX(IBCPT_" "_IBRC)=$S(IBRCCT=1:"Facility",1:"Professional")_" Charge for "_IBCPT_" deleted "_$P(IBRC0,U,2)
42 . ;
43 . S IBTCHG=$P(IBCHGS,U,3) Q:'IBTCHG
44 . ;
45 . I $$RVCHG(IBIFN,IBRC,IBTCHG) S IBDONE(IBMATCH)=1 D ; match found, combine charges
46 .. S IBX(IBCPT_" "_IBRC)="Charge for "_IBCPT_" combined: "_$P(IBCHGS,U,1)_"+"_$P(IBCHGS,U,2)_"="_IBTCHG
47 ;
48 I '$D(ZTQUEUED),'$G(IBAUTO) S IBX="" F S IBX=$O(IBX(IBX)) Q:IBX="" W !,IBX(IBX)
49 K ^TMP($J,"IBCU65 CMB")
50 Q
51 ;
52 ;
53 ;
54RVDEL(IBIFN,RCIFN) ; delete charge line item, Output: 0/1
55 ; Input: IBIFN = Bill Number, RCIFN = Charge Line Item in RC multiple
56 N IBX,DIK,DIC,X,Y,Z,Z1,DA,D0,D1,DG,DICR,DIG,DIH,DIW,DGXRF1 S IBX=0
57 I $D(^DGCR(399,+$G(IBIFN),"RC",+$G(RCIFN),0)) D S IBX=1
58 . S DA(1)=+IBIFN,DA=+RCIFN,DIK="^DGCR(399,"_DA(1)_",""RC""," D ^DIK K DIK
59 Q IBX
60 ;
61RVCHG(IBIFN,RCIFN,CHG) ; update line item charge and remove component, Output: 0/1
62 ; Input: IBIFN = Bill Number, RCIFN = Charge Line Item in RC multiple, CHG = New Charge Amount
63 N IBX,DA,DIE,DIC,DR,X,Y,Z,Z1,D,D0,D1,DI,DQ,DGXRF1 S IBX=0
64 I $D(^DGCR(399,+$G(IBIFN),"RC",+$G(RCIFN),0)) D S IBX=1
65 . S DA(1)=+IBIFN,DIE="^DGCR(399,"_DA(1)_",""RC"",",DR=".12///@;.02////"_+$G(CHG),DA=+RCIFN D ^DIE
66 Q IBX
67 ;
68 ;
69CHKCODE(CPT) ; return true if CPT code combinable
70 N IBOUT S CPT=+$G(CPT) S IBOUT=0
71 I (CPT<90800)!(CPT>99500) S IBOUT=0 G CHKCODQ
72 ;
73 I CPT>90800,CPT<90816 S IBOUT=1 G CHKCODQ
74 I CPT>90844,CPT<90900 S IBOUT=1 G CHKCODQ
75 I CPT>99200,CPT<99216 S IBOUT=1 G CHKCODQ
76 I CPT>99240,CPT<99246 S IBOUT=1 G CHKCODQ
77 I CPT>99270,CPT<99289 S IBOUT=1 G CHKCODQ
78 I CPT>99384,CPT<99388 S IBOUT=1 G CHKCODQ
79 I CPT>99394,CPT<99430 S IBOUT=1 G CHKCODQ
80 I CPT=99499 S IBOUT=1
81 ;
82CHKCODQ Q IBOUT
83 ;
84CHKBILL(IBIFN) ; return true if combining charges is applicable or available for bill
85 ; bill must be Provider Based and have at least one combinable procedure
86 N IBOUT,IBX,IBY S IBOUT=0 S IBIFN=+$G(IBIFN) I 'IBIFN G CHKBILQ
87 ;
88 S IBX=$P($G(^DGCR(399,+IBIFN,0)),U,22) S IBY=$P($$RCDV^IBCRU8(IBX),U,3) I IBY'=1,IBY'=2 S IBOUT=0 G CHKBILQ
89 ;
90 S IBX="90800;" F S IBX=$O(^DGCR(399,IBIFN,"CP","B",IBX)) Q:('IBX)!(+IBX>99499) I +$$CHKCODE(+IBX) S IBOUT=1 Q
91 ;
92CHKBILQ Q IBOUT
93 ;
94 ;
95BILLCHG(IBIFN) ; get all possible charges for bill with discounts applied
96 ; output array of charges for combinable procedures
97 ; Output: ^TMP($J,"IBCU65 CMB", "units ^ cpt ^ div ^ itm type ^ itm ptr") = inst chg ^ prof chg ^ total chg
98 ;
99 N IBX,IB0,IBU,IBBRT,IBBTYPE,IBCBARR,IBLN,IBCPT,IBCMP,IBSBCR,IBCHGI,IBCHGP
100 K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN")
101 K ^TMP($J,"IBCU65 TMP"),^TMP($J,"IBCU65 CMB") Q:'$G(IBIFN)
102 I '$O(^DGCR(399,+IBIFN,"RC",0)) Q
103 ;
104 S IB0=$G(^DGCR(399,+IBIFN,0)) Q:IB0="" S IBU=$G(^DGCR(399,+IBIFN,"U")) Q:'IBU
105 S IBBRT=+$P(IB0,U,7),IBBTYPE=$S($P(IB0,U,5)<3:1,1:3)
106 ;
107 ; get standard set of charge sets available for bill, including all Instutional and Professional charge sets
108 D RT^IBCRU3(IBBRT,IBBTYPE,$P(IBU,U,1,2),.IBCBARR,"PROCEDURE") I 'IBCBARR Q
109 ;
110 ; get all possible charges and sort as they would be added to the bill, including all discounts applied
111 D BILL^IBCRBH1(IBIFN,1,.IBCBARR),SORTCI^IBCRBH1(IBIFN)
112 ;
113 ;
114 ; compile like charges for procedures that are combinable
115 S IBX=0 F S IBX=$O(^TMP($J,"IBCRCSX",IBX)) Q:'IBX D
116 . S IBLN=$G(^TMP($J,"IBCRCSX",IBX))
117 . ;
118 . S IBCPT=$P(IBLN,U,5) Q:'IBCPT I '$$CHKCODE(IBCPT) Q ; CPT must be defined and combinable
119 . S IBCMP=+$P(IBLN,U,9) Q:'IBCMP ; must be a component charge
120 . I '$P(IBLN,U,8) Q ; item pointer must be defined
121 . I $P(IBLN,U,7)'=4 Q ; item type must be cpt
122 . ;
123 . S IBSBCR=$P(IBLN,U,4,8)
124 . S ^TMP($J,"IBCU65 TMP",IBSBCR)=+$G(^TMP($J,"IBCU65 TMP",IBSBCR))+1
125 . S ^TMP($J,"IBCU65 TMP",IBSBCR,IBCMP)=IBLN
126 ;
127 ;
128 ; compile array of combinable charges by procedure, must be combinable cpt and have both charges available
129 S IBSBCR="" F S IBSBCR=$O(^TMP($J,"IBCU65 TMP",IBSBCR)) Q:IBSBCR="" D
130 . I +$G(^TMP($J,"IBCU65 TMP",IBSBCR))'=2 Q
131 . ;
132 . S IBCHGI=$P($G(^TMP($J,"IBCU65 TMP",IBSBCR,1)),U,3) Q:'IBCHGI
133 . S IBCHGP=$P($G(^TMP($J,"IBCU65 TMP",IBSBCR,2)),U,3) Q:'IBCHGP
134 . ;
135 . S ^TMP($J,"IBCU65 CMB",IBSBCR)=IBCHGI_U_IBCHGP_U_(IBCHGI+IBCHGP)
136 ;
137 ;
138 K ^TMP($J,"IBCRCC"),^TMP($J,"IBCRCSX"),^TMP($J,"IBCRCSXR"),^TMP($J,"IBCRCSXN"),^TMP($J,"IBCU65 TMP")
139 Q
Note: See TracBrowser for help on using the repository browser.