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

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

initial load of FOIAVistA 6/30/08 version

File size: 9.5 KB
Line 
1IBCEF ;ALB/TMP - FORMATTER SPECIFIC BILL FUNCTIONS ;22-JAN-96
2 ;;2.0;INTEGRATED BILLING;**52,80,51,137,288,296,361,371**;21-MAR-94;Build 57
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;IBIFN = bill ien throughout this routine
6COB(IBIFN) ; Bill seq
7 N A
8 S A=$P($G(^DGCR(399,IBIFN,0)),U,21) S:A="" A="P"
9 Q A
10 ;
11COBN(IBIFN,A) ; Return seq # of selected payer
12 ; A = 'PST' or null to get current bill payer seq #
13 I $G(A)="" S A=$$COB(IBIFN) S:"PST"'[A A="P"
14 I 'A S A=$F("PST",A)-1 S:A<1 A=1
15 Q A
16 ;
17POLICY(IBIFN,IBPC,IBCOBN) ; Return raw data from policy info on bill
18 ; IBPC = pc # of data element in policy (optional)
19 ; if null, 0-node is returned
20 ; IBCOBN = bill designation 1-3 or 'PST' (optional)
21 ; if null, default to current
22 N IBI
23 I "PST"[$G(IBCOBN) S IBCOBN=$$COBN(IBIFN,$G(IBCOBN))
24 S IBI=$G(^DGCR(399,IBIFN,"I"_IBCOBN))
25 I $G(IBPC) S IBI=$P(IBI,U,IBPC)
26POLICYQ Q IBI
27 ;
28INSADDR(IBIFN,IBCOB) ; Return insured's address in 7 pieces:
29 ; ALL STREET ADDRESSES^CITY^STATE ABBREVIATION^ZIP^STREET ADDRESS 1^
30 ; STREET ADDRESS 2^STREET ADDRESS 3
31 ; IBIFN = bill ien
32 ; IBCOB = bill designation (P)rimary, (S)econdary, (T)ertiary
33 ; or 1-2-3. If not defined or null, return current
34 ; If insured is patient or spouse, take from patient file top level
35 ; fields, then if top-level street addresses are blank and policy
36 ; level fields are not, use policy level
37 ; If insured is other than patient/spouse, use policy level fields only
38 N A,B,IBADDR,IBI,DFN,VAPA,VATEST
39 S:$G(IBCOB)="" IBCOB=""
40 I 'IBCOB S IBCOB=$$COBN(IBIFN,$G(IBCOB))
41 S IBI=+$$POLICY(IBIFN,16,IBCOB) ; pt relationship to insured
42 S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
43 I $S('IBI:1,1:"12"'[IBI) S IBADDR="" G INSADDQ
44 ; insured's address (patient/spouse) same as patient's
45 S VATEST("ADD",9)=+$G(^DGCR(399,IBIFN,"U")),VATEST("ADD",10)=+$P($G(^("U")),U,2)
46 D ADD^VADPT
47 S IBADDR=VAPA(1)_" "_VAPA(2)_" "_VAPA(3)_U_VAPA(4)_U_$P($G(^DIC(5,+VAPA(5),0)),U,2)_U_VAPA(6)_U_VAPA(1)_U_VAPA(2)_U_VAPA(3)
48INSADDQ S A=$P($G(^DGCR(399,IBIFN,"M")),U,(11+IBCOB))
49 S A=$G(^DPT(DFN,.312,+A,3))
50 I $TR($P(IBADDR,U)," ")="" D PI3
51 I IBI=2,$$NOPUNCT($P(A,U,6,10),1)'="" D PI3
52 Q IBADDR
53 ;
54PI3 ; build IBADDR string from patient insurance 3 node data
55 S $P(IBADDR,U,1)=$P(A,U,6)_" "_$P(A,U,7)
56 S $P(IBADDR,U,5,6)=$P(A,U,6,7)
57 F B=2,4 S $P(IBADDR,U,B)=$P(A,U,B+6)
58 S $P(IBADDR,U,3)=$P($G(^DIC(5,+$P(A,U,9),0)),U,2)
59 S $P(IBADDR,U,7)="" ; no street address 3 in file 2.312
60 Q
61 ;
62PTADDR(IBIFN,ELE) ;Return part of patient's permanent address
63 ;IBIFN = bill ien
64 ;ELE = subscript in ^UTILITY("VAPA", array for element needed
65 ;
66 I '$D(^UTILITY("VAPA",$J)) D ; once per pt
67 .N VAHOW,DFN,VAPA
68 .S VAHOW=2,DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2),VAPA("P")=""
69 .D ADD^VADPT
70 Q $P($G(^UTILITY("VAPA",$J,ELE)),U)
71 ;
72PTDEM(IBIFN,ELE,PC) ;Return part of patient's demographics
73 ;IBIFN = bill ien
74 ;ELE = subscript in ^UTILITY("VADM" array for demographic element needed
75 ;PC = pc of string at subscript ELE to be returned
76 ;
77 I '$G(PC) S PC=1
78 I '$D(^UTILITY("VADM",$J)) D ; once per pt
79 .N VAHOW,DFN,VADM
80 .S VAHOW=2,DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
81 .D DEM^VADPT
82 Q $P($G(^UTILITY("VADM",$J,ELE)),U,PC)
83 ;
84PTEMPL(IBIFN,ELE,WHOSE,VAOA) ;Return part of pt's or spouse's employer info
85 ;ELE = subscript in VAOA array for employer element needed
86 ;WHOSE = 6 if spouse's info needed 5 if pt info needed (DEFAULT)
87 ;
88 N DFN
89 S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2),VAOA("A")=$S($G(WHOSE):WHOSE,1:5)
90 D OAD^VADPT
91 Q $P($G(VAOA(ELE)),U)
92 ;
93INSDEM(IBIFN,IBCOB) ; Return insured's demographics in 6 pieces:
94 ; DATE OF BIRTH^SEX^PHONE^BRANCH pointer^RANK^SSN(no dashes)
95 ; IBIFN = bill ien
96 ; IBCOB = bill designation (P)rimary (default), (S)econdary, (T)ertiary
97 ; or 1,2,3 ... if not defined or null, return current
98 ; If insured is patient/spouse, take from patient file top level
99 ; fields, then if top-level are blank and policy level aren't,
100 ; use policy level
101 ; If insured other than patient/spouse, use policy level fields only
102 N A,B,IBDEM,IBI,DFN,VADM
103 S:$G(IBCOB)="" IBCOB=""
104 S:'IBCOB IBCOB=$$COBN(IBIFN,IBCOB)
105 S IBI=$$WHOSINS(IBIFN,IBCOB)
106 S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
107 I $S('IBI:1,1:"12"'[IBI) S IBDEM="" G INSDEM1
108 ; If it gets here, assume insured is patient/spouse
109 S A=$$PTDEM(IBIFN,0),A=$$PTADDR(IBIFN,0)
110 F A=2,3,5 S VADM(A)=$P($G(^UTILITY("VADM",$J,A)),U)
111 S VAPA(8)=$P($G(^UTILITY("VAPA",$J,8)),U)
112 I VADM(5)="",'VADM(3),VAPA(8)="" S IBDEM="" G INSDEM1
113 S $P(IBDEM,U,3)=VAPA(8),$P(IBDEM,U,6)=VADM(2)
114 I IBI=1,VADM(3) S $P(IBDEM,U)=VADM(3) ;Patient's own policy only
115INSDEM1 S A=$P($G(^DGCR(399,IBIFN,"M")),U,(11+IBCOB))
116 S A=$G(^DPT(DFN,.312,+A,3))
117 S:"MF"'[$G(VADM(5)) VADM(5)=""
118 S $P(IBDEM,U,2)=$S(IBI=1:VADM(5),1:$P(A,U,12))
119 S $P(IBDEM,U,4,5)=$P(A,U,2)_U_$P(A,U,3)
120 S:'$P(IBDEM,U) $P(IBDEM,U)=$P(A,U)
121 S:$P(IBDEM,U,3)="" $P(IBDEM,U,3)=$P(A,U,11)
122 S:$P(IBDEM,U,6)="" $P(IBDEM,U,6)=$P(A,U,5)
123 Q IBDEM
124 ;
125INSEMPL(IBIFN,IBCOB) ; Return insured's employer data in 5 pieces:
126 ; EMPLOYER NAME^EMPLOYER CITY^EMPLOYER STATE ABBREVIATION^STATE IEN^STREET 1
127 ; IBCOB = bill designation (P)rimary-default, (S)econdary, (T)ertiary
128 ; or 123 - if not defined or null, return current
129 N A,IBEMPL,IBI,DFN,VAOA
130 S IBI=$$WHOSINS(IBIFN,$G(IBCOB))
131 I $S('IBI:1,1:"12"'[IBI) S IBEMPL="^^" G INSEMPQ
132 ; insured = pt/spouse
133 S DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
134 S A=$$PTEMPL(IBIFN,0,IBI+4,.VAOA)
135 S IBEMPL=VAOA(9)_U_VAOA(4)_U_$P($G(^DIC(5,+VAOA(5),0)),U,2)_U_+VAOA(5)_U_VAOA(1)
136INSEMPQ Q IBEMPL
137 ;
138WHOSINS(IBIFN,IBCOB) ; Determine who is insured for bill IBIFN and
139 ; seq of coverage COB (123 or PST) or if not defined or null, current
140 N Z,Z0,VAEL,DFN
141 S Z=+$$POLICY(IBIFN,16,$G(IBCOB))
142 I 'Z D
143 .S Z0=$$POLICY(IBIFN,6,$G(IBCOB)),DFN=$P($G(^DGCR(399,IBIFN,0)),U,2)
144 .I Z0="v" D ELIG^VADPT I VAEL(4) S Z=1 Q ;vet is pt
145 .I Z0="s" D ELIG^VADPT I VAEL(4) S Z=2 Q ;vet is pt, so vets spouse is pt's spouse
146 .S Z=9 ; relationship of insured to pt unknown
147 Q Z
148 ;
149EMPSTAT(IBIFN,WHOSE) ;Return employment status
150 ; IBIFN = bill ien
151 ; WHOSE = v for vet, s for spouse status
152 N STAT,DFN,VAPD
153 S STAT="",DFN=+$P($G(^DGCR(399,IBIFN,0)),U,2)
154 I WHOSE="v" D OPD^VADPT S STAT=$P(VAPD(7),U)
155 I WHOSE="s" S STAT=$P($G(^DPT(DFN,.25)),U,15)
156 I STAT="" S STAT=9
157 Q STAT
158 ;
159INPAT(IBIFN,OUT) ; Determine if bill is inpatient
160 ; OUT = optional - if 1, return output value based on
161 ; inpatient/outpatient from UB-04 type of bill field
162 ; Return 1 if inpatient, 0 if not inpatient or can't be determined
163 N INPT,CODE,CODE0,IB0
164 S IB0=$G(^DGCR(399,IBIFN,0))
165 S OUT=+$G(OUT),CODE=+$P(IB0,U,5)
166 I 'OUT S INPT=CODE
167 I OUT D
168 . S CODE0=$P($G(^DGCR(399.1,+$P(IB0,U,25),0)),U,2)
169 . I CODE0=8,$P(IB0,U,24)=1 S INPT=$P(IB0,U,5) Q ; 18X
170 . I CODE0=9,$P(IB0,U,24)=8 S INPT=$P(IB0,U,5) Q ; 89X
171 . I CODE0=1,$P(IB0,U,24)=8 S INPT=0 Q ; 81X
172 . I CODE0=1,$P(IB0,U,24)=7 S INPT=0 Q ; 71X
173 . I CODE0=2,$P(IB0,U,24)=7 S INPT=0 Q ; 72X
174 . S INPT=CODE0
175 Q $S(INPT:INPT'>2,1:0)
176 ;
177INSPRF(IBIFN) ; Function to determine if bill is prof or inst
178 ; Return 1 if institutional (UB-04) claim, 0 if professional (CMS-1500) claim
179 N A
180 S A=$G(^DGCR(399,IBIFN,0))
181 I $P(A,U,27)="" S $P(A,U,27)=$S($P(A,U,19)=3:1,1:0)
182 Q $S($P(A,U,27)=1:1,1:0)
183 ;
184F(FLD,IBXRET,IBXERR1,IBIEN) ;Execute extract for data element FLD and bill IBIEN
185 ; If IBXDATA array to be returned as data value(s) of fld
186 ; D F^IBCEF("FLD NAME","IBXDATA","IBXERR") or D F^IBCEF("FLD NAME")
187 ; Variable ref-ed by IBXERR1 will contain error message if an error
188 ; @IBXRET always defined on return. It will be null if error
189 I $G(IBIEN) N IBXIEN S IBXIEN=IBIEN
190 I $G(IBXERR1)="" S IBXERR1="IBXERR"
191 N IBXHOLD
192 S IBXHOLD=""
193 I $G(IBXRET)=""!($G(IBXRET)="IBXDATA") S IBXHOLD="IBXDATA",IBXRET="IBXRET"
194 S @IBXERR1=""
195 ;
196 N FLDN,OFLD,STOP,Z,IBXERR2,IBXRETX
197 ;
198 I '$G(IBXIEN) S @IBXERR1="Invalid entry #" G FQ
199 I '$D(^IBA(364.5,"B",FLD)) S OFLD=FLD,STOP=0 D I FLD="" S @IBXERR1=OFLD_" Field not found!!" G FQ
200 .F S FLD=$O(^IBA(364.5,"B",FLD)) D Q:STOP
201 ..I $E(FLD,1,$L(OFLD))'=OFLD S FLD=""
202 ..S STOP=1
203 ;
204 S Z=0
205 F S Z=$O(^IBA(364.5,"B",FLD,Z)) Q:'Z I $P($G(^IBA(364.5,Z,0)),U,5)=399 Q
206 I 'Z S @IBXERR1=FLD_" Field not found!!" G FQ
207 ;
208 S FLDN(1)=Z D EXTONE^IBCEFG0(IBXIEN,.FLDN,""_IBXRET_"",.IBXERR2)
209 ;
210 I $G(IBXERR2)'="" S @IBXERR1=IBXERR2
211FQ S IBXARRY=$S(IBXHOLD="IBXDATA":"IBXDATA",1:""_IBXRET_"")
212 I @IBXERR1'="" K @IBXARRY S @IBXARRY="" Q
213 ;
214 I IBXHOLD="IBXDATA" S IBXRET="IBXRET"
215 M IBXRETX=@IBXRET K @IBXARRY M @IBXARRY=IBXRETX(1)
216 S:'($D(@IBXARRY)#2) @IBXARRY=""
217 Q
218 ;
219SERVDT(IBIFN,LENGTH,FORMAT) ; Return default service date for
220 ; outpatient/UB-04 lines or X12-837 institutional lines
221 ; LENGTH = null/8 for 8 digit date, 6 for 6 digit date
222 ; FORMAT = 1 = X12 format (YYYYMMDD), 2 = FM internal (NNNNNNN),
223 ; 0 = external (MMDDYY or MMDDYYYY)
224 N IBZ
225 G:$$INPAT^IBCEF(IBIFN,1)!($$FT^IBCEF(IBIFN)'=3) SERVDTQ ;Inpatient claim or billed on a CMS-1500
226 S LENGTH=$G(LENGTH),FORMAT=$G(FORMAT)
227 D F("N-STATEMENT COVERS FROM DATE","IBZ",,IBIFN)
228 I '$G(IBZ)!(FORMAT=2) G SERVDTQ
229 ;
230 I FORMAT=1 S IBZ=$$DT^IBCEFG1(IBZ,"",$S(LENGTH'=6:"D8",1:"D6")) G SERVDTQ
231 S IBZ=$$DATE^IBCF2(IBZ,$S(LENGTH=6:0,1:1),1)
232 ;
233SERVDTQ Q $G(IBZ)
234 ;
235NOPUNCT(X,SPACE,EXC) ; Strip punctuation from data in X
236 ; SPACE = flag if 1 strip SPACES
237 ; EXC = list of punctuation not to strip
238 ;
239 N PUNCT,Z
240 S PUNCT=".,-+(){}[]\/><:;?|=_*&%$#@!~`^'"""
241 I $G(SPACE) S PUNCT=PUNCT_" "
242 I $G(EXC)'="" F Z=1:1:$L(EXC) S PUNCT=$TR(PUNCT,$E(EXC,Z))
243 S X=$TR(X,PUNCT)
244 Q X
245 ;
246FT(IBIFN) ; Internal code for bill form type
247 Q +$P($G(^DGCR(399,IBIFN,0)),U,19)
248 ;
249COBCT(IBIFN) ; # of payers on claim
250 N CT,Z
251 S CT=0 F Z="I1","I2","I3" Q:'$D(^DGCR(399,IBIFN,Z)) S CT=CT+1
252 Q CT
253 ;
Note: See TracBrowser for help on using the repository browser.