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

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

initial load of WorldVistAEHR

File size: 6.3 KB
RevLine 
[613]1IBBFAPI ;OAK/ELZ - FOR OTHER PACKAGES TO QUERY INSURANCE INFO ;19-AUG-2004
2 ;;2.0;INTEGRATED BILLING;**267,297,249,317,361**;21-MAR-94;Build 9
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ; -- see IBBDOC for API documentation
6 ; no applications should call here directly
7INSUR(DFN,IBDT,IBSTAT,IBR,IBFLDS) ; Return Patient Insurance Information
8 ;
9 N ERROR,ERRORT,FCNT,IBPLN,ICNT,INSP,N,N1,NOK,PASS,PASS1,X,%
10 K ERRORT D ERRORLD
11 S NOK=-1
12 S DFN=$G(DFN)
13 S IBSTAT=$G(IBSTAT)
14 S IBDT=$P($G(IBDT),".")
15 S IBFLDS=$G(IBFLDS)
16 I IBDT,IBSTAT["A" S ERROR=107 D ERROR Q NOK
17 S (ERROR,PASS)=0 K IBR
18 I 'DFN S ERROR=102 D ERROR Q NOK
19 I '$D(^DPT(DFN)) S ERROR=106 D ERROR Q NOK
20 I IBDT]"",IBDT'?7N S ERROR=104 D ERROR Q NOK
21 I +IBDT=0 D NOW^%DTC S IBDT=$P(%,".",1)
22 I IBSTAT]"" N Y F X=1:1:$L(IBSTAT) S Y=$E(IBSTAT,X) I '$F("^A^R^P^O^I^B^",(U_Y_U)) S ERROR=105 D ERROR Q
23 I ERROR=105 Q NOK
24 I IBFLDS]"",IBFLDS'="*" N Y F X=1:1:$L(IBFLDS,",") D
25 . S Y=$P(IBFLDS,",",X)
26 . I Y'?1N.N S ERROR=103
27 . I Y?1N.N,(Y<1)!(Y>21) S ERROR=103
28 I ERROR=103 D ERROR Q NOK
29 K IBR
30 ; set buffer file flag
31 S (X,IBR("BUFFER"))=0 F S X=$O(^IBA(355.33,"C",DFN,X)) Q:'X S IBR("BUFFER")=IBR("BUFFER")+1
32 S (ICNT,N)=0 F S N=$O(^DPT(DFN,.312,N)) Q:'N I $D(^(N,0)) D
33 . S X=^DPT(DFN,.312,N,0)
34 . N X1
35 . S X1=$G(^DIC(36,+X,0)) I X1="" Q ; no insurance company entry
36 . S INSP=$P(X,U,1),IBPLN=$P(X,U,18)
37 . I IBSTAT'["R",$P(X1,U,2)="N" Q ; does not reimburse
38 . I IBSTAT'["B",$$INDEM^IBCNS1(X) Q ; indemnity policy
39 . S PASS1=0
40 . I IBSTAT'["A" D
41 . . I $P(X,U,8),IBDT<$P(X,U,8) S PASS1=1 Q ;effective after care date
42 . . I $P(X,U,4),IBDT>$P(X,U,4) S PASS1=1 Q ;terminated before care date
43 . . I $P($G(^IBA(355.3,+$P(X,U,18),0)),U,11) S PASS1=1 Q ;inactive plan
44 . . I $P(X1,U,5) S PASS1=1 Q ; inactive insurance company
45 . Q:PASS1
46 . S ICNT=ICNT+1
47 . S FCNT=$S(IBFLDS="*":22,1:$L(IBFLDS,",")) ; number of fields to pull
48 . S IBR("IBBAPI","INSUR",ICNT)=""
49 . I IBFLDS'="" F N1=1:1:FCNT D
50 . . N RET,RETVAL
51 . . S RET=$S(IBFLDS="*":N1,1:$P(IBFLDS,",",N1)),RETVAL="" I RET?1N.N,RET>0,RET<23 D @RET S IBR("IBBAPI","INSUR",ICNT,RET)=RETVAL
52 . I IBSTAT["P"!(IBSTAT["O")!(IBSTAT["I") D I PASS1=0 K IBR("IBBAPI","INSUR",ICNT) S ICNT=ICNT-1
53 . . S PASS1=0 Q:IBPLN=""
54 . . I IBSTAT["P",+$$PLCOV(IBPLN,IBDT,"PHARMACY")>0 S PASS1=1
55 . . I IBSTAT["O",+$$PLCOV(IBPLN,IBDT,"OUTPATIENT")>0 S PASS1=1
56 . . I IBSTAT["I",+$$PLCOV(IBPLN,IBDT,"INPATIENT")>0 S PASS1=1
57 I $D(IBR("IBBAPI","INSUR")),$O(IBR("IBBAPI","INSUR",0))'="ERROR" S PASS=1 F X=1:1 Q:'$D(IBR("IBBAPI","INSUR",X)) K:'$O(IBR("IBBAPI","INSUR",X,"")) IBR("IBBAPI","INSUR",X)
58 Q PASS
59ERRORLD ; load error array
60 F X=1:1:9 S ERRORT(X+100)=$P($T(ERRORLD1+X),";;",2)
61 Q
62 ;
63ERRORLD1 ; error messages
64 ;;DATABASE IS UNAVAILABLE
65 ;;PATIENT ID IS REQUIRED
66 ;;INVALID FIELD LIST
67 ;;INVALID EFFECTIVE DATE
68 ;;INVALID INSURANCE STATUS FILTER
69 ;;INVALID PATIENT ID
70 ;;INVALID COMBINATION, YOU CANNOT USE ""A"" WITH A DATE
71 ;;DATA SOURCE IS NOT DEFINED
72 ;;NO DATA ELEMENTS TO STORE
73 ;;
74ERROR ;
75 K IBR S IBR("IBBAPI","INSUR","ERROR",ERROR)=ERRORT(ERROR)
76 Q
77 ;
781 ; Ins. Comp. name
79 S RETVAL=$$GET1^DIQ(2.312,N_","_DFN_",",.01,"I")_U_$$GET1^DIQ(2.312,N_","_DFN_",",.01)
80 Q
812 ; Ins. Comp. Street Address Line 1
82 S RETVAL=$$GET1^DIQ(36,INSP_",",.111)
83 Q
843 ; Ins. Comp. City
85 S RETVAL=$$GET1^DIQ(36,INSP_",",.114)
86 Q
874 ; Ins. Comp. State
88 S RETVAL=$$GET1^DIQ(36,INSP_",",.115,"I") S:RETVAL RETVAL=RETVAL_U_$$GET1^DIQ(36,INSP_",",.115)
89 Q
905 ; Ins. Comp. Zip
91 S RETVAL=$$GET1^DIQ(36,INSP_",",.116)
92 Q
936 ; Ins. Comp. Phone
94 S RETVAL=$$GET1^DIQ(36,INSP_",",.131)
95 Q
967 ; Coordination of Benefits
97 S RETVAL=$$GET1^DIQ(2.312,N_","_DFN_",",.2,"I")_U_$$GET1^DIQ(2.312,N_","_DFN_",",.2)
98 I RETVAL="^" S RETVAL=""
99 Q
1008 ; Policy Name
101 S RETVAL=$$GET1^DIQ(2.312,N_","_DFN_",",.18,"I") S:RETVAL RETVAL=RETVAL_U_$$GET1^DIQ(355.3,RETVAL,.03)
102 Q
1039 ; Policy Reimbursable?
104 S RETVAL=$$GET1^DIQ(36,INSP_",",1,"I")
105 S RETVAL=$S(RETVAL="Y":"1^YES",RETVAL="*":"1^YES",RETVAL="**":"1^YES",RETVAL="":"1^YES",1:"0^NO")
106 Q
10710 ; Policy Effective Date
108 S RETVAL=$$GET1^DIQ(2.312,N_","_DFN_",",8,"I")
109 Q
11011 ; Policy Expiration Date
111 S RETVAL=$$GET1^DIQ(2.312,N_","_DFN_",",3,"I")
112 Q
11312 ; Subscriber Relationship
114 S RETVAL=$$GET1^DIQ(2.312,N_","_DFN_",",16,"I")
115 S RETVAL=$S(RETVAL="01":"P^PATIENT",RETVAL="02":"S^SPOUSE",RETVAL:"O^OTHER",1:"")
116 Q
11713 ; Subscriber Name
118 S RETVAL=$$GET1^DIQ(2.312,N_","_DFN_",",17)
119 Q
12014 ; Subscriber ID
121 S RETVAL=$$GET1^DIQ(2.312,N_","_DFN_",",1)
122 Q
12315 ; Pharmacy Coverage?
124 N IBCOV
125 S IBCOV=$$PLCOV(IBPLN,IBDT,"PHARMACY")
126 S RETVAL=$S(+IBCOV=0:"0^NO",1:"1^YES")
127 Q
12816 ; Outpatient Coverage?
129 N IBCOV
130 S IBCOV=$$PLCOV(IBPLN,IBDT,"OUTPATIENT")
131 S RETVAL=$S(+IBCOV=0:"0^NO",1:"1^YES")
132 Q
13317 ; Inpatient Coverage?
134 N IBCOV
135 S IBCOV=$$PLCOV(IBPLN,IBDT,"INPATIENT")
136 S RETVAL=$S(+IBCOV=0:"0^NO",1:"1^YES")
137 Q
13818 ; Group Number
139 S RETVAL=$$GET1^DIQ(355.3,$$GET1^DIQ(2.312,N_","_DFN_",",.18,"I")_",",.04)
140 Q
141 ;
14219 ; Patient Relationship to Subscriber
143 S RETVAL=$$GET1^DIQ(2.312,N_","_DFN_",",16,"I") S:RETVAL RETVAL=RETVAL_U_$$GET1^DIQ(2.312,N_","_DFN_",",16)
144 Q
145 ;
14620 ; VA Advantage and Tricare plan
147 S RETVAL=0 ; VA Advantage to be determined at a later date
148 N PLN,TYP1,TYP2,RETVAL1
149 S PLN=$$GET1^DIQ(2.312,N_","_DFN_",",.18,"I")
150 S TYP1=$$GET1^DIQ(355.3,PLN_",",.09,"I")
151 S TYP2=$$GET1^DIQ(355.1,TYP1_",",.03,"I")
152 S RETVAL1=$S(TYP2=7:1,1:0) ; determine if Tricare plan
153 S RETVAL=RETVAL_U_RETVAL1
154 Q
155 ;
15621 ; Plan Type
157 N PLN,TYP1
158 S PLN=$$GET1^DIQ(2.312,N_","_DFN_",",.18,"I")
159 S TYP1=$$GET1^DIQ(355.3,PLN_",",.09,"I")
160 S RETVAL=$S(TYP1:TYP1_U_$$GET1^DIQ(355.1,TYP1_",",.01,"I"),1:"")
161 Q
162 ;
16322 ; Subscriber Sex
164 D 12
165 I $E(RETVAL)="P" S RETVAL=$$GET1^DIQ(2,DFN_",",.02,"I") S:$L(RETVAL) RETVAL=RETVAL_U_$$GET1^DIQ(2,DFN_",",.02)
166 E S RETVAL=$$GET1^DIQ(2.312,N_","_DFN_",",3.12,"I") S:$L(RETVAL) RETVAL=RETVAL_U_$$GET1^DIQ(2.312,N_","_DFN_",",3.12)
167 Q
168 ;
169PLCOV(IBPL,IBVDT,IBCAT) ; Determine if a specific plan covers a category of coverage as of a date
170 ; IBPL - pointer to file 355.3 group insurance plan (req)
171 ; IBVDT - fileman format visit date (req)
172 ; IBCAT - pointer to file 355.31 limitation of coverage category (req)
173 N CATLIM,X,Y
174 I '$G(IBPL)!('$G(IBVDT))!('$L($G(IBCAT))) Q 0
175 S X=0
176 S IBCAT=$O(^IBE(355.31,"B",IBCAT,"")) G:IBCAT="" PLCOVQ
177 S CATLIM=$O(^IBA(355.32,"APCD",IBPL,IBCAT,+$O(^IBA(355.32,"APCD",IBPL,IBCAT,-(IBVDT+1))),""))
178 S X=$S(CATLIM="":1,1:+$P($G(^IBA(355.32,CATLIM,0)),U,4))
179PLCOVQ Q X
180 ;
Note: See TracBrowser for help on using the repository browser.