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

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

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