RORDD ;HCIOFO/SG - DATA DICTIONARY UTILITIES ;9/2/05 10:58am
;;1.5;CLINICAL CASE REGISTRIES;**10**;Feb 17, 2006;Build 32
;
; This routine uses the following IAs:
;
; #10076 ^XUSEC(KEY,DUZ (supported)
; #10142 EN^DDIOL (supported)
; #10008 DQ^DICQ (supported)
; #2052 $$GET1^DID (supported)
; #2055 $$ROOT^DILFD (supported)
; #2056 $$GET1^DIQ (supported)
; #10044 H^XUS (supported)
; #2198 $$BROKER^XWBLIB (supported)
; #10096 ^%ZOSF("TEST" (supported)
;
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'
;NOTE: With patch 10, pending patients are included in the extractions
;(nightly and historical), so this API is not called anymore to
;determine whether to include the patient in the extracts. The DEL API
;is called instead. But this 'ACTIVE' API is still used in the CCR application
;for other things.
;
;
; 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 Patient is pending
; 5 Patient is marked for deletion
;
; Return Values:
; 0 The record is not confirmed
; 1 The record is confirmed
;
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 ; Confirmed/Active
;
;***** CHECKS IF THE REGISTRY RECORD IS MARKED FOR DELETION
;NOTE: these records are excluded from the historical extract
;
; IEN IEN of the registry record
;
; Return Values:
; 1 The record is marked for deletion
; 0 The record is not marked for deletion
;
DEL(IEN) ;
N NODE0,STATUS
S NODE0=$G(^RORDATA(798,+IEN,0))
I NODE0="" Q 0
S STATUS=+$P(NODE0,U,5)
Q:STATUS=5 1 ; Marked for deletion
Q 0 ; Not marked for deletion
;
;***** 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"")" ;Naked Ref: ^ROR(799.2,IEN
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRORDD 10626 printed Dec 13, 2024@01:41:22 Page 2
RORDD ;HCIOFO/SG - DATA DICTIONARY UTILITIES ;9/2/05 10:58am
+1 ;;1.5;CLINICAL CASE REGISTRIES;**10**;Feb 17, 2006;Build 32
+2 ;
+3 ; This routine uses the following IAs:
+4 ;
+5 ; #10076 ^XUSEC(KEY,DUZ (supported)
+6 ; #10142 EN^DDIOL (supported)
+7 ; #10008 DQ^DICQ (supported)
+8 ; #2052 $$GET1^DID (supported)
+9 ; #2055 $$ROOT^DILFD (supported)
+10 ; #2056 $$GET1^DIQ (supported)
+11 ; #10044 H^XUS (supported)
+12 ; #2198 $$BROKER^XWBLIB (supported)
+13 ; #10096 ^%ZOSF("TEST" (supported)
+14 ;
+15 QUIT
+16 ;
+17 ;***** CHECKS USER KEYS AND LOGS ATTEMPTS OF UNAUTHORIZED ACCESS
+18 ;
+19 ; FILE File number
+20 ;
+21 ; [REGISTRY] Either a registry name or a registry IEN.
+22 ; By default ($G(REGISTRY)=""), the function checks if
+23 ; the user has any Clinical Case Registries keys.
+24 ;
+25 ; [STRICT] If this parameter is defined and not zero then an
+26 ; access violation event is recorded even if the user
+27 ; has other Clinical Case Registries keys.
+28 ;
+29 ; This mode can be used to restrict access to a file,
+30 ; which is solely associated with a single registry
+31 ; (for example, the ROR HIV STUDY file).
+32 ;
+33 ; Return Values:
+34 ; 0 Access denied
+35 ; 1 Access granted
+36 ;
ACCESS(FILE,REGISTRY,STRICT) ;
+1 ; Unknown user
if $GET(DUZ)'>0
QUIT 0
+2 ; KIDS
if $EXTRACT($GET(XPDNM),1,3)="ROR"
QUIT 1
+3 NEW ANYKEY,REGKEY
+4 SET (REGKEY,ANYKEY)=1
+5 ;--- Check the user's security keys
+6 IF $GET(REGISTRY)'=""
if $DATA(^ROR(798.1,"ACL",DUZ,REGISTRY))<10
Begin DoDot:1
+7 if $DATA(^XUSEC("ROR VA IRM",DUZ))
QUIT
+8 SET REGKEY=0
SET ANYKEY=($DATA(^ROR(798.1,"ACL",DUZ))>1)
End DoDot:1
+9 IF '$TEST
if $DATA(^ROR(798.1,"ACL",DUZ))<10
Begin DoDot:1
+10 if '$DATA(^XUSEC("ROR VA IRM",DUZ))
SET (REGKEY,ANYKEY)=0
End DoDot:1
+11 if REGKEY
QUIT 1
+12 ;--- Do not record an access violation event if the user has
+13 ; any Clinical Case Registries key and the "strict" mode
+14 ;--- has not been requested by the caller.
+15 IF '$GET(STRICT)
if ANYKEY
QUIT 0
+16 NEW RORMSG,X
+17 ;--- Record the access violation event (if the API is available)
+18 SET X="RORLOG"
XECUTE ^%ZOSF("TEST")
+19 IF $TEST
Begin DoDot:1
+20 SET X="Attempt of unauthorized access to the file #"_FILE
End DoDot:1
DO ACVIOLTN^RORLOG(X,$GET(REGISTRY))
+21 ;--- Display the message (if the current device is a display)
+22 IF $EXTRACT($GET(IOST),1,2)="C-"
Begin DoDot:1
+23 DO TEXT^RORTXT(7980000.003,.RORMSG)
+24 WRITE !!!
SET X=""
+25 FOR
SET X=$ORDER(RORMSG(X))
if X=""
QUIT
Begin DoDot:2
+26 WRITE ?($GET(IOM,80)-$LENGTH(RORMSG(X))\2),RORMSG(X),!
End DoDot:2
End DoDot:1
HANG 4
+27 ;--- Log Off the user (if not an RPC Broker session)
+28 if '$$BROKER^XWBLIB
DO H^XUS
+29 QUIT 0
+30 ;
+31 ;***** "ACL" CROSS-REFERENCE UTILITIES
+32 ;
+33 ; These two procedures are used by the kill and set logic of the
+34 ; "ACL" cross-reference (MUMPS type) of the .01 field of the SECURITY
+35 ; KEY multiple of the ROR REGISTRY PARAMETERS file (#798.1).
+36 ;
+37 ; FileMan initializes the X variable (name of the security key) and
+38 ; the DA array before calling these procedures.
+39 ;
ACLKILL ;
+1 NEW RORDUZ,RORREG
+2 SET RORREG=$PIECE($GET(^ROR(798.1,DA(1),0)),U)
+3 SET RORDUZ=""
+4 FOR
SET RORDUZ=$ORDER(^XUSEC(X,RORDUZ))
if RORDUZ=""
QUIT
Begin DoDot:1
+5 KILL ^ROR(798.1,"ACL",RORDUZ,DA(1),X,DA)
+6 if RORREG'=""
KILL ^ROR(798.1,"ACL",RORDUZ,RORREG,X,DA)
End DoDot:1
+7 QUIT
+8 ;
ACLSET ;
+1 NEW RORDUZ,RORREG
+2 SET RORREG=$PIECE($GET(^ROR(798.1,DA(1),0)),U)
+3 SET RORDUZ=""
+4 FOR
SET RORDUZ=$ORDER(^XUSEC(X,RORDUZ))
if RORDUZ=""
QUIT
Begin DoDot:1
+5 SET ^ROR(798.1,"ACL",RORDUZ,DA(1),X,DA)=""
+6 if RORREG'=""
SET ^ROR(798.1,"ACL",RORDUZ,RORREG,X,DA)=""
End DoDot:1
+7 QUIT
+8 ;
+9 ;***** CHECKS IF THE REGISTRY RECORD IS 'ACTIVE'
+10 ;NOTE: With patch 10, pending patients are included in the extractions
+11 ;(nightly and historical), so this API is not called anymore to
+12 ;determine whether to include the patient in the extracts. The DEL API
+13 ;is called instead. But this 'ACTIVE' API is still used in the CCR application
+14 ;for other things.
+15 ;
+16 ;
+17 ; IEN IEN of the registry record
+18 ;
+19 ; [CHKDT] Date/Time for status calculation. The current date
+20 ; and time are used by default.
+21 ; Currently, this parameter has no effect .
+22 ;
+23 ; [.STATUS] Status code is returned via this parameter.
+24 ; It explains the reason for inactivity:
+25 ; "" Status unknown or no record
+26 ; 4 Patient is pending
+27 ; 5 Patient is marked for deletion
+28 ;
+29 ; Return Values:
+30 ; 0 The record is not confirmed
+31 ; 1 The record is confirmed
+32 ;
ACTIVE(IEN,CHKDT,STATUS) ;
+1 NEW NODE0
+2 SET NODE0=$GET(^RORDATA(798,+IEN,0))
+3 IF NODE0=""
SET STATUS=""
QUIT 0
+4 SET STATUS=+$PIECE(NODE0,U,5)
+5 ; Pending
if STATUS=4
QUIT 0
+6 ; Marked for deletion
if STATUS=5
QUIT 0
+7 ; Confirmed/Active
QUIT 1
+8 ;
+9 ;***** CHECKS IF THE REGISTRY RECORD IS MARKED FOR DELETION
+10 ;NOTE: these records are excluded from the historical extract
+11 ;
+12 ; IEN IEN of the registry record
+13 ;
+14 ; Return Values:
+15 ; 1 The record is marked for deletion
+16 ; 0 The record is not marked for deletion
+17 ;
DEL(IEN) ;
+1 NEW NODE0,STATUS
+2 SET NODE0=$GET(^RORDATA(798,+IEN,0))
+3 IF NODE0=""
QUIT 0
+4 SET STATUS=+$PIECE(NODE0,U,5)
+5 ; Marked for deletion
if STATUS=5
QUIT 1
+6 ; Not marked for deletion
QUIT 0
+7 ;
+8 ;***** DISPLAYS A LIST OF APIs DEFINED IN THE SUBFILE #799.23
+9 ;
+10 ; IEN IEN of the current record of the file #799.2
+11 ;
APILST(IEN) ;
+1 NEW D,DIC,DLAYGO,DZ,RORMSG
+2 SET DIC=$$ROOT^DILFD(799.23,","_(+IEN)_",")
if DIC=""
QUIT
+3 SET D=$$GET1^DID(799.23,.01,,"FIELD LENGTH",,"RORMSG")
+4 DO EN^DDIOL($JUSTIFY(1,D),,"?2")
DO EN^DDIOL("GETS^DIQ",,"?10")
+5 SET DIC(0)=""
SET D="B"
SET DZ="??"
+6 ;Naked Ref: ^ROR(799.2,IEN
SET DIC("W")="D EN^DDIOL($P(^(0),U,3)_""^""_$P(^(0),U,2),,""?10"")"
+7 DO DQ^DICQ
+8 QUIT
+9 ;
+10 ;***** VALIDATES A NAME OF THE CALLBACK FUNCTION
+11 ;
+12 ; MNFP Minimal number of formal parameters (opt'l).
+13 ; If this parameter has a value greater than 1, the
+14 ; function makes very simple check of the number of
+15 ; formal parameters in the source code.
+16 ;
+17 ; This function is intended for use in the input transforms
+18 ; of registry definition fields. It kills the X variable if it
+19 ; contains illegal value.
+20 ;
+21 ; The function does not allow to use '%' in the routine and
+22 ; tag names (this is prohibited by VistA SAC).
+23 ;
+24 ; If the function cannot obtain the source code of the callback
+25 ; function (because the code does not exist yet or has been stripped)
+26 ; or there are not enough formal parameters in the definition of the
+27 ; function, it issues a warning but does not reject the value.
+28 ;
+29 ; Return Values:
+30 ; 0 Ok
+31 ; 1 Illegal name (X is killed)
+32 ;
EP(MNFP) ;
+1 if $GET(X)=""
QUIT 0
+2 NEW ENTPNT,TMP
+3 ;--- Check if the value has the "$$TAG^ROUTINE" format
+4 IF '(X?2"$"1.8UN1"^"1.8UN)
KILL X
QUIT 1
+5 ;--- Check if the routine exists
+6 SET ENTPNT=X
SET X=$PIECE(X,U,2)
+7 XECUTE ^%ZOSF("TEST")
IF '$TEST
Begin DoDot:1
+8 DO EN^DDIOL("The '"_X_"' routine does not exist!")
End DoDot:1
KILL X
QUIT 1
+9 SET X=ENTPNT
+10 ;--- Skip the enhanced checks when verifying fields
+11 if $GET(DIUTIL)="VERIFY FIELDS"
QUIT 0
+12 ;--- Get the line of source code
+13 SET ENTPNT=$PIECE(X,"$$",2)
SET TMP=$TRANSLATE($PIECE($TEXT(@ENTPNT),";")," ")
+14 ;--- Display a warning if there is no source line
+15 IF TMP=""
Begin DoDot:1
+16 SET TMP="Make sure that the '"_$PIECE(ENTPNT,U)_"' tag"
+17 DO EN^DDIOL(TMP_" exists in the '"_$PIECE(ENTPNT,U,2)_"' routine.")
End DoDot:1
QUIT 0
+18 ;--- Display a warning if there are not enough formal parameters
+19 IF $GET(MNFP)>1
IF $LENGTH(TMP,",")<MNFP
Begin DoDot:1
+20 SET TMP="Make sure that the entry point has at least "_MNFP
+21 DO EN^DDIOL(TMP_" formal parameter(s).")
End DoDot:1
QUIT 0
+22 QUIT 0
+23 ;
+24 ;***** VALIDATES A SELECTION RULE EXPRESSION
+25 ;
+26 ; FILE File number that the expression is associated with
+27 ;
+28 ; This function is intended for use in the input transforms
+29 ; of registry definition fields. It kills the X variable if
+30 ; it contains an illegal value.
+31 ;
+32 ; Return Values:
+33 ; 0 Ok
+34 ; 1 Illegal expression (X is killed)
+35 ;
EXPR(FILE) ;
+1 if ($GET(FILE)'>0)!($GET(X)="")
QUIT 0
+2 NEW EXPR,RC,RESULT,RORERROR,RORLOG,RORPARM,TMP
+3 ;--- Check if the parser routine exists in the UCI
+4 SET EXPR=X
SET X="RORUPEX"
XECUTE ^%ZOSF("TEST")
SET X=EXPR
IF '$TEST
QUIT 0
+5 ;--- Parse and validate the expression
+6 SET RC=$$PARSER^RORUPEX(FILE,X,.RESULT)
+7 if RC'<0
QUIT 0
KILL X
+8 ;--- Field does not exist
+9 IF RC=-7
Begin DoDot:1
+10 SET TMP="One of the referenced fields"
+11 DO EN^DDIOL(TMP_" does not exist in the file #"_FILE_"!")
End DoDot:1
QUIT 1
+12 ;--- Syntax error in the expression
+13 IF RC=-21
Begin DoDot:1
+14 DO EN^DDIOL("Invalid expression: '"_EXPR_"'")
+15 DO EN^DDIOL("Parsed to: '"_$GET(RESULT)_"' ")
End DoDot:1
QUIT 1
+16 ;--- File does not exist
+17 IF RC=-58
Begin DoDot:1
+18 DO EN^DDIOL("Referenced file #"_FILE_" does not exist!")
End DoDot:1
QUIT 1
+19 QUIT 1
+20 ;
+21 ;***** CHECKS IF A FIELD OF A NATIONAL DEFINITION CAN BE DELETED
+22 ;
+23 ; FILE Top-level file number
+24 ; [IEN] IEN of the current record of the top-level file
+25 ; [FIELD] Number of the NATIONAL field.
+26 ; If value of this parameter less than zero, local
+27 ; modifications of all records will be prohibited.
+28 ; By default, the .09 field is used.
+29 ;
+30 ; This function is intended for use in the "DEL" node logic
+31 ; of registry definition fields.
+32 ;
+33 ; Return Values:
+34 ; 0 The value of the field can be deleted
+35 ; 1 Deletion is prohibited
+36 ;
VADEL(FILE,IEN,FIELD) ;
+1 if $GET(XPDNM)'=""
QUIT 0
+2 ;--- An authorized developer can delete anything
+3 if $GET(RORPARM("DEVELOPER"))
QUIT 0
+4 ;--- Check if the registry definition is a national one
+5 NEW RC,RORMSG
+6 IF $GET(FIELD)'<0
SET RC=0
if $GET(IEN)>0
Begin DoDot:1
+7 if '$GET(FIELD)
SET FIELD=.09
+8 SET RC=$$GET1^DIQ(FILE,IEN_",",FIELD,"I",,"RORMSG")
End DoDot:1
if 'RC
QUIT 0
+9 DO EN^DDIOL("You cannot edit a national registry definition!")
+10 QUIT 1
+11 ;
+12 ;***** CHECKS IF A FIELD OF A NATIONAL DEFINITION CAN BE EDITED
+13 ;
+14 ; FILE Top-level file number
+15 ; [IEN] IEN of the current record of the top-level file
+16 ; [FIELD] Number of the NATIONAL field.
+17 ; If value of this parameter less than zero, local
+18 ; modifications of all records will be prohibited.
+19 ; By default, the .09 field is used.
+20 ;
+21 ; This function is intended for use in the input transforms
+22 ; of registry definition fields. It kills the X variable if
+23 ; it contains illegal value.
+24 ;
+25 ; Return Values:
+26 ; 0 The field can be edited
+27 ; 1 Editing is prohibited (X is killed)
+28 ;
VAEDT(FILE,IEN,FIELD) ;
+1 if ($GET(DIUTIL)="VERIFY FIELDS")!($GET(XPDNM)'="")
QUIT 0
+2 ;--- An authorized developer can edit anything
+3 if $GET(RORPARM("DEVELOPER"))
QUIT 0
+4 ;--- Check if the registry definition is a national one
+5 NEW RC,RORMSG
+6 IF $GET(FIELD)'<0
SET RC=0
if $GET(IEN)>0
Begin DoDot:1
+7 if '$GET(FIELD)
SET FIELD=.09
+8 SET RC=$$GET1^DIQ(FILE,IEN_",",FIELD,"I",,"RORMSG")
End DoDot:1
if 'RC
QUIT 0
+9 KILL X
+10 DO EN^DDIOL("You cannot edit a national registry definition!")
+11 QUIT 1
