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

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

initial load of FOIAVistA 6/30/08 version
File size: 8.5 KB
Line 
1IBCEF7 ;WOIFO/SS - FORMATTER AND EXTRACTOR SPECIFIC BILL FUNCTIONS ;8/6/03 10:56am
2 ;;2.0;INTEGRATED BILLING;**232,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5ALLPROV ;called from #364.5 entry "N-ALL CUR/OTH PROVIDER INFO"
6 I +$G(IBXSAVE("PROVINF",IBXIEN))=0 N IBZ D PROVIDER(IBXIEN,"C",.IBZ),PROVIDER(IBXIEN,"O",.IBZ) S IBXSAVE("PROVINF",IBXIEN)=IBXIEN M IBXSAVE("PROVINF",IBXIEN)=IBZ
7 Q
8 ;for PRV1
9 ;Input:
10 ; IB399 ien of #399
11PRV1(IB399) ;
12 N IBN,IBZ,IBZ1,IBZN,IBZD,IBRES,IBIND,IBDEF,IBDEFTYP,IBQ,IBFRMTYP,IBZNAME
13 S IBFRMTYP=+$$FT^IBCEF(IB399)
14 S IBN=0,IBIND=0,IBRES="",IBQ=0
15 S IBDEF=$P($G(^DGCR(399,IB399,"M1")),U,$$COBN^IBCEF(IB399)+1),IBDEFTYP=""
16 I IBDEF'="" S IBDEFTYP=$$SOP^IBCEP2B(IB399,"")
17 I IBDEFTYP'="",$$CHCKPRV1^IBCEF73($S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0),IBDEFTYP)=0 S (IBDEF,IBDEFTYP)=""
18 I IBDEF'="",IBDEFTYP'="" S IBIND=IBIND+2,$P(IBRES,U,IBIND)=(IBDEFTYP_U_IBDEF)
19 F S IBN=$O(^IBE(355.97,IBN)) Q:+IBN=0!(IBQ=1) D
20 . S IBZ=$G(^IBE(355.97,IBN,0)),IBZ1=$G(^(1))
21 . Q:$P(IBZ,"^",4)=""!$P(IBZ1,U,9) ;if no FACILITY'S DEFAULT ID #
22 . Q:$P(IBZ1,"^",4)!(IBDEFTYP=$P(IBZ,U,3))
23 . S IBZN=$P(IBZ,"^",3),IBZNAME=$P(IBZ,"^",1)
24 . I IBFRMTYP=2 Q:IBZN="1A"!(IBZNAME="MEDICARE PART A") ;1500
25 . I IBFRMTYP=3 Q:IBZN="1B"!(IBZNAME="MEDICARE PART B") ;UB
26 . Q:$$CHCKPRV1^IBCEF73($S(IBFRMTYP=2:2,IBFRMTYP=3:1,1:0),IBZN)=0
27 . I $P(IBZ,"^",2)=0!($P(IBZ,"^",2)=2) D
28 . . S IBIND=IBIND+2
29 . . I IBIND>14 S IBQ=1 Q
30 . . S $P(IBRES,"^",IBIND)=IBZN_"^"_$P(IBZ,"^",4)
31 ;Remove any duplicate entries
32 N I,Q,QUAL,QUALC,IBRESTMP,SEQ
33 F I=2:2:($L(IBRES,"^")-1) D
34 . S QUAL=$P(IBRES,"^",I)
35 . I $G(IBRESTMP(QUAL))="" S IBRESTMP(QUAL)=$P(IBRES,"^",(I+1))
36 S Q=2
37 S I="",QUAL=""
38 K IBRES
39 S IBRES=""
40 S SEQ=0
41 F S QUAL=$O(IBRESTMP(QUAL)) Q:QUAL="" D
42 . S SEQ=SEQ+2
43 . S $P(IBRES,"^",SEQ)=QUAL,$P(IBRES,"^",(SEQ+1))=IBRESTMP(QUAL)
44 Q IBRES
45 ;
46 ; creates array of SUBSCR IDs for all "other insurances"
47 ;Input :
48 ; IBXIEN - ien in #399
49 ;Output:
50 ; IBZOUT(Z) - array with ien of #36
51OTHSBID(IBXIEN,IBZOUT) ;
52 N Z,Z0,Z1,IBZ,C
53 D F^IBCEF("N-ALL INSURANCE CO 837 ID","IBZ")
54 F Z=1,2,3 S IBZ(Z)=$$POLICY^IBCEF(IBXIEN,2,$E("PST",Z))
55 K IBXDATA
56 S C=$$OTHINS1^IBCEF2(IBXIEN)
57 F Z=1,2 I $G(IBZ(Z))'="",$E(C,Z) D
58 . S IBZOUT(Z)=IBZ(+$E(C,Z))
59 Q
60 ;Input :
61 ; IBXIEN - ien in #399
62 ; IBP - # piece in address string : STR LINE1|STR LINE2|CITY|STATE|ZIP
63 ;Output:
64 ; IBARR - output array m by reference
65ELMADD2(IBXIEN,IBP,IBARR) ;
66 N IBZZZ,A,CHECK,IB1
67 I '$D(IBXSAVE("OTH_INSURED_ADDR")) D OTHADD2(IBXIEN,.IBZZZ) M IBXSAVE("OTH_INSURED_ADDR")=IBZZZ
68 S IB1=0
69 F S IB1=$O(IBXSAVE("OTH_INSURED_ADDR",IB1)) Q:'IB1 D
70 . ;IF ANY PORTION OF ADDRESS IS NULL SET CHECK VALUE, ERASE ENTRY
71 . S CHECK=0
72 . F A=1,3,4,5 I $P(IBXSAVE("OTH_INSURED_ADDR",IB1),"|",A)="" S CHECK=1 K IBXSAVE("OTH_INSURED_ADDR",IB1) Q
73 . I 'CHECK D
74 . . I IBP=0 S IBARR(IB1)=$G(IBXSAVE("OTH_INSURED_ADDR",IB1)) Q
75 . . S IBARR(IB1)=$P($G(IBXSAVE("OTH_INSURED_ADDR",IB1)),"|",IBP)
76 Q
77 ;creates an array with address info for all other insured persons
78 ;Input :
79 ; IBXIEN - ien in #399
80 ;Output:
81 ; IBZOUT(Z) - array with STR LINE1|STR LINE2|CITY|STATE|ZIP
82OTHADD2(IBXIEN,IBZOUT) ;
83 N C,Z,Z0,Z1,IBZ,IBZIP,IB1,IBDFN1
84 S IBZOUT=""
85 D OTHP36^IBCEF72(IBXIEN,.IBZ) ;array with iens of file #36
86 K IBXDATA
87 S C=$$OTHINS1^IBCEF2(IBXIEN)
88 F Z=1,2 I $G(IBZ(Z))'="",$E(C,Z) D
89 . S IBINS=+IBZ(+$E(C,Z))
90 . S IBDFN1=$P($G(^DGCR(399,IBXIEN,0)),"^",2)
91 . S IBZOUT(Z)=$$FR2PAT(IBDFN1,IBINS)
92 Q
93 ;Input:
94 ; IBDFN-patient ien
95 ; IBINS - input array with insurance pointers to 36
96 ;Output
97 ; STR LINE1|STR LINE2|CITY|STATE|ZIP
98FR2PAT(IBDFN,IBINS) ;information about "other insured" address
99 N Z3,Z4,Z5,IBZIP
100 S Z3=$O(^DPT(IBDFN,.312,"B",$G(IBINS),0))
101 Q:+Z3=0 "||||"
102 S Z4=$G(^DPT(IBDFN,.312,Z3,3))
103 S IBZIP=$P($G(^DIC(5,+$P(Z4,"^",9),0)),"^",2)
104 S Z5=$P(Z4,"^",6,8)_"^"_IBZIP_"^"_$P(Z4,"^",10)
105 Q $TR(Z5,"^","|")
106 ;
107 ;Input :
108 ; IBXIEN - ien in #399
109 ; IBP - # piece in address string : STR LINE1|STR LINE2|CITY|STATE|ZIP
110 ; if IBP=0 then returns whole string
111 ;Output:
112 ; IBARR - output array m by reference
113ELMADDR(IBXIEN,IBP,IBARR) ;
114 N IB1,A,CHECK
115 D:'$D(IBXSAVE("OTH_PROV_ADDR")) OTHADDR(IBXIEN)
116 S IB1=0
117 F S IB1=$O(IBXSAVE("OTH_PROV_ADDR",IB1)) Q:'IB1 D
118 . S CHECK=0
119 . ;EXCLUDE ADD LINE 2 SECOND PC SINCE IT'S OK FOR THAT TO BE EMPTY
120 . F A=1,3,4,5 I $P(IBXSAVE("OTH_PROV_ADDR",IB1),"|",A)="" D Q
121 . . ;IF ANY PORTION OF ADDRESS IS NULL SET CHECK VALUE, ERASE ENTRY
122 . . S CHECK=1 K IBXSAVE("OTH_PROV_ADDR",IB1)
123 . I 'CHECK D
124 . . I IBP=0 S IBARR(IB1)=$G(IBXSAVE("OTH_PROV_ADDR",IB1)) Q
125 . . S IBARR(IB1)=$P($G(IBXSAVE("OTH_PROV_ADDR",IB1)),"|",IBP)
126 Q
127 ;
128 ;creates an array with address info for all insurances
129 ;Input :
130 ; IBXIEN - ien in #399
131 ;Output:
132 ; IBXSAVE("OTH_PROV_ADDR",Z)
133OTHADDR(IBXIEN) ;
134 N C,Z,Z0,Z1,IBZ,IBZIP,IB1,IBINS
135 D F^IBCEF("N-OTH INSURANCE CO IEN 36") ;array with iens of file #36
136 M IBZ=IBXDATA
137 K IBXDATA
138 S C=$$OTHINS1^IBCEF2(IBXIEN)
139 F Z=1,2 I $G(IBZ(Z))'="",$E(C,Z) D
140 . S IBINS=+IBZ(+$E(C,Z))
141 . S IBZIP=$P($G(^DIC(5,+$P($G(^DIC(36,IBINS,.11)),"^",5),0)),"^",2)
142 . S IB1=$P($G(^DIC(36,IBINS,.11)),"^",1,2)_"^"_$P($G(^DIC(36,IBINS,.11)),"^",4)_"^"_IBZIP_"^"_$P($G(^DIC(36,IBINS,.11)),"^",6)
143 . S IBXSAVE("OTH_PROV_ADDR",Z)=$TR(IB1,"^","|")
144 Q
145 ;
146 ;Retrieves pointer to get info about the service provider
147 ;IBIEN399 - ien in #399
148 ;IBFUNC -function (3-RENDERING,etc)
149 ;Output: VARIABLE POINTER (PTR;file_root)
150PROVPTR(IBIEN399,IBFUNC) ;
151 N IBN
152 S IBN=$O(^DGCR(399,IBIEN399,"PRV","B",IBFUNC,0))
153 I +IBN=0 Q 0
154 Q $P($G(^DGCR(399,IBIEN399,"PRV",+IBN,0)),"^",2)
155 ;
156 ;Retrieves SSN from #200
157 ;IBPTR- VARIABLE POINTER to #200
158PROVSSN(IBIEN399) ;
159 N IBRETVAL S IBRETVAL=""
160 N IBPTR,IBFT
161 F IBFT=1:1:9 D
162 . S IBPTR=$$PROVPTR(IBIEN399,IBFT)
163 . S $P(IBRETVAL,"^",IBFT)=$$GETSSN^IBCEF72(IBPTR)
164 Q IBRETVAL
165 ;
166 ;Input:
167 ; IBPTR- ptr to ^VA(200 or ^IBA(355.93
168 ;Output:
169 ; SSN or null
170GETNMEL(IBFULL,IBEL) ;Get name element
171 D NAMECOMP^XLFNAME(.IBFULL)
172 Q $G(IBFULL(IBEL))
173 ;-
174 ;PROVIDER
175 ;Input:
176 ; IB399 - ien of #399
177 ; IBPROV:
178 ; "C"- to get info for CURRENT provider
179 ; "O"- to get info for all others (in this case the array will contain info fot two providers
180 ; IBRES - array for results (by reference)
181 ;
182 ;Output:
183 ; IBRES - array to get back info (by reference)
184 ; IBRES(IBPROV,PRNUM,PRTYPE,SEQ#)=PROV^INSUR^IDTYPE^ID^FORMTYP^CARETYP
185 ; where:
186 ; IBPROV - see input parameter
187 ; PRNUM: 1=primary insurance provider, 2= secondary, 3 -tretiary
188 ; PRTYPE: Provider type(FUNCTION)
189 ; SEQ# : sequence number (1st is used for ID1, 2nd - for ID2, etc)
190 ; PROV : provider/VARIABLEPTR
191 ; INSUR: Insurance PTR #36 or NONE
192 ; IDTYPE: ID type
193 ; ID: ID
194 ; FORMTYP: Form type 1=UB,2=1500
195 ; CARETYP: Care type 0=both inp/outp,1=inpatient, 2=outpatient
196PROVIDER(IB399,IBPROV,IBRES) ;
197 N IBCURR,IBZ,IBRESARR
198 S IBRESARR=""
199 S IBCURR=$$COB^IBCEF(IB399) ;current bill payer sequence
200 Q:IBPROV="A" ;PATIENT's bill
201 I IBPROV="C" D
202 . D:$$ISINSUR^IBCEF71(IBCURR,IB399) PROVINF(IB399,$S(IBCURR="T":3,IBCURR="S":2,IBCURR="P":1,1:1),.IBRESARR,1,IBPROV)
203 I IBPROV="O" D
204 . I IBCURR="P" D:$$ISINSUR^IBCEF71("S",IB399) PROVINF(IB399,2,.IBRESARR,1,IBPROV) D:$$ISINSUR^IBCEF71("T",IB399) PROVINF(IB399,3,.IBRESARR,2,IBPROV)
205 . I IBCURR="S" D:$$ISINSUR^IBCEF71("P",IB399) PROVINF(IB399,1,.IBRESARR,1,IBPROV) D:$$ISINSUR^IBCEF71("T",IB399) PROVINF(IB399,3,.IBRESARR,2,IBPROV)
206 . I IBCURR="T" D:$$ISINSUR^IBCEF71("P",IB399) PROVINF(IB399,1,.IBRESARR,1,IBPROV) D:$$ISINSUR^IBCEF71("S",IB399) PROVINF(IB399,2,.IBRESARR,2,IBPROV)
207 M IBRES(IBPROV)=IBRESARR
208 Q
209 ;
210PROVINF(IB399,IBPRNUM,IBRES,IBSORT,IBINSTP) ;
211 D PROVINF^IBCEF74(IB399,IBPRNUM,.IBRES,IBSORT,IBINSTP)
212 Q
213 ;
214PSPRV(IBIFN) ; Returns information for bill ien IBIFN for purchased svc
215 ; Returns 4 digit data in following format:
216 ; 1st digit: 0 if not outside facility
217 ; 1 if outside facility
218 ; 2nd digit: 0 if not non-VA provider for rendering/attending
219 ; 1 if non-VA provider for rendering/attending
220 ; 3rd digit: 0 if not purchased svc
221 ; 1 if purchased svc
222 ; 4th digit: 0 if 1500 bill
223 ; 1 if UB bill
224 N IBSVC,Z,Z0,IBU2
225 S IBSVC="000"_+$$INSFT^IBCEU5(IBIFN),IBU2=$G(^DGCR(399,IBIFN,"U2"))
226 I $P(IBU2,U,10) S $E(IBSVC,1)=1 ; NON-VA FACILITY
227 S Z=($$FT^IBCEF(IBIFN)=3)+3,Z0=+$O(^DGCR(399,IBIFN,"PRV","B",Z,0))
228 I $P($G(^DGCR(399,IBIFN,"PRV",Z0,0)),U,2)["IBA(355.93" S $E(IBSVC,2)=1
229 I $P(IBU2,U,11)>0,$P(IBU2,U,11)'>2 S $E(IBSVC,3)=1
230PSPRVQ Q IBSVC
231 ;
232CHKADD ;CHECK ALL ADDRESS ELEMENTS PRESENT IF NOT KILL ALL ADDRESS ELEMENTS
233 ;EXPECT IBXSAVE("CADR") AS SOURCE ARRAY
234 N Z,CHECK
235 S Z="",CHECK=0
236 F Z=1,4,5,6 D
237 . I $P($G(IBXSAVE("CADR")),"^",Z)="" S CHECK=1
238 I CHECK=1 S IBXSAVE("CADR")=""
239 Q
240 ;
Note: See TracBrowser for help on using the repository browser.