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

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

initial load of FOIAVistA 6/30/08 version
File size: 8.9 KB
Line 
1IBCNEDE4 ;DAOU/ALA - NO INSURANCE DATA EXTRACT ;24-JUN-2002
2 ;;2.0;INTEGRATED BILLING;**184,271**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;**Program Description**
6 ; This program finds veterans who have been seen within a
7 ; specified date range but who have no active or no
8 ; insurance records
9 ; Periodically check for stop request for background task
10 ;
11 Q ;can't call directly
12 ;
13EN ;
14 NEW TMPCNT,IEN,TQIEN,DATA1,DATA2,EACTIVE,XDAYS,YDAYS,MAXCNT,IBBDT,IBEDT
15 NEW IBD,IBPM,IBPMD,IBQUERY,IBCNCNT,SRVICEDT,IBINS,IBDD,IBDDI,DFN
16 NEW IBOUTP,PTN,PAYER,FOUND1,FOUND2,DFN,DISYS,TDT,IBCNETOT,FRESH,FRESHDT
17 NEW DGPMDT,AUPNDT
18 ;
19 S IBCNCNT=0
20 ; Initialize count for periodic TaskMan check
21 S IBCNETOT=0
22 ;
23 ; Get Extract parameters
24 S EACTIVE=$$SETTINGS^IBCNEDE7(4)
25 I 'EACTIVE Q ; quit if not active
26 S XDAYS=$P(EACTIVE,U,2)
27 S YDAYS=$P(EACTIVE,U,3)
28 S MAXCNT=$P(EACTIVE,U,4)
29 S:MAXCNT="" MAXCNT=9999999999
30 ;
31 ; Check for Date Last Treated and get DFN's
32 S IBBDT=$$FMADD^XLFDT(DT,-XDAYS),IBEDT=DT
33 ;
34 ; * Main Control
35 ;
36 S IBD=IBBDT-.0001
37 K ^TMP("IBCNEDE4",$J,"PTS")
38 F II=1:1 D Q:(IBD="")!(IBD\1>IBEDT)!(IBCNCNT'<MAXCNT)!($G(ZTSTOP))
39 . S DGPMDT=$O(^DGPM("ATT3",IBD)),AUPNDT=$O(^AUPNVSIT("B",IBD))
40 . I (AUPNDT="")!((DGPMDT\1)<(AUPNDT\1)) S IBD=DGPMDT
41 . I (DGPMDT="")!((DGPMDT\1)>(AUPNDT\1)) S IBD=AUPNDT
42 . I (IBD\1>IBEDT)!(IBD="") Q
43 . ;
44 . K ^TMP("IBJDI51",$J)
45 . D INP(IBD) ; sets up ^TMP("IBJDI51",$J)
46 . I $G(ZTSTOP) Q
47 . D OUTP(IBD)
48 . I $G(ZTSTOP) Q
49 . D REST(IBBDT-.0001,IBEDT)
50 . D PROCESS
51 . I $G(ZTSTOP) Q
52 . S IBD=($$FMADD^XLFDT(IBD,+1))-.0001
53 ;
54EXIT ;
55 K VINS,^TMP("IBJDI51",$J),^TMP("IBCNEDE4",$J,"PTS") ; clean up
56 ;
57 Q
58 ; * end of routine processing
59 ;============================
60 ;
61INP(DATE) ; Find inpatients for that date (we want most recent encounter)
62 NEW IBD,IBPM,IBPMD,DFN
63 S IBD=DATE-.0001
64 F S IBD=$O(^DGPM("ATT3",IBD)) Q:(IBD="")!(IBD\1>DATE) D Q:$G(ZTSTOP)
65 . S IBPM=0 F S IBPM=$O(^DGPM("ATT3",IBD,IBPM)) Q:IBPM="" D Q:$G(ZTSTOP)
66 .. ; Update count for periodic check
67 .. S IBCNETOT=IBCNETOT+1
68 .. ; Check for request to stop background job, periodically
69 .. I $D(ZTQUEUED),IBCNETOT#100=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
70 .. ;
71 .. S IBPMD=$G(^DGPM(IBPM,0)) Q:'IBPMD
72 .. S DFN=+$P(IBPMD,U,3) Q:'DFN
73 .. I $P($G(^DPT(DFN,0)),U,21) Q ; Exclude if test patient
74 .. Q:$D(^TMP("IBCNEDE4",$J,"PTS",DFN,"INP")) ; already processed
75 .. S ^TMP("IBCNEDE4",$J,"PTS",DFN,"INP",IBD)=""
76 .. D PROC^IBJDI5(DFN,"*",IBD)
77 Q
78 ;
79OUTP(DATE) ; Find outpatients treated for this date (most recent encounter)
80 NEW IBD,IEN,DFN
81 S IBD=DATE-.000001
82 F S IBD=$O(^AUPNVSIT("B",IBD)) Q:(IBD="")!(IBD\1>DATE) D Q:$G(ZTSTOP)
83 . S IEN=""
84 . F S IEN=$O(^AUPNVSIT("B",IBD,IEN)) Q:IEN="" D Q:$G(ZTSTOP)
85 .. ; Update count for periodic check
86 .. S IBCNETOT=IBCNETOT+1
87 .. ; Check for request to stop background job, periodically
88 .. I $D(ZTQUEUED),IBCNETOT#100=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
89 .. ;
90 .. S DFN=$P($G(^AUPNVSIT(IEN,0)),U,5)
91 .. Q:DFN=""
92 .. I $P($G(^DPT(DFN,0)),U,21) Q ; Exclude if test patient
93 .. Q:$D(^TMP("IBCNEDE4",$J,"PTS",DFN,"OUTP")) ; already processed
94 .. S ^TMP("IBCNEDE4",$J,"PTS",DFN,"OUTP",IBD)=""
95 .. ; Capture the most recent (last) encounter date
96 .. I $G(^TMP("IBJDI51",$J,DFN))<(IBD\1) D PROC^IBJDI5(DFN,"",IBD)
97 Q
98 ;
99REST(STARTDT,ENDDT) ; Check for a more recent encounter (inpat. or outpat.)
100 ;
101 NEW IBPM,IBPMD,IBD,DFN
102 S DFN=0
103 F S DFN=$O(^TMP("IBJDI51",$J,DFN)) Q:DFN="" D
104 . ;
105 . ; inpatients
106 . S IBPM=0 F S IBPM=$O(^DGPM("C",DFN,IBPM)) Q:IBPM="" D
107 .. S IBPMD=$G(^DGPM(IBPM,0)) Q:'IBPMD
108 .. S IBD=$P(IBPMD,U,1) I ((IBD\1)<STARTDT)!((IBD\1)>ENDDT) Q
109 .. Q:$D(^TMP("IBJDI51",$J,"PTS",DFN,"INP",IBD)) ;already checked
110 .. S ^TMP("IBJDI51",$J,"PTS",DFN,"INP",IBD)=""
111 .. ; Capture the most recent (last) encounter date
112 .. I $G(^TMP("IBJDI51",$J,DFN))<(IBD\1) D PROC^IBJDI5(DFN,"*",IBD)
113 . ;
114 . ; outpatients
115 . S IBD="" F S IBD=$O(^AUPNVSIT("AA",DFN,IBD)) Q:IBD="" D
116 .. I ((IBD\1)<STARTDT)!((IBD\1)>ENDDT) Q
117 .. Q:$D(^TMP("IBJDI51",$J,"PTS",DFN,"OUTP",IBD)) ;already checked
118 .. S ^TMP("IBJDI51",$J,"PTS",DFN,"OUTP",IBD)=""
119 .. ; Capture the most recent (last) encounter date
120 .. I $G(^TMP("IBJDI51",$J,DFN))<(IBD\1) D PROC^IBJDI5(DFN,"",IBD)
121 ;
122 Q
123 ;
124PROCESS ; Check selection criteria for each person with
125 ; a visit in the last defined time frame (e.g. 6 months)
126 N SVIBDDI
127 S DFN=0 F S DFN=$O(^TMP("IBJDI51",$J,DFN)) Q:'DFN D Q:IBCNCNT'<MAXCNT!$G(ZTSTOP)
128 . ;
129 . ; Update count for periodic check
130 . S IBCNETOT=IBCNETOT+1
131 . ; Check for request to stop background job, periodically
132 . I $D(ZTQUEUED),IBCNETOT#100=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
133 . ;
134 . S SRVICEDT=$P(^TMP("IBJDI51",$J,DFN),U)
135 . S FRESHDT=$$FMADD^XLFDT(SRVICEDT,YDAYS)
136 . ;
137 . ; Call IB utility to search for patient's inactive insurance
138 . ; IBCNS passes back IBINS = 1 if active insurance was found
139 . ; IBCNS sets the array IBDD to the patient's valid insurance
140 . ; IBCNS sets the array IBDDI to the patient's invalid insurance
141 . ;
142 . K IBINS,IBDD,IBDDI,SVIBDDI
143 . S IBOUTP=2
144 . D ^IBCNS
145 . K IBDD ; don't need this array
146 . I $G(IBINS)=1 Q ; if active insurance was found quit
147 . M SVIBDDI=IBDDI
148 . ;
149 . S (FOUND1,FOUND2)=0
150 . ;
151 . ; Returned all inactive insurances in IBDDI array
152 . I $D(IBDDI)>0,(IBCNCNT<MAXCNT) S FOUND2=$$INAC^IBCNEDE6(.IBCNCNT,MAXCNT,.IBDDI,SRVICEDT,YDAYS)
153 . M IBDDI=SVIBDDI
154 . ;
155 . ; If no inactive insurances, work the popular insurances
156 . I IBCNCNT<MAXCNT S FOUND1=$$POP(.IBCNCNT,MAXCNT,SRVICEDT,YDAYS,,.IBDDI)
157 . ;
158 . I 'FOUND1,'FOUND2,(IBCNCNT<MAXCNT) D BLANKTQ^IBCNEDE6(SRVICEDT,FRESHDT,YDAYS,.IBCNCNT)
159 K ^TMP("IBJDI51",$J),IBDD,IBDDI,IBINS
160 Q
161 ;
162POP(IBCNCNT,MAXCNT,SRVICEDT,FDAYS,APPTFLG,IBDDI) ; Get Popular Insurances
163 ; FDAYS (Fresh Days value)
164 ; APPTFLG - Appt extract flag ONLY set from IBCNEDE2 - optional 0/1
165 ;
166 NEW PDATA,POPFL,PNUM,PCNT,II,RESULT,PAYER,PAYERID
167 NEW DATA1,DATA2,TQIEN,FOUND,SIDARRAY,SID,SIDACT,SIDCNT
168 NEW FRESHDT,INACT,SKIPPAY
169 ;
170 ; Need FOUND to avoid the creation of a no payer inquiry the day after
171 ; the original inquiry for pre-reg (appt) extract and no insurance
172 ; extract was created.
173 S FOUND=0 ; set flag to 1 if potential inquiry was found
174 ;
175 S APPTFLG=$G(APPTFLG)
176 S PDATA=$G(^IBE(350.9,1,51))
177 S POPFL=$P(PDATA,U,9),PNUM=$P(PDATA,U,10)
178 S INACT=$P(PDATA,U,8) ; get inactive flag from site parameters
179 ;
180 ; If the search for popular insurances is 'No', quit
181 I 'POPFL G POPX
182 ;
183 ; If the site does not check inactive insurances and the patient
184 ; has inactive insurances, set up the array of payers to skip.
185 ; This will be used to screen the patient's inactive payers from being
186 ; included with the most popular payers.
187 I 'INACT,$D(IBDDI) D
188 . N INCP,INSPAYID
189 . S INCP="" F S INCP=$O(IBDDI(INCP)) Q:'INCP D
190 .. S RESULT=$$INSERROR^IBCNEUT3("I",INCP)
191 .. Q:$P(RESULT,U)'=""
192 .. S INSPAYID=$P(RESULT,U,3)
193 .. I INSPAYID="" Q
194 .. S SKIPPAY(INSPAYID)=""
195 ;
196 S FRESHDT=$$FMADD^XLFDT(SRVICEDT,-FDAYS)
197 ;
198 ; If no list of popular insurances, quit
199 I $O(^IBE(350.9,1,51.18,0))="" G POPX
200 S II=0 F PCNT=1:1:PNUM S II=$O(^IBE(350.9,1,51.18,II)) Q:'II D Q:IBCNCNT'<MAXCNT
201 . S PAYER=$P(^IBE(350.9,1,51.18,II,0),U,1)
202 . ;
203 . S RESULT=$$PAYER^IBCNEUT4(PAYER)
204 . I $P(RESULT,U)'="" Q ; quit if error, don't record in ins. buffer
205 . ; PAYERID = National ID
206 . S PAYERID=$P(RESULT,U,2)
207 . I PAYERID="" Q
208 . ;
209 . I $D(SKIPPAY(PAYERID)) Q ; quit if it was determined that this payer be skipped
210 . ;
211 . S FOUND=1 ; potential inquiry
212 . ;
213 . ; Update service date and freshness date based on payer allowed
214 . ; date range
215 . D UPDDTS^IBCNEDE6(PAYER,.SRVICEDT,.FRESHDT)
216 . ;
217 . ; DAOU/BHS - Update service dates for inquiries to be transmitted
218 . D TQUPDSV^IBCNEUT5(DFN,PAYER,SRVICEDT)
219 . ;
220 . ;check for outstanding/current entries in File 356.1
221 . ; Freshness check - are we allowed to add this entry to the TQ file
222 . I '$$ADDTQ^IBCNEUT5(DFN,PAYER,SRVICEDT,FDAYS) Q
223 . ;
224 . ; Call function to set IIV TRANSMISSION QUEUE file #365.1
225 . ;
226 . K SIDARRAY
227 . S SIDACT=$$SIDCHK2^IBCNEDE5(DFN,PAYER,.SIDARRAY,FRESHDT)
228 . S SIDCNT=$P(SIDACT,U,2),SIDACT=$P(SIDACT,U)
229 . ; Add to TQ to compensate for TQ w/ blank Sub ID
230 . I SIDACT'<5,(SIDACT'>8) S SIDCNT=SIDCNT+1
231 . I IBCNCNT+SIDCNT>MAXCNT S IBCNCNT=MAXCNT Q ; see if TQ entries will exceed MAXCNT
232 . S SID=""
233 . F S SID=$O(SIDARRAY(SID)) Q:SID="" D POPSET($P(SID,"_"),$P(SID,"_",2))
234 . ;
235 . ; Create TQ entry w/ blank Sub ID
236 . I SIDACT=5!(SIDACT=6)!(SIDACT=7)!(SIDACT=8) S SID="" D POPSET("","") ;D POPSET()
237POPX ; POP exit point
238 Q FOUND
239 ;
240POPSET(SID,INREC) ;
241 N FRESH
242 ; The hard coded '1' in the 3rd piece of DATA1 sets the Transmission
243 ; status of file 365.1 to "Ready to Transmit"
244 S FRESH=$$FMADD^XLFDT(SRVICEDT,-FDAYS)
245 S DATA1=DFN_U_PAYER_U_1_U_""_U_SID_U_FRESH
246 ;
247 ; The hardcoded 1st piece of DATA2 tells file 365.1 which extract
248 ; it is.
249 I APPTFLG S DATA2=2 ; appt extract IBCNEDE2
250 I 'APPTFLG S DATA2=4 ; no ins extract IBCNEDE4
251 S DATA2=DATA2_U_"I"_U_SRVICEDT_U_$G(INREC)
252 ;
253 S TQIEN=$$SETTQ^IBCNEDE7(DATA1,DATA2)
254 I TQIEN'="" S IBCNCNT=IBCNCNT+1
255 ;
256 Q
257 ;
Note: See TracBrowser for help on using the repository browser.