source: WorldVistAEHR/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORDD.m@ 1404

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

initial load of WorldVistAEHR
File size: 8.9 KB
Line 
1RORDD ;HCIOFO/SG - DATA DICTIONARY UTILITIES ; 9/2/05 10:58am
2 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
3 ;
4 Q
5 ;
6 ;***** CHECKS USER KEYS AND LOGS ATTEMPTS OF UNAUTHORIZED ACCESS
7 ;
8 ; FILE File number
9 ;
10 ; [REGISTRY] Either a registry name or a registry IEN.
11 ; By default ($G(REGISTRY)=""), the function checks if
12 ; the user has any Clinical Case Registries keys.
13 ;
14 ; [STRICT] If this parameter is defined and not zero then an
15 ; access violation event is recorded even if the user
16 ; has other Clinical Case Registries keys.
17 ;
18 ; This mode can be used to restrict access to a file,
19 ; which is solely associated with a single registry
20 ; (for example, the ROR HIV STUDY file).
21 ;
22 ; Return Values:
23 ; 0 Access denied
24 ; 1 Access granted
25 ;
26ACCESS(FILE,REGISTRY,STRICT) ;
27 Q:$G(DUZ)'>0 0 ; Unknown user
28 Q:$E($G(XPDNM),1,3)="ROR" 1 ; KIDS
29 N ANYKEY,REGKEY
30 S (REGKEY,ANYKEY)=1
31 ;--- Check the user's security keys
32 I $G(REGISTRY)'="" D:$D(^ROR(798.1,"ACL",DUZ,REGISTRY))<10
33 . Q:$D(^XUSEC("ROR VA IRM",DUZ))
34 . S REGKEY=0,ANYKEY=($D(^ROR(798.1,"ACL",DUZ))>1)
35 E D:$D(^ROR(798.1,"ACL",DUZ))<10
36 . S:'$D(^XUSEC("ROR VA IRM",DUZ)) (REGKEY,ANYKEY)=0
37 Q:REGKEY 1
38 ;--- Do not record an access violation event if the user has
39 ; any Clinical Case Registries key and the "strict" mode
40 ;--- has not been requested by the caller.
41 I '$G(STRICT) Q:ANYKEY 0
42 N RORMSG,X
43 ;--- Record the access violation event (if the API is available)
44 S X="RORLOG" X ^%ZOSF("TEST")
45 I $T D D ACVIOLTN^RORLOG(X,$G(REGISTRY))
46 . S X="Attempt of unauthorized access to the file #"_FILE
47 ;--- Display the message (if the current device is a display)
48 I $E($G(IOST),1,2)="C-" D H 4
49 . D TEXT^RORTXT(7980000.003,.RORMSG)
50 . W !!! S X=""
51 . F S X=$O(RORMSG(X)) Q:X="" D
52 . . W ?($G(IOM,80)-$L(RORMSG(X))\2),RORMSG(X),!
53 ;--- Log Off the user (if not an RPC Broker session)
54 D:'$$BROKER^XWBLIB H^XUS
55 Q 0
56 ;
57 ;***** "ACL" CROSS-REFERENCE UTILITIES
58 ;
59 ; These two procedures are used by the kill and set logic of the
60 ; "ACL" cross-reference (MUMPS type) of the .01 field of the SECURITY
61 ; KEY multiple of the ROR REGISTRY PARAMETERS file (#798.1).
62 ;
63 ; FileMan initializes the X variable (name of the security key) and
64 ; the DA array before calling these procedures.
65 ;
66ACLKILL ;
67 N RORDUZ,RORREG
68 S RORREG=$P($G(^ROR(798.1,DA(1),0)),U)
69 S RORDUZ=""
70 F S RORDUZ=$O(^XUSEC(X,RORDUZ)) Q:RORDUZ="" D
71 . K ^ROR(798.1,"ACL",RORDUZ,DA(1),X,DA)
72 . K:RORREG'="" ^ROR(798.1,"ACL",RORDUZ,RORREG,X,DA)
73 Q
74 ;
75ACLSET ;
76 N RORDUZ,RORREG
77 S RORREG=$P($G(^ROR(798.1,DA(1),0)),U)
78 S RORDUZ=""
79 F S RORDUZ=$O(^XUSEC(X,RORDUZ)) Q:RORDUZ="" D
80 . S ^ROR(798.1,"ACL",RORDUZ,DA(1),X,DA)=""
81 . S:RORREG'="" ^ROR(798.1,"ACL",RORDUZ,RORREG,X,DA)=""
82 Q
83 ;
84 ;***** CHECKS IF THE REGISTRY RECORD IS ACTIVE
85 ;
86 ; IEN IEN of the registry record
87 ;
88 ; [CHKDT] Date/Time for status calculation. The current date
89 ; and time are used by default.
90 ; Currently, this parameter has no effect .
91 ;
92 ; [.STATUS] Status code is returned via this parameter.
93 ; It explains the reason for inactivity:
94 ; "" Status unknown or no record
95 ; 4 Pending patient
96 ; 5 Patient is marked for deletion
97 ;
98 ; Return Values:
99 ; 0 The record is inactive
100 ; 1 The record is active
101 ;
102ACTIVE(IEN,CHKDT,STATUS) ;
103 N NODE0
104 S NODE0=$G(^RORDATA(798,+IEN,0))
105 I NODE0="" S STATUS="" Q 0
106 S STATUS=+$P(NODE0,U,5)
107 Q:STATUS=4 0 ; Pending
108 Q:STATUS=5 0 ; Marked for deletion
109 Q 1 ; Active
110 ;
111 ;***** DISPLAYS A LIST OF APIs DEFINED IN THE SUBFILE #799.23
112 ;
113 ; IEN IEN of the current record of the file #799.2
114 ;
115APILST(IEN) ;
116 N D,DIC,DLAYGO,DZ,RORMSG
117 S DIC=$$ROOT^DILFD(799.23,","_(+IEN)_",") Q:DIC=""
118 S D=$$GET1^DID(799.23,.01,,"FIELD LENGTH",,"RORMSG")
119 D EN^DDIOL($J(1,D),,"?2"),EN^DDIOL("GETS^DIQ",,"?10")
120 S DIC(0)="",D="B",DZ="??"
121 S DIC("W")="D EN^DDIOL($P(^(0),U,3)_""^""_$P(^(0),U,2),,""?10"")"
122 D DQ^DICQ
123 Q
124 ;
125 ;***** VALIDATES A NAME OF THE CALLBACK FUNCTION
126 ;
127 ; MNFP Minimal number of formal parameters (opt'l).
128 ; If this parameter has a value greater than 1, the
129 ; function makes very simple check of the number of
130 ; formal parameters in the source code.
131 ;
132 ; This function is intended for use in the input transforms
133 ; of registry definition fields. It kills the X variable if it
134 ; contains illegal value.
135 ;
136 ; The function does not allow to use '%' in the routine and
137 ; tag names (this is prohibited by VistA SAC).
138 ;
139 ; If the function cannot obtain the source code of the callback
140 ; function (because the code does not exist yet or has been stripped)
141 ; or there are not enough formal parameters in the definition of the
142 ; function, it issues a warning but does not reject the value.
143 ;
144 ; Return Values:
145 ; 0 Ok
146 ; 1 Illegal name (X is killed)
147 ;
148EP(MNFP) ;
149 Q:$G(X)="" 0
150 N ENTPNT,TMP
151 ;--- Check if the value has the "$$TAG^ROUTINE" format
152 I '(X?2"$"1.8UN1"^"1.8UN) K X Q 1
153 ;--- Check if the routine exists
154 S ENTPNT=X,X=$P(X,U,2)
155 X ^%ZOSF("TEST") E D K X Q 1
156 . D EN^DDIOL("The '"_X_"' routine does not exist!")
157 S X=ENTPNT
158 ;--- Skip the enhanced checks when verifying fields
159 Q:$G(DIUTIL)="VERIFY FIELDS" 0
160 ;--- Get the line of source code
161 S ENTPNT=$P(X,"$$",2),TMP=$TR($P($T(@ENTPNT),";")," ")
162 ;--- Display a warning if there is no source line
163 I TMP="" D Q 0
164 . S TMP="Make sure that the '"_$P(ENTPNT,U)_"' tag"
165 . D EN^DDIOL(TMP_" exists in the '"_$P(ENTPNT,U,2)_"' routine.")
166 ;--- Display a warning if there are not enough formal parameters
167 I $G(MNFP)>1,$L(TMP,",")<MNFP D Q 0
168 . S TMP="Make sure that the entry point has at least "_MNFP
169 . D EN^DDIOL(TMP_" formal parameter(s).")
170 Q 0
171 ;
172 ;***** VALIDATES A SELECTION RULE EXPRESSION
173 ;
174 ; FILE File number that the expression is associated with
175 ;
176 ; This function is intended for use in the input transforms
177 ; of registry definition fields. It kills the X variable if
178 ; it contains an illegal value.
179 ;
180 ; Return Values:
181 ; 0 Ok
182 ; 1 Illegal expression (X is killed)
183 ;
184EXPR(FILE) ;
185 Q:($G(FILE)'>0)!($G(X)="") 0
186 N EXPR,RC,RESULT,RORERROR,RORLOG,RORPARM,TMP
187 ;--- Check if the parser routine exists in the UCI
188 S EXPR=X,X="RORUPEX" X ^%ZOSF("TEST") S X=EXPR E Q 0
189 ;--- Parse and validate the expression
190 S RC=$$PARSER^RORUPEX(FILE,X,.RESULT)
191 Q:RC'<0 0 K X
192 ;--- Field does not exist
193 I RC=-7 D Q 1
194 . S TMP="One of the referenced fields"
195 . D EN^DDIOL(TMP_" does not exist in the file #"_FILE_"!")
196 ;--- Syntax error in the expression
197 I RC=-21 D Q 1
198 . D EN^DDIOL("Invalid expression: '"_EXPR_"'")
199 . D EN^DDIOL("Parsed to: '"_$G(RESULT)_"' ")
200 ;--- File does not exist
201 I RC=-58 D Q 1
202 . D EN^DDIOL("Referenced file #"_FILE_" does not exist!")
203 Q 1
204 ;
205 ;***** CHECKS IF A FIELD OF A NATIONAL DEFINITION CAN BE DELETED
206 ;
207 ; FILE Top-level file number
208 ; [IEN] IEN of the current record of the top-level file
209 ; [FIELD] Number of the NATIONAL field.
210 ; If value of this parameter less than zero, local
211 ; modifications of all records will be prohibited.
212 ; By default, the .09 field is used.
213 ;
214 ; This function is intended for use in the "DEL" node logic
215 ; of registry definition fields.
216 ;
217 ; Return Values:
218 ; 0 The value of the field can be deleted
219 ; 1 Deletion is prohibited
220 ;
221VADEL(FILE,IEN,FIELD) ;
222 Q:$G(XPDNM)'="" 0
223 ;--- An authorized developer can delete anything
224 Q:$G(RORPARM("DEVELOPER")) 0
225 ;--- Check if the registry definition is a national one
226 N RC,RORMSG
227 I $G(FIELD)'<0 S RC=0 D:$G(IEN)>0 Q:'RC 0
228 . S:'$G(FIELD) FIELD=.09
229 . S RC=$$GET1^DIQ(FILE,IEN_",",FIELD,"I",,"RORMSG")
230 D EN^DDIOL("You cannot edit a national registry definition!")
231 Q 1
232 ;
233 ;***** CHECKS IF A FIELD OF A NATIONAL DEFINITION CAN BE EDITED
234 ;
235 ; FILE Top-level file number
236 ; [IEN] IEN of the current record of the top-level file
237 ; [FIELD] Number of the NATIONAL field.
238 ; If value of this parameter less than zero, local
239 ; modifications of all records will be prohibited.
240 ; By default, the .09 field is used.
241 ;
242 ; This function is intended for use in the input transforms
243 ; of registry definition fields. It kills the X variable if
244 ; it contains illegal value.
245 ;
246 ; Return Values:
247 ; 0 The field can be edited
248 ; 1 Editing is prohibited (X is killed)
249 ;
250VAEDT(FILE,IEN,FIELD) ;
251 Q:($G(DIUTIL)="VERIFY FIELDS")!($G(XPDNM)'="") 0
252 ;--- An authorized developer can edit anything
253 Q:$G(RORPARM("DEVELOPER")) 0
254 ;--- Check if the registry definition is a national one
255 N RC,RORMSG
256 I $G(FIELD)'<0 S RC=0 D:$G(IEN)>0 Q:'RC 0
257 . S:'$G(FIELD) FIELD=.09
258 . S RC=$$GET1^DIQ(FILE,IEN_",",FIELD,"I",,"RORMSG")
259 K X
260 D EN^DDIOL("You cannot edit a national registry definition!")
261 Q 1
Note: See TracBrowser for help on using the repository browser.