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

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

initial load of FOIAVistA 6/30/08 version
File size: 10.2 KB
Line 
1IBCEP8 ;ALB/TMP - Functions for NON-VA PROVIDER ;11-07-00
2 ;;2.0;INTEGRATED BILLING;**51,137,232,288,320,343,374,377**;21-MAR-94;Build 23
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5EN ; -- main entry point
6 N IBNPRV
7 K IBFASTXT
8 D FULL^VALM1
9 D EN^VALM("IBCE PRVNVA MAINT")
10 Q
11 ;
12HDR ; -- header code
13 K VALMHDR
14 Q
15 ;
16INIT ; Initialization
17 N DIC,DA,X,Y,DLAYGO,IBIF,DIR,DTOUT,DUOUT
18 K ^TMP("IBCE_PRVNVA_MAINT",$J)
19 ;
20 ; if coming in from main routine ^IBCEP6 this special variable IBNVPMIF is set already
21 I $G(IBNVPMIF)'="" S IBIF=IBNVPMIF G INIT1
22 ;
23 S DIR("A")="(I)NDIVIDUAL OR (F)ACILITY?: ",DIR(0)="SA^I:INDIVIDUAL;F:FACILITY" D ^DIR K DIR
24 I $D(DUOUT)!$D(DTOUT) S VALMQUIT=1 G INITQ
25 S IBIF=Y
26 ;
27INIT1 ;
28 ;
29 I IBIF="F" D
30 . S VALM("TITLE")="Non-VA Lab or Facility Info"
31 . K VALM("PROTOCOL")
32 . S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA NONIND MAINT")
33 . I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
34 ;
35 S DIC="^IBA(355.93,",DIC("DR")=".02///"_$S(IBIF'="F":2,1:1)
36 S DIC("S")="I $P(^(0),U,2)="_$S(IBIF'="F":2,1:1)
37 S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON"_$S(IBIF="I":"-",1:"/OTHER ")_"VA PROVIDER: "
38 D ^DIC K DIC,DLAYGO
39 I Y'>0 S VALMQUIT=1 G INITQ
40 S IBNPRV=+Y
41 D BLD
42INITQ Q
43 ;
44BLD ; Build/Rebuild display
45 N IBLCT,IBCT,IBLST,IBPRI,IBIEN,Z,Z1,Z2
46 K @VALMAR
47 S (IBLCT,IBCT)=0,Z=$G(^IBA(355.93,IBNPRV,0))
48 S IBCT=IBCT+1
49 S Z1=$J("Name: ",15)_$P(Z,U) D SET1(.IBLCT,Z1,IBCT)
50 I $P(Z,U,2)=2 D
51 . S IBCT=IBCT+1
52 . S Z1=$J("Type: ",15)_$S($P(Z,U,2)=2:"INDIVIDUAL PROVIDER",1:"OUTSIDE OR OTHER VA FACILITY") D SET1(.IBLCT,Z1,IBCT)
53 . S IBCT=IBCT+1
54 . S Z1=$J("Credentials: ",15)_$P(Z,U,3) D SET1(.IBLCT,Z1,IBCT)
55 . S IBCT=IBCT+1
56 . S Z1=$J("Specialty: ",15)_$P(Z,U,4) D SET1(.IBLCT,Z1,IBCT)
57 . S IBCT=IBCT+1
58 . S Z1=$J("NPI: ",15)_$$NPIGET^IBCEP81(IBNPRV) D SET1(.IBLCT,Z1,IBCT)
59 . S IBCT=IBCT+1
60 . S IBPRI=$$TAXGET^IBCEP81(IBNPRV,.IBLST)
61 . S Z1=$J("Taxonomy Code: ",15)_$P(IBPRI,U)
62 . I $D(IBLST) S Z1=Z1_" ("_$S($P(IBLST(IBLST),U,3)=1:"Primary",1:"Secondary")_")"
63 . D SET1(.IBLCT,Z1,IBCT)
64 . S IBIEN=""
65 . F S IBIEN=$O(IBLST(IBIEN)) Q:IBIEN="" D
66 .. I IBIEN=IBLST Q
67 .. S IBCT=IBCT+1
68 .. S Z1=$J("",15)_$P(IBLST(IBIEN),U)_" ("_$S($P(IBLST(IBIEN),U,3)=1:"Primary",1:"Secondary")_")"
69 .. D SET1(.IBLCT,Z1,IBCT)
70 E D
71 . S IBCT=IBCT+1
72 . S Z1=$J("Address: ",15)_$P(Z,U,5) D SET1(.IBLCT,Z1,IBCT)
73 . I $P(Z,U,10) D
74 .. S IBCT=IBCT+1
75 .. S Z1=$J("",15)_$P(Z,U,10)
76 . S IBCT=IBCT+1
77 . S Z1=$J("",15)_$P(Z,U,6)_$S($P(Z,U,6)'="":", ",1:"")_$S($P(Z,U,7):$$EXTERNAL^DILFD(355.93,.07,"",$P(Z,U,7))_" ",1:"")_$P(Z,U,8)
78 . D SET1(.IBLCT,Z1,IBCT)
79 . S IBCT=IBCT+1
80 . S Z1=" " D SET1(.IBLCT,Z1,IBCT)
81 . S IBCT=IBCT+1
82 . S Z1=$J("Type of Facility: ",30)_$$EXTERNAL^DILFD(355.93,.11,,$P(Z,U,11))
83 . D SET1(.IBLCT,Z1,IBCT)
84 . S IBCT=IBCT+1
85 . S Z1=$J("Primary ID: ",30)_$P(Z,U,9)
86 . D SET1(.IBLCT,Z1,IBCT)
87 . S IBCT=IBCT+1
88 . S Z1=$J("ID Qualifier: ",30)_$$GET1^DIQ(355.97,$P(Z,U,13),.03) I $P(Z,U,13)]"" S Z1=Z1_" - "_$$GET1^DIQ(355.97,$P(Z,U,13),.01)
89 . D SET1(.IBLCT,Z1,IBCT)
90 . S IBCT=IBCT+1
91 . S Z1=$J("Mammography Certification #: ",30)_$P(Z,U,15)
92 . D SET1(.IBLCT,Z1,IBCT)
93 . S IBCT=IBCT+1
94 . S Z1=$J("NPI: ",30)_$$NPIGET^IBCEP81(IBNPRV) D SET1(.IBLCT,Z1,IBCT)
95 . S IBCT=IBCT+1
96 . S IBPRI=$$TAXGET^IBCEP81(IBNPRV,.IBLST)
97 . S Z1=$J("Taxonomy Code: ",30)_$P(IBPRI,U)
98 . I $D(IBLST) S Z1=Z1_" ("_$S($P(IBLST(IBLST),U,3)=1:"Primary",1:"Secondary")_")"
99 . D SET1(.IBLCT,Z1,IBCT)
100 . S IBIEN=""
101 . F S IBIEN=$O(IBLST(IBIEN)) Q:IBIEN="" D
102 .. I IBIEN=IBLST Q
103 .. S IBCT=IBCT+1
104 .. S Z1=$J("",30)_$P(IBLST(IBIEN),U)_" ("_$S($P(IBLST(IBIEN),U,3)=1:"Primary",1:"Secondary")_")"
105 .. D SET1(.IBLCT,Z1,IBCT)
106 K VALMBG,VALMCNT
107 S VALMBG=1,VALMCNT=IBLCT
108 Q
109 ;
110SET1(IBLCT,TEXT,IBCT) ;
111 S IBLCT=IBLCT+1 D SET^VALM10(IBLCT,TEXT,$G(IBCT))
112 Q
113EXPND ;
114 Q
115 ;
116HELP ;
117 Q
118 ;
119EXIT ;
120 K ^TMP("IBCE_PRVNVA_MAINT",$J)
121 D CLEAN^VALM10
122 K IBFASTXT
123 Q
124 ;
125EDIT1(IBNPRV,IBNOLM) ; Edit non-VA provider/facility demographics
126 ; IBNPRV = ien of entry in file 355.93
127 ; IBNOLM = 1 if not called from list manager
128 ;
129 N DA,X,Y,DIE,DR,IBP
130 I '$G(IBNOLM) D FULL^VALM1
131 I IBNPRV D
132 . I '$G(IBNOLM) D CLEAR^VALM1
133 . S DIE="^IBA(355.93,",DA=IBNPRV,IBP=($P($G(^IBA(355.93,IBNPRV,0)),U,2)=2)
134 . ; PRXM/KJH - Added NPI and Taxonomy to the list of fields to be edited. Put a "NO^" around the Taxonomy multiple (#42) since some of the sub-field entries are 'required'.
135 . S DR=".01;"_$S(IBP:".03;.04",1:".05;.1;.06;.07;.08;.13///24;W !,""ID Qualifier: 24 - EMPLOYER'S IDENTIFICATION #"";.09Lab or Facility Primary ID;.11;.15")_";D EN^IBCEP82;S DIE(""NO^"")="""";42;K DIE(""NO^"")"
136 . D ^DIE
137 . Q:$G(IBNOLM)
138 . D BLD
139 I '$G(IBNOLM) K VALMBCK S VALMBCK="R"
140 Q
141 ;
142EDITID(IBNPRV,IBSLEV) ; Link from this list template to maintain provider-specific ids
143 ; This entry point is called by 4 action protocols.
144 ; IBNPRV = ien of entry in file 355.93 (can be either an individual or a facility) (required)
145 ; IBSLEV = 1 for facility/provider own ID's
146 ; IBSLEV = 2 for facility/provider ID's furnished by an insurance company
147 ;
148 Q:'$G(IBNPRV)
149 Q:'$G(IBSLEV)
150 N IBPRV,IBIF
151 D FULL^VALM1 ; set full scrolling region
152 D CLEAR^VALM1 ; clear screen
153 S IBPRV=IBNPRV
154 ;
155 K IBFASTXT
156 S IBIF=$$GET1^DIQ(355.93,IBPRV,.02,"I") ; 1=facility/group 2=individual
157 D EN^VALM("IBCE PRVPRV MAINT")
158 ;
159 K VALMQUIT
160 S VALMBCK=$S($G(IBFASTXT)'="":"Q",1:"R")
161 Q
162 ;
163NVAFAC ; Enter/edit Non-VA facility information
164 ; This entry point is called by the menu system for option IBCE PRVNVA FAC EDIT
165 N X,Y,DA,DIC,IBNPRV,DLAYGO
166 S DIC="^IBA(355.93,",DIC("S")="I $P(^(0),U,2)=1",DIC("DR")=".02///1"
167 S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON/Other VA FACILITY: "
168 D ^DIC K DIC,DLAYGO
169 I Y'>0 S VALMQUIT=1 G NVAFACQ
170 S IBNPRV=+Y
171 D EDIT1(IBNPRV,1)
172 ;
173NVAFACQ Q
174 ;
175GETFAC(IB,IBFILE,IBELE,IBSFD) ; Returns facility name,address lines or city-state-zip
176 ; IB = ien of entry in file
177 ; IBFILE = 0 for retrieval from file 4, 1 for retrieval from file 355.93
178 ; If IBELE=0, returns name
179 ; =1, returns address line 1
180 ; =2, returns address line 2
181 ; =3, returns city, state zip
182 ; = "3C", returns city = "3S", state = "3Z", zip
183 ; IBSFD (optional) = Output formatter segment name if the output needs
184 ; to be screened thru the VAMCFD^IBCEF75 procedure for the flag
185 ; in the insurance company file
186 ;
187 N Z,IBX,IBZ
188 S IBX=""
189 ;
190 I $G(IBSFD)="SUB" D VAMCFD^IBCEF75(+$G(IBXIEN),.IBZ) I $D(IBZ),'$G(IBZ("C",1)) G GETFACX
191 ;
192 S Z=$S('IBFILE:$G(^DIC(4,+IB,1)),1:$G(^IBA(355.93,+IB,0)))
193 I +IBELE=0 S IBX=$S('IBFILE:$P($G(^DIC(4,+IB,0)),U),1:$P($G(^IBA(355.93,+IB,0)),U))
194 I IBELE=1!(IBELE=12) S IBX=$S('IBFILE:$P(Z,U),1:$P(Z,U,5))
195 I IBELE=2!(IBELE=12) S IBX=$S(IBELE=12:IBX_" ",1:"")_$S('IBFILE:$P(Z,U,2),1:$P(Z,U,10))
196 ;
197 I +IBELE=3,'IBFILE D
198 . S:IBELE=3!(IBELE["C") IBX=$P(Z,U,3) Q:IBELE["C"
199 . S:IBELE=3 IBX=IBX_$S(IBX'="":", ",1:"") S:IBELE=3!(IBELE["S") IBX=IBX_$$STATE^IBCEFG1($P($G(^DIC(4,+IB,0)),U,2)) Q:IBELE["S"
200 . S:IBELE=3 IBX=IBX_" " S:IBELE=3!(IBELE["Z") IBX=IBX_$P(Z,U,4)
201 . Q
202 ;
203 I +IBELE=3,IBFILE D
204 . S:IBELE=3!(IBELE["C") IBX=$P(Z,U,6) Q:IBELE["C"
205 . S:IBELE=3 IBX=IBX_$S(IBX'="":", ",1:"") S:IBELE=3!(IBELE["S") IBX=IBX_$$STATE^IBCEFG1($P(Z,U,7))
206 . S:IBELE=3 IBX=IBX_" " S:IBELE=3!(IBELE["Z") IBX=IBX_$P(Z,U,8)
207 . Q
208GETFACX ;
209 Q IBX
210 ;
211ALLID(IBPRV,IBPTYP,IBZ) ; Returns array IBZ for all ids for provider IBPRV
212 ; for all provider id types or for id type in IBPTYP
213 ; IBPRV = vp ien of provider
214 ; IBPTYP = ien of provider id type to return or "" for all
215 ; IBZ = array returned with internal data:
216 ; IBZ(file 355.9 ien)=ID type^ID#^ins co^form type^bill care type^care un^X12 code for id type
217 N Z,Z0
218 K IBZ
219 G:'$G(IBPRV) ALLIDQ
220 S IBPTYP=$G(IBPTYP)
221 S Z=0 F S Z=$O(^IBA(355.9,"B",IBPRV,Z)) Q:'Z S Z0=$G(^IBA(355.9,Z,0)) D
222 . I $S(IBPTYP="":1,1:($P(Z0,U,6)=IBPTYP)) S IBZ(Z)=($P(Z0,U,6)_U_$P(Z0,U,7)_U_$P(Z0,U,2)_U_$P(Z0,U,4)_U_$P(Z0,U,5)_U_$P(Z0,U,3))_U_$P($G(^IBE(355.97,+$P(Z0,U,6),0)),U,3)
223 ;
224ALLIDQ Q
225 ;
226CLIA() ; Returns ien of CLIA # provider id type
227 N Z,IBZ
228 S (IBZ,Z)=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z I $P($G(^(Z,0)),U,3)="X4",$P(^(0),U)["CLIA" S IBZ=Z Q
229 Q IBZ
230 ;
231STLIC() ; Returns ien of STLIC# provider id type
232 N Z,IBZ
233 S (IBZ,Z)=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z I $P($G(^(Z,1)),U,3) S IBZ=Z Q
234 Q IBZ
235 ;
236TAXID() ; Returns ien of Fed tax id provider id type
237 N Z,IBZ
238 S (IBZ,Z)=0 F S Z=$O(^IBE(355.97,Z)) Q:'Z I $P($G(^(Z,1)),U,4) S IBZ=Z Q
239 Q IBZ
240 ;
241CLIANVA(IBIFN) ; Returns CLIA # for a non-VA facility on bill ien IBIFN
242 N IBCLIA,IBZ,IBNVA,Z
243 S IBCLIA="",IBZ=$$CLIA()
244 I IBZ D
245 . S IBNVA=$P($G(^DGCR(399,IBIFN,"U2")),U,10) Q:'IBNVA
246 . S IBCLIA=$$IDFIND^IBCEP2(IBIFN,IBZ,IBNVA_";IBA(355.93,","",1)
247 Q IBCLIA
248 ;
249VALFAC(X) ; Function returns 1 if format is valid for X12 facility name
250 ; Alpha/numeric/certain punctuation valid. Must start with an Alpha
251 N OK,VAL
252 S OK=1
253 S VAL("A")="",VAL("N")="",VAL=",.- "
254 I $E(X)'?1A!'$$VALFMT(X,.VAL) S OK=0
255 Q OK
256 ;
257VALFMT(X,VAL) ; Returns 1 if format of X is valid, 0 if not
258 ; X = data to be examined
259 ; VAL = a 'string' of valid characters AND/OR (passed by reference)
260 ; if VAL("A") defined ==> Alpha
261 ; if VAL("A") defined ==> Numeric valid
262 ; if VAL("A") defined ==> Punctuation valid
263 ; any other character included in the string is checked individually
264 N Z
265 I $D(VAL("A")) D
266 . N Z0
267 . F Z=1:1:$L(X) I $E(X,Z)?1A S Z0(Z)=""
268 . S Z0="" F S Z0=$O(Z0(Z0),-1) Q:'Z0 S $E(X,Z0)=""
269 I $D(VAL("N")) D
270 . N Z0
271 . F Z=1:1:$L(X) I $E(X,Z)?1N S Z0(Z)=""
272 . S Z0="" F S Z0=$O(Z0(Z0),-1) Q:'Z0 S $E(X,Z0)=""
273 I $D(VAL("P")) D
274 . N Z0
275 . F Z=1:1:$L(X) I $E(X,Z)?1P S Z0(Z)=""
276 . S Z0="" F S Z0=$O(Z0(Z0),-1) Q:'Z0 S $E(X,Z0)=""
277 I $G(VAL)'="" S X=$TR(X,VAL,"")
278 Q (X="")
279 ;
280PS(IBXSAVE) ; Returns 1 if IBXSAVE("PSVC") indicates the svc was non-lab
281 ;
282 Q $S($G(IBXSAVE("PSVC"))="":0,1:"13"[IBXSAVE("PSVC"))
283 ;
284 ; Pass in the Internal Entry number to File 355.93
285 ; Return the Primary ID and Qualifier (ID Type) from 355.9
286PRIMID(IEN35593) ; Return External Primary ID and ID Quailier
287 N INDXVAL,LIST,MSG,IDCODE
288 S INDXVAL=IEN35593_";IBA(355.93,"
289 N SCREEN S SCREEN="I $P(^(0),U,8)"
290 D FIND^DIC(355.9,,"@;.06EI;.07","Q",INDXVAL,,,SCREEN,,"LIST","MSG")
291 I '+$G(LIST("DILIST",0)) Q "" ; No Primary ID
292 I +$G(LIST("DILIST",0))>1 Q "***ERROR***^***ERROR***" ; Bad. More than one.
293 ; Found just one
294 S IDCODE=$$GET1^DIQ(355.97,LIST("DILIST","ID",1,.06,"I"),.03)
295 Q $G(LIST("DILIST","ID",1,.07))_U_IDCODE_" - "_$G(LIST("DILIST","ID",1,.06,"E"))
Note: See TracBrowser for help on using the repository browser.