source: FOIAVistA/tag/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPFUT.m@ 711

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

WorldVistAEHR overlayed on FOIAVistA
File size: 8.8 KB
Line 
1DGPFUT ;ALB/RPM - PRF UTILITIES ;7:46 PM 30 Jan 2008
2 ;;5.3;Registration;**425,554,650,VWEHR1**;WorldVistA 30-Jan-08
3 ;
4 ;Modified from FOIA VISTA,
5 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
6 ;General Public License See attached copy of the License.
7 ;
8 ;This program is free software; you can redistribute it and/or modify
9 ;it under the terms of the GNU General Public License as published by
10 ;the Free Software Foundation; either version 2 of the License, or
11 ;(at your option) any later version.
12 ;
13 ;This program is distributed in the hope that it will be useful,
14 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;GNU General Public License for more details.
17 ;
18 ;You should have received a copy of the GNU General Public License along
19 ;with this program; if not, write to the Free Software Foundation, Inc.,
20 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
21 ;
22 Q ;no direct entry
23 ;
24ANSWER(DGDIRA,DGDIRB,DGDIR0,DGDIRH,DGDIRS) ;wrap FileMan Classic Reader call
25 ;
26 ; Input
27 ; DGDIR0 - DIR(0) string
28 ; DGDIRA - DIR("A") string
29 ; DGDIRB - DIR("B") string
30 ; DGDIRH - DIR("?") string
31 ; DGDIRS - DIR("S") string
32 ;
33 ; Output
34 ; Function Value - Internal value returned from ^DIR or -1 if user
35 ; up-arrows, double up-arrows or the read times out.
36 ;
37 ; DIR(0) type Results
38 ; ------------ -------------------------------
39 ; DD IEN of selected entry
40 ; Pointer IEN of selected entry
41 ; Set of Codes Internal value of code
42 ; Yes/No 0 for No, 1 for Yes
43 ;
44 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y ;^DIR variables
45 ;
46 S DIR(0)=DGDIR0
47 S DIR("A")=$G(DGDIRA)
48 I $G(DGDIRB)]"" S DIR("B")=DGDIRB
49 I $D(DGDIRH) S DIR("?")=DGDIRH
50 I $G(DGDIRS)]"" S DIR("S")=DGDIRS
51 D ^DIR
52 Q $S($D(DUOUT):-1,$D(DTOUT):-1,$D(DIROUT):-1,X="@":"@",1:$P(Y,U))
53 ;
54CONTINUE() ;pause display
55 ;
56 ; Input: none
57 ;
58 ; Output: 1 - continue
59 ; 0 - quit
60 ;
61 N DIR,Y
62 S DIR(0)="E" D ^DIR
63 Q $S(Y'=1:0,1:1)
64 ;
65VALID(DGRTN,DGFILE,DGIP,DGERR) ;validate input values before filing
66 ;
67 ; Input:
68 ; DGRTN - (required) Routine name that contains $TEXT table
69 ; DGFILE - (required) File number for input values
70 ; DGIP - (required) Input value array
71 ; DGERR - (optional) Returns error message passed by reference
72 ;
73 ; Output:
74 ; Function Value - Returns 1 on all values valid, 0 on failure
75 ;
76 I $G(DGRTN)=""!('$G(DGFILE)) Q 0
77 N DGVLD ;function return value
78 N DGFXR ;node name to field xref array
79 N DGREQ ;array of required fields
80 N DGWP ;word processing flag
81 N DGN ;array node name
82 ;
83 S DGVLD=1
84 S DGN=""
85 D BLDXR(DGRTN,.DGFXR)
86 ;
87 F S DGN=$O(DGFXR(DGN)) Q:DGN="" D Q:'DGVLD
88 . S DGREQ=$P(DGFXR(DGN),U,2)
89 . S DGWP=$P(DGFXR(DGN),U,3)
90 . I DGREQ D ;required field check
91 . . I DGWP,'$$CKWP("DGIP(DGN)") S DGVLD=0 Q
92 . . I 'DGWP,$G(DGIP(DGN))']"" S DGVLD=0 Q
93 . I 'DGVLD D Q
94 . . S DGERR=$$GET1^DID(DGFILE,+DGFXR(DGN),,"LABEL")_" REQUIRED"
95 . Q:DGWP ;don't check word processing fields for invalid values
96 . ;check for invalid values
97 . I '$$TESTVAL(DGFILE,+DGFXR(DGN),$P($G(DGIP(DGN)),U)) D Q
98 . . S DGVLD=0,DGERR=$$GET1^DID(DGFILE,+DGFXR(DGN),,"LABEL")_" NOT VALID"
99 Q DGVLD
100 ;
101BLDXR(DGRTN,DGFLDA) ;build name/field xref array
102 ;This procedure reads in the text from the XREF line tag of the DGRTN
103 ;input parameter and loads name/field xref array with parsed line data.
104 ;
105 ; Input:
106 ; DGRTN - (required) Routine name that contains the XREF line tag
107 ; DGFLDA - (required) Array name for name/field xref passed by
108 ; reference
109 ;
110 ; Output:
111 ; Function Value - Returns 1 on success, 0 on failure
112 ; DGFLDA - Name/field xref array
113 ; format: DGFLDA(subscript)=field#^required?^word proc?
114 ;
115 S DGRTN=$G(DGRTN)
116 Q:DGRTN=""
117 I $E(DGRTN,1)'="^" S DGRTN="^"_DGRTN
118 Q:($T(@DGRTN)="")
119 N DGTAG
120 N DGOFF
121 N DGLINE
122 ;
123 F DGOFF=1:1 S DGTAG="XREF+"_DGOFF_DGRTN,DGLINE=$T(@DGTAG) Q:DGLINE="" D
124 . S DGFLDA($P(DGLINE,";",3))=$P(DGLINE,";",4)_U_+$P(DGLINE,";",5)_U_+$P(DGLINE,";",6)
125 Q
126 ;
127CKWP(DGROOT) ;ck word processing required fields
128 ;This function verifies that at least one line in the word processing
129 ;array contains text more than one space long.
130 ;
131 ; Input:
132 ; DGROOT - (required) Word processing root
133 ;
134 ; Output:
135 ; Function Value - Returns 1 on success, 0 on failure
136 ;
137 N DGLIN
138 N DGRSLT
139 S DGRSLT=0
140 I $D(@DGROOT) D
141 . S DGLIN=""
142 . F S DGLIN=$O(@DGROOT@(DGLIN)) Q:DGLIN="" D Q:DGRSLT
143 . . I $G(@DGROOT@(DGLIN,0))]"",@DGROOT@(DGLIN,0)'=" " S DGRSLT=1
144 Q DGRSLT
145 ;
146TESTVAL(DGFIL,DGFLD,DGVAL) ;validate individual value against field def
147 ;
148 ; Input:
149 ; DGFIL - (required) File number
150 ; DGFLD - (required) Field number
151 ; DGVAL - (required) Field value to be validated
152 ;
153 ; Output:
154 ; Function Value - Returns 1 if value is valid, 0 if value is invalid
155 ;
156 N DGVALEX ;external value after conversion
157 N DGTYP ;field type
158 N DGRSLT ;results of CHK^DIE
159 N VALID ;function results
160 ;
161 S VALID=1
162 I $G(DGFIL)>0,($G(DGFLD)>0),($G(DGVAL)'="") D
163 . S DGVALEX=$$EXTERNAL^DILFD(DGFIL,DGFLD,"F",DGVAL)
164 . I DGVALEX="" S VALID=0 Q
165 . I $$GET1^DID(DGFIL,DGFLD,"","TYPE")'["POINTER" D
166 . . D CHK^DIE(DGFIL,DGFLD,,DGVALEX,.DGRSLT) I DGRSLT="^" S VALID=0 Q
167 Q VALID
168 ;
169STATUS(DGACT) ;calculate the assignment STATUS given an ACTION code
170 ;
171 ; Input:
172 ; DGACT - (required) Action (.03) field value for PRF ASSIGNMENT
173 ; HISTORY (#26.14) file in internal or external format
174 ;
175 ; Output:
176 ; Function Value - Status value on success, -1 on failure
177 ;
178 N DGERR ;FM message root
179 N DGRSLT ;CHK^DIE result array
180 N DGSTAT ;calculated status value
181 ;
182 S DGSTAT=-1
183 I $G(DGACT)]"" D
184 . I DGACT?1.N S DGACT=$$EXTERNAL^DILFD(26.14,.03,"F",DGACT,"DGERR")
185 . Q:$D(DGERR)
186 . D CHK^DIE(26.14,.03,"E",DGACT,.DGRSLT,"DGERR")
187 . Q:$D(DGERR)
188 . I DGRSLT(0)="INACTIVATE"!(DGRSLT(0)="ENTERED IN ERROR") S DGSTAT=0
189 . E S DGSTAT=1
190 Q DGSTAT
191 ;
192MPIOK(DGDFN,DGICN) ;return national ICN
193 ;This function verifies that a given patient has a valid national
194 ;Integration Control Number.
195 ;
196 ; Supported DBIA #2701: The supported DBIA is used to access MPI
197 ; APIs to retrieve ICN and determine if ICN
198 ; is local.
199 ;
200 ; Input:
201 ; DGDFN - (required) IEN of patient in PATIENT (#2) file
202 ; DGICN - (optional) passed by reference to contain national ICN
203 ;
204 ; Output:
205 ; Function Value - 1 on valid national ICN;
206 ; 0 on failure
207 ; DGICN - Patient's Integrated Control Number
208 ;
209 N DGRSLT
210 S DGRSLT=0
211 I $G(DGDFN)>0 D
212 . S DGICN=$$GETICN^MPIF001(DGDFN)
213 . ;
214 . ;ICN must be valid
215 . Q:(DGICN'>0)
216 . ;
217 . ;ICN must not be local
218 . Q:$$IFLOCAL^MPIF001(DGDFN)
219 . ;
220 . S DGRSLT=1
221 Q DGRSLT
222 ;
223GETNXTF(DGDFN,DGLTF) ;get previous treating facility
224 ;This function will return the treating facility with a DATE LAST
225 ;TREATED value immediately prior to the date for the treating facility
226 ;passed as the second parameter. The most recent treating facility
227 ;will be returned when the second parameter is missing, null, or zero.
228 ;
229 ; Input:
230 ; DGDFN - pointer to patient in PATIENT (#2) file
231 ; DGLTF - (optional) last treating facility [default=0]
232 ;
233 ; Output:
234 ; Function value - previous facility as a pointer to INSTITUTION (#4)
235 ; file on success; 0 on failure
236 ;
237 N DGARR ;fully subscripted array node
238 N DGDARR ;date sorted treating facilities
239 N DGINST ;institution pointer
240 N DGNAM ;name of sorted treating facilities array
241 N DGTFARR ;array of non-local treating facilities
242 ;
243 ;
244 I $G(DGDFN)>0,$$BLDTFL^DGPFUT2(DGDFN,.DGTFARR) D
245 . ;
246 . ;validate last treating facility input parameter
247 . S DGLTF=+$G(DGLTF)
248 . S DGLTF=$S(DGLTF&($D(DGTFARR(DGLTF))):DGLTF,1:0)
249 . ;
250 . ;build date sorted list
251 . S DGINST=0
252 . F S DGINST=$O(DGTFARR(DGINST)) Q:'DGINST D
253 . . S DGDARR(DGTFARR(DGINST),DGINST)=""
254 . ;
255 . ;find entry for previous treating facility
256 . S DGNAM="DGDARR"
257 . ;
258 . ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
259 . ;
260 . ;S DGARR=$QUERY(@DGNAM@(""),-1)
261 . S DGARR=$$Q^VWUTIL($NA(@DGNAM@("")),-1)
262 . ;
263 . ;END CHANGE
264 . ;
265 . I DGLTF,DGARR]"" D
266 . . I $QS(DGARR,2)'=DGLTF D
267 . . . ;
268 . . . ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
269 . . . ;
270 . . . ;F S DGARR=$QUERY(@DGARR,-1) Q:+$QS(DGARR,2)=DGLTF
271 . . . F S DGARR=$$Q^VWUTIL($NA(@DGARR),-1) Q:+$QS(DGARR,2)=DGLTF
272 . . . ;
273 . . . ;END CHANGE
274 . . . ;
275 . . ;
276 . . ;WV/EHR REVERSE $Q REPLACEMENT; SO 01/12/08 ;VWEHR1
277 . . ;
278 . . ;S DGARR=$QUERY(@DGARR,-1)
279 . . S DGARR=$$Q^VWUTIL($NA(@DGARR),-1)
280 . . ;
281 . . ;END CHANGE
282 . . ;
283 ;
284 Q $S($G(DGARR)]"":+$QS(DGARR,2),1:0)
285 ;
286ISDIV(DGSITE) ;is site local division
287 ;
288 ; Input:
289 ; DGSITE - pointer to INSTITUTION (#4) file
290 ;
291 ; Output:
292 ; Function value - 1 on success; 0 on failure
293 ;
294 S DGSITE=+$G(DGSITE)
295 Q $S($D(^DG(40.8,"AD",DGSITE)):1,1:0)
Note: See TracBrowser for help on using the repository browser.