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

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

initial load of FOIAVistA 6/30/08 version
File size: 8.8 KB
Line 
1IBCNEUT5 ;DAOU/ALA - IIV MISC. UTILITIES ;20-JUN-2002
2 ;;2.0;INTEGRATED BILLING;**184,284,271**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;**Program Description**
6 ; This program contains some general utilities or functions
7 ;
8 Q
9 ;
10MSG(MGRP,XMSUB,XMTEXT,FROMFLAG,XMY) ; Send a MailMan Message
11 ;
12 ; Input Parameters
13 ; MGRP = Mailgroup Name (optional)
14 ; XMSUB = Subject Line (required)
15 ; XMTEXT = Message Text Array Name in open format: "MSG(" (required)
16 ; FROMFLAG = Flag indicating from whom the message is sent (optional)
17 ; false/undefined: from the specific, non-human IIV user
18 ; true: from the actual user (DUZ)
19 ; XMY = recipients array; pass by reference (optional)
20 ; The possible recipients are the sender, the Mail Group in the
21 ; first parameter, and anybody else already defined in the XMY
22 ; array when this parameter is used.
23 ;
24 ; New MailMan variables and also some FileMan variables. The FileMan
25 ; variables are used and not cleaned up when sending to external
26 ; internet addresses.
27 NEW DIFROM,XMDUZ,XMDUN,XMZ,XMMG,XMSTRIP,XMROU,XMYBLOB
28 NEW D0,D1,D2,DG,DIC,DICR,DISYS,DIW
29 NEW TMPSUB,TMPTEXT,TMPY,XX
30 ;
31 I $G(FROMFLAG),$G(DUZ) S XMDUZ=DUZ
32 E S XMDUZ="IIV INTERFACE (IB)"
33 ;I $G(DUZ) S XMY(DUZ)="" ; original location of line - moved below
34 I $G(MGRP)'="" S XMY("G."_MGRP)=""
35 ; If no recipients are defined, send to postmaster
36 I '$D(XMY) S XMY(.5)=""
37 I $G(DUZ) S XMY(DUZ)=""
38 ; Store off subject, array reference and array of recipients
39 S TMPSUB=XMSUB,TMPTEXT=XMTEXT
40 M TMPY=XMY
41 D ^XMD
42 ;
43 ; Error logic
44 ; If there's an error message and the message was not originally sent
45 ; to the postmaster, then send a message to the postmaster with this
46 ; error message.
47 ;
48 I $D(XMMG),'$D(TMPY(.5)) D
49 . S XMY(.5)=""
50 . S XMTEXT=TMPTEXT,XMSUB="MailMan Error"
51 . ; Add XMMG error message as the first line of the message
52 . S XX=999999
53 . F S XX=$O(@(XMTEXT_"XX)"),-1) Q:'XX S @(XMTEXT_"XX+3)")=@(XMTEXT_"XX)")
54 . S @(XMTEXT_"1)")=" MailMan Error: "_XMMG
55 . S @(XMTEXT_"2)")="Original Subject: "_TMPSUB
56 . S @(XMTEXT_"3)")="------Original Message------"
57 . D ^XMD
58 . Q
59 Q
60 ;
61 ;
62BFEXIST(DFN,INSNAME) ; Function returns 1 if an Entered Ins Buffer File
63 ; entry exists with the same DFN and INSNAME, otherwise it returns a 0
64 ;
65 ; DFN - Patient DFN
66 ; INSNAME - Insurance Company Name File 36 - Field .01
67 ;
68 NEW EXIST,IEN
69 S EXIST=0
70 S INSNAME=$$TRIM^XLFSTR(INSNAME) ; trimmed
71 I ('DFN)!(INSNAME="") G BFEXIT
72 ;
73 S IEN=0
74 F S IEN=$O(^IBA(355.33,"C",DFN,IEN)) Q:'IEN!EXIST D
75 . ; Quit if status is NOT 'Entered'
76 . I $P($G(^IBA(355.33,IEN,0)),U,4)'="E" Q
77 . ; Quit if Ins Buffer Ins Co Name (trimmed) is NOT EQUAL to
78 . ; the Ins Co Name parameter (trimmed)
79 . I $$TRIM^XLFSTR($P($G(^IBA(355.33,IEN,20)),U))'=INSNAME Q
80 . ; Match found
81 . S EXIST=1
82 . Q
83BFEXIT ;
84 Q EXIST
85 ;
86 ;
87MGRP() ; Get the Mail Group for the IIV Interface - IB Site Parameters (51.04)
88 Q $$GET1^DIQ(350.9,"1,",51.04,"E")
89 ;
90 ;
91PYRAPP(APP,PAYERIEN) ; Get the Payer Application multiple IEN
92 ; based on the payer application name and payer ien.
93 ;
94 NEW MIEN,APPIEN,DISYS
95 S MIEN=""
96 S APPIEN=$$FIND1^DIC(365.13,,"X",APP,"B")
97 I 'APPIEN G PYRAPPX
98 I '$G(PAYERIEN) G PYRAPPX
99 S MIEN=$O(^IBE(365.12,PAYERIEN,1,"B",APPIEN,""))
100PYRAPPX ;
101 Q MIEN
102 ;
103 ;
104ACTAPP(IEN) ; Active payer applications
105 ; This function will return 1 if any of the payer applications for
106 ; this payer (being passed in by the payer IEN) are NOT deactivated.
107 ; This should not be confused with the other payer application fields
108 ; such as national active or local active. The deactivated field is
109 ; the .11 field in the payer application multiple.
110 ;
111 ; This function is invoked by the FileMan data dictionary as a screen
112 ; for the Payer field (#3.1) in the Insurance company file (#36).
113 ;
114 NEW APPIEN,ACTAPP,APPDATA
115 S APPIEN=0,ACTAPP="",IEN=+$G(IEN)
116 F S APPIEN=$O(^IBE(365.12,IEN,1,APPIEN)) Q:'APPIEN D Q:ACTAPP
117 . S APPDATA=$G(^IBE(365.12,IEN,1,APPIEN,0))
118 . I $P(APPDATA,U,11) Q
119 . I $P(APPDATA,U,12) Q
120 . S ACTAPP=1
121 . Q
122 Q ACTAPP
123 ;
124ADDTQ(DFN,PAYER,SRVDT,FDAYS,ANYPAYER) ; Function - Returns flag (0/1)
125 ; 1 - TQ File entry can be added as the service date for the patient
126 ; and payer >= MAX TQ service date + Freshness Days
127 ; If ANYPAYER is set, check for recent entries for this patient and
128 ; any payer
129 ; 0 - otherwise
130 ;
131 ; Input:
132 ; DFN - Patient DFN (File #2)
133 ; PAYER - Payer IEN (File #365.12)
134 ; SRVDT - Service dt for potential TQ entry
135 ; FDAYS - Freshness Days param (by extract type)
136 ; ANYPAYER - NUMERIC>0 if checking for any payer
137 ;
138 N ADDTQ,MAXDT
139 ;
140 S ADDTQ=1
141 I ($G(DFN)="")!($G(SRVDT)="")!($G(FDAYS)="") S ADDTQ=0 G ADDTQX
142 I '$G(ANYPAYER),$G(PAYER)="" S ADDTQ=0 G ADDTQX
143 ; MAX TQ Service Date
144 S MAXDT=$$TQMAXSV(DFN,$G(PAYER),$G(ANYPAYER))
145 I MAXDT="" G ADDTQX
146 ; If Service Date < Max Service Date + Freshness Days, do not add
147 I SRVDT<$$FMADD^XLFDT(MAXDT,FDAYS) S ADDTQ=0
148 ;
149ADDTQX ; ADDTQ exit pt
150 Q ADDTQ
151 ;
152TQUPDSV(DFN,PAYER,SRVDT) ; Update service dates & freshness dates for TQ
153 ; entries awaiting transmission
154 ;
155 N SVDT,STS,ERACT,CSRVDT,CSPAN,SPAN,DA,HL7IEN,RIEN
156 ;
157 I ($G(DFN)="")!($G(PAYER)="")!($G(SRVDT)="") G TQUPDSVX
158 ;
159 ; Loop thru all inquiries to be transmitted to update the service date
160 ; Statuses: Ready to Transmit(1), Hold(4) and Retry(6)
161 S SVDT=""
162 F S SVDT=$O(^IBCN(365.1,"AD",DFN,PAYER,SVDT)) Q:'SVDT D
163 . S DA=0
164 . F S DA=$O(^IBCN(365.1,"AD",DFN,PAYER,SVDT,DA)) Q:'DA D
165 .. ; TQ Status
166 .. S STS=$P($G(^IBCN(365.1,DA,0)),U,4)
167 .. ; Check to see if record is still scheduled to be transmitted.
168 .. ; If so, update the service date if the new service date and current
169 .. ; service date are both in the past or future and the new service
170 .. ; date is closer to Today. Also, if the current service date is in
171 .. ; the future and the new service date is in the past, update with the
172 .. ; new service date.
173 .. ; If not Ready to Transmit(1), Hold(4) and Retry(6), quit
174 .. I STS'=1,STS'=4,STS'=6 Q
175 .. ; If Hold and last Response returned Error Action - Please resubmit
176 .. ; Original Transaction (P) - do not update
177 .. I STS=4 S ERACT="" D I ERACT="P" Q
178 .. . ; Last msg sent
179 .. . S HL7IEN=$O(^IBCN(365.1,DA,2," "),-1) Q:'HL7IEN
180 .. . ; Assoc IIV Response IEN
181 .. . S RIEN=$P($G(^IBCN(365.1,DA,2,HL7IEN,0)),U,3) Q:'RIEN
182 .. . ; Error Action IEN (365.018)
183 .. . S ERACT=$P($G(^IBCN(365,RIEN,1)),U,15) Q:'ERACT
184 .. . S ERACT=$P($G(^IBE(365.018,ERACT,0)),U,1)
185 .. ;
186 .. ; Current service date for TQ entry
187 .. S CSRVDT=$P($G(^IBCN(365.1,DA,0)),U,12)
188 .. ; If current service date is today (DT), do not update
189 .. I CSRVDT=DT Q
190 .. ; If new service date is in the future and current service date is in
191 .. ; the past, do not update
192 .. I SRVDT>DT,CSRVDT<DT Q
193 .. ; If new service date is today, update
194 .. I SRVDT=DT D SAVETQ^IBCNEUT2(DA,SRVDT),SAVFRSH(DA,+$$FMDIFF^XLFDT(SRVDT,CSRVDT,1)) Q
195 .. ; If both current and new service dates are in the past or future,
196 .. ; only update, when new service date is closer to today (DT).
197 .. I ((CSRVDT<DT)&(SRVDT<DT))!((CSRVDT>DT)&(SRVDT>DT)) D Q
198 .. . S CSPAN=$$FMDIFF^XLFDT(CSRVDT,DT,1),SPAN=$$FMDIFF^XLFDT(SRVDT,DT,1)
199 .. . I CSPAN<0 S CSPAN=-CSPAN
200 .. . I SPAN<0 S SPAN=-SPAN
201 .. . I SPAN<CSPAN D SAVETQ^IBCNEUT2(DA,SRVDT),SAVFRSH(DA,+$$FMDIFF^XLFDT(SRVDT,CSRVDT,1))
202 .. ; If new service date is in the past and current service date is in
203 .. ; the future, update
204 .. I SRVDT<CSRVDT D SAVETQ^IBCNEUT2(DA,SRVDT),SAVFRSH(DA,+$$FMDIFF^XLFDT(SRVDT,CSRVDT,1)) Q
205 .. Q
206TQUPDSVX ; TQUPDSV exit pt
207 Q
208 ;
209TQMAXSV(DFN,PAYER,ANYPAYER) ; Returns MAX(TQ Service Date) for Patient & Payer
210 ; Input:
211 ; DFN - Patient DFN (2)
212 ; PAYER - Payer IEN (365.12) (If no PAYER passed in, check them all)
213 ; ANYPAYER - NUMERIC>0 if checking for any payer
214 ; Output:
215 ; TQMAXSV - MAX (most recent) service date from TQ entry for Patient &
216 ; Payer
217 ;
218 N TQMAXSV
219 S TQMAXSV=""
220 I $G(DFN)="" G TQMAXSVX
221 I '$G(ANYPAYER) S TQMAXSV=$O(^IBCN(365.1,"AD",DFN,PAYER,""),-1) G TQMAXSVX
222 ;
223 N PIEN,LASTBYP
224 S PIEN="" F S PIEN=$O(^IBCN(365.1,"AD",DFN,PIEN)) Q:PIEN="" D
225 .S LASTBYP=$O(^IBCN(365.1,"AD",DFN,PIEN,""),-1)
226 .Q:'LASTBYP ; Just in case
227 .I LASTBYP>TQMAXSV S TQMAXSV=LASTBYP
228 ;
229TQMAXSVX ; TQMAXSV exit pt
230 Q TQMAXSV
231 ;
232 ;
233SNDSSN(PIEN,APP) ; Determine Transmit SSN flag based on Payer and Payer
234 ; Application values
235 ; Input:
236 ; PIEN - Payer IEN (365.12)
237 ; APP - Payer application description (like "IIV")
238 N IBFLG
239 ;
240 S IBFLG=0
241 ;
242 I $G(PIEN)=""!($G(APP)="") G SNDSSNX
243 S IBFLG=+$P($G(^IBE(365.12,PIEN,1,+$$PYRAPP(APP,PIEN),0)),U,10)
244 ;
245SNDSSNX Q IBFLG
246 ;
247SAVFRSH(TQIEN,DTDIFF) ; Update TQ freshness date based on service date diff
248 ;
249 N DIE,DA,FDT,DR,D,D0,DI,DIC,DQ,X
250 I $G(TQIEN)="" Q
251 S FDT=$P($G(^IBCN(365.1,TQIEN,0)),U,17)
252 ; Note - will only update if FDT > 0.
253 S FDT=$$FMADD^XLFDT(FDT,+DTDIFF)
254 S DIE="^IBCN(365.1,",DA=TQIEN,DR=".17////"_FDT
255 D ^DIE
256 Q
257 ;
Note: See TracBrowser for help on using the repository browser.