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

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

initial load of FOIAVistA 6/30/08 version

File size: 9.4 KB
Line 
1IBEMTSCU ;ALB/RFJ-print billable types for visit copay ;23 Nov 01
2 ;;2.0;INTEGRATED BILLING;**167,177,187**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6EFFDT() ;effect date Visit Copay 2
7 Q 3021001 ;OCT 1,2002
8 ;
9ADD(IBSTOPCD,IBEFFDT,IBBILTYP,IBDESC,IBOVER) ; add a stop code to file 352.5
10 ; ibstopcd = 3 or 6 digit stop code to add
11 ; ibeffdt = effective date, internal fileman form (ex:3011206)
12 ; if effective date is not passed, it uses today (dt)
13 ; ibbiltyp = billable type (B=basic, S=specialty, N=non-billable)
14 ; default is non-billable if a B or S is not passed
15 ; ibdesc = description of stop code
16 ; ibover = if the code belongs to Override table
17 ; returns 1 if added, -#^error if not added
18 ;
19 N D,D0,DA,DI,DIC,DIE,DLAYGO,DQ,DR,IBDA,X,Y,IBZ
20 ;
21 ; check length of stop code
22 I '(($L(IBSTOPCD)=3)!($L(IBSTOPCD)=6)) Q "-1^STOP CODE "_IBSTOPCD_" NOT 3 OR 6 CHARACTERS IN LENGTH."
23 ;
24 ; change billable type code to match set of codes in file 352.5
25 S IBBILTYP=$S(IBBILTYP="B":1,IBBILTYP="S":2,1:0)
26 ;
27 S (DIC,DIE)="^IBE(352.5,",DIC(0)="L",DLAYGO=352.5
28 ;
29 ; check to see if entry is in the file
30 S IBDA=$O(^IBE(352.5,"AEFFDT",IBSTOPCD,-IBEFFDT,0))
31 I IBDA S IBZ=$G(^IBE(352.5,IBDA,0)) D Q 1
32 . S DR=""
33 . ; check to see if the correct billable type is set correctly
34 . I $P(IBZ,"^",3)'=IBBILTYP S DR=".03////"_IBBILTYP_";"
35 . ; check description
36 . I $P(IBZ,"^",4)'=$E(IBDESC,1,30) S DR=DR_".04////"_$E(IBDESC,1,30)
37 . ; if not, change it
38 . I $L(DR) S DA=IBDA D ^DIE
39 ;
40 ; add entry to file 352.5
41 S X=IBSTOPCD
42 S DIC("DR")=".02////"_IBEFFDT_";.03////"_IBBILTYP_";.04////"_$E(IBDESC,1,30)_";"
43 S:$G(IBOVER)=1 DIC("DR")=DIC("DR")_".05////1;"
44 D FILE^DICN
45 Q 1
46 ;
47 ;
48DIQ407(DA,DR) ; diq call to retrieve data for dr fields in file 40.7
49 N D0,DIC,DIQ,DIQ2,YY
50 K IBSCDATA(40.7,DA)
51 I $G(DR)="" S DR=".01:4;"
52 S DIQ(0)="IE",DIC="^DIC(40.7,",DIQ="IBSCDATA" D EN^DIQ1
53 Q
54 ;
55 ;0 - active
56ISINACT(IBCODE) ;
57 Q:$L(IBCODE)=6 $$INACTIVE($E(IBCODE,1,3))+$$INACTIVE($E(IBCODE,4,6))
58 Q $$INACTIVE(IBCODE)
59 ;
60INACTIVE(IBSTCODE) ; return 1 if inactive in file 40.7
61 ; also, return ibscdata(da for stop code entries in 40.7)
62 N DA,IBSCDATA,RESULT
63 ;
64 ; default is inactive
65 S RESULT=1
66 ;
67 S DA=0 F S DA=$O(^DIC(40.7,"C",IBSTCODE,DA)) Q:'DA D
68 . D DIQ407(DA,2)
69 . I 'IBSCDATA(40.7,DA,2,"I") S RESULT=0
70 ;
71 Q RESULT
72 ;
73 ;
74ASK() ; ask if the user wants to enter a stop code or select a clinic
75 ; return will be what entry point to use
76 N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
77 S DIR(0)="S^C:Clinic;S:Stop Code" D ^DIR
78 Q $S(Y="C":"C",Y="S":"S",1:"")
79 ;
80ASKSCODE(IBPROMPT) ; ask and return selected stop code from file 352.5
81 ; ibprompt = optional prompt to display
82 ;
83 N DIC,DILN,I,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
84 S DIC="^IBE(352.5,",DIC(0)="QEAM"
85 S DIC("A")="Select OUTPATIENT VISIT STOP CODE: "
86 I $G(IBPROMPT)'="" S DIC("A")=IBPROMPT
87 S DIC("S")="I $$STOPSCRN^IBEMTSCU(Y)"
88 ;
89 W ! D ^DIC
90 I Y<1 Q -1
91 Q +Y
92 ;
93 ;
94STOPSCRN(IBX) ; screens out so only active and current ones are selectable
95 ;
96 ; if we have no from date, all are selectable
97 I '$G(IBFR) Q 1
98 ;
99 N IBZ,IBAX,IBS,IBEFFDT
100 S IBZ=$G(^IBE(352.5,IBX,0)),IBS=$P(IBZ,"^")
101 ;
102 ; is the effective date for this entry in the future?
103 I $P(IBZ,"^",2)>IBFR Q 0
104 ;
105 ; get the effective date for stop code and visit date
106 S IBEFFDT=$O(^IBE(352.5,"AEFFDT",IBS,-(IBFR+.1)))
107 I 'IBEFFDT Q 0
108 ;
109 ; get the billable entry to compare
110 S IBAX=$O(^IBE(352.5,"AEFFDT",IBS,IBEFFDT,0))
111 ;
112 Q $S(IBX=IBAX:1,1:0)
113 ;
114ASKSC(IBVISTDT) ; ask for a clinic to look up the stop code
115 ; it will prompt for a clinic selection, and return the stop
116 ; code number in 352.5 associated with the clinic
117 N DIC,X,Y,IB407,IBEFDT,IBCLIN
118 S DIC="^SC(",DIC(0)="AEMQZ",DIC("A")="Select CLINIC: ",DIC("S")="I $P(^(0),U,3)=""C""" D ^DIC Q:Y<1 -1
119 S IBCLIN=+Y
120 ;primary
121 S IB407=$P(Y(0),"^",7)
122 S IBCODE1=$$GETCODE(IB407)
123 ; if < eff date
124 Q:IBVISTDT<$$EFFDT() $$GET3525(+IBCODE1,0,IBVISTDT)
125 ;secondary
126 ; get the secondary stop code value
127 S IBCODE2=$$GETCRED(IBCLIN)
128 ;return proper IEN of #352.5
129 Q +$$GET3525(IBCODE1,IBCODE2,IBVISTDT)
130 ;
131 ;
132GETTYPE(IBSTOPCD,IBVISTDT) ; lookup billable type
133 ; input ibstopcd = stop code (.01 field entry in file 352.5)
134 ; ibvistdt = visit date in fileman format
135 ;
136 ; returns -1 = stop code/effective date not found or defined
137 ; 0 = non-billable
138 ; 1 = basic rate
139 ; 2 = specialty rate
140 ;
141 N DA,IBEFFDT,RESULT
142 ;
143 ; get the effective date for stop code and visit date
144 S IBEFFDT=$O(^IBE(352.5,"AEFFDT",IBSTOPCD,-(IBVISTDT+.1)))
145 I 'IBEFFDT Q -1
146 ;
147 ; get the billable type
148 S DA=$O(^IBE(352.5,"AEFFDT",IBSTOPCD,IBEFFDT,0))
149 I 'DA Q -1
150 ;
151 ; get the billable type
152 S RESULT=+$P($G(^IBE(352.5,DA,0)),"^",3)
153 Q RESULT
154 ;
155 ;
156GETSC(IBSL,IBVISTDT) ; return the ien of the entry in file 352.5.
157 ; ibsl is the clinic stop code in 409.68. find the matching
158 ; entry in file 352.5. the 352.5 entry is populated in the 350 field
159 ; for reference using the ibstopda variable
160 ; input ibsl = 409.68:ien
161 N IB407,IBCLIN,IBCODE1,IBCODE2
162 I $P(IBSL,":")'=409.68 Q ""
163 ;primary
164 ;this is the ien for file 40.7 (dbia402)
165 S IB407=+$P($G(^SCE(+$P(IBSL,":",2),0)),"^",3)
166 ;get the primary stop code value
167 S IBCODE1=+$$GETCODE(IB407)
168 ;if < eff date
169 Q:IBVISTDT<$$EFFDT() $$GET3525(+IBCODE1,0,IBVISTDT)
170 ;secondary
171 ;get clinic(#44) pointer from #409.68
172 S IBCLIN=+$P($G(^SCE(+$P(IBSL,":",2),0)),"^",4)
173 ;get the secondary stop code value
174 S IBCODE2=+$$GETCRED(IBCLIN)
175 ;return proper IEN of #352.5
176 Q $$GET3525(+IBCODE1,+IBCODE2,IBVISTDT)
177 ;
178 ;apply business rules, select appropr. code in #352.5 and return its IEN
179 ;if not found then return ""
180GET3525(IBCODE1,IBCODE2,IBVISTDT) ;
181 Q:+IBCODE1=0 "" ;must be defined as a required field in #44
182 Q:$L(+IBCODE1)'=3!(IBCODE1<0) ""
183 I $L(+IBCODE2)'=3!(IBCODE2<0) S IBCODE2=0
184 N IB6DIG
185 N IBEFDT1,IBIEN1,IBOVER1,IBTYPE1
186 N IBEFDT2,IBIEN2,IBOVER2,IBTYPE2
187 S (IBIEN1,IBIEN2,IBOVER1,IBOVER2)=0
188 ;------ find appropriate ien in file #352.5
189 S IB6DIG=$S(IBCODE2>0:IBCODE1_IBCODE2,1:IBCODE1)
190 ;in the #352.5 with appropriate eff date?
191 S IBEFDT1=+$O(^IBE(352.5,"AEFFDT",IB6DIG,-(IBVISTDT+.1)))
192 ;
193 ;A) if found and it is 6 or 3 digit code
194 I IBEFDT1 D Q:IBIEN1>0 IBIEN1
195 . ;get the entry in 352.5
196 . S IBIEN1=+$O(^IBE(352.5,"AEFFDT",IB6DIG,IBEFDT1,0))
197 ;
198 ;B) if not found and it is 3 digit - return nothing, BASIC applies
199 I +IBCODE2=0 Q ""
200 ;
201 ;C) if not found and it is 6 digit - try each separately
202 ;-- primary code
203 ;in the #352.5 "override" tables with appropriate eff date?
204 S IBEFDT1=+$O(^IBE(352.5,"AEFFDT",IBCODE1,-(IBVISTDT+.1)))
205 I IBEFDT1 D
206 . ;get the entry in 352.5
207 . S IBIEN1=+$O(^IBE(352.5,"AEFFDT",IBCODE1,IBEFDT1,0))
208 . Q:IBIEN1=0
209 . S IBOVER1=+$P($G(^IBE(352.5,IBIEN1,0)),"^",5)
210 . S IBTYPE1=+$P($G(^IBE(352.5,IBIEN1,0)),"^",3)
211 ;-- secondary code
212 ;in the #352.5 "override" tables with appropriate eff date?
213 S IBEFDT2=+$O(^IBE(352.5,"AEFFDT",IBCODE2,-(IBVISTDT+.1)))
214 I IBEFDT2 D
215 . ;get the entry in 352.5
216 . S IBIEN2=+$O(^IBE(352.5,"AEFFDT",IBCODE2,IBEFDT2,0))
217 . Q:IBIEN2=0
218 . S IBOVER2=+$P($G(^IBE(352.5,IBIEN2,0)),"^",5)
219 . S IBTYPE2=+$P($G(^IBE(352.5,IBIEN2,0)),"^",3)
220 ;
221 ; If not found in override tables
222 ; - AND primary is not in #352.5 then return nothing, BASIC applies
223 ; - AND primary is in #352.5 then return IBIEN1
224 I IBOVER1=0,IBOVER2=0 Q $S(IBIEN1>0:IBIEN1,1:"")
225 ;
226 I IBOVER1=0,IBOVER2'=0 Q +IBIEN2
227 ;
228 I IBOVER1'=0,IBOVER2=0 Q +IBIEN1
229 ;
230 ; If IBOVER1'=0,IBOVER2'=0
231 I IBTYPE1=0 Q +IBIEN1 ;NON
232 I IBTYPE2=0 Q +IBIEN2 ;NON
233 I IBTYPE1=2 Q +IBIEN1 ;SPEC
234 I IBTYPE2=2 Q +IBIEN2 ;SPEC
235 Q +IBIEN1 ;BASIC
236 ;
237 ;
238OPT ; perform outpatient copay edits for visits after 11/29/01
239 ; called from IBECEA3
240 ;
241 ; return IBSTOPDA (if selected) to be stored in file 350
242 K IBSTOPDA,IBANS
243 ;
244 ; ask selection by clinic or stop code
245 S IBANS=$$ASK I '$L(IBANS) W !!,"Charge NOT added." S IBY=-1 Q
246 ;
247 ; ask clinic stop to calc charges
248 S IBSTOPDA=+$S(IBANS="S":$$ASKSCODE,1:$$ASKSC(IBFR))
249 I IBSTOPDA<0 S IBY=-1 W !!,"Charge NOT added." K IBSTOPDA Q
250 ;
251 ; user selected a non-billable clinic stop
252 I IBSTOPDA>0,'$P($G(^IBE(352.5,IBSTOPDA,0)),"^",3) W !?5,"********** This is a NON-BILLABLE Clinic Stop **********",!?5,"Select an active billable clinic stop or press RETURN to exit." G OPT
253 ; user selected an inactive stop code
254 I IBSTOPDA>0,$$ISINACT($P($G(^IBE(352.5,IBSTOPDA,0)),"^")) W !?5,"********** This is a INACTIVE Clinic Stop in file #40.7 **********",!?5,"Select an active billable clinic stop or press RETURN to exit." G OPT
255 ;
256 ; *** get the charge ***
257 ; return IBTO, IBUNIT, IBEVDA, IBCHG for processing in IBECEAU3
258 N IBDT,IBTYPE,IBX
259 S (IBDT,IBTO)=IBFR ;visit date
260 S IBX="O" ;O for outpatient
261 S IBUNIT=1,IBEVDA="*"
262 S IBTYPE=1 ;BASIC by default
263 S:IBSTOPDA>0 IBTYPE=$P(^IBE(352.5,IBSTOPDA,0),"^",3) ;type of charge, basic or specialty
264 D TYPE^IBAUTL2
265 I IBY<0 Q
266 ;
267 W !!,"Charge to be billed under the ",$$TYPE^IBEMTSCR($P($G(^IBE(352.5,IBSTOPDA,0)),"^",3))," Rate --> $",$J(IBCHG,0,2)
268 Q
269 ;
270 ;Get credit pair (secondary code) from #44
271GETCRED(IBCLIN) ;
272 N IB407
273 ; get credit pair (secondary stop code pointer) from #44
274 S IB407=+$P($G(^SC(IBCLIN,0)),"^",18)
275 ; if IB407 is defined, get the stop code in IBSCDATA(40.7,IB407,1,"E")
276 Q $$GETCODE(IB407)
277 ;
278GETCODE(IB407) ;
279 ; get the stop code in IBSCDATA(40.7,IB407,1,"E")
280 N IBCODE,IBSCDATA
281 S IBCODE=0
282 I IB407'=0 D DIQ407(IB407,1) D
283 . I $G(IBSCDATA(40.7,IB407,1,"E"))="" Q
284 . S IBCODE=+$G(IBSCDATA(40.7,IB407,1,"E"))
285 . S:$L(+IBCODE)'=3!(IBCODE<0) IBCODE=0
286 Q IBCODE
287 ;
Note: See TracBrowser for help on using the repository browser.