source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNEQU.m@ 724

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

initial load of WorldVistAEHR

File size: 8.9 KB
Line 
1IBCNEQU ;DAOU/BHS - IIV REQUEST ELECTRONIC INSURANCE INQUIRY ;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 ; IIV - Insurance Identification and Verification Interface
6 ;
7 ; Must call from EN
8 Q
9 ;
10EN ; Entry pt
11 ; Init vars
12 N DFN,X,POP,IBFASTXT,VALMCNT,VALMBG,VALMHDR,VALMBCK,IDUZ
13 ;
14EN1 I $G(IBFASTXT) G ENX
15 S DFN=$$PAT I 'DFN G ENX
16 D EN^VALM("IBCNE REQUEST INS INQUIRY LIST")
17 G EN1
18 ;
19ENX ; EN exit pt
20 Q
21 ;
22INIT ; -- set up initial variables
23 S VALMCNT=0,VALMBG=1,IDUZ=DUZ
24 K ^TMP("IBCNEQU",$J),^TMP("IBCNEQUX",$J)
25 D HDR
26 D BLD(DFN)
27 ;
28INITX ; INIT exit pt
29 Q
30 ;
31HDR ; -- screen header for initial screen
32 N VA,VAERR,%DT,II
33 D PID^VADPT
34 S VALMHDR(1)="Request Electronic Insurance Inquiry for Patient: "_$E($P($G(^DPT(DFN,0)),U),1,20)_" "_$E($G(^(0)),1)_VA("BID")
35 S VALMHDR(2)=" "
36 S VALMHDR(3)=" "
37 S II=1
38 I +$$BUFFER^IBCNBU1(DFN) S II=II+1,VALMHDR(II)="*** Patient has Insurance Buffer Records"
39 I $P($G(^DPT(DFN,.35)),U)'="" S II=II+1,VALMHDR(II)="*** Date of Death: "_$$FMTE^XLFDT($P($G(^DPT(DFN,.35)),U)\1,"5Z")
40 Q
41 ;
42HELP ; -- help code
43 D FULL^VALM1
44 W @IOF
45 W !,"This screen lists all eligible (non-Medicaid/non-Medicare) Insurance policies"
46 W !,"for the patient. Selecting an entry in this list creates an Insurance Buffer"
47 W !,"entry with Source 'eIIV' and Override Freshness Flag 'Yes'. Setting this flag"
48 W !,"is designed to force the IIV extract to attempt to create an insurance"
49 W !,"inquiry based on this entry."
50 W !!,"Entries with an asterisk (*) preceding the Insurance Co name already exist in"
51 W !,"the Insurance Buffer with the exact same name, the exact same Group Number,"
52 W !,"and the Override Freshness Flag set to 'Yes'. Selecting an entry with an"
53 W !,"asterisk (*) will create a duplicate entry in the Insurance Buffer file for"
54 W !,"the patient."
55 W !!,"An option is available to Search for All. This creates a generalized"
56 W !,"electronic inquiry to search for any VA known insurance information for the"
57 W !,"selected patient. The inquiry is transmitted as part of the nightly"
58 W !,"IIV batch extract process."
59 D PAUSE^VALM1
60 S VALMBCK="R"
61 Q
62 ;
63EXIT ; -- exit code
64 K ^TMP("IBCNEQU",$J),^TMP("IBCNEQUX",$J)
65 Q
66 ;
67PAT() ; Prompt user to select a patient
68 ; Init vars
69 N DIC,X,Y,DISYS,%H,%I,DUOUT,DTOUT
70 ;
71 W !
72 ; Exclude non-Veterans
73 S DIC(0)="AEQMN"
74 S DIC("S")="I $G(^(""VET""))=""Y"",('$P($G(^(0)),U,21))",DIC="^DPT("
75 ;S DIC(0)="AEQMN",DIC("S")="I $G(^(""VET""))=""Y""",DIC="^DPT("
76 D ^DIC
77 I $D(DUOUT)!$D(DTOUT)!(Y<1) Q ""
78 ;
79 Q +Y
80 ;
81BLD(DFN) ; Build list of all insurance for patient
82 N IBCT,IBINS,IBDATA0,IBDATA1,IBDATA2,II,STR,IBINSIEN,IBINAME,IBHOLD
83 N VNODT,X,POP,IBBUF,IBBUFNM,IBIEN,IBBUFDT,TMPNM,GRPNUM,SFANAME
84 ;
85 K ^TMP("IBCNEQU",$J),^TMP("IBCNEQUX",$J)
86 ;
87 S (IBCT,VALMCNT)=0
88 ;
89 ; Determine if buffer entries exist for this DFN and build array by name
90 S IBIEN=0
91 F S IBIEN=$O(^IBA(355.33,"C",DFN,IBIEN)) Q:'IBIEN D
92 . S IBBUFDT=$G(^IBA(355.33,IBIEN,0))
93 . ; Include E status and those with Override Freshness Flags = 1
94 . I $P(IBBUFDT,U,4)'="E"!('$P(IBBUFDT,U,13)) Q
95 . S IBBUFNM=$$TRIM^XLFSTR($P($G(^IBA(355.33,IBIEN,20)),U))
96 . I IBBUFNM="" Q
97 . S GRPNUM=$$TRIM^XLFSTR($P($G(^IBA(355.33,IBIEN,40)),U,3))
98 . S IBBUF(IBBUFNM," "_GRPNUM)=""
99 . Q
100 ;
101 ; Populate IBINS array with Patient Insurance records
102 D ALL^IBCNS1(DFN,"IBINS")
103 I $G(IBINS(0)) S II=0 F S II=$O(IBINS(II)) Q:'II D
104 . S IBDATA0=$G(IBINS(II,0))
105 . S IBDATA1=$G(IBINS(II,1))
106 . S IBDATA2=$G(^IBA(355.3,+$P(IBDATA0,U,18),0))
107 . S GRPNUM=$$TRIM^XLFSTR($P(IBDATA2,U,4))
108 . S IBINSIEN=+$P(IBDATA0,U)
109 . Q:'IBINSIEN!'$D(^DIC(36,IBINSIEN,0))
110 . S IBINAME=$P($G(^DIC(36,IBINSIEN,0)),U)
111 . S TMPNM=$$TRIM^XLFSTR(IBINAME)
112 . ; Filter Ins Co's by name - currently filter Medicare/Medicaid
113 . I $$EXCLUDE^IBCNEUT4(TMPNM) Q
114 . S IBCT=IBCT+1
115 . S STR=""
116 . S STR=$$SETFLD^VALM1(IBCT,STR,"NUMBER")
117 . ; Update IBINAME if found in buffer already
118 . S IBINAME=$S($D(IBBUF(TMPNM," "_GRPNUM)):"*",1:"")_IBINAME
119 . S STR=$$SETFLD^VALM1(IBINAME,STR,"NAME")
120 . S STR=$$SETFLD^VALM1($E($P(IBDATA0,U,2),1,14),STR,"POLICY")
121 . S IBHOLD=$P(IBDATA0,U,6),STR=$$SETFLD^VALM1($S(IBHOLD="v":"SELF",IBHOLD="s":"SPOUSE",IBHOLD="o":"OTHER",1:"UNKNOWN"),STR,"HOLDER")
122 . S STR=$$SETFLD^VALM1($E($$GRP^IBCNS($P(IBDATA0,U,18)),1,10),STR,"GROUP")
123 . S STR=$$SETFLD^VALM1($$FMTE^XLFDT($P(IBDATA0,U,8),"5Z"),STR,"EFFDT")
124 . S STR=$$SETFLD^VALM1($$FMTE^XLFDT($P(IBDATA0,U,4),"5Z"),STR,"EXPIRE")
125 . S STR=$$SETFLD^VALM1($E($P($G(^IBE(355.1,+$P(IBDATA2,U,9),0)),U),1,8),STR,"TYPE")
126 . S STR=$$SETFLD^VALM1($P($G(^IBE(355.1,+$P(IBDATA2,U,9),0)),U),STR,"TYPEPOL")
127 . S STR=$$SETFLD^VALM1($E($P($G(^VA(200,+$P(IBDATA1,U,4),0)),U),1,15),STR,"VERIFIED BY")
128 . S STR=$$SETFLD^VALM1($$FMTE^XLFDT($P(IBDATA1,U,3),"5Z"),STR,"VERIFIED ON")
129 . S STR=$$SETFLD^VALM1($$YN($P(IBDATA2,U,6)),STR,"PRECERT")
130 . S STR=$$SETFLD^VALM1($$YN($P(IBDATA2,U,5)),STR,"UR")
131 . S STR=$$SETFLD^VALM1($$YN($P(IBDATA0,U,20)),STR,"COB")
132 . D SET(STR)
133 ;
134 S IBCT=IBCT+1
135 S STR="",II=""
136 S STR=$$SETFLD^VALM1(IBCT,STR,"NUMBER")
137 S SFANAME=$S($$ADD():"*",1:"")_"Search for All"
138 S STR=$$SETFLD^VALM1(SFANAME,STR,"NAME")
139 S IBINAME="~NO PAYER",IBDATA0=""
140 D SET(STR)
141 ;
142 S VNODT=$G(^IBA(354,DFN,50)) I VNODT D
143 . S IBCT=IBCT+1,VALMCNT=VALMCNT+1
144 . S ^TMP("IBCNEQU",$J,IBCT,0)=" Verification of No Coverage "_$$FMTE^XLFDT(VNODT,"5Z")
145 ;
146BLDX ; BLD exit pt
147 Q
148 ;
149SET(LINE) ; -- set arrays
150 ; LINE - line of text to display
151 S VALMCNT=VALMCNT+1
152 S ^TMP("IBCNEQU",$J,VALMCNT,0)=LINE
153 S ^TMP("IBCNEQU",$J,"IDX",VALMCNT,IBCT)=""
154 S ^TMP("IBCNEQUX",$J,IBCT)=VALMCNT_U_DFN_U_II_U_IBINAME_U_IBDATA0
155 Q
156 ;
157YN(X) ; -- convert 1 or 0 to yes/no/unknown
158 Q $S(X=0:"NO",X=1:"YES",1:"UNK")
159 ;
160SELECT ; User selects insurance from list to be reconfirmed
161 N IBDATA,IBDPT,IBDA,DIR,X,Y,D0,DG,DIC,DISYS,DIW,IENS,IBERROR,IBIEN,IBSYM
162 ;
163 D FULL^VALM1
164 S (IBDPT,IBDA,IBERROR)=""
165 S IBDATA=$$SEL
166 S IBDPT=+$P(IBDATA,U) ; Patient DFN
167 S IBDA=+$P(IBDATA,U,2) ; 2.312 ptr
168 I +IBDPT,+IBDA D
169 . S IBIEN=+$P(IBDATA,U,4) ; Ins Co IEN (#36)
170 . S IBSYM=+$$INSERROR^IBCNEUT3("I",IBIEN)
171 . D PT^IBCNEBF(IBDPT,IBDA,IBSYM,1,1,.IBERROR)
172 . ; Check for errors
173 . I $G(IBERROR)'="" W !!,"Insurance Buffer entry could not be created due to error! Please try again.",!
174 . I $G(IBERROR)="" W !!,"Insurance Buffer entry created!",!
175 . S DIR(0)="E" D ^DIR K DIR
176 ;
177 I $P(IBDATA,U,3)="~NO PAYER" D
178 . N PTNAME
179 . S PTNAME=$P($G(^DPT(IBDPT,0)),U)
180 . W !!,"A request to search for all known insurance information for patient"
181 . W !,PTNAME," will be processed overnight."
182 . S DIR(0)="E" D ^DIR K DIR
183 . D BLKTQ
184 S VALMBCK="R"
185 ;
186 Q
187 ;
188SEL() ; User selects insurance from list
189 N IBSELN,DIR,X,Y,DIRUT,DUOUT
190 ;
191 S IBSELN=""
192 ; Select entry to reconfirm
193 S DIR(0)="NO^1:"_VALMCNT_":0"
194 S DIR("A")="Select entry to request electronic inquiry"
195 S DIR("?",1)=" Select an entry to initiate an insurance inquiry."
196 S DIR("?",2)=" If entry contains an Insurance Co name, an Insurance"
197 S DIR("?",3)=" Buffer entry will be created for nightly batch extract."
198 S DIR("?",4)=" Select 'Search for All' entry to find all identified"
199 S DIR("?",5)=" insurances for this patient."
200 S DIR("?")=" "
201 D ^DIR K DIR
202 I $D(DIRUT)!$D(DUOUT)!(Y<1) G SELX
203 S IBSELN=$O(^TMP("IBCNEQU",$J,"IDX",Y,0))
204 I IBSELN S IBSELN=$P($G(^TMP("IBCNEQUX",$J,IBSELN)),U,2,99)
205 I $E($P(IBSELN,U,3))="*" W !!,"Selecting this entry will create a duplicate entry in the Insurance Buffer."
206 ;
207 W !
208 S DIR(0)="Y"
209 S DIR("A")="Are you sure you want to request an insurance inquiry"
210 S DIR("B")="NO"
211 S DIR("?",1)=" If yes, a request will be created for the nightly batch."
212 D ^DIR K DIR
213 I $D(DIRUT)!$D(DUOUT)!('Y) S IBSELN=""
214 ;
215SELX Q IBSELN
216 ;
217FASTEXIT ; Sets flag to indicate a quick exit from the option
218 N DIR,DIRUT,X,Y
219 S VALMBCK="Q"
220 D FULL^VALM1
221 S DIR(0)="Y",DIR("A")="Exit option entirely",DIR("B")="NO"
222 D ^DIR
223 I +Y S IBFASTXT=1
224 Q
225 ;
226ADD() ;
227 NEW PAYER,TQIEN,OK,STR,SRVICEDT,FRESHDT,DATA1,DATA2,TQIEN,FRESHDAY
228 I '$D(^IBCN(365.1,"E",DFN)) Q 0 ; Does this pt have a TQ entry?
229 S (TQIEN,OK)=""
230 S PAYER=$$FIND1^DIC(365.12,,"X","~NO PAYER") ; Get payer IEN
231 F S TQIEN=$O(^IBCN(365.1,"E",DFN,TQIEN)) Q:'TQIEN!OK D
232 . S STR=$G(^IBCN(365.1,TQIEN,0))
233 . ; If "~NO PAYER" & Transmitted
234 . I $P(STR,U,3)=PAYER,$P(STR,U,4)=2 S OK=1 Q
235 . ; If "~NO PAYER" & Ready to Transmit & override flag
236 . I $P(STR,U,3)=PAYER,($P(STR,U,4)=1),($P(STR,U,14)=1) S OK=1 Q
237 I 'OK Q 0
238 Q 1
239 ;
240BLKTQ ; Create a ~NO PAYER request for 'Search for All'
241 NEW PAYER,SRVICEDT,FRESHDT,DATA1,DATA2,TQIEN,FRESHDAY
242 S PAYER=$$FIND1^DIC(365.12,,"X","~NO PAYER")
243 D NPINIT ; Update service date and freshness
244 ; Update service dates for inquiries to be transmitted
245 S DATA1=DFN_U_PAYER_U_1_U_""_U_""_U_FRESHDT
246 S DATA2=4_U_"I"_U_SRVICEDT
247 S TQIEN=$$SETTQ^IBCNEDE7(DATA1,DATA2,"",1)
248 Q
249 ;
250BLKX Q
251 ;
252NPINIT ; Initialize variables for ~NO PAYER
253 S SRVICEDT=DT
254 S FRESHDAY=$P($G(^IBE(350.9,1,51)),U)
255 S FRESHDT=$$FMADD^XLFDT(SRVICEDT,-FRESHDAY)
256 ;
257 ; Update service date and freshness date based on payer allowed
258 Q
Note: See TracBrowser for help on using the repository browser.