262 lines
8.9 KiB
Mathematica
262 lines
8.9 KiB
Mathematica
RORDD ;HCIOFO/SG - DATA DICTIONARY UTILITIES ; 9/2/05 10:58am
|
|
;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
|
|
;
|
|
Q
|
|
;
|
|
;***** CHECKS USER KEYS AND LOGS ATTEMPTS OF UNAUTHORIZED ACCESS
|
|
;
|
|
; FILE File number
|
|
;
|
|
; [REGISTRY] Either a registry name or a registry IEN.
|
|
; By default ($G(REGISTRY)=""), the function checks if
|
|
; the user has any Clinical Case Registries keys.
|
|
;
|
|
; [STRICT] If this parameter is defined and not zero then an
|
|
; access violation event is recorded even if the user
|
|
; has other Clinical Case Registries keys.
|
|
;
|
|
; This mode can be used to restrict access to a file,
|
|
; which is solely associated with a single registry
|
|
; (for example, the ROR HIV STUDY file).
|
|
;
|
|
; Return Values:
|
|
; 0 Access denied
|
|
; 1 Access granted
|
|
;
|
|
ACCESS(FILE,REGISTRY,STRICT) ;
|
|
Q:$G(DUZ)'>0 0 ; Unknown user
|
|
Q:$E($G(XPDNM),1,3)="ROR" 1 ; KIDS
|
|
N ANYKEY,REGKEY
|
|
S (REGKEY,ANYKEY)=1
|
|
;--- Check the user's security keys
|
|
I $G(REGISTRY)'="" D:$D(^ROR(798.1,"ACL",DUZ,REGISTRY))<10
|
|
. Q:$D(^XUSEC("ROR VA IRM",DUZ))
|
|
. S REGKEY=0,ANYKEY=($D(^ROR(798.1,"ACL",DUZ))>1)
|
|
E D:$D(^ROR(798.1,"ACL",DUZ))<10
|
|
. S:'$D(^XUSEC("ROR VA IRM",DUZ)) (REGKEY,ANYKEY)=0
|
|
Q:REGKEY 1
|
|
;--- Do not record an access violation event if the user has
|
|
; any Clinical Case Registries key and the "strict" mode
|
|
;--- has not been requested by the caller.
|
|
I '$G(STRICT) Q:ANYKEY 0
|
|
N RORMSG,X
|
|
;--- Record the access violation event (if the API is available)
|
|
S X="RORLOG" X ^%ZOSF("TEST")
|
|
I $T D D ACVIOLTN^RORLOG(X,$G(REGISTRY))
|
|
. S X="Attempt of unauthorized access to the file #"_FILE
|
|
;--- Display the message (if the current device is a display)
|
|
I $E($G(IOST),1,2)="C-" D H 4
|
|
. D TEXT^RORTXT(7980000.003,.RORMSG)
|
|
. W !!! S X=""
|
|
. F S X=$O(RORMSG(X)) Q:X="" D
|
|
. . W ?($G(IOM,80)-$L(RORMSG(X))\2),RORMSG(X),!
|
|
;--- Log Off the user (if not an RPC Broker session)
|
|
D:'$$BROKER^XWBLIB H^XUS
|
|
Q 0
|
|
;
|
|
;***** "ACL" CROSS-REFERENCE UTILITIES
|
|
;
|
|
; These two procedures are used by the kill and set logic of the
|
|
; "ACL" cross-reference (MUMPS type) of the .01 field of the SECURITY
|
|
; KEY multiple of the ROR REGISTRY PARAMETERS file (#798.1).
|
|
;
|
|
; FileMan initializes the X variable (name of the security key) and
|
|
; the DA array before calling these procedures.
|
|
;
|
|
ACLKILL ;
|
|
N RORDUZ,RORREG
|
|
S RORREG=$P($G(^ROR(798.1,DA(1),0)),U)
|
|
S RORDUZ=""
|
|
F S RORDUZ=$O(^XUSEC(X,RORDUZ)) Q:RORDUZ="" D
|
|
. K ^ROR(798.1,"ACL",RORDUZ,DA(1),X,DA)
|
|
. K:RORREG'="" ^ROR(798.1,"ACL",RORDUZ,RORREG,X,DA)
|
|
Q
|
|
;
|
|
ACLSET ;
|
|
N RORDUZ,RORREG
|
|
S RORREG=$P($G(^ROR(798.1,DA(1),0)),U)
|
|
S RORDUZ=""
|
|
F S RORDUZ=$O(^XUSEC(X,RORDUZ)) Q:RORDUZ="" D
|
|
. S ^ROR(798.1,"ACL",RORDUZ,DA(1),X,DA)=""
|
|
. S:RORREG'="" ^ROR(798.1,"ACL",RORDUZ,RORREG,X,DA)=""
|
|
Q
|
|
;
|
|
;***** CHECKS IF THE REGISTRY RECORD IS ACTIVE
|
|
;
|
|
; IEN IEN of the registry record
|
|
;
|
|
; [CHKDT] Date/Time for status calculation. The current date
|
|
; and time are used by default.
|
|
; Currently, this parameter has no effect .
|
|
;
|
|
; [.STATUS] Status code is returned via this parameter.
|
|
; It explains the reason for inactivity:
|
|
; "" Status unknown or no record
|
|
; 4 Pending patient
|
|
; 5 Patient is marked for deletion
|
|
;
|
|
; Return Values:
|
|
; 0 The record is inactive
|
|
; 1 The record is active
|
|
;
|
|
ACTIVE(IEN,CHKDT,STATUS) ;
|
|
N NODE0
|
|
S NODE0=$G(^RORDATA(798,+IEN,0))
|
|
I NODE0="" S STATUS="" Q 0
|
|
S STATUS=+$P(NODE0,U,5)
|
|
Q:STATUS=4 0 ; Pending
|
|
Q:STATUS=5 0 ; Marked for deletion
|
|
Q 1 ; Active
|
|
;
|
|
;***** DISPLAYS A LIST OF APIs DEFINED IN THE SUBFILE #799.23
|
|
;
|
|
; IEN IEN of the current record of the file #799.2
|
|
;
|
|
APILST(IEN) ;
|
|
N D,DIC,DLAYGO,DZ,RORMSG
|
|
S DIC=$$ROOT^DILFD(799.23,","_(+IEN)_",") Q:DIC=""
|
|
S D=$$GET1^DID(799.23,.01,,"FIELD LENGTH",,"RORMSG")
|
|
D EN^DDIOL($J(1,D),,"?2"),EN^DDIOL("GETS^DIQ",,"?10")
|
|
S DIC(0)="",D="B",DZ="??"
|
|
S DIC("W")="D EN^DDIOL($P(^(0),U,3)_""^""_$P(^(0),U,2),,""?10"")"
|
|
D DQ^DICQ
|
|
Q
|
|
;
|
|
;***** VALIDATES A NAME OF THE CALLBACK FUNCTION
|
|
;
|
|
; MNFP Minimal number of formal parameters (opt'l).
|
|
; If this parameter has a value greater than 1, the
|
|
; function makes very simple check of the number of
|
|
; formal parameters in the source code.
|
|
;
|
|
; This function is intended for use in the input transforms
|
|
; of registry definition fields. It kills the X variable if it
|
|
; contains illegal value.
|
|
;
|
|
; The function does not allow to use '%' in the routine and
|
|
; tag names (this is prohibited by VistA SAC).
|
|
;
|
|
; If the function cannot obtain the source code of the callback
|
|
; function (because the code does not exist yet or has been stripped)
|
|
; or there are not enough formal parameters in the definition of the
|
|
; function, it issues a warning but does not reject the value.
|
|
;
|
|
; Return Values:
|
|
; 0 Ok
|
|
; 1 Illegal name (X is killed)
|
|
;
|
|
EP(MNFP) ;
|
|
Q:$G(X)="" 0
|
|
N ENTPNT,TMP
|
|
;--- Check if the value has the "$$TAG^ROUTINE" format
|
|
I '(X?2"$"1.8UN1"^"1.8UN) K X Q 1
|
|
;--- Check if the routine exists
|
|
S ENTPNT=X,X=$P(X,U,2)
|
|
X ^%ZOSF("TEST") E D K X Q 1
|
|
. D EN^DDIOL("The '"_X_"' routine does not exist!")
|
|
S X=ENTPNT
|
|
;--- Skip the enhanced checks when verifying fields
|
|
Q:$G(DIUTIL)="VERIFY FIELDS" 0
|
|
;--- Get the line of source code
|
|
S ENTPNT=$P(X,"$$",2),TMP=$TR($P($T(@ENTPNT),";")," ")
|
|
;--- Display a warning if there is no source line
|
|
I TMP="" D Q 0
|
|
. S TMP="Make sure that the '"_$P(ENTPNT,U)_"' tag"
|
|
. D EN^DDIOL(TMP_" exists in the '"_$P(ENTPNT,U,2)_"' routine.")
|
|
;--- Display a warning if there are not enough formal parameters
|
|
I $G(MNFP)>1,$L(TMP,",")<MNFP D Q 0
|
|
. S TMP="Make sure that the entry point has at least "_MNFP
|
|
. D EN^DDIOL(TMP_" formal parameter(s).")
|
|
Q 0
|
|
;
|
|
;***** VALIDATES A SELECTION RULE EXPRESSION
|
|
;
|
|
; FILE File number that the expression is associated with
|
|
;
|
|
; This function is intended for use in the input transforms
|
|
; of registry definition fields. It kills the X variable if
|
|
; it contains an illegal value.
|
|
;
|
|
; Return Values:
|
|
; 0 Ok
|
|
; 1 Illegal expression (X is killed)
|
|
;
|
|
EXPR(FILE) ;
|
|
Q:($G(FILE)'>0)!($G(X)="") 0
|
|
N EXPR,RC,RESULT,RORERROR,RORLOG,RORPARM,TMP
|
|
;--- Check if the parser routine exists in the UCI
|
|
S EXPR=X,X="RORUPEX" X ^%ZOSF("TEST") S X=EXPR E Q 0
|
|
;--- Parse and validate the expression
|
|
S RC=$$PARSER^RORUPEX(FILE,X,.RESULT)
|
|
Q:RC'<0 0 K X
|
|
;--- Field does not exist
|
|
I RC=-7 D Q 1
|
|
. S TMP="One of the referenced fields"
|
|
. D EN^DDIOL(TMP_" does not exist in the file #"_FILE_"!")
|
|
;--- Syntax error in the expression
|
|
I RC=-21 D Q 1
|
|
. D EN^DDIOL("Invalid expression: '"_EXPR_"'")
|
|
. D EN^DDIOL("Parsed to: '"_$G(RESULT)_"' ")
|
|
;--- File does not exist
|
|
I RC=-58 D Q 1
|
|
. D EN^DDIOL("Referenced file #"_FILE_" does not exist!")
|
|
Q 1
|
|
;
|
|
;***** CHECKS IF A FIELD OF A NATIONAL DEFINITION CAN BE DELETED
|
|
;
|
|
; FILE Top-level file number
|
|
; [IEN] IEN of the current record of the top-level file
|
|
; [FIELD] Number of the NATIONAL field.
|
|
; If value of this parameter less than zero, local
|
|
; modifications of all records will be prohibited.
|
|
; By default, the .09 field is used.
|
|
;
|
|
; This function is intended for use in the "DEL" node logic
|
|
; of registry definition fields.
|
|
;
|
|
; Return Values:
|
|
; 0 The value of the field can be deleted
|
|
; 1 Deletion is prohibited
|
|
;
|
|
VADEL(FILE,IEN,FIELD) ;
|
|
Q:$G(XPDNM)'="" 0
|
|
;--- An authorized developer can delete anything
|
|
Q:$G(RORPARM("DEVELOPER")) 0
|
|
;--- Check if the registry definition is a national one
|
|
N RC,RORMSG
|
|
I $G(FIELD)'<0 S RC=0 D:$G(IEN)>0 Q:'RC 0
|
|
. S:'$G(FIELD) FIELD=.09
|
|
. S RC=$$GET1^DIQ(FILE,IEN_",",FIELD,"I",,"RORMSG")
|
|
D EN^DDIOL("You cannot edit a national registry definition!")
|
|
Q 1
|
|
;
|
|
;***** CHECKS IF A FIELD OF A NATIONAL DEFINITION CAN BE EDITED
|
|
;
|
|
; FILE Top-level file number
|
|
; [IEN] IEN of the current record of the top-level file
|
|
; [FIELD] Number of the NATIONAL field.
|
|
; If value of this parameter less than zero, local
|
|
; modifications of all records will be prohibited.
|
|
; By default, the .09 field is used.
|
|
;
|
|
; This function is intended for use in the input transforms
|
|
; of registry definition fields. It kills the X variable if
|
|
; it contains illegal value.
|
|
;
|
|
; Return Values:
|
|
; 0 The field can be edited
|
|
; 1 Editing is prohibited (X is killed)
|
|
;
|
|
VAEDT(FILE,IEN,FIELD) ;
|
|
Q:($G(DIUTIL)="VERIFY FIELDS")!($G(XPDNM)'="") 0
|
|
;--- An authorized developer can edit anything
|
|
Q:$G(RORPARM("DEVELOPER")) 0
|
|
;--- Check if the registry definition is a national one
|
|
N RC,RORMSG
|
|
I $G(FIELD)'<0 S RC=0 D:$G(IEN)>0 Q:'RC 0
|
|
. S:'$G(FIELD) FIELD=.09
|
|
. S RC=$$GET1^DIQ(FILE,IEN_",",FIELD,"I",,"RORMSG")
|
|
K X
|
|
D EN^DDIOL("You cannot edit a national registry definition!")
|
|
Q 1
|