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

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

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