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

Last change on this file since 619 was 613, checked in by George Lilly, 16 years ago

initial load of WorldVistAEHR
File size: 7.8 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,391**;21-MAR-94;Build 39
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^IBCEP8B(IBNPRV)
42INITQ Q
43 ;
44EXPND ;
45 Q
46 ;
47HELP ;
48 Q
49 ;
50EXIT ;
51 K ^TMP("IBCE_PRVNVA_MAINT",$J)
52 D CLEAN^VALM10
53 K IBFASTXT
54 Q
55 ;
56EDIT1(IBNPRV,IBNOLM) ; Edit non-VA provider/facility demographics
57 ; IBNPRV = ien of entry in file 355.93
58 ; IBNOLM = 1 if not called from list manager
59 ;
60 N DA,X,Y,DIE,DR,IBP
61 I '$G(IBNOLM) D FULL^VALM1
62 I IBNPRV D
63 . I '$G(IBNOLM) D CLEAR^VALM1
64 . S DIE="^IBA(355.93,",DA=IBNPRV,IBP=($P($G(^IBA(355.93,IBNPRV,0)),U,2)=2)
65 . ; 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'.
66 . 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 PRENPI^IBCEP81(IBNPRV);D EN^IBCEP82(IBNPRV);S DIE(""NO^"")="""";42;K DIE(""NO^"")"
67 . D ^DIE
68 . Q:$G(IBNOLM)
69 . D BLD^IBCEP8B(IBNPRV)
70 I '$G(IBNOLM) K VALMBCK S VALMBCK="R"
71 Q
72 ;
73EDITID(IBNPRV,IBSLEV) ; Link from this list template to maintain provider-specific ids
74 ; This entry point is called by 4 action protocols.
75 ; IBNPRV = ien of entry in file 355.93 (can be either an individual or a facility) (required)
76 ; IBSLEV = 1 for facility/provider own ID's
77 ; IBSLEV = 2 for facility/provider ID's furnished by an insurance company
78 ;
79 Q:'$G(IBNPRV)
80 Q:'$G(IBSLEV)
81 N IBPRV,IBIF
82 D FULL^VALM1 ; set full scrolling region
83 D CLEAR^VALM1 ; clear screen
84 S IBPRV=IBNPRV
85 ;
86 K IBFASTXT
87 S IBIF=$$GET1^DIQ(355.93,IBPRV,.02,"I") ; 1=facility/group 2=individual
88 D EN^VALM("IBCE PRVPRV MAINT")
89 ;
90 K VALMQUIT
91 S VALMBCK=$S($G(IBFASTXT)'="":"Q",1:"R")
92 Q
93 ;
94NVAFAC ; Enter/edit Non-VA facility information
95 ; This entry point is called by the menu system for option IBCE PRVNVA FAC EDIT
96 N X,Y,DA,DIC,IBNPRV,DLAYGO
97 S DIC="^IBA(355.93,",DIC("S")="I $P(^(0),U,2)=1",DIC("DR")=".02///1"
98 S DLAYGO=355.93,DIC(0)="AELMQ",DIC("A")="Select a NON/Other VA FACILITY: "
99 D ^DIC K DIC,DLAYGO
100 I Y'>0 S VALMQUIT=1 G NVAFACQ
101 S IBNPRV=+Y
102 D EDIT1(IBNPRV,1)
103 ;
104NVAFACQ Q
105 ;
106GETFAC(IB,IBFILE,IBELE,IBSFD) ; Returns facility name,address lines or city-state-zip
107 ; IB = ien of entry in file
108 ; IBFILE = 0 for retrieval from file 4, 1 for retrieval from file 355.93
109 ; If IBELE=0, returns name
110 ; =1, returns address line 1
111 ; =2, returns address line 2
112 ; =3, returns city, state zip
113 ; = "3C", returns city = "3S", state = "3Z", zip
114 ; IBSFD (optional) = Output formatter segment name if the output needs
115 ; to be screened thru the VAMCFD^IBCEF75 procedure for the flag
116 ; in the insurance company file
117 ;
118 N Z,IBX,IBZ
119 S IBX=""
120 ;
121 I $G(IBSFD)="SUB" D VAMCFD^IBCEF75(+$G(IBXIEN),.IBZ) I $D(IBZ),'$G(IBZ("C",1)) G GETFACX
122 ;
123 S Z=$S('IBFILE:$G(^DIC(4,+IB,1)),1:$G(^IBA(355.93,+IB,0)))
124 I +IBELE=0 S IBX=$S('IBFILE:$P($G(^DIC(4,+IB,0)),U),1:$P($G(^IBA(355.93,+IB,0)),U))
125 I IBELE=1!(IBELE=12) S IBX=$S('IBFILE:$P(Z,U),1:$P(Z,U,5))
126 I IBELE=2!(IBELE=12) S IBX=$S(IBELE=12:IBX_" ",1:"")_$S('IBFILE:$P(Z,U,2),1:$P(Z,U,10))
127 ;
128 I +IBELE=3,'IBFILE D
129 . S:IBELE=3!(IBELE["C") IBX=$P(Z,U,3) Q:IBELE["C"
130 . 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"
131 . S:IBELE=3 IBX=IBX_" " S:IBELE=3!(IBELE["Z") IBX=IBX_$P(Z,U,4)
132 . Q
133 ;
134 I +IBELE=3,IBFILE D
135 . S:IBELE=3!(IBELE["C") IBX=$P(Z,U,6) Q:IBELE["C"
136 . S:IBELE=3 IBX=IBX_$S(IBX'="":", ",1:"") S:IBELE=3!(IBELE["S") IBX=IBX_$$STATE^IBCEFG1($P(Z,U,7))
137 . S:IBELE=3 IBX=IBX_" " S:IBELE=3!(IBELE["Z") IBX=IBX_$P(Z,U,8)
138 . Q
139GETFACX ;
140 Q IBX
141 ;
142ALLID(IBPRV,IBPTYP,IBZ) ; Returns array IBZ for all ids for provider IBPRV
143 ; for all provider id types or for id type in IBPTYP
144 ; IBPRV = vp ien of provider
145 ; IBPTYP = ien of provider id type to return or "" for all
146 ; IBZ = array returned with internal data:
147 ; IBZ(file 355.9 ien)=ID type^ID#^ins co^form type^bill care type^care un^X12 code for id type
148 N Z,Z0
149 K IBZ
150 G:'$G(IBPRV) ALLIDQ
151 S IBPTYP=$G(IBPTYP)
152 S Z=0 F S Z=$O(^IBA(355.9,"B",IBPRV,Z)) Q:'Z S Z0=$G(^IBA(355.9,Z,0)) D
153 . 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)
154 ;
155ALLIDQ Q
156 ;
157CLIA() ; Returns ien of CLIA # provider id type
158 N Z,IBZ
159 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
160 Q IBZ
161 ;
162STLIC() ; Returns ien of STLIC# provider id type
163 N Z,IBZ
164 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
165 Q IBZ
166 ;
167TAXID() ; Returns ien of Fed tax id provider id type
168 N Z,IBZ
169 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
170 Q IBZ
171 ;
172CLIANVA(IBIFN) ; Returns CLIA # for a non-VA facility on bill ien IBIFN
173 N IBCLIA,IBZ,IBNVA,Z
174 S IBCLIA="",IBZ=$$CLIA()
175 I IBZ D
176 . S IBNVA=$P($G(^DGCR(399,IBIFN,"U2")),U,10) Q:'IBNVA
177 . S IBCLIA=$$IDFIND^IBCEP2(IBIFN,IBZ,IBNVA_";IBA(355.93,","",1)
178 Q IBCLIA
179 ;
180VALFAC(X) ; Function returns 1 if format is valid for X12 facility name
181 ; Alpha/numeric/certain punctuation valid. Must start with an Alpha
182 N OK,VAL
183 S OK=1
184 S VAL("A")="",VAL("N")="",VAL=",.- "
185 I $E(X)'?1A!'$$VALFMT(X,.VAL) S OK=0
186 Q OK
187 ;
188VALFMT(X,VAL) ; Returns 1 if format of X is valid, 0 if not
189 ; X = data to be examined
190 ; VAL = a 'string' of valid characters AND/OR (passed by reference)
191 ; if VAL("A") defined ==> Alpha
192 ; if VAL("A") defined ==> Numeric valid
193 ; if VAL("A") defined ==> Punctuation valid
194 ; any other character included in the string is checked individually
195 N Z
196 I $D(VAL("A")) D
197 . N Z0
198 . F Z=1:1:$L(X) I $E(X,Z)?1A S Z0(Z)=""
199 . S Z0="" F S Z0=$O(Z0(Z0),-1) Q:'Z0 S $E(X,Z0)=""
200 I $D(VAL("N")) D
201 . N Z0
202 . F Z=1:1:$L(X) I $E(X,Z)?1N S Z0(Z)=""
203 . S Z0="" F S Z0=$O(Z0(Z0),-1) Q:'Z0 S $E(X,Z0)=""
204 I $D(VAL("P")) D
205 . N Z0
206 . F Z=1:1:$L(X) I $E(X,Z)?1P S Z0(Z)=""
207 . S Z0="" F S Z0=$O(Z0(Z0),-1) Q:'Z0 S $E(X,Z0)=""
208 I $G(VAL)'="" S X=$TR(X,VAL,"")
209 Q (X="")
210 ;
211PS(IBXSAVE) ; Returns 1 if IBXSAVE("PSVC") indicates the svc was non-lab
212 ;
213 Q $S($G(IBXSAVE("PSVC"))="":0,1:"13"[IBXSAVE("PSVC"))
214 ;
215 ; Pass in the Internal Entry number to File 355.93
216 ; Return the Primary ID and Qualifier (ID Type) from 355.9
217PRIMID(IEN35593) ; Return External Primary ID and ID Quailier
218 N INDXVAL,LIST,MSG,IDCODE
219 S INDXVAL=IEN35593_";IBA(355.93,"
220 N SCREEN S SCREEN="I $P(^(0),U,8)"
221 D FIND^DIC(355.9,,"@;.06EI;.07","Q",INDXVAL,,,SCREEN,,"LIST","MSG")
222 I '+$G(LIST("DILIST",0)) Q "" ; No Primary ID
223 I +$G(LIST("DILIST",0))>1 Q "***ERROR***^***ERROR***" ; Bad. More than one.
224 ; Found just one
225 S IDCODE=$$GET1^DIQ(355.97,LIST("DILIST","ID",1,.06,"I"),.03)
226 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.