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

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

initial load of FOIAVistA 6/30/08 version
File size: 8.7 KB
Line 
1IBCEF73 ;WOIFO/SS - FORMATTER AND EXTRACTOR SPECIFIC BILL FUNCTIONS ;8/6/03 10:56am
2 ;;2.0;INTEGRATED BILLING;**232,320,358,349,377**;21-MAR-94;Build 23
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;check qualifier
6 ;IBFRM 0-both, 1=UB,2=1500
7 ;IBPROV - function in #399 (1-referring, 2-operating,etc)
8 ;IBTYPE - "C"-current insurance, "O"-other insurance
9 ;IBVAL - value to check
10CHCKSEC(IBFRM,IBPROV,IBTYPE,IBVAL) ;
11 I IBFRM=0 Q:$$CHSEC(1,IBPROV,IBTYPE,IBVAL) 1 Q $$CHSEC(2,IBPROV,IBTYPE,IBVAL)
12 Q $$CHSEC(IBFRM,IBPROV,IBTYPE,IBVAL)
13 ;
14CHSEC(IBFRM,IBPROV,IBTYPE,IBVAL) ;
15 N IBSTR S IBSTR=""
16 ;referring
17 I IBPROV=1 S IBSTR=$S(IBTYPE="C":$$OPR5(IBFRM),IBTYPE="O":$$OP4(IBFRM),1:"")
18 ;operating
19 I IBPROV=2 S IBSTR=$S(IBTYPE="C":$$OPR3(IBFRM),IBTYPE="O":$$OP2(IBFRM),1:"")
20 ;rendering
21 I IBPROV=3 S IBSTR=$S(IBTYPE="C":$$OPR2(IBFRM),IBTYPE="O":$$OP1(IBFRM),1:"")
22 ;attending
23 I IBPROV=4 S IBSTR=$S(IBTYPE="C":$$OPR2(IBFRM),IBTYPE="O":$$OP1(IBFRM),1:"")
24 ;supervising
25 I IBPROV=5 S IBSTR=$S(IBTYPE="C":$$OPR8(IBFRM),IBTYPE="O":$$OP8(IBFRM),1:"")
26 ;other
27 I IBPROV=9 S IBSTR=$S(IBTYPE="C":$$OPR4(IBFRM),IBTYPE="O":$$OP9(IBFRM),1:"")
28 Q:IBPROV=0!(IBSTR="") 1 ;if "" or facility id always return 1
29 Q IBSTR[("^"_IBVAL_"^")
30 ;
31 ;Filter invalid qualifier entries for records SUB1,SUB2,OP6,OP7,OP3
32 ; Rebuild the IBXSAVE("PROVINF" or IBXSAVE("PROVINF_FAC" array with
33 ; only ids that have valid qualifiers
34 ;IBFRM 0-both, 1=UB,2=1500
35 ;IBREC record ID whose ids are being filtered (SUB1,SUB2,etc)
36 ;IBFAC - 1 if facility check, 0 if attending/rendering check
37 ;IBTYPE - "C"-current insurance, "O"-other insurance
38 ;IBXSAVE - the array of provider ids extracted, returned filtered -
39 ; passed by reference
40CHCKSUB(IBFRM,IBREC,IBFAC,IBTYPE,IBXSAVE) ;
41 N Z,Z0,Z1,Z2,CT,IBSAVE
42 S Z="PROVINF"_$P("^_FAC",U,$G(IBFAC)+1)
43 I '$G(IBXSAVE(Z,IBXIEN)) D
44 . D F^IBCEF("N-ALL "_$S($G(IBFAC):"OUTSIDE FAC PROVIDER INF",1:"CUR/OTH PROVIDER INFO"))
45 M IBSAVE(Z,IBXIEN,IBTYPE)=IBXSAVE(Z,IBXIEN,IBTYPE) K IBXSAVE(Z,IBXIEN,IBTYPE)
46 S Z0=0 F S Z0=$O(IBSAVE(Z,IBXIEN,IBTYPE,Z0)) Q:'Z0 S Z1="" F S Z1=$O(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1)) Q:Z1="" S (Z2,CT)=0 F S Z2=$O(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2)) Q:'Z2 D
47 . N IBVAL
48 . S IBVAL=$P(IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2),U,3)
49 . I IBFRM=0 D Q
50 .. I $S($$CHSUB(1,IBREC,IBVAL):1,1:$$CHSUB(2,IBPROV,IBTYPE,IBVAL)) D
51 ... S CT=CT+1,IBXSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,CT)=IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2)
52 ... I $G(IBXSAVE(Z,IBXIEN,IBTYPE,Z0))="",$G(IBSAVE(Z,IBXIEN,IBTYPE,Z0))'="" S IBXSAVE(Z,IBXIEN,IBTYPE,Z0)=IBSAVE(Z,IBXIEN,IBTYPE,Z0)
53 . I $$CHSUB(IBFRM,IBREC,IBVAL) D
54 .. S CT=CT+1,IBXSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,CT)=IBSAVE(Z,IBXIEN,IBTYPE,Z0,Z1,Z2)
55 .. I $G(IBXSAVE(Z,IBXIEN,IBTYPE,Z0))="",$G(IBSAVE(Z,IBXIEN,IBTYPE,Z0))'="" S IBXSAVE(Z,IBXIEN,IBTYPE,Z0)=IBSAVE(Z,IBXIEN,IBTYPE,Z0)
56 Q
57 ;
58 ; Check if valid qualifier
59 ;IBFRM 0-both, 1=UB,2=1500
60 ;IBREC record ID whose ids are being filtered (SUB1,SUB2,etc)
61 ;IBVAL - value to check
62CHSUB(IBFRM,IBREC,IBVAL) ;
63 N IBSTR
64 I IBREC="SUB1" S IBSTR=$$SUB1(IBFRM)
65 I IBREC="SUB2" S IBSTR=$$SUB2(IBFRM)
66 I IBREC="OP7" S IBSTR=$$OP7(IBFRM)
67 I IBREC="OP3" S IBSTR=$$OP3(IBFRM)
68 I IBREC="OP6" S IBSTR=$$OP6(IBFRM)
69 Q:$G(IBSTR)="" 1 ;if "" always return 1
70 Q IBSTR[("^"_IBVAL_"^")
71 ;
72 ;IBFRM 0-both, 1=UB,2=1500
73OPR2(IBFRM) ;
74 Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
75 Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
76 Q ""
77 ;
78 ;IBFRM 0-both, 1=UB,2=1500
79OP1(IBFRM) ;
80 Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^"
81 Q:IBFRM=2 "^1B^1C^1D^EI^G2^LU^N5^"
82 Q ""
83 ;
84 ;IBFRM 0-both, 1=UB,2=1500
85OPR3(IBFRM) ;
86 Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
87 Q ""
88 ;
89 ;IBFRM 0-both, 1=UB,2=1500
90OP2(IBFRM) ;
91 Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^"
92 Q ""
93 ;
94 ;IBFRM 0-both, 1=UB,2=1500
95SUB1(IBFRM) ;
96 Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
97 Q:IBFRM=2 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^U3^SY^X5^"
98 Q ""
99 ;
100 ;IBFRM 0-both, 1=UB,2=1500
101OPR4(IBFRM) ;
102 Q:IBFRM=1 "^0B^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
103 Q ""
104 ;
105 ;IBFRM 0-both, 1=UB,2=1500
106OP9(IBFRM) ;
107 Q:IBFRM=1 "^1A^1B^1C^1D^1G^1H^EI^G2^LU^N5^"
108 Q ""
109 ;
110 ;IBFRM 0-both, 1=UB,2=1500
111SUB2(IBFRM) ;
112 Q:IBFRM=1 "^0B^1A^1B^1C^1G^1H^1J^EI^FH^G2^G5^LU^N5^X5^TJ^B3^BQ^SY^U3^"
113 Q:IBFRM=2 "^0B^X4^1A^1B^1C^1G^1H^G2^LU^X5^TJ^B3^BQ^SY^U3^"
114 Q ""
115 ;
116 ;IBFRM 0-both, 1=UB,2=1500
117OP3(IBFRM) ;
118 Q:IBFRM=1 "^1B^1C^EI^G2^LU^N5^"
119 Q ""
120 ;
121 ;IBFRM 0-both, 1=UB,2=1500
122OPR5(IBFRM) ;
123 Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
124 Q ""
125 ;
126 ;IBFRM 0-both, 1=UB,2=1500
127OPR8(IBFRM) ;
128 Q:IBFRM=2 "^0B^1B^1C^1D^1G^1H^EI^G2^LU^N5^SY^X5^"
129 Q ""
130 ;
131 ;IBFRM 0-both, 1=UB,2=1500
132OP4(IBFRM) ;
133 Q:IBFRM=2 "^1B^1C^1D^EI^G2^LU^N5^"
134 Q ""
135 ;
136 ;IBFRM 0-both, 1=UB,2=1500
137OP8(IBFRM) ;
138 Q:IBFRM=2 "^1B^1C^1D^EI^G2^N5^"
139 Q ""
140 ;
141 ;IBFRM 0-both, 1=UB,2=1500
142OP6(IBFRM) ;
143 Q:IBFRM=2 "^1A^1B^1C^G2^LU^N5^"
144 Q ""
145 ;
146 ;IBFRM 0-both, 1=UB,2=1500
147OP7(IBFRM) ;
148 Q:IBFRM=2 "^1A^1B^1C^G2^LU^N5^"
149 Q ""
150 ;
151 ;check qualifier for PRV1
152 ;IBFRM 0-both, 1=UB,2=1500
153 ;IBVAL - value to check
154CHCKPRV1(IBFRM,IBVAL) ;
155 I IBFRM=0 Q:$$CHPRV1(1,IBVAL) 1 Q $$CHPRV1(2,IBVAL)
156 Q $$CHPRV1(IBFRM,IBVAL)
157 ;IBFRM 0-both, 1=UB,2=1500
158CHPRV1(IBFRM,IBVAL) ;
159 N IBSTR S IBSTR=""
160 S IBSTR=$$PRV1(IBFRM)
161 Q:IBSTR="" 1
162 Q IBSTR[("^"_IBVAL_"^")
163 ;
164PRV1(IBFRM) ;
165 Q:IBFRM=1 "^1A^1C^1D^1G^1H^1J^B3^BQ^EI^FH^G2^G5^LU^SY^X5^"
166 Q:IBFRM=2 "^1B^1C^1D^1G^1H^1J^B3^BQ^EI^FH^G2^G5^LU^U3^SY^X5^"
167 Q ""
168 ;
169PTSELF ;This tag is for the CI2 segment. If the IBXSAVE("IADR") is empty
170 ;check to see if the relationship to pt is 18 (self) if so pull info
171 ;from PT1 calls
172 ;See if relationship to insured is 18 if not or if "" quit
173 N IBZ
174 D F^IBCEF("N-ALL INSURED PT RELATION","IBZ",,IBXIEN)
175 S IBZ=$G(IBZ(+$$COBN^IBCEF(IBXIEN)))
176 S IBZ=$$PRELCNV^IBCNSP1(IBZ,1)
177 I IBZ'="18" S IBXDATA="" Q
178 N IBZ D F^IBCEF("N-PATIENT STREET ADDRESS 1-3","IBZ",,IBXIEN)
179 S IBXDATA="18"
180 Q
181 ;
182NOPUNCT(X,SPACE,EXC) ; Strip punctuation from data in X
183 ; SPACE = flag if 1 strip SPACES
184 ; EXC = list of punct not to strip
185 ;
186 N PUNCT,Z
187 S PUNCT=".,-+(){}[]\/><:;?|=_*&%$#@!~`^'"""
188 I $G(SPACE) S PUNCT=PUNCT_" "
189 I $G(EXC)'="" S PUNCT=$TR(PUNCT,EXC)
190 N L S L=""
191 F S L=$O(X(L)) Q:L="" D
192 . S X(L)=$TR(X(L),PUNCT)
193 I $G(X)'="" D
194 . S X=$TR(X,PUNCT)
195 Q
196 ;
197PROVID(IBXIEN) ;This modified version of prov id call is to acquire the SSN
198 ;first, if the ssn is not available then we need to get the tax id.
199 ;we also need to provide the modifier for which value it is
200 Q:+$G(IBXIEN)=0 ""
201 S IBXSAVE("ID")=""
202 S IBXSAVE=""
203 S IBXSAVE=$$PROVSSN^IBCEF7(IBXIEN)
204 N I
205 F I=1:1:9 D
206 . I $P(IBXSAVE,"^",I)]"" S $P(IBXSAVE("ID"),U,I)="34"
207 ;If no ibxdata go look in 355.97 for 24
208 N IBRETVAL S IBRETVAL=""
209 N IBPTR,IBFT
210 F IBFT=1:1:9 D
211 . Q:$P(IBXSAVE,U,IBFT)]""
212 . S IBPTR=$$PROVPTR^IBCEF7(IBXIEN,IBFT)
213 . S $P(IBRETVAL,"^",IBFT)=$$TAX3559(IBPTR)
214 . I $P(IBRETVAL,U,IBFT)]"" D
215 . . S $P(IBXSAVE,U,IBFT)=$P(IBRETVAL,U,IBFT)
216 . . S $P(IBXSAVE("ID"),U,IBFT)="24"
217 Q IBXSAVE
218 ;
219TAX3559(IBPROV) ;
220 I $P(IBPROV,";",2)'["IBA(355.9" Q ""
221 N IB2,IB3559,IBIDTYP,IBID,IBQFL
222 S (IB3559,IBQFL)=0
223 S IBID=""
224 Q:+$G(IBPROV)=0 ""
225 F IB2=1:1 S IB3559=$O(^IBA(355.9,"B",IBPROV,IB3559)) Q:IB3559=""!IBQFL D
226 . S IBIDTYP=+$P($G(^IBA(355.9,IB3559,0)),"^",6) ;provider ID type, ptr to #355.97
227 . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3)
228 . S:IBIDTYP="EI" IBID=$P($G(^IBA(355.9,IB3559,0)),"^",7),IBQFL=1
229 ; if nothing found yet, look in file 355.93 for Facility Default ID
230 I IBID="",IBPROV["IBA(355.93" D
231 .N IB0,IBFID,IBQ
232 .S IB0=$G(^IBA(355.93,+IBPROV,0)) Q:IB0=""!($P(IB0,U,2)'=1) ; not a facility - bail out
233 .S IBFID=$P(IB0,U,9) Q:IBFID="" ; no default id on file - bail out
234 .S IBQ=$P(IB0,U,13) I +IBQ>0,$P($G(^IBE(355.97,IBQ,0)),U,3)=24 S IBID=IBFID
235 .Q
236 Q $$NOPUNCT^IBCEF(IBID)
237 ;
238 ;IBFULL-full name
239 ;IBEL - Name element : "FAMILY","GIVEN","MIDDLE","SUFFIX"
240 ;
241SSN200(IBPTR) ;
242 I $P(IBPTR,";",2)'="VA(200," Q ""
243 Q $$NOPUNCT^IBCEF($$GET1^DIQ(200,+$P(IBPTR,";")_",",9))
244 ;
245 ;Input:
246 ; IBIEN399 - ien in #399
247 ;Output:
248 ; returns a string with "^" delimiters that contains SSNs (if any)
249 ; in the position that equal to FUNCTION number
250 ; i.e. if RENDERING function # is 3 then SSN will be
251 ; in $P(return value,"^",3), etc.
252 ;
253SSN3559(IBPROV) ;
254 N IB2,IB3559,IBIDTYP,IBID,IBQFL
255 S (IB3559,IBQFL)=0
256 S IBID=""
257 Q:+$G(IBPROV)=0 ""
258 F IB2=1:1 S IB3559=$O(^IBA(355.9,"B",IBPROV,IB3559)) Q:IB3559=""!IBQFL D
259 . S IBIDTYP=+$P($G(^IBA(355.9,IB3559,0)),"^",6)
260 . S IBIDTYP=$P($G(^IBE(355.97,IBIDTYP,0)),"^",3)
261 . S:IBIDTYP="SY" IBID=$P($G(^IBA(355.9,IB3559,0)),"^",7),IBQFL=1
262 Q $$NOPUNCT^IBCEF(IBID)
263 ;
264 ;IBIDTYP-provider ID type, ptr to #355.97
265 ;IBFULL-full name
266 ;IBEL - Name element : "FAMILY","GIVEN","MIDDLE","SUFFIX"
267 ;
268PRV1FMT(P) ;FORMAT CODE FOR PRV1 SEGMENT THAT WON'T FIT ON LINE
269 K IBXDATA
270 S:'$D(IBXSAVE("BIL-PROV-SEC")) IBXSAVE("BIL-PROV-SEC")=$$PRV1^IBCEF7(IBXIEN)
271 S IBXDATA=$P($G(IBXSAVE("BIL-PROV-SEC")),"^",P)
272 I $G(IBXDATA)'="" S IBXDATA=$$NOPUNCT^IBCEF(IBXDATA,1)
273 Q
274 ;
Note: See TracBrowser for help on using the repository browser.