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

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

initial load of FOIAVistA 6/30/08 version
File size: 7.7 KB
Line 
1IBCNS1 ;ALB/AAS - INSURANCE MANAGEMENT SUPPORTED FUNCTIONS ;22-JULY-91
2 ;;2.0;INTEGRATED BILLING;**28,60,52,85,107,51,137,240,371**;21-MAR-94;Build 57
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5INSURED(DFN,IBINDT) ; -- Is patient insured
6 ; --Input DFN = patient
7 ; IBINDT = (optional) date insured (default = today)
8 ; -- Output = 0 - not insured
9 ; = 1 - insured
10 ;
11 N J,X,IBINS S IBINS=0,J=0
12 I '$G(DFN) G INSQ
13 I '$G(IBINDT) S IBINDT=DT
14 F S J=$O(^DPT(DFN,.312,J)) Q:'J S X=$G(^(J,0)) S IBINS=$$CHK(X,IBINDT) Q:IBINS
15INSQ Q IBINS
16 ;
17PRE(DFN,IBINDT) ; -- is pre-certification required for patient
18 N X,Y,J,IBPRE
19 S IBPRE=0,J=0
20 S:'$G(IBINDT) IBINDT=DT
21 F S J=$O(^DPT(DFN,.312,J)) Q:'J S X=$G(^(J,0)) I $$CHK(X,IBINDT),$P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",6) S IBPRE=1 Q
22PREQ Q IBPRE
23 ;
24UR(DFN,IBINDT) ; -- is ur required for patient
25 N X,Y,J,IBPRE
26 S IBUR=0,J=0
27 S:'$G(IBINDT) IBINDT=DT
28 F S J=$O(^DPT(DFN,.312,J)) Q:'J S X=$G(^(J,0)) I $$CHK(X,IBINDT),$P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",5) S IBUR=1 Q
29URQ Q IBUR
30 ;
31CHK(X,Z,Y) ; -- check one entry for active
32 ; -- Input X = Zeroth node of entry in insurance multiple (2.312)
33 ; Z = date to check
34 ; Y = 2 if want will not reimburse
35 ; = 3 if want will not reimburse AND indemnity plans
36 ; = 4 if want will not reimburse, but only if it's
37 ; MEDICARE
38 ; -- Output 1 = Insurance Active
39 ; 0 = Inactive
40 ;
41 N Z1,X1
42 S Z1=0,Y=$G(Y)
43 I Y'=3,$$INDEM(X) G CHKQ ; is an indemnity policy or company
44 S X1=$G(^DIC(36,+X,0)) G:X1="" CHKQ ;insurance company entry doesn't exist
45 I $P(X,"^",8) G:Z<$P(X,"^",8) CHKQ ;effective date later than care
46 I $P(X,"^",4) G:Z>$P(X,"^",4) CHKQ ;care after expiration date
47 I $P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",11) G CHKQ ;plan is inactive
48 G:$P(X1,"^",5) CHKQ ;insurance company inactive
49 I Y<2 G:$P(X1,"^",2)="N" CHKQ ;insurance company will not reimburse
50 I Y=4,$P(X1,"^",2)="N",'$$MCRWNR^IBEFUNC(+X) G CHKQ ;only MEDICARE WNR
51 S Z1=1
52CHKQ Q Z1
53 ;
54ACTIVE(IBCIFN) ; -- is this company active for this patient for this date
55 ; -- called from input transform and x-refs for fields 101,102,103
56 ; -- input
57 N ACTIVE,DFN,IBINDT
58 S DFN=$P(^DGCR(399,DA,0),"^",2),IBINDT=$S(+$G(^DGCR(399,DA,"U")):+$G(^("U")),1:DT)
59 ;
60ACTIVEQ Q ACTIVE
61 ;
62DD ; - called from input transform and x-refs for field 101,102,103
63 ; - input requires da=internal entry number in 399
64 ; - outputs IBdd(ins co.) array
65 N DFN S DFN=$P(^DGCR(399,DA,0),"^",2),IBINDT=$S(+$G(^DGCR(399,DA,"U")):+$G(^("U")),1:DT)
66 D ALLACT
67DDQ K IBINDT Q
68 ;
69 ;
70ALLACT ; -- return active insurance zeroth nodes in ibdd(ins co,entry in mult)
71 N X,X1
72 S (X1,IBDD)=0
73 F S X1=$O(^DPT(DFN,.312,X1)) Q:'X1 S X=$G(^(X,0)) I $$CHK(X,IBINDT) S IBDD(+X,X1)=X
74 ;
75ALLACTQ Q
76 ;
77HDR W !?4,"Insurance Co.",?22,"Policy #",?40,"Group",?52,"Holder",?60,"Effective",?70,"Expires" S X="",$P(X,"=",IOM-4)="" W !?4,X
78 Q
79 ;
80 ;
81D1 N X Q:'$D(IBINS)
82 W !?4,$S($D(^DIC(36,+IBINS,0)):$E($P(^(0),"^",1),1,16),1:"UNKNOWN")
83 W ?22,$E($P(IBINS,"^",2),1,16)
84 W ?40,$E($$GRP^IBCNS($P(IBINS,"^",18)),1,10)
85 S X=$P(IBINS,"^",6) W ?52,$S(X="v":"SELF",X="s":"SPOUSE",1:"OTHER")
86 W ?60,$$DAT1^IBOUTL($P(IBINS,"^",8)),?70,$$DAT1^IBOUTL($P(IBINS,"^",4))
87 Q
88 ;
89ALL(DFN,VAR,ACT,ADT,SOP) ; -- find all insurance data on a patient
90 ;
91 ; -- input DFN = patient
92 ; VAR = variable to output in format of abc
93 ; or abc(dfn)
94 ; or ^tmp($j,"Insurance")
95 ; ACT = 1 if only active ins. desired
96 ; = 2 if active and will not reimburse desired
97 ; = 3 if active, will not reimburse, and indemnity are
98 ; all desired (for the $$INSTYP function below)
99 ; = 4 if only active and MEDICARE WNR only desired
100 ; ADT = if ACT=1 or 4, then ADT is the internal date to check
101 ; active for, default = dt
102 ; SOP = if SOP=1, then sort policies in COB order
103 ;
104 ; -- output var(0) =: number of entries insurance multiple
105 ; var(x,0) =: ^dpt(dfn,.312,x,0)
106 ; var(x,1) =: ^dpt(dfn,.312,x,1)
107 ; var(x,2) =: ^dpt(dfn,.312,x,2)
108 ; var(x,3) =: ^dpt(dfn,.312,x,3)
109 ; var(x,4) =: ^dpt(dfn,.312,x,4)
110 ; var(x,5) =: ^dpt(dfn,.312,x,5)
111 ; var(x,355.3) =: ^iba(355.3,$p(var(x,0),"^",18),0)
112 ; var("S",COB sequence,x) =: (null) as an xref for COB
113 ;
114 N X,IBMRA,IBSP
115 S X=0 I $G(ACT),$E($G(ADT),1,7)'?7N S ADT=DT
116 S (IBMRA,IBSP)=0 ;Flag to say if pt has medicare wnr, spouse has policy
117 F S X=$O(^DPT(DFN,.312,X)) Q:'X I $D(^(X,0)) D
118 .I $G(ACT),'$$CHK(^DPT(DFN,.312,X,0),ADT,$G(ACT)) Q
119 .S @VAR@(0)=$G(@VAR@(0))+1
120 .S @VAR@(X,0)=$$ZND(DFN,X)
121 .S @VAR@(X,1)=$G(^DPT(DFN,.312,X,1))
122 .S @VAR@(X,2)=$G(^DPT(DFN,.312,X,2))
123 .S @VAR@(X,3)=$G(^DPT(DFN,.312,X,3))
124 .S @VAR@(X,4)=$G(^DPT(DFN,.312,X,4))
125 .S @VAR@(X,5)=$G(^DPT(DFN,.312,X,5))
126 .S @VAR@(X,355.3)=$G(^IBA(355.3,+$P($G(^DPT(DFN,.312,X,0)),"^",18),0))
127 .I $G(SOP) D
128 ..N COB,WHO
129 ..S COB=$P(@VAR@(X,0),U,20)
130 ..S WHO=$P(@VAR@(X,0),U,6) S:WHO="s" IBSP=1
131 ..I $$MCRWNR^IBEFUNC(+@VAR@(X,0)) D
132 ... S COB=.5,IBMRA=1
133 ...
134 ..S COB=$S(COB'="":COB,WHO="v":1,WHO="s":$S(IBMRA:1,1:2),1:3)
135 ..S @VAR@("S",COB,X)=""
136 ..Q
137 ; Ck for spouse's insurance, move it before any MEDICARE WNR if sorting
138 I $G(SOP),IBMRA,IBSP D
139 . ; Shuffle Medicare WNR, if necessary
140 . S X=0 F S X=$O(@VAR@("S",.5,X)) Q:'X S @VAR@("S",2,X)="" K @VAR@("S",.5,X)
141 . S X=0 F S X=$O(@VAR@("S",2,X)) Q:'X I $P(@VAR@(X,0),U,6)="s",'$P(@VAR@(X,0),U,20) S @VAR@("S",1,X)="" K @VAR@("S",2,X)
142ALLQ Q
143 ;
144ALLWNR(DFN,VAR,ADT) ; Returns 'all active and MEDICARE WNR'
145 D ALL(DFN,VAR,4,ADT)
146 Q
147 ;
148ZND(DFN,NODE) ; -- set group number and group name back into zeroth node of ins. type
149 N X,Y S (X,Y)=""
150 I '$G(DFN)!('$G(NODE)) G ZNDQ
151 S X=$G(^DPT(+DFN,.312,+NODE,0))
152 S Y=$G(^IBA(355.3,+$P(X,"^",18),0)) I Y="" G ZNDQ
153 S $P(X,"^",3)=$P(Y,"^",4) ; move group number
154 S $P(X,"^",15)=$P(Y,"^",3) ; move group name
155 ;
156ZNDQ Q X
157 ;
158INDEM(X) ; -- is this an indemnity plan
159 ; -- input zeroth node if insurance type field
160 N IBINDEM,IBCTP
161 S IBINDEM=1
162 I $P($G(^DIC(36,+X,0)),"^",13)=15 G INDEMQ ; company is indemnity co.
163 S IBCTP=$P($G(^IBA(355.3,+$P(X,"^",18),0)),"^",9)
164 I IBCTP,$P($G(^IBE(355.1,+IBCTP,0)),"^",3)=9 G INDEMQ ; plan is an indemnity plan
165 S IBINDEM=0
166INDEMQ Q IBINDEM
167 ;
168 ;
169INSTYP(DFN,DATE) ; -- return type of insurance policy for patient
170 ;
171 ; -- input dfn := pointer to patient file (required)
172 ; date := date of insurance (optional, default = today)
173 ;
174 ; -- output Major Category of type of Plan (file 355.1, field .03)
175 ; for policy which would be billed first (cob)
176 ; null no insurance found
177 ; 1 MAJOR MEDICAL (default)
178 ; 2 DENTAL
179 ; 3 HMO
180 ; 4 PPO
181 ; 5 MEDICARE
182 ; 6 MEDICAID
183 ; 7 TRICARE
184 ; 8 WORKMANS COMP
185 ; 9 INDEMNITY
186 ; 10 PRESCRIPTION
187 ; 11 MEDICARE SUPPLEMENTAL
188 ; 12 ALL OTHER
189 ;
190 N TYPE,POL,IBCPOL
191 S TYPE=""
192 I '$G(DFN) G INSTYPQ
193 I '$G(DATE) S DATE=DT
194 D ALL(DFN,"POL",3,DATE)
195 I $G(POL(0))<1 G INSTYPQ
196 I $G(POL(0))=1 S IBCPOL=+$O(POL(0))
197 I $G(POL(0))>1 S IBCPOL=$$COB(.POL)
198 ;
199 I IBCPOL S TYPE=$P($G(^IBE(355.1,+$P($G(POL(IBCPOL,355.3)),"^",9),0)),"^",3)
200 I TYPE="" S TYPE=1 ;default is major medical
201 ;
202INSTYPQ Q TYPE
203 ;
204COB(POL) ; -- find policy with high coordination of benefits
205 N I,X,IBC,COB,WHO,IBCOB
206 ;
207 S IBC=""
208 S I=0 F S I=$O(POL(I)) Q:'I D
209 .S WHO=$P($G(POL(I,0)),"^",6),COB=$P($G(POL(I,0)),"^",20)
210 .S X=$S(COB'="":COB,WHO="v":1,WHO="s":2,1:3)
211 .I 'IBC S IBC=I,IBCOB=X Q
212 .I X<IBCOB S IBC=I,IBCOB=X
213 Q IBC
Note: See TracBrowser for help on using the repository browser.