source: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUAF4.m@ 1621

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

initial load of FOIAVistA 6/30/08 version
File size: 7.1 KB
Line 
1XUAF4 ;ISC-SF/RWF/RAM - Institution file access. ;04/01/99 08:07
2 ;;8.0;KERNEL;**43,112,206,209,232,217,261,394**;Jul 10, 1995
3 Q ;No access from the top.
4 ;
5PARENT(ROOT,CHILD,ASSO) ;sr. Return array of IEN's of parents
6 N %,%0
7 S CHILD=$$LKUP(CHILD),ASSO=$$ASSO($G(ASSO)),%=0
8 F S %=$O(^DIC(4,CHILD,7,%)) Q:%'>0 S %0=+$P(^(%,0),U,2) D
9 . Q:+%'=ASSO
10 . S @ROOT@("P",+%0)=$$NS(+%0)
11 Q
12CHILDREN(ROOT,PAR,ASSO,XUAC) ;sr. Return the children
13 N %,%1 S %=0,PAR=$$LKUP(PAR),ASSO=$$ASSO($G(ASSO)),XUAC=$G(XUAC)
14 Q:ASSO'>0
15 F S %=$O(^DIC(4,"AC",ASSO,PAR,%)) Q:%'>0 D
16 . I XUAC,$$STATUS(%)="I" Q
17 . S @ROOT@("C",%)=$$NS(%)
18 Q
19SIBLING(ROOT,CHILD,ASSO) ;sr. Return the siblings
20 N % S %=0,ASSO=$$ASSO($G(ASSO))
21 D PARENT(ROOT,CHILD,ASSO)
22 F S %=$O(@ROOT@("P",%)) Q:%'>0 D CHILDREN($NA(@ROOT@("P",%)),"`"_%,ASSO)
23 Q
24NNT(%) ;ef.sr. Return Name, Station Number, ASSO
25 I %'>0 Q ""
26 Q $$NS(%)_"^"_$$WHAT(%,13)
27 ;
28LKUP(%) ;ef.sr. Resolve a value into IEN
29 I $E(%)="`" S %=+$E(%,2,99) Q:$D(^DIC(4,%,0))#2 % Q 0
30 ;Q $$FIND1^DIC(4,,"MX",%)
31 Q $$FIND1^DIC(4,,"MX",%,,"I $P(^(0),U,11)'=""I""") ;To screen Inactive
32 ;
33STATUS(%) ;Get the status of a IEN
34 Q $P($G(^DIC(4,%,0)),U,11)
35 ;
36TYPE(%) ;Lookup a Faclity TYPE in file 4.1
37 I %="" Q %
38 I $D(^DIC(4.1,"B",%))>9 Q %
39 S %=$$FIND1^DIC(4.1,,"MX",%)
40 Q $P($G(^DIC(4.1,+%,0)),U)
41 ;
42ASSO(%) ;Lookup an Asso
43 Q:+%=% % S:%="" %="VISN"
44 S %=$$FIND1^DIC(4.05,,"MX",%)
45 Q +%
46 ;
47NS(IEN) ;ef.sr. Return name and station #
48 Q $P($G(^DIC(4,IEN,0)),U,1)_U_$P($G(^DIC(4,+IEN,99)),U,1)
49 ;
50WHAT(IEN,FLD) ;ef.sr. Field to return
51 Q $$GET1^DIQ(4,IEN_",",FLD,"")
52 ;
53CIRN(%1,%2) ;ef.sr. Is this a CIRN Enables inst.
54 N % S %1=+$G(%1)
55 Q:'$D(^DIC(4,%1,0)) -1
56 I $G(%2)]"" N DIE,DR,DA S DA=%1,DR="990.1///"_%2,DIE="^DIC(4," D ^DIE
57 Q $$WHAT(%1,990.1)
58 ;
59IEN(STA) ;return IEN for a station number
60 S STA=$G(STA) Q:STA="" STA
61 Q $O(^DIC(4,"D",STA,0))
62 ;
63STA(IEN) ;return station number for an IEN
64 Q $P($G(^DIC(4,+IEN,99)),U)
65 ;
66TF(IEN) ;active treating facility? (1=YES,0=NO)
67 N ARRAY Q:'$G(IEN) 0
68 D F4($$STA(IEN),.ARRAY,"AM")
69 Q $S(ARRAY:1,1:0)
70 ;
71RT(IEN) ;realigned to
72 N ARRAY Q:'$G(IEN) 0
73 D F4($$STA(IEN),.ARRAY)
74 Q $G(ARRAY("REALIGNED TO"))
75 ;
76RF(IEN) ;realigned from
77 N ARRAY Q:'$G(IEN) 0
78 D F4($$STA(IEN),.ARRAY)
79 Q $G(ARRAY("REALIGNED FROM"))
80 ;
81O99(IEN) ;returns pointer to new station number IEN
82 Q:$O(^DIC(4,"AOLD99",+$G(IEN),""))="" ""
83 Q $O(^DIC(4,"D",$O(^DIC(4,"AOLD99",+$G(IEN),"")),0))
84 ;
85LEGACY(STA) ; -- legacy station number (1=yes; 0=no)
86 Q $S($$RT^XUAF4(+$$IEN^XUAF4(STA)):1,1:0)
87 ;
88PRNT(STA) ; -- parent facility
89 N X S STA=$G(STA) Q:STA="" "0^no station number passed"
90 D PARENT("X",STA,"PARENT FACILITY") S X=$O(X("P",0))
91 Q:'X "0^no parent associated with input station number"
92 Q X_U_$P($G(X("P",+X)),U,2)_U_$P($G(X("P",+X)),U)
93 ;
94NAME(IEN) ; -- Official Name
95 Q:$P($G(^DIC(4,+IEN,99)),U,3)'="" $P($G(^DIC(4,+IEN,99)),U,3)
96 Q $P($G(^DIC(4,+IEN,0)),U)
97 ;
98ACTIVE(IEN) ; -- active facility (1=active, 0=inactive)
99 ;
100 Q '$P($G(^DIC(4,+IEN,99)),U,4)
101 ;
102PADD(IEN) ; -- physical address (street addr^city^state^zip)
103 ;
104 N X,STATE
105 ;
106 S X=$P($G(^DIC(4,+IEN,0)),U,2)
107 S STATE=$P($G(^DIC(5,+X,0)),U,2)
108 S X=$G(^DIC(4,+IEN,1)) Q:X="" X
109 ;
110 Q $P(X,U)_U_$P(X,U,3)_U_STATE_U_$P(X,U,4)
111 ;
112MADD(IEN) ; -- mailing address (street addr^city^state^zip)
113 ;
114 N X,STATE
115 ;
116 S X=$G(^DIC(4,+IEN,4)) Q:X="" X
117 S STATE=$P($G(^DIC(5,+$P(X,U,4),0)),U,2)
118 ;
119 Q $P(X,U)_U_$P(X,U,3)_U_STATE_U_$P(X,U,5)
120 ;
121F4(STA,ARRAY,FLAG,ONDT) ;File #4 multipurpose API
122 ;
123 ;INPUT
124 ; STA Station number (required)
125 ;
126 ; [.]ARRAY $NAME reference for return values. (required)
127 ;
128 ; FLAG A = Active entries only. (optional)
129 ; M = Medical treating facilities only.
130 ;
131 ; ONDT Return name on this FM internal date. (optional);
132 ;
133 ;OUTPUT
134 ; ARRAY IEN or '0^error message'
135 ; ARRAY("NAME") name
136 ; ARRAY("VA NAME") offical va name
137 ; ARRAY("STATION NUMBER") station number
138 ; ARRAY("TYPE") facilty type name
139 ; ARRAY("INACTIVE") inactive date (0=not inactive)
140 ; note: if inactive date not available but entry inactive then 1
141 ;
142 ; ARRAY("REALIGNED TO") IEN^station number^date
143 ; ARRAY("REALIGNED FROM") IEN^station number^date
144 ;
145 K ARRAY
146 S STA=$G(STA),FLAG=$G(FLAG),ONDT=$G(ONDT)
147 I STA="" S ARRAY="0^invalid input STA - required" Q
148 ;
149 N IEN,N99,TO,FM,I,RDT,NAME,VANAME,HDT
150 ;
151 S IEN=$$IEN(STA)
152 I 'IEN S ARRAY="0^station number does not exist" Q
153 S N99=$G(^DIC(4,+IEN,99))
154 S ARRAY=$$SCRN() Q:'ARRAY
155 ;
156 S ARRAY("NAME")=$P(^DIC(4,IEN,0),U)
157 S ARRAY("VA NAME")=$P(N99,U,3)
158 S ARRAY("STATION NUMBER")=STA
159 S ARRAY("TYPE")=$P($G(^DIC(4.1,+$G(^DIC(4,IEN,3)),0)),U)
160 ;
161 ;realignments
162 S TO=$O(^DIC(4,"ARTO",IEN,0)) D:TO
163 .S RDT=$O(^DIC(4,"ART",TO,IEN,0))
164 .S ARRAY("REALIGNED TO")=TO_U_$$STA(TO)_U_RDT
165 S FM=$O(^DIC(4,"ARFM",IEN,0)) D:FM
166 .S ARRAY("REALIGNED FROM")=FM_U_$$STA(FM)_U_$O(^DIC(4,"ARF",FM,IEN,0))
167 ;
168 S I=$O(^DIC(4,"AI",IEN,0)),I=$S(I:I,$G(RDT):RDT,1:+$P(N99,U,4))
169 S ARRAY("INACTIVE")=I
170 ;
171 Q:'ONDT
172 ;
173 ;get name for date
174 S NAME=ARRAY("NAME")
175 S VANAME=ARRAY("VA NAME")
176 S HDT=DT
177 F S HDT=$O(^DIC(4,IEN,999,HDT),-1) Q:('HDT!(HDT<ONDT)) D
178 .N X S X=$G(^DIC(4,IEN,999,HDT,0)) Q:X=""
179 .S:$P(X,U,2)'="" NAME=$P(X,U,2)
180 .S:$P(X,U,3)'="" VANAME=$P(X,U,3)
181 S ARRAY("NAME")=NAME
182 S ARRAY("VA NAME")=VANAME
183 ;
184 Q
185 ;
186IDT(IEN) ; inactive date
187 N IDT,ND,XDT
188 S IEN=$G(IEN) Q:'IEN IEN
189 S XDT=9999999,IDT=""
190 F S XDT=$O(^DIC(4,+IEN,999,XDT),-1) Q:'XDT D Q:IDT
191 .S ND=$G(^DIC(4,+IEN,999,XDT,0)) Q:ND=""
192 .S IDT=$S($P(ND,U,5):XDT,$P(ND,U,7):XDT,1:IDT)
193 Q IDT
194 ;
195SCRN() ;sreen IEN
196 N X S X=$E(N99,1,3)
197 I FLAG["A",$P(N99,U,4) Q "0^inactive facility"
198 I FLAG["M",$S(X=358:0,X<400:1,X>759:1,X<700:0,X<750:1,1:0),$G(DUZ("AG"))="V" Q "0^not a treating facility"
199 Q IEN
200 ;
201LOOKUP ; -- lookup an enty by coding system / ID pair
202 ;
203 N DIC,D
204 ;
205 S DIC="^DIC(4,",DIC(0)="QEA",D="XUMFIDX" D IX^DIC
206 ;
207 Q
208 ;
209IDX(CDSYS,ID) ; -- return IEN for a given coding system / ID pair
210 ;
211 ;INPUT
212 ; CDSYS coding system (required)
213 ; ID identifier (required)
214 ;OUTPUT
215 ; $$ Internal Entry Number
216 ;
217 N IEN
218 ;
219 S CDSYS=$G(CDSYS),ID=$G(ID)
220 ;
221 Q:CDSYS="" "0^CDSYS required"
222 Q:ID="" "0^ID required"
223 ;
224 S IEN=$O(^DIC(4,"XUMFIDX",CDSYS,ID,0))
225 ;
226 Q $S(IEN:IEN,1:"0^not found")
227 ;
228ID(CDSYS,IEN) ; returns the ID for a given coding system / IEN
229 ;
230 ;INPUT
231 ; CDSYS coding system (required)
232 ; IEN Internal Entry Number (required)
233 ;OUTPUT
234 ; $$ Identifier
235 ;
236 N ID,IDX
237 ;
238 S CDSYS=$G(CDSYS),IEN=$G(IEN)
239 Q:CDSYS="" "" Q:'IEN "" Q:'$D(^DIC(4,IEN)) ""
240 ;
241 S IDX=$O(^DIC(4,IEN,9999,"B",CDSYS,0)) Q:'IDX ""
242 ;
243 Q $P($G(^DIC(4,IEN,9999,IDX,0)),U,2)
244 ;
245CDSYS(Y) ; coding systems
246 ;
247 ;INPUT/OUTPUT
248 ; .Y Y(CDSYS) = $D local system ^ coding system name
249 ;
250 S Y("DMIS")=$D(^DIC(4,"XUMFIDX","DMIS"))_U_"DoD DMIS ID"
251 S Y("VASTANUM")=$D(^DIC(4,"XUMFIDX","VASTANUM"))_U_"VA Station Number"
252 S Y("CLIA")=$D(^DIC(4,"XUMFIDX","CLIA"))_U_"CLIA number"
253 S Y("MAMMO-ACR")=$D(^DIC(4,"XUMFIDX","MAMMO-ACR"))_U_"MAMMO-ACR number"
254 ;
255 Q
256 ;
257LCDSYS(Y) ; list coding systems
258 ;
259 N CDSYS
260 S CDSYS=""
261 F S CDSYS=$O(^DIC(4,"XUMFIDX",CDSYS)) Q:CDSYS="" D
262 .S Y(CDSYS)=""
263 ;
264 Q
265 ;
266
Note: See TracBrowser for help on using the repository browser.