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

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

initial load of FOIAVistA 6/30/08 version
File size: 6.9 KB
Line 
1IBCNSU ;ALB/AAS - INSURANCE UTILITY ROUTINE ;19-MAY-93
2 ;;2.0;INTEGRATED BILLING;**28,103,371**; 21-MAR-94;Build 57
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5AB(IBCPOL,IBYR,IBASK) ; -- Return entry in Annual Benefits file
6 ; Input: IBCPOL = pointer to health insurance policy file
7 ; IBYR = fileman internal date, Default = dt
8 ; IBASK = 1 if want to ask okay to add new entry
9 ;
10 ; Output: IBCAB = pointer to Annual Benefits file if added, else null
11 ;
12 N DIR,IBCAB
13 S IBCAB=""
14 I $G(IBCPOL)="" G ABQ
15 I $G(IBYR)="" S IBYR=DT
16 ;S IBYR=$E(IBYR,1,3)_"0000"
17 ;
18 ; -- try to find entry for policy for year
19 S IBCAB=$O(^IBA(355.4,"APY",IBCPOL,-IBYR,0))
20 ;
21 ; -- if no match add new entry
22 I 'IBCAB D
23 .I $G(IBASK) S DIR(0)="Y",DIR("A")="Are you adding a new Annual Benefits YEAR",DIR("B")="YES" D ^DIR I $D(DIRUT)!(Y<1) S VALMQUIT="" Q
24 .S IBCAB=$$ADDB(IBCPOL,IBYR)
25 .Q
26ABQ Q IBCAB
27 ;
28ADDB(IBCPOL,IBYR) ; -- add entries to Annual Benefits file
29 ; Input: IBCPOL = pointer to health insurance policy file
30 ; IBYR = fileman internal date, Default = dt
31 ;
32 ; Output: IBCAB = pointer to Annual Benefits file if added, else null
33 ;
34 N %DT,IBN1,IBCAB,DIC,DIE,DR,DA,DLAYGO,DO,DD
35 S IBCAB=""
36 I $G(IBCPOL)="" G ADDBQ
37 I $G(IBYR)="" S IBYR=DT
38 K DD,DO,DIC,DR S DIC="^IBA(355.4,",DIC(0)="L",DLAYGO=355.4
39 ;
40 ;S X=$E(IBYR,1,3)_"0000"
41 S X=IBYR D FILE^DICN I +Y<0 G ADDBQ
42 S (IBCAB,DA)=+Y,DIE="^IBA(355.4,",DR=".02////"_IBCPOL
43 D ^DIE K DIC,DIE,DA,DR
44ADDBQ Q IBCAB
45 ;
46CHIP(IBCDFND) ; -- convert node with no hip pointer to one with hip pointer
47 ; Input: IBCDFND = zeroth node of insurance type multiple
48 ; = ^dpt(dfn,.312,ibcdfn,0)
49 ;
50 ; Output: IBCPOL = pointer to policy file
51 ;
52 N IBCNS,IBGRP,IBGRNA,IBGRNU
53 S IBCNS=+IBCDFND,IBGRNA=$P(IBCDFND,"^",15),IBGRNU=$P(IBCDFND,"^",3),IBGRP=0
54 I IBGRNA'=""!(IBGRNU'="") S IBGRP=1
55 S IBCPOL=$$HIP(IBCNS,IBGRP,IBGRNA,IBGRNU)
56CHIPQ Q IBCPOL
57 ;
58HIP(IBCNS,IBGRP,IBGRNA,IBGRNU) ; -- find internal entry number in policy file
59 ; Input: IBCNS = pointer to ins co file
60 ; IBGRP = 1 if group policy, 0 if not
61 ; IBGRNA = group name
62 ; IBGRNU = group number
63 ;
64 ; Output: IBCPOL = pointer to policy file
65 ;
66 N %DT
67 S IBCPOL=""
68 I $G(^DIC(36,+$G(IBCNS),0))="" G HIPQ
69 S IBGRP=+$G(IBGRP) ; if undefine, is not a group policy
70 I 'IBGRP S IBCPOL=$$ADDH(IBCNS,IBGRP) G HIPQ
71 ;
72 S:$G(IBGRNU)="" IBGRNU="IB ZZZZZ"
73 I IBGRNU'="IB ZZZZZ" S IBCPOL=$O(^IBA(355.3,"AGNU",IBCNS,IBGRNU,0))
74 I IBCPOL,$P($G(^IBA(355.3,+IBCPOL,0)),"^",3)=IBGRNA G HIPQ ; match both
75 ;
76 S:$G(IBGRNA)="" IBGRNA="IB ZZZZZ"
77 S IBCPOL=$O(^IBA(355.3,"AGNA",IBCNS,IBGRNA,0))
78 I IBCPOL,$P($G(^IBA(355.3,+IBCPOL,0)),"^",4)=IBGRNU G HIPQ ; match both
79 ;
80 I 'IBCPOL S IBCPOL=$$ADDH(IBCNS,IBGRP) D
81 .I IBGRNA="",IBGRNU="" Q
82 .S:IBGRNA="IB ZZZZZ" IBGRNA="" S:IBGRNU="IB ZZZZZ" IBGRNU=""
83 .S DA=IBCPOL,DIE="^IBA(355.3,",DR=".03////"_$$STRIP(IBGRNA,";")_";.04////"_$$STRIP(IBGRNU,";")
84 .D ^DIE K DA,DR,DIC,DIE
85HIPQ Q IBCPOL
86 ;
87ADDH(IBCNS,IBGRP,IBGNA,IBGNU) ; -- add entries to health insurance policy file (355.3)
88 ; Input: IBCNS = pointer to ins co file
89 ; IBGRP = 1 if group policy, 0 if no
90 ;
91 ; Output: IBCPOL = pointer to policy file, if added else null
92 ;
93 N %DT,IBN1,IBCAB,DIC,DIE,DR,DA,DLAYGO,DO,DD
94 S IBCPOL=""
95 I $G(IBCNS)="" G ADDHQ
96 K DD,DO,DIC,DR S DIC="^IBA(355.3,",DIC(0)="L",DLAYGO=355.3
97 ;
98 S X=IBCNS D FILE^DICN I +Y<0 G ADDHQ
99 S (DA,IBCPOL)=+Y,DIE="^IBA(355.3,",DR=".02////"_+$G(IBGRP)
100 I IBGRP=0,$G(DFN) S DR=DR_";.1////"_DFN
101 I $D(IBGNU) S DR=DR_";.04///^S X=IBGNU"
102 I $D(IBGNA) S DR=DR_";.03///^S X=IBGNA"
103 D ^DIE K DA,DR,DIE,DIC
104 I $G(IBCNTP)'="" S IBCNTP=IBCNTP+1
105ADDHQ Q IBCPOL
106 ;
107ODELP(DFN,INS) ; -- can an insurance policy be deleted
108 ; -- called by ^dd(2.312,0,"del",.01) and by ibcnsm
109 ; -- input dfn: ien of patient in file 2.
110 ; ins: ien of ins. co in file 36
111 ;
112 ; -- output 1 if no deletion allowed
113 ; 0 if deletion allowed
114 N I,X,Y S X=0
115 ;
116 ; -- do not delete if any uncancelled bills
117 S J=0 F S J=$O(^DGCR(399,"AE",DFN,INS,J)) Q:'J I $P(^DGCR(399,J,"S"),"^",17)="" S X=1 Q
118ODELPQ Q X
119 ;
120STRIP(X,X1) ; -- strip characters from string
121 ; input: x = string
122 ; x1 = character to strip (default is ";"
123 N I,X2
124 S X2="" S:$G(X1)="" X1=";"
125 S X1=$E(X1)
126 F I=1:1 S X2=X2_$P(X,X1,I) Q:($P(X,X1,I+1,999)'[X1)
127 Q X2
128 ;
129 ;
130DELP(DFN,INS,IBC) ; -- can an insurance policy be deleted
131 ; -- called by ^dd(2.312,0,"del",.01) and by ibcnsm
132 ; -- input dfn: ien of patient in file 2.
133 ; ins: ien of ins. co in file 36
134 ; ibc: ien of policy in file 2.312 to do a match
135 ;
136 ; -- output 1 if no deletion allowed
137 ; 0 if deletion allowed
138 ;
139 N ARR,J,ONEPOL,X
140 ;
141 ; - check input
142 I '$G(DFN)!'$G(INS) S X=1 G DELPQ
143 ;
144 ; - see if vet has more than one policy with carrier; set flag
145 ; - also, if no policy is passed, assume the patient has one policy
146 I $G(IBC) D
147 .S J=0 F S J=$O(^DPT("AB",IBC,DFN,J)) Q:'J S ARR(J)=$G(^DPT(DFN,.312,J,0))
148 .S (J,ONEPOL)=0 S J=$O(ARR(J)) I J,'$O(ARR(J)) S ONEPOL=1
149 E S ONEPOL=1
150 ;
151 ;
152 ; -- do not delete if any uncancelled bills
153 S (J,X)=0 F S J=$O(^DGCR(399,"AE",DFN,INS,J)) Q:'J D Q:X
154 .;
155 .N ARRP,POL,K,L,M,MP,S,Z
156 .S Z=$G(^DGCR(399,J,0)),M=$G(^("M")),MP=$G(^("MP")),S=$G(^("S"))
157 .;
158 .; - skip cancelled bills
159 .I $P(S,"^",17)'="" Q
160 .;
161 .; - set flag if the patient has just one policy with the company
162 .I ONEPOL S X=1 Q
163 .;
164 .; - if there are no policy pointers in the claim,
165 .I '$P(M,"^",12),'$P(M,"^",13),'$P(M,"^",14),'$P(MP,"^",2) D Q
166 ..;
167 ..; - find all policies effective on the event date
168 ..S K=0 F S K=$O(ARR(K)) Q:'K S POL=ARR(K) D
169 ...I $P(POL,"^",8) Q:$P(Z,"^",3)<$P(POL,"^",8)
170 ...I $P(POL,"^",4) Q:$P(Z,"^",3)>$P(POL,"^",4)
171 ...S ARRP(K)=""
172 ..;
173 ..; - if there are two such policies, trust user judgement and assume
174 ..; - policy is not related to this claim.
175 ..S L=$O(ARRP(0)) I L,$O(ARR(L)) Q
176 ..;
177 ..; - if there is just one policy, and it is the same as the one
178 ..; - passed in, do not allow deletion.
179 ..I L=IBC S X=1
180 .;
181 .; - if one of the claim policy pointers is the same as the policy
182 .; - passed in, do not allow deletion.
183 .I $P(MP,"^",2)=IBC S X=1 Q
184 .I $P(M,"^",12)=IBC!($P(M,"^",13)=IBC)!($P(M,"^",14)=IBC) S X=1
185 ;
186 ;
187DELPQ Q X
188 ;
189DUPADDRL(DATA,IBCNS,FLD1,FLD2) ; Insurance address lines can not be duplicated
190 ; DATA - Value being compared
191 ; FLD1 - First field to check against
192 ; FLD2 - Second field to check against (OPTIONAL)
193 ;
194 ; Returns 1 if this field is a duplicate of another field.
195 ;
196 N Z1,Z2
197 Q:$G(DATA)="" 0 ; should not happen because this is invoked as an input transform
198 Q:'$G(IBCNS) 1 ; stop from editing through fileman
199 S DATA=$$UP^XLFSTR($G(DATA)),DATA=$$TRIM^XLFSTR(DATA)
200 S Z1=$$GET1^DIQ(36,+$G(IBCNS),+$G(FLD1),"I")
201 S Z1=$$UP^XLFSTR(Z1),Z1=$$TRIM^XLFSTR(Z1)
202 S Z2=$$GET1^DIQ(36,+$G(IBCNS),+$G(FLD2),"I")
203 S Z2=$$UP^XLFSTR(Z2),Z2=$$TRIM^XLFSTR(Z2)
204 I DATA=Z1 D CLEAN^DILF Q 1
205 I DATA=Z2 D CLEAN^DILF Q 1
206 D CLEAN^DILF
207 Q 0
208 ;
Note: See TracBrowser for help on using the repository browser.