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

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

initial load of FOIAVistA 6/30/08 version

File size: 8.2 KB
Line 
1IBCNEDE2 ;DAOU/DAC - IIV PRE REG EXTRACT (APPTS) ;18-JUN-2002
2 ;;2.0;INTEGRATED BILLING;**184,271,249,345**;21-MAR-94;Build 28
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;**Program Description**
6 ; This program finds veterans who are scheduled to be seen within a
7 ; specified date range.
8 ; Periodically check for stop request for background task
9 ;
10 Q ; can't be called directly
11 ;
12EN ; Loop through designated cross-references for updates
13 ; Pre reg extract (Appointment extract)
14 ;
15 N TODAYSDT,FRESHDAY,SLCCRIT1,MAXCNT,CNT,ENDDT,CLNC,FRESHDT
16 N APTDT,INREC,INSIEN,PAYER,PIEN,PAYERSTR,SYMBOL,SUPPBUFF
17 N DFN,OK,VAIN,INS,DATA1,DATA2,ELG,PAYERID,SETSTR,SRVICEDT,ACTINS
18 N TQIEN,IBINDT,IBOUTP,QURYFLAG,INSNAME,FOUND1,FOUND2,IBCNETOT
19 N SID,SIDACT,SIDDATA,SCNT5,SIDARRAY,SIDCNT,IBDDI,IBINS,DISYS
20 ;
21 S SETSTR=$$SETTINGS^IBCNEDE7(2) ; Get setting for pre reg. extract
22 I 'SETSTR Q ; Quit if extract is not active
23 S SLCCRIT1=$P(SETSTR,U,2) ; Selection Criteria #1
24 S MAXCNT=$P(SETSTR,U,4) ; Max # of TQ entries to create
25 S:MAXCNT="" MAXCNT=9999999999
26 S SUPPBUFF=$P(SETSTR,U,5) ; Suppress Buffer Flag
27 S FRESHDAY=$P($G(^IBE(350.9,1,51)),U,1) ; Freshness days span
28 S CNT=0 ; Init. TQ entry counter
29 S ENDDT=$$FMADD^XLFDT(DT,SLCCRIT1) ; End of appt. date selection range
30 S IBCNETOT=0 ; Initialize count for periodic TaskMan check
31 K ^TMP($J,"SDAMA301"),^TMP("IBCNEDE2",$J) ; Clean TMP globals
32 ;
33 S CLNC=0 ; Init. clinic
34 ; Loop through clinics
35 F S CLNC=$O(^SC(CLNC)) Q:'CLNC!(CNT'<MAXCNT) D Q:$G(ZTSTOP)
36 . ;
37 . D CLINICEX Q:'OK ; Check for clinic exclusion
38 . ;
39 . S ^TMP("IBCNEDE2",$J,CLNC)=""
40 ;
41 ; Set up variables for scheduling call and call
42 S IBSDA("FLDS")=8
43 S IBSDA(1)=DT_";"_ENDDT
44 S IBSDA(2)="^TMP(""IBCNEDE2"",$J,"
45 S IBSDA(3)="R"
46 I $$SDAPI^SDAMA301(.IBSDA)<1 D ERRMSG G ENQ
47 ;
48 ;
49 S CLNC=0 ; Init. clinic
50 ; Loop through clinics returned
51 F S CLNC=$O(^TMP($J,"SDAMA301",CLNC)) Q:'CLNC D Q:$G(ZTSTOP)!(CNT'<MAXCNT)
52 . ;
53 . ; Loop through patients returned
54 . S DFN=0 F S DFN=$O(^TMP($J,"SDAMA301",CLNC,DFN)) Q:'DFN!(CNT'<MAXCNT) D Q:$G(ZTSTOP)
55 .. ;
56 .. S APTDT=DT ; Check for appointment date
57 .. ;
58 .. ; Loop through dates in range at clinic
59 .. F S APTDT=$O(^TMP($J,"SDAMA301",CLNC,DFN,APTDT)) Q:('APTDT)!((APTDT\1)>ENDDT)!(CNT'<MAXCNT) D Q:$G(ZTSTOP)
60 ... ;
61 ... S SRVICEDT=APTDT\1 ;Set service date equal to appointment date
62 ... S FRESHDT=$$FMADD^XLFDT(SRVICEDT,-FRESHDAY)
63 ... ;
64 ... ; Update count for periodic check
65 ... S IBCNETOT=IBCNETOT+1
66 ... ; Check for request to stop background job, periodically
67 ... I $D(ZTQUEUED),IBCNETOT#100=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
68 ... ;
69 ... S IBSDATA=$G(^TMP($J,"SDAMA301",CLNC,DFN,APTDT))
70 ... S ELG=$P(IBSDATA,U,8)
71 ... S ELG=$S(ELG'="":ELG,1:$P($G(^DPT(DFN,.36)),U,1))
72 ... I $P($G(^DPT(DFN,0)),U,21) Q ; Exclude if test patient
73 ... I $P($G(^DPT(DFN,.35)),"^",1)'="" Q ; Exclude if patient is deceased
74 ... ;
75 ... D ELG Q:'OK ; Check for eligibility exclusion
76 ... ; D INP Q:'OK ; No longer check for inpatient status
77 ... ;
78 ... K ACTINS
79 ... D ALL^IBCNS1(DFN,"ACTINS",1)
80 ... ;
81 ... I '$D(ACTINS(0)) D NOACTIVE Q ; Patient has no active ins
82 ... ;
83 ... S INREC=0 ; Record ien
84 ... F S INREC=$O(ACTINS(INREC)) Q:('INREC)!(CNT'<MAXCNT) D
85 ... . S INSIEN=$P($G(ACTINS(INREC,0)),U,1) ; Insurance ien
86 ... . S INSNAME=$P($G(^DIC(36,INSIEN,0)),U)
87 ... . ;
88 ... . ; check for ins. to exclude (i.e. Medicare/Medicaid)
89 ... . I $$EXCLUDE^IBCNEUT4(INSNAME) Q
90 ... . ;
91 ... . S PAYERSTR=$$INSERROR^IBCNEUT3("I",INSIEN) ; Get payer info
92 ... . ;
93 ... . S SYMBOL=+PAYERSTR ; error symbol
94 ... . S PAYERID=$P(PAYERSTR,U,3) ; (National ID) payer id
95 ... . S PIEN=$P(PAYERSTR,U,2) ; Payer ien
96 ... . ;
97 ... . ; If error symbol exists, set record in insurance buffer & quit
98 ... . I SYMBOL D Q
99 ... . . I 'SUPPBUFF,'$$BFEXIST^IBCNEUT5(DFN,INSNAME) D PT^IBCNEBF(DFN,INREC,SYMBOL,"",1)
100 ... . ;
101 ... . ; Update service date and freshness date based on payers allowed
102 ... . ; date range
103 ... . D UPDDTS^IBCNEDE6(PIEN,.SRVICEDT,.FRESHDT)
104 ... . ;
105 ... . ; Update service dates for inquiry to be transmitted
106 ... . D TQUPDSV^IBCNEUT5(DFN,PIEN,SRVICEDT)
107 ... . ;
108 ... . ; Quit before filing if outstanding entries in TQ
109 ... . I '$$ADDTQ^IBCNEUT5(DFN,PIEN,SRVICEDT,FRESHDAY) Q
110 ... . ;
111 ... . S QURYFLAG="V"
112 ... . K SIDARRAY
113 ... . S SIDDATA=$$SIDCHK^IBCNEDE5(PIEN,DFN,,.SIDARRAY,FRESHDT)
114 ... . S SIDACT=$P(SIDDATA,U),SIDCNT=$P(SIDDATA,U,2)
115 ... . I SIDACT=3,'SUPPBUFF,'$$BFEXIST^IBCNEUT5(DFN,INSNAME) D PT^IBCNEBF(DFN,INREC,18,"",1) Q
116 ... . S SCNT5=$S(SIDACT=5:1,1:0)
117 ... . I CNT+SCNT5+SIDCNT>MAXCNT S CNT=MAXCNT Q ;exceeds MAXCNT
118 ... . ;
119 ... . S SID=""
120 ... . F S SID=$O(SIDARRAY(SID)) Q:SID="" D SET($P(SID,"_"),$P(SID,"_",2))
121 ... . I SIDACT=4!(SIDACT=5) D SET("","")
122 ... . Q
123 ... Q
124ENQ K ^TMP($J,"SDAMA301"),^TMP("IBCNEDE2",$J)
125 Q
126 ;
127CLINICEX ; Clinic exclusion
128 S OK=1
129 I $D(^DG(43,1,"DGPREC","B",CLNC)) S OK=0
130 Q
131 ;
132ELG ; Eligibility exclusion
133 I ELG="" S OK=0 Q
134 I $D(^DG(43,1,"DGPREE","B",ELG)) S OK=0 Q
135 S OK=1
136 Q
137 ;
138INP ; Inpatient status
139 D INP^VADPT
140 I $G(VAIN(1))'="" K VAIN S OK=0 Q
141 K VAIN
142 S OK=1
143 Q
144 ;
145NOACTIVE ; No active insurance
146 ;
147 ; Call IB utility to search for patient's inactive insurance
148 ; IBCNS passes back IBINS = 1 if active insurance was found
149 ; IBCNS sets the array IBDD to the patient's valid insurance
150 ; IBCNS sets the array IBDDI to the patient's invalid insurance
151 ;
152 N SVIBDDI
153 K IBINS,IBDD,IBDDI
154 S IBINDT=APTDT,IBOUTP=2,(FOUND1,FOUND2)=0
155 ;
156 D ^IBCNS
157 K IBDD ; don't need this array
158 I $G(IBINS)=1 Q ; if active insurance was found quit
159 M SVIBDDI=IBDDI
160 ; Inactive Insurance
161 I CNT<MAXCNT,$D(IBDDI)>0 S FOUND2=$$INAC^IBCNEDE6(.CNT,MAXCNT,.IBDDI,SRVICEDT,FRESHDAY,1)
162 M IBDDI=SVIBDDI
163 ;
164 ; Most Popular Payer
165 I CNT<MAXCNT S FOUND1=$$POP^IBCNEDE4(.CNT,MAXCNT,SRVICEDT,FRESHDAY,1,.IBDDI)
166 ;
167 I 'FOUND1,'FOUND2,(CNT<MAXCNT) D BLANKTQ
168 ;
169 K INS,IBBDI
170 Q
171 ;
172SET(SID,INR) ; Set data in TQ
173 ;
174 ; The hard coded '1' in the 3rd piece of DATA1 sets the Transmission
175 ; status of file 365.1 to "Ready to Transmit"
176 S DATA1=DFN_U_PIEN_U_1_U_""_U_SID_U_FRESHDT ; SETTQ 1st parameter
177 ;
178 ; The hardcoded '2' in the 1st piece of DATA2 is the value to tell
179 ; the file 365.1 that it is the appointment extract.
180 S DATA2=2_U_QURYFLAG_U_SRVICEDT_U_INR ; SETTQ 2nd parameter
181 ;
182 S TQIEN=$$SETTQ^IBCNEDE7(DATA1,DATA2) ; Sets in TQ
183 I TQIEN'="" S CNT=CNT+1 ; If filed increment count
184 ;
185 Q
186 ;
187BLANKTQ ; no new records were created in file 365.1 for this DFN
188 ; need to check if a blank inquiry exists (patient w/o a payer)
189 ; if it doesn't exist create a new blank inquiry
190 ;
191 ; Check for at least 1 other VAMC a patient has traveled to
192 I $$TFL^IBCNEDE6(DFN)=0 Q
193 ;
194 N DISYS
195 S PIEN=$$FIND1^DIC(365.12,,"X","~NO PAYER"),SID=""
196 ;
197 ; Update service date and freshness date based on payer allowed
198 ; date range
199 D UPDDTS^IBCNEDE6(PIEN,.SRVICEDT,.FRESHDT)
200 ;
201 ; Update service dates for inquiry to be transmitted - necessary here?
202 D TQUPDSV^IBCNEUT5(DFN,PIEN,SRVICEDT)
203 ;
204 I '$$ADDTQ^IBCNEUT5(DFN,PIEN,SRVICEDT,FRESHDAY,1) G BLANKXT
205 ;
206 S QURYFLAG="I" D SET("","")
207 S PIEN=""
208BLANKXT ;
209 Q
210 ;
211ERRMSG ; Send a message indicating an extract error has occured
212 N MGRP,XMSUB,MSG,IBX,IBM
213 ;
214 ; Set to IB site parameter MAILGROUP
215 S MGRP=$$MGRP^IBCNEUT5()
216 ;
217 S XMSUB="IIV Problem: Appointment Extract"
218 S MSG(1)="On "_$$FMTE^XLFDT(DT)_" the Appointment Extract for IIV encountered one or more"
219 S MSG(2)="errors while attempting to get Appointment data from the scheduling"
220 S MSG(3)="package."
221 S MSG(4)=""
222 S MSG(5)="Error(s) encountered: "
223 S MSG(6)=""
224 S MSG(7)=" Error Code Error Message"
225 S MSG(8)=" ---------- -------------"
226 S IBM=8,IBX=0 F S IBX=$O(^TMP($J,"SDAMA301",IBX)) Q:IBX="" S IBM=IBM+1,MSG(IBM)=" "_$$LJ^XLFSTR(IBX,13)_$G(^TMP($J,"SDAMA301",IBX))
227 S IBM=IBM+1,MSG(IBM)=""
228 S IBM=IBM+1,MSG(IBM)="As a result of this error the extract was not done. The extract"
229 S IBM=IBM+1,MSG(IBM)="will be attempted again the next night automatically. If you"
230 S IBM=IBM+1,MSG(IBM)="continue to receive error messages you should contact your IRM"
231 S IBM=IBM+1,MSG(IBM)="and possibly log a NOIS call for assistance."
232 ;
233 D MSG^IBCNEUT5(MGRP,XMSUB,"MSG(")
234 ;
235 Q
Note: See TracBrowser for help on using the repository browser.