source: Scheduling/trunk/m/BSDX01.m@ 1150

Last change on this file since 1150 was 1142, checked in by Sam Habiel, 14 years ago

Updated version number to 1.5 Beta 1
File size: 11.3 KB
Line 
1BSDX01 ; IHS/OIT/HMW - WINDOWS SCHEDULING RPCS ; 3/16/11 7:08am
2 ;;1.5T1;BSDX;;Apr 06, 2011
3 ;
4SUINFOD(BSDXY,BSDXDUZ) ;EP Debugging entry point
5 ;D DEBUG^%Serenji("SUINFO^BSDX01(.BSDXY,BSDXDUZ)")
6 ;
7 Q
8 ;
9SUINFO(BSDXY,BSDXDUZ) ;EP
10 ;Called by BSDX SCHEDULING USER INFO
11 ;Returns ADO Recordset having column MANAGER
12 ;MANAGER = YES if user has keys BSDXZMGR or XUPROGMODE
13 ;
14 N BSDXMGR,BSDXERR
15 K ^BSDXTMP($J)
16 S BSDXY="^BSDXTMP("_$J_")"
17 S BSDXI=0
18 S BSDXERR=""
19 S ^BSDXTMP($J,BSDXI)="T00010MANAGER"_$C(30)
20 ;Check SECURITY KEY file for BSDXZMGR or XUPROGMODE keys
21 I '+BSDXDUZ S BSDXDUZ=DUZ
22 S BSDXMGR=$$APSEC("BSDXZMGR",BSDXDUZ)
23 S BSDXMGR=$S(BSDXMGR=1:"YES",1:"NO")
24 S BSDXI=BSDXI+1
25 S ^BSDXTMP($J,BSDXI)=BSDXMGR_$C(30)
26 S ^BSDXTMP($J,BSDXI+1)=$C(31)_BSDXERR
27 Q
28DEPUSRD(BSDXY,BSDXDUZ) ;EP Debugging entry point
29 ;
30 ;
31 ;D DEBUG^%Serenji("DEPUSR^BSDX01(.BSDXY,BSDXDUZ)")
32 ;
33 Q
34 ;
35DEPUSR(BSDXY,BSDXDUZ) ;EP
36 ;Called by BSDX RESOURCE GROUPS BY USER
37 ;Returns ADO Recordset with all ACTIVE resource group names to which user has access
38 ;based on entries in BSDX RESOURCE USER file (Say this again for myself: Groups ONLY!!)
39 ;If BSDXDUZ=0 then returns all department names for current DUZ
40 ;if not linked, always returned.
41 ;If user BSDXDUZ possesses the key BSDXZMGR or XUPROGMODE
42 ;then ALL resource group names are returned regardless of whether any active resources
43 ;are associated with the group or not.
44 ;
45 ;
46 N BSDXERR,BSDXRET,BSDXIEN,BSDXRES,BSDXDEP,BSDXDDR,BSDXDEPN,BSDXRDAT,BSDXRNOD,BSDXI
47 N BSDXMGR,BSDXNOD
48 K ^BSDXTEMP($J)
49 K ^BSDXTMP($J)
50 S BSDXY="^BSDXTMP("_$J_")"
51 S BSDXI=0
52 S BSDXERR=""
53 S ^BSDXTMP($J,BSDXI)="I00020RESOURCE_GROUPID^T00030RESOURCE_GROUP"_$C(30)
54 I '+BSDXDUZ S BSDXDUZ=DUZ
55 ;Check SECURITY KEY file for BSDXZMGR or XUPROGMODE keys
56 S BSDXMGR=$$APSEC("BSDXZMGR",BSDXDUZ)
57 ;
58 ;User does not have BSDXZMGR or XUPROGMODE keys, so
59 ;$O THRU AC XREF OF BSDX RESOURCE USER
60 I 'BSDXMGR,$D(^BSDXRSU("AC",BSDXDUZ)) S BSDXIEN=0 F S BSDXIEN=$O(^BSDXRSU("AC",BSDXDUZ,BSDXIEN)) Q:'+BSDXIEN D
61 . S BSDXRES=$P(^BSDXRSU(BSDXIEN,0),U)
62 . Q:'$D(^BSDXDEPT("AB",BSDXRES)) ; If not part of a group, quit ("AB" is the whole file index for the resource multiple in Group file)
63 . ; Q:'$$INDIV2(BSDXRES) ; If not in the same division as user, quit
64 . S BSDXRNOD=^BSDXRES(BSDXRES,0)
65 . ;QUIT if the resource is inactive
66 . Q:$P(BSDXRNOD,U,2)=1
67 . S BSDXDEP=0 F S BSDXDEP=$O(^BSDXDEPT("AB",BSDXRES,BSDXDEP)) Q:'+BSDXDEP D
68 . . Q:'$D(^BSDXDEPT(BSDXDEP,0))
69 . . Q:$D(^BSDXTEMP($J,BSDXDEP))
70 . . S ^BSDXTEMP($J,BSDXDEP)=""
71 . . S BSDXDEPN=$P(^BSDXDEPT(BSDXDEP,0),U)
72 . . S BSDXI=BSDXI+1
73 . . S ^BSDXTMP($J,BSDXI)=BSDXDEP_U_BSDXDEPN_$C(30)
74 . . Q
75 . Q
76 ;
77 ;User does have BSDXZMGR or XUPROGMODE keys, so
78 ;$O THRU BSDX RESOURCE GROUP file directly
79 I BSDXMGR S BSDXIEN=0 F S BSDXIEN=$O(^BSDXDEPT(BSDXIEN)) Q:'+BSDXIEN D
80 . Q:'$D(^BSDXDEPT(BSDXIEN,0))
81 . S BSDXNOD=^BSDXDEPT(BSDXIEN,0)
82 . S BSDXDEPN=$P(BSDXNOD,U)
83 . S BSDXI=BSDXI+1
84 . S ^BSDXTMP($J,BSDXI)=BSDXIEN_U_BSDXDEPN_$C(30)
85 . Q
86 ;
87 S ^BSDXTMP($J,BSDXI+1)=$C(31)_BSDXERR
88 Q
89 ;
90 ;
91RESUSRD(BSDXY,BSDXDUZ) ;EP Debugging entry point
92 ;
93 ;
94 ;D DEBUG^%Serenji("RESUSR^BSDX01(.BSDXY,BSDXDUZ)")
95 ;
96 Q
97 ;
98RESUSR(BSDXY,BSDXDUZ) ;EP
99 ;Returns ADO Recordset with ALL RESOURCE names
100 ;Inactive RESOURCES are NOT filtered out
101 ;Called by BSDX RESOURCES BY USER
102 ;
103 N BSDXERR,BSDXRET,BSDXIEN,BSDXRES,BSDXDEP,BSDXDDR,BSDXDEPN,BSDXRDAT,BSDXRNOD,BSDXI,BSDX,BSDXLTR
104 N BSDXNOS,BSDXCAN
105 K ^BSDXTMP($J)
106 S BSDXY="^BSDXTMP("_$J_")"
107 S BSDXI=0
108 S BSDXERR=""
109 S ^BSDXTMP($J,BSDXI)="I00010RESOURCEID^T00030RESOURCE_NAME^T00010INACTIVE^I00010TIMESCALE^I00010HOSPITAL_LOCATION_ID^T00030LETTER_TEXT^T00030NO_SHOW_LETTER"
110 S ^BSDXTMP($J,BSDXI)=^(BSDXI)_"^T00030CLINIC_CANCELLATION_LETTER^I00010VIEW^I00010OVERBOOK^I00010MODIFY_SCHEDULE^I00010MODIFY_APPOINTMENTS"_$C(30)
111 I '+BSDXDUZ S BSDXDUZ=DUZ
112 ;$O THRU AC XREF OF BSDX RESOURCE USER
113 ;Rmoved these lines in order to just return all resource names
114 ;I $D(^BSDXRSU("AC",BSDXDUZ)) S BSDXIEN=0 F S BSDXIEN=$O(^BSDXRSU("AC",BSDXDUZ,BSDXIEN)) Q:'+BSDXIEN D
115 ;. S BSDXRES=$P(^BSDXRSU(BSDXIEN,0),U)
116 ;
117 ;$O THRU BSDX RESOURCE File
118 S BSDXRES=0 F S BSDXRES=$O(^BSDXRES(BSDXRES)) Q:'+BSDXRES D
119 . Q:'$D(^BSDXRES(BSDXRES,0))
120 . S BSDXRNOD=^BSDXRES(BSDXRES,0)
121 . N BSDXSC S BSDXSC=$P(BSDXRNOD,U,4) ; Hospital Location
122 . ;Q:$P(BSDXRNOD,U,2)=1 ;Inactive resources not filtered
123 . ;S BSDXRDAT=$P(BSDXRNOD,U,1,4)
124 . ;I '$$INDIV(BSDXSC) QUIT ; If not in division, quit
125 . K BSDXRDAT
126 . F BSDX=1:1:4 S $P(BSDXRDAT,U,BSDX)=$P(BSDXRNOD,U,BSDX)
127 . S BSDXRDAT=BSDXRES_U_BSDXRDAT
128 . ;Get letter text from wp field
129 . S BSDXLTR=""
130 . I $D(^BSDXRES(BSDXRES,1)) D
131 . . S BSDXIEN=0
132 . . F S BSDXIEN=$O(^BSDXRES(BSDXRES,1,BSDXIEN)) Q:'+BSDXIEN D
133 . . . S BSDXLTR=BSDXLTR_$G(^BSDXRES(BSDXRES,1,BSDXIEN,0))
134 . . . S BSDXLTR=BSDXLTR_$C(13)_$C(10)
135 . S BSDXNOS=""
136 . I $D(^BSDXRES(BSDXRES,12)) D
137 . . S BSDXIEN=0 F S BSDXIEN=$O(^BSDXRES(BSDXRES,12,BSDXIEN)) Q:'+BSDXIEN D
138 . . . S BSDXNOS=BSDXNOS_$G(^BSDXRES(BSDXRES,12,BSDXIEN,0))
139 . . . S BSDXNOS=BSDXNOS_$C(13)_$C(10)
140 . S BSDXCAN=""
141 . I $D(^BSDXRES(BSDXRES,13)) D
142 . . S BSDXIEN=0 F S BSDXIEN=$O(^BSDXRES(BSDXRES,13,BSDXIEN)) Q:'+BSDXIEN D
143 . . . S BSDXCAN=BSDXCAN_$G(^BSDXRES(BSDXRES,13,BSDXIEN,0))
144 . . . S BSDXCAN=BSDXCAN_$C(13)_$C(10)
145 . N BSDXACC,BSDXMGR
146 . S BSDXACC="0^0^0^0"
147 . S BSDXMGR=$O(^DIC(19.1,"B","BSDXZMGR",0))
148 . I +BSDXMGR,$D(^VA(200,BSDXDUZ,51,BSDXMGR)) S BSDXACC="1^1^1^1"
149 . S BSDXMGR=$O(^DIC(19.1,"B","XUPROGMODE",0))
150 . I +BSDXMGR,$D(^VA(200,BSDXDUZ,51,BSDXMGR)) S BSDXACC="1^1^1^1"
151 . I BSDXACC="0^0^0^0" D
152 . . N BSDXNOD,BSDXRUID
153 . . S BSDXRUID=0
154 . . ;Get entry for this user and resource
155 . . F S BSDXRUID=$O(^BSDXRSU("AC",BSDXDUZ,BSDXRUID)) Q:'+BSDXRUID I $D(^BSDXRSU(BSDXRUID,0)),$P(^(0),U)=BSDXRES Q
156 . . Q:'+BSDXRUID
157 . . S $P(BSDXACC,U)=1
158 . . S BSDXNOD=$G(^BSDXRSU(BSDXRUID,0))
159 . . S $P(BSDXACC,U,2)=+$P(BSDXNOD,U,3)
160 . . S $P(BSDXACC,U,3)=+$P(BSDXNOD,U,4)
161 . . S $P(BSDXACC,U,4)=+$P(BSDXNOD,U,5)
162 . S BSDXRDAT=BSDXRDAT_U_BSDXLTR_U_BSDXNOS_U_BSDXCAN_U_BSDXACC
163 . S BSDXI=BSDXI+1
164 . S ^BSDXTMP($J,BSDXI)=BSDXRDAT_$C(30)
165 S ^BSDXTMP($J,BSDXI+1)=$C(31)_BSDXERR
166 Q
167 ;
168DEPRESD(BSDXY,BSDXDUZ) ;EP Debugging entry point
169 ;
170 ;
171 ;D DEBUG^%Serenji("DEPRES^BSDX01(.BSDXY,BSDXDUZ)")
172 ;
173 Q
174 ;
175DEPRES(BSDXY,BSDXDUZ) ;EP
176 ;Called by BSDX GROUP RESOURCE
177 ;Returns ADO Recordset with all ACTIVE GROUP/RESOURCE combinations
178 ;to which user has access based on entries in BSDX RESOURCE USER file
179 ;If BSDXDUZ=0 then returns all ACTIVE GROUP/RESOURCE combinations for current DUZ
180 ;If user BSDXDUZ possesses the key BSDXZMGR or XUPROGMODE
181 ;then ALL ACTIVE resource group names are returned
182 ;
183 N BSDXERR,BSDXRET,BSDXIEN,BSDXRES,BSDXDEP,BSDXDDR,BSDXDEPN,BSDXRDAT,BSDXRNOD,BSDXI
184 N BSDXRESN,BSDXMGR,BSDXRESD,BSDXNOD,BSDXSUBID
185 K ^BSDXTEMP($J)
186 K ^BSDXTMP($J)
187 S BSDXY="^BSDXTMP("_$J_")"
188 S BSDXI=0
189 S BSDXERR=""
190 S ^BSDXTMP($J,BSDXI)="I00020RESOURCE_GROUPID^T00030RESOURCE_GROUP^I00020RESOURCE_GROUP_ITEMID^T00030RESOURCE_NAME^I00020RESOURCEID"_$C(30)
191 I '+BSDXDUZ S BSDXDUZ=DUZ
192 ;Check SECURITY KEY file for BSDXZMGR or XUPROGMODE keys
193 S BSDXMGR=$$APSEC("BSDXZMGR",BSDXDUZ)
194 ;
195 ;User does not have BSDXZMGR or XUPROGMODE keys, so
196 ;$O THRU AC XREF OF BSDX RESOURCE USER
197 I 'BSDXMGR,$D(^BSDXRSU("AC",BSDXDUZ)) S BSDXIEN=0 F S BSDXIEN=$O(^BSDXRSU("AC",BSDXDUZ,BSDXIEN)) Q:'+BSDXIEN D
198 . S BSDXRES=$P(^BSDXRSU(BSDXIEN,0),U)
199 . Q:'$D(^BSDXDEPT("AB",BSDXRES)) ; Quit if Resource isn't part of any Group
200 . ;Q:'$$INDIV2(BSDXRES) ; Quit if Resource isn't in same division as user.
201 . S BSDXRNOD=$G(^BSDXRES(BSDXRES,0))
202 . Q:BSDXRNOD=""
203 . ;QUIT if the resource is inactive
204 . Q:$P(BSDXRNOD,U,2)=1
205 . S BSDXRESN=$P(BSDXRNOD,U)
206 . S BSDXDEP=0 F S BSDXDEP=$O(^BSDXDEPT("AB",BSDXRES,BSDXDEP)) Q:'+BSDXDEP D
207 . . Q:'$D(^BSDXDEPT(BSDXDEP,0))
208 . . S BSDXDEPN=$P(^BSDXDEPT(BSDXDEP,0),U)
209 . . S BSDXSUBID=$O(^BSDXDEPT(BSDXDEP,1,"B",BSDXRES,0))
210 . . S BSDXI=BSDXI+1
211 . . S ^BSDXTMP($J,BSDXI)=BSDXDEP_U_BSDXDEPN_U_BSDXSUBID_U_BSDXRESN_U_BSDXRES_$C(30)
212 . Q
213 ;
214 ;User does have BSDXZMGR or XUPROGMODE keys, so
215 ;$O THRU BSDX RESOURCE GROUP file directly
216 I BSDXMGR S BSDXIEN=0 F S BSDXIEN=$O(^BSDXDEPT(BSDXIEN)) Q:'+BSDXIEN D
217 . Q:'$D(^BSDXDEPT(BSDXIEN,0))
218 . S BSDXNOD=^BSDXDEPT(BSDXIEN,0)
219 . S BSDXDEPN=$P(BSDXNOD,U)
220 . S BSDXRES=0 F S BSDXRES=$O(^BSDXDEPT(BSDXIEN,1,BSDXRES)) Q:'+BSDXRES D
221 . . N BSDXRESD
222 . . Q:'$D(^BSDXDEPT(BSDXIEN,1,BSDXRES,0)) ; Quit if zero node is invalid in multiple
223 . . S BSDXRESD=$P(^BSDXDEPT(BSDXIEN,1,BSDXRES,0),"^")
224 . . Q:'$D(^BSDXRES(BSDXRESD,0)) ; Quit if zero node of resouce file is invalid
225 . . ;Q:'$$INDIV2(BSDXRESD) ; Quit if resource is not in the same division
226 . . S BSDXRNOD=$G(^BSDXRES(BSDXRESD,0))
227 . . Q:BSDXRNOD=""
228 . . ;QUIT if the resource is inactive
229 . . Q:$P(BSDXRNOD,U,2)=1
230 . . S BSDXRESN=$P(BSDXRNOD,U)
231 . . S BSDXI=BSDXI+1
232 . . S ^BSDXTMP($J,BSDXI)=BSDXIEN_U_BSDXDEPN_U_BSDXRES_U_BSDXRESN_U_BSDXRESD_$C(30)
233 . . Q
234 . Q
235 ;
236 S ^BSDXTMP($J,BSDXI+1)=$C(31)_BSDXERR
237 Q
238 ;
239APSEC(BSDXKEY,BSDXDUZ) ;EP - Return TRUE (1) if user has keys BSDXKEY or XUPROGMODE, otherwise, returns FALSE (0)
240 ;
241 N BSDXIEN,BSDXPROG,BSDXPKEY
242 I '$G(BSDXDUZ) Q 0
243 ;
244 ;Test for programmer mode key
245 S BSDXPROG=0
246 I $D(^DIC(19.1,"B","XUPROGMODE")) D
247 . S BSDXPKEY=$O(^DIC(19.1,"B","XUPROGMODE",0))
248 . I '+BSDXPKEY Q
249 . I '$D(^VA(200,BSDXDUZ,51,BSDXPKEY,0)) Q
250 . S BSDXPROG=1
251 I BSDXPROG Q 1
252 ;
253 I BSDXKEY="" Q 0
254 I '$D(^DIC(19.1,"B",BSDXKEY)) Q 0
255 S BSDXIEN=$O(^DIC(19.1,"B",BSDXKEY,0))
256 I '+BSDXIEN Q 0
257 I '$D(^VA(200,BSDXDUZ,51,BSDXIEN,0)) Q 0
258 Q 1
259SP(BSDXY,PARAM,YESNO) ; Save Param at User Level - EP
260 ; Called by RPC: BSDX SET PARAM
261 ; Input:
262 ; - Param: Name of Parameter (prog name of course)
263 ; - Yes/No: 1 or 0
264 ; Output: Error Code as string; 0 is good
265 ;
266 ; Security Protection
267 IF $EXTRACT(PARAM,1,4)'="BSDX" S BSDXY="-1^BSDX Params only allowed" QUIT
268 ;
269 N ERROR
270 D PUT^XPAR("USR",PARAM,1,YESNO,.ERROR)
271 S BSDXY=$G(ERROR)
272 QUIT
273 ;
274GP(BSDXY,PARAM) ; Get Param - EP
275 ; Called by RPC: BSDX GET PARAM
276 ; Input: Name of Parameter
277 ; Output: Value of parameter: 0 or 1, for now.
278 ;
279 S BSDXY=$$GET^XPAR("USR^LOC^SYS^PKG",PARAM,1,"I")
280 QUIT
281 ;
282INDIV(BSDXSC) ; PEP - Is ^SC clinic in the same DUZ(2) as user?
283 ; Input: BSDXSC - Hospital Location IEN
284 ; Output: True or False
285 I '+BSDXSC QUIT 1 ;If not tied to clinic, yes
286 I '$D(^SC(BSDXSC,0)) QUIT 1 ; If Clinic does not exist, yes
287 ; Jump to Division:Medical Center Division:Inst File Pointer for
288 ; Institution IEN (and get its internal value)
289 N DIV S DIV=$$GET1^DIQ(44,BSDXSC_",","3.5:.07","I")
290 I DIV="" Q 1 ; If clinic has no division, consider it avial to user.
291 I DIV=DUZ(2) Q 1 ; If same, then User is in same Div as Clinic
292 E Q 0 ; Otherwise, no
293 QUIT
294INDIV2(BSDXRES) ; PEP - Is Resource in the same DUZ(2) as user?
295 ; Input BSDXRES - BSDX RESOURCE IEN
296 ; Output: True of False
297 Q $$INDIV($P($G(^BSDXRES(BSDXRES,0)),U,4)) ; Extract Hospital Location and send to $$INDIV
298UnitTestINDIV
299 W "Testing if they are the same",!
300 S DUZ(2)=67
301 I '$$INDIV(1) W "ERROR",!
302 I '$$INDIV(2) W "ERROR",!
303 W "Testing if Div not defined in 44, should be true",!
304 I '$$INDIV(3) W "ERROR",!
305 W "Testing empty string. Should be true",!
306 I '$$INDIV("") W "ERROR",!
307 W "Testing if they are different",!
308 S DUZ(2)=899
309 I $$INDIV(1) W "ERROR",!
310 I $$INDIV(2) W "ERROR",!
311 QUIT
312UnitTestINDIV2
313 W "Testing if they are the same",!
314 S DUZ(2)=69
315 I $$INDIV2(22)'=0 W "ERROR",!
316 I $$INDIV2(25)'=1 W "ERROR",!
317 I $$INDIV2(26)'=1 W "ERROR",!
318 I $$INDIV2(27)'=1 W "ERROR",!
319 QUIT
Note: See TracBrowser for help on using the repository browser.