source: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP2.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 7.9 KB
Line 
1IBCEP2 ;ALB/TMP - EDI UTILITIES for provider ID ;13-DEC-99
2 ;;2.0;INTEGRATED BILLING;**137,181,232,280,320,349**;21-MAR-94;Build 46
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ; DBIA for access to fields 53.2,54.1,54.2 in file 200: 224
5 ;
6GETID(IBIFN,IBTYPE,IBPROV,IBSEQ,IBT,IBT1,IBFUNC) ; Extract IBTYPE id for the bill
7 ; IBIFN = bill ien (file 399)
8 ; IBTYPE = 2:PERFORMING PROVIDER ID (1 and 3 deleted)
9 ; IBSEQ = numeric COB sequence of the insurance on bill
10 ; IBFUNC = 1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING;5:SUPERVISING;9:OTHER;
11 ; Returns IBT = ien of the provider id type^ien of entry^file # for id
12 ;
13 S IBT=0
14 Q:IBTYPE'=2 ""
15 N IBID,IBPTYP
16 S IBID=$$IDFIND(IBIFN,"",IBPROV,IBSEQ,1,.IBT,$G(IBFUNC))
17 I IBID="" S IBT=""
18 ;
19 Q IBID
20 ;
21IDFIND(IBIFN,IBPTYP,IBPROV,IBSEQ,IBPERF,IBT,IBFUNC) ;Loop thru source levels
22 ; (if id definition allows) to find correct ID
23 ; IBIFN = bill ien (file 399)
24 ; IBPTYP = ien of the provider id type in file 355.97 or if null,
25 ; the default performing provider ID type for the ins co. in
26 ; COB sequence IBSEQ will be calculated
27 ; IBPROV = (variable pointer syntax) provider on bill IBIFN
28 ; IBSEQ = numeric COB sequence of the bill
29 ; IBPERF = 1 if the performing provider id is needed
30 ; IBFUNC = 1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING;5:SUPERVISING;9:OTHER;
31 ; Returns IBT = ptr to file 355.97^entry #^file #
32 ;
33 S IBT=+$G(IBPTYP)
34 Q:'$G(IBPERF)!'$G(IBPROV) ""
35 N IBSPEC,IBINS,IBINS4,IBSRC,IBUP,IBID,IBALT,IBPROF,Z
36 I $G(IBSEQ)="" S IBSEQ=+$$COBN^IBCEF(IBIFN) ; Default to current COB seq
37 S IBINS=+$P($G(^DGCR(399,IBIFN,"I"_IBSEQ)),U),IBINS4=$G(^DIC(36,+IBINS,4))
38 S IBPROF=($$FT^IBCEF(IBIFN)=2) S:'IBPROF IBPROF=2
39 ; form type is CMS-1500 (prof)=1, UB-04 (inst)=2
40 I $G(IBPTYP)="",$G(IBFUNC)=1,IBPROF=1 S (IBT,IBPTYP)=+$P(IBINS4,U,4) ; Referring Default ID on CMS-1500
41 I $G(IBPTYP)="" S (IBT,IBPTYP)=+$P(IBINS4,U,IBPROF) ; Def to perf prv typ for form
42 I 'IBPTYP Q "" ; No default id type
43 S IBSPEC=$G(^IBE(355.97,IBPTYP,1)),IBSRC=$P($G(^IBE(355.97,+IBPTYP,0)),U,2),IBSRC=$S('IBSRC:5,1:IBSRC),IBUP=1
44 S IBALT=0
45 ;
46 F D Q:'IBUP!($G(IBID)'="") S IBSRC=IBSRC-1 Q:'IBSRC
47 . ;
48 . I IBSRC=1,$TR($P(IBSPEC,U,1,3),"^0")'="" D Q ; Indiv prov default
49 .. N IBSTATE
50 .. I $P(IBSPEC,U,2) D Q ; Federal DEA # from field 53.2 file 200
51 ... S IBID=$P($G(^VA(200,+IBPROV,"PS")),U,2) ; DBIA224
52 ... S $P(IBT,U,2,3)=(IBPROV_U_200)
53 .. S IBSTATE=+$$CAREST^IBCEP2A(IBIFN)
54 .. I $P(IBSPEC,U) D Q ; State issued DEA # needed
55 ... Q:'IBSTATE
56 ... ; Extract the state issuing DEA # from field 54.2 file 200
57 ... S Z=+$O(^VA(200,+IBPROV,"PS2","B",IBSTATE,0)),IBID=$P($G(^VA(200,+IBPROV,"PS2",Z,0)),U,2) ; DBIA224
58 ... S $P(IBT,U,2,3)=(+IBPROV_";"_Z_U_200)
59 .. I $P(IBSPEC,U,3) D Q ; State license # needed
60 ... Q:'IBSTATE
61 ... ; Extract the state license # from field 54.1 file 200
62 ... I IBPROV["VA(200" S Z=+$O(^VA(200,+IBPROV,"PS1","B",IBSTATE,0)),IBID=$P($G(^VA(200,+IBPROV,"PS1",Z,0)),U,2),$P(IBT,U,2,3)=(+IBPROV_";"_IBSTATE_U_200) ; DBIA224
63 ... I IBPROV["IBA(355.93" S IBID=$P($G(^IBA(355.93,+IBPROV,0)),U,12),$P(IBT,U,2,3)=(+IBPROV_U_355.93)
64 . ;
65 . I IBSRC=2,$P(IBSPEC,U,4) D Q ; FACILITY FED TAX ID #
66 .. N IBXDATA
67 .. D F^IBCEF("N-FEDERAL TAX ID",,,IBIFN)
68 .. S IBID=IBXDATA,$P(IBT,U,2,3)=(U_350.9)
69 . ;
70 . I IBSRC=1 S IBID=$$SRC1(IBIFN,"*ALL*",IBPTYP,IBPROV,.IBT) Q
71 . ;
72 . I IBSRC=2 S IBID=$$SRC2(IBPTYP,.IBT) Q
73 . ;
74 . I IBSRC=3 S IBID=$$SRC3(IBIFN,IBINS,IBPTYP,.IBT) Q
75 . ;
76 . I IBSRC=4 S IBID=$$SRC4(IBIFN,IBINS,IBPTYP,IBPROV,.IBT) Q
77 . ;
78 . I IBSRC=5 S IBID=$$SRC5(IBIFN,IBINS,IBPTYP,IBSEQ,.IBT,$G(IBFUNC)) Q
79 . ;
80 . I IBSRC=6 S IBID=$$SRC6(IBIFN,IBINS,IBPTYP,IBPROV,IBSEQ,.IBT) Q
81 ;
82 Q $G(IBID)
83 ;
84GETALL(IBTYPE,IBIFN,IBPROV,IBPID) ; Extract all performing prov id's for a
85 ; provider (IBPROV - vp format) on bill IBIFN
86 ; IBTYPE = type of ID to return (see GETID above)
87 ;
88 ; Returns array IBPID(COB SEQ #)=id (pass by reference) AND
89 ; IBPID(COB SEQ #,1)=ien of id type (ptr to 355.97)
90 ; IBPID = current insurance co's id
91 ;
92 N Z,COB,Z1,IBT
93 S COB=$$COBN^IBCEF(IBIFN)
94 F Z=1:1:3 Q:'$D(^DGCR(399,IBIFN,"I"_Z)) S IBPID(Z)=$$GETID(IBTYPE,IBIFN,IBPROV,Z,.IBT),IBPID(Z,1)=IBT I Z=COB S Z1=IBPID(Z)
95 Q $G(Z1)
96 ;
97SRC1(IBIFN,IBINS,IBPTYP,IBPROV,IBT) ; Licensing/gov't issued # - provider specific
98 ; Parameter definitions for SRC1, SRC3, SRC4, SRC5, SRC6:
99 ; IBIFN = ien of bill (file 399)
100 ; IBINS = ien of insurance co (file 36) or *ALL* for all insurance
101 ; (always *ALL* for SRC1)
102 ; IBPTYP = ien of the provider id type in file 355.97
103 ; IBPROV = (variable pointer syntax) provider on bill IBIFN
104 ; IBT = returned as type ien^file ien^file #
105 ;
106 N IBID,IB,IBRX,IBIDSV
107 S IBID="",IB=0,IBRX=$$ISRX^IBCEF1(IBIFN),IBIDSV=""
108 I $G(IBPROV) F S IB=$O(^IBA(355.9,"AD",IBPTYP,IBPROV,IBINS,IB)) Q:'IB D Q:IBID'=""
109 . S IBID=$$UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,"",IB)
110 . I IBRX,$P($G(^IBA(355.9,IB,0)),U,5)'=3 S:IBIDSV="" IBIDSV=IBID S IBID="" ; Save 1st 'match' if no rx specific id
111 I IBID="",IBIDSV'="" S IBID=IBIDSV
112 Q IBID
113 ;
114SRC2(IB35597,IBT) ; Facility default - all providers
115 ; IB35597 = ien of the provider id type entry in file 355.97
116 ; IBT = returned as type ien^file ien^file #
117 ;
118 S $P(IBT,U,2,3)=(+IB35597_U_355.97)
119 Q $P($G(^IBE(355.97,+IB35597,0)),U,4)
120 ;
121SRC3(IBIFN,IBINS,IBPTYP,IBT) ; Ins co/all providers
122 ; See SRC1 for parameter definitions
123 N IB,IBID,IBRX,IBIDSV
124 S IBID="",IB=0,IBRX=$$ISRX^IBCEF1(IBIFN),IBIDSV=""
125 F S IB=$O(^IBA(355.91,"AC",IBINS,IBPTYP,"*N/A*",IB)) Q:'IB D Q:IBID'=""
126 . S IBID=$$UNIQ2(IBIFN,IBINS,IBPTYP,"",IB,.IBT)
127 . I IBRX,$P($G(^IBA(355.91,IB,0)),U,5)'=3 S:IBIDSV="" IBIDSV=IBID S IBID="" ; Save 1st 'match' if no rx specific id
128 I IBID="",IBIDSV'="" S IBID=IBIDSV
129 Q IBID
130 ;
131SRC4(IBIFN,IBINS,IBPTYP,IBPROV,IBT) ; Insurance co/individual provider
132 ; See SRC1 for parameter definitions
133 ;
134 N IBID,IB,IBRX,IBIDSV
135 S IBID="",IB=0,IBRX=$$ISRX^IBCEF1(IBIFN),IBIDSV=""
136 I $G(IBPROV) F S IB=$O(^IBA(355.9,"AD",IBPTYP,IBPROV,IBINS,IB)) Q:'IB D Q:IBID'=""
137 . S IBID=$$UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,"",IB,.IBT)
138 . I IBRX,$P($G(^IBA(355.9,IB,0)),U,5)'=3 S:IBIDSV="" IBIDSV=IBID S IBID="" ; Save 1st 'match' if no rx specific id
139 I IBID="",IBIDSV'="" S IBID=IBIDSV
140 Q IBID
141 ;
142SRC5(IBIFN,IBINS,IBPTYP,IBSEQ,IBT,IBFUNC) ; Ins co/all providers/care unit
143 ; See SRC1 for missing parameter definitions
144 ; IBSEQ = the numeric COB sequence of the insurance on the bill
145 ;
146 N IBP,IBUNIT,IBID,IB,Z,IBIDSV,IBRX
147 S IBID="",Z=0,IBRX=$$ISRX^IBCEF1(IBIFN),IBIDSV=""
148 S IBP=+$O(^DGCR(399,IBIFN,"PRV","B",$S($G(IBFUNC)=1:1,$$FT^IBCEF(IBIFN)=3:4,1:3),0)),IBUNIT=$P($G(^DGCR(399,IBIFN,"PRV",IBP,0)),U,8+IBSEQ)
149 I IBUNIT'="" F S Z=$O(^IBA(355.96,"AC",IBINS,IBPTYP,Z)) Q:'Z D Q:IBID'=""
150 . S IB=0 F S IB=$O(^IBA(355.91,"ACARE",Z,IB)) Q:'IB D Q:IBID'=""
151 .. S IBID=$$UNIQ2(IBIFN,IBINS,IBPTYP,IBUNIT,IB,.IBT)
152 .. I IBRX,$P($G(^IBA(355.91,IB,0)),U,5)'=3 S:IBIDSV="" IBIDSV=IBID S IBID="" ; Save 1st 'match' if no rx specific id
153 I IBID="",IBIDSV'="" S IBID=IBIDSV
154 Q IBID
155 ;
156SRC6(IBIFN,IBINS,IBPTYP,IBPROV,IBSEQ,IBT) ; Ins co/ind provider/care unit
157 ; See SRC1 for missing parameter definitions
158 ; IBSEQ = the numeric COB sequence of the insurance on the bill
159 ;
160 N IBUNIT,IBP,IBID,IB
161 S IBID="",IB=0
162 S IBP=+$O(^DGCR(399,"PRV","B",$S($$FT^IBCEF(IBIFN)=3:3,1:4),0)),IBUNIT=$P($G(^DGCR(399,IBIFN,"PRV",IBP,0)),U,8+IBSEQ)
163 I $G(IBPROV),IBUNIT'="" F S IB=$O(^IBA(355.9,"AD",IBPTYP,IBPROV,IBINS,IB)) Q:'IB D Q:IBID'=""
164 . S IBID=$$UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,IBUNIT,IB,.IBT)
165 Q IBID
166 ;
167UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,IBUNIT,IBCU,IBT) ; Match most-least specific
168 ; *** SEE PARAMETER DEFINITIONS IN IBCEP3 ***
169 ;
170 ; Start in file 355.9 (Specific Provider)
171 ; IBPROV = (variable pointer syntax) provider on bill IBIFN
172 ;
173 Q $$UNIQ1^IBCEP2A($G(IBIFN),$G(IBINS),$G(IBPTYP),$G(IBPROV),$G(IBUNIT),$G(IBCU),$G(IBT))
174 ;
175UNIQ2(IBIFN,IBINS,IBPTYP,IBUNIT,IBCU,IBT) ; Match on most-least specific
176 ; *** SEE PARAMETER DEFINITIONS IN IBCEP3 ***
177 ;
178 ; Start in file 355.91 (Specific Insurance)
179 ;
180 Q $$UNIQ2^IBCEP2A($G(IBIFN),$G(IBINS),$G(IBPTYP),$G(IBUNIT),$G(IBCU),$G(IBT))
Note: See TracBrowser for help on using the repository browser.