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

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

initial load of WorldVistAEHR

File size: 7.4 KB
RevLine 
[613]1DGPFUT2 ;ALB/KCL - PRF UTILITIES CONTINUED ; 12/17/03 2:56pm
2 ;;5.3;Registration;**425,554,650**;Aug 13, 1993;Build 3
3 ;
4 ; This routine contains generic calls for use throughout DGPF*.
5 ;
6 ;- no direct entry
7 QUIT
8 ;
9 ;
10GETPAT(DGDFN,DGPAT) ;retrieve patient identifying information
11 ; Used to obtain identifying information for a patient
12 ; in the PATIENT (#2) file and place it in an array format.
13 ;
14 ; NOTE: Direct global reference of patient's zero node in the
15 ; PATIENT (#2) file is supported by DBIA #10035
16 ;
17 ; Input:
18 ; DGDFN - (required) ien of patient in PATIENT (#2) file
19 ;
20 ; Output:
21 ; Function Value - returns 1 on success, 0 on failure
22 ; DGPAT - output array containing the patient identifying information,
23 ; on success, pass by reference.
24 ; Array subscripts are:
25 ; "DFN" - ien PATIENT (#2) file
26 ; "NAME" - patient name
27 ; "SSN" - patient Social Security Number
28 ; "DOB" - patient date of birth (FM format)
29 ; "SEX" - patient sex
30 ;
31 N DGNODE
32 N RESULT
33 ;
34 S RESULT=0
35 ;
36 I $G(DGDFN)>0,$D(^DPT(DGDFN,0)) D
37 .
38 . ;-- obtain zero node of patient record (supported by DBIA #10035)
39 . S DGNODE=$G(^DPT(DGDFN,0))
40 . ;
41 . S DGPAT("DFN")=DGDFN
42 . S DGPAT("NAME")=$P(DGNODE,"^")
43 . S DGPAT("SEX")=$P(DGNODE,"^",2)
44 . S DGPAT("DOB")=$P(DGNODE,"^",3)
45 . S DGPAT("SSN")=$P(DGNODE,"^",9)
46 . S RESULT=1 ;success
47 ;
48 Q RESULT
49 ;
50GETDFN(DGICN,DGEROOT) ;Used to convert an ICN to a DFN.
51 ;
52 ; Supported DBIA #2701: The supported DBIA is used to retrieve the
53 ; pointer (DFN) to the PATIENT (#2) file for a
54 ; given ICN.
55 ;
56 ; Input:
57 ; DGICN - Integrated Control Number with or without checksum
58 ; DGEROOT - (optional) closed root array name (i.e. "DGERROR") for
59 ; error dialog returned from BLD^DIALOG. If not passed,
60 ; error dialog is returned in ^TMP("DIERR",$J) global.
61 ;
62 ; Output:
63 ; Function Value - DFN on success, 0 on failure
64 ; DGEROOT() - error output array from BLD^DIALOG
65 ;
66 N DGDFN ;ptr to patient
67 N DIERR ;var returned from BLD^DIALOG
68 ;
69 ;init error output array if passed
70 S DGEROOT=$G(DGEROOT)
71 I DGEROOT]"" K @DGEROOT
72 ;
73 S DGDFN=+$$GETDFN^MPIF001(+$G(DGICN))
74 I DGDFN'>0 D BLD^DIALOG(261127,,,DGEROOT,"F")
75 ;
76 Q $S(DGDFN'>0:0,1:DGDFN)
77 ;
78SORT(DGPFARR) ;Re-sort of active record assignments by category then flag name
79 ; This function re-sorts the active record flag assignment list for a
80 ; patient by category (Cat I or Cat II) and then by flag name.
81 ;
82 ; Input: [Required]
83 ; DGPFARR - Closed root reference array name of active assignments
84 ; to be sorted
85 ;
86 ; Output:
87 ; Function Value - returns 1 on success, 0 on failure
88 ;
89 ; DGPFARR() - Closed Root reference name of re-sorted assignments
90 ; - Category I's will sort first in the returned array.
91 ; - Category II's will sort second.
92 ;
93 N DGCAT ;category
94 N DGINDX ;index array
95 N DGNAME ;flag name
96 N DGSORT ;re-sorted data array
97 N DGX ;generic counter
98 ;
99 ; check for input value - Quit if none found
100 Q:DGPFARR']"" 0
101 Q:'$O(@DGPFARR@("")) 0
102 ;
103 S DGSORT=$NA(^TMP("DGPFUT2",$J))
104 K @DGSORT
105 ;
106 ;build index - ARRAY(Category (I or II),Flag Name)=sort number
107 S DGX=0
108 F S DGX=$O(@DGPFARR@(DGX)) Q:'DGX D
109 . S DGCAT=$S($P(@DGPFARR@(DGX,"FLAG"),U)[26.11:2,1:1)
110 . S DGINDX(DGCAT,$P(@DGPFARR@(DGX,"FLAG"),U,2))=DGX
111 ;
112 ;build sorted data array -
113 S (DGCAT,DGX)=0
114 F S DGCAT=$O(DGINDX(DGCAT)) Q:'DGCAT D
115 . S DGNAME=""
116 . F S DGNAME=$O(DGINDX(DGCAT,DGNAME)) Q:DGNAME="" D
117 . . S DGX=DGX+1
118 . . M @DGSORT@(DGX)=@DGPFARR@(DGINDX(DGCAT,DGNAME))
119 ;
120 ;remove input array and replace with sorted array, kill sort array
121 K @DGPFARR
122 M @DGPFARR=@DGSORT
123 K @DGSORT
124 ;
125 Q 1
126 ;
127ACTDT ; update PRF Software Activation Date field in (#26.18)
128 ; This utility should only be run at the Alpha and Beta test sites
129 ; of the Patient Record Flags Project, Patch DG*5.3*425.
130 ; If necessary, this entry point will change the date that the
131 ; Patient Record Flags (PRF) System became active.
132 ; The (#1) PRF SOFTWARE ACTIVATION DATE field of the (#26.18) PRF
133 ; PARAMETERS file, will be changed to: SEP 25, 2003
134 ;
135 ; Input: none
136 ;
137 ; Output: User message on successful or failure of file update
138 ;
139 N DGACTDT ; Nationally Released Software Activation Date value
140 N DGIENS ; IEN - internal entry # OF (#26.18) FILE
141 N DGFLD ; PRF Software Activation Date field #
142 N DGFDA ; FDA data array for filer
143 N DGERR ; error message array returned from filer
144 N DGERRMSG ; error message for display
145 N DGPARM ; current internal/external values of field
146 ;
147 S DGACTDT="SEP 25, 2003"
148 S DGIENS="1,"
149 S DGFLD=1
150 ;
151 ; display user message
152 W !!,"Updating the PRF SOFTWARE ACTIVATION DATE (#1) field in the PRF PARAMETERS FILE (#26.18) to the value of SEP 25, 2003..."
153 ;
154 ; checks for necessary programmer variables
155 I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D
156 . S DGERRMSG="Your programming variables are not set up properly."
157 ;
158 ; check if activation is not less than the current date
159 I '$D(DGERRMSG),DT<3030925 D
160 . S DGERRMSG="This file/field update can't be run before the date of SEP 25, 2003 is reached."
161 ;
162 ; get current activation date from PRF PARAMETERS (#26.18) file
163 I '$D(DGERRMSG) D
164 . D GETS^DIQ(26.18,"1,",1,"IE","DGPARM","DGERR")
165 . ;
166 . ; check for errors and inform the user
167 . I $D(DGERR) D Q
168 . . S DGERRMSG=$G(DGERR("DIERR",1,"TEXT",1))
169 . ;
170 . ; check to make sure field is not set already
171 . I $G(DGPARM(26.18,"1,",1,"I"))=3030925 D
172 . . S DGERRMSG="The date value is already set to SEP 25, 2003."
173 ;
174 ; now start the (#26.18) filing process
175 I '$D(DGERRMSG) D
176 . ;
177 . ; DELETE activation date before filing since field is uneditable
178 . S DGFDA(26.18,DGIENS,1)="@"
179 . D FILE^DIE("","DGFDA","DGERR")
180 . ;
181 . ; check for errors and inform the user
182 . I $D(DGERR) D Q
183 . . S DGERRMSG=$G(DGERR("DIERR",1,"TEXT",1))
184 . ;
185 . ; setup and file the new activation date value (external)
186 . S DGFDA(26.18,DGIENS,1)=DGACTDT
187 . D FILE^DIE("SE","DGFDA","DGERR")
188 . ;
189 . ; check for success or errors and inform the user of update status
190 . I $D(DGERR) D Q
191 . . S DGERRMSG=$G(DGERR("DIERR",1,"TEXT",1))
192 ;
193 ; display successful/failure file update - updated field and value
194 W !!,$C(7)
195 I $D(DGERRMSG) D
196 . W "Field could not be updated...",DGERRMSG
197 E D
198 . W "Field was successfully changed from ",$G(DGPARM(26.18,"1,",1,"E"))," to ",$G(DGFDA(26.18,DGIENS,DGFLD)),"."
199 ;
200 Q
201 ;
202BLDTFL(DGDFN,DGTFL) ;build array of Treating Facilities
203 ; This function builds an array of INSTITUTION (#4) file pointers
204 ; that are non-local medical treating facilities for a given patient.
205 ;
206 ; Input:
207 ; DGDFN - pointer to patient in PATIENT (#2) file
208 ;
209 ; Output:
210 ; Function value - 1 on results returned; 0 on failure
211 ; DGTFL - array of treating facility INSTITUTION (#4) file pointers
212 ; Format: DGTFL(pointer)=date last treated
213 ;
214 N DGLOC ;pointer to local facility in INSTITUTION (#4) file
215 N DGDLT ;date last treated
216 N DGFAC ;TFL API results array
217 N DGI ;generic counter
218 N DGINST ;pointer to INSTITUTION (#4) file
219 ;
220 Q:$G(DGDFN)'>0 0 ;validate input parameter
221 ;
222 D TFL^VAFCTFU1(.DGFAC,DGDFN)
223 S DGLOC=$P($$SITE^VASITE(),U)
224 S DGI=0
225 F S DGI=$O(DGFAC(DGI)) Q:'DGI D
226 . S DGINST=$$IEN^XUAF4($P(DGFAC(DGI),U))
227 . Q:DGINST'>0
228 . Q:DGINST=DGLOC ;filter local facility
229 . Q:'$$TF^XUAF4(DGINST) ;facility must be active treating facility
230 . S DGDLT=+$P(DGFAC(DGI),U,3)
231 . S DGTFL(DGINST)=DGDLT
232 ;
233 Q $S(+$O(DGTFL(0)):1,1:0)
Note: See TracBrowser for help on using the repository browser.