XULM1 ;IRMFO-ALB/CJM/SWO/RGG - KERNEL LOCK MANAGER ;12/04/2012
;;8.0;KERNEL;**608**;JUL 10, 1995;Build 84
;;Per VA Directive 6402, this routine should not be modified
;
; ******************************************************************
; * *
; * The Kernel Lock Manager is based on the VistA Lock Manager *
; * developed by Tommy Martin. *
; * *
; ******************************************************************
;Contains routines for editing and creating entries in the LOCK DICTIONARY
;
SNTXLOCK(X,PARTS) ;
;
;Checks the syntax for a lock, returns 1 if ok, 0 otherwise
;
;Input:
; X - the value of the LOCK TEMPLATE that was entered
; DA - if defined, it should be the ien of the record that is being edited
;Output:
; function returns 1 if X is syntactically correct, 0 otherwise
; PARTS - optional, pass-by-references. Returns the parsed of the LOCK TEMPLATE
; PARTS(<subscripts>):
; ("GLOBAL") =1 if the lock is on a global, 0 otherwise
; ("VARIABLE") = the locked variable, without subscripts
; (0) = count of subscripts
; (<1,2,3,...>) = the subscripts, in the order they occur
;
N LOCK,BAD,NODE0,NODE1
I $E(X)=" " S X=$E(X,2,500)
I $L(X)>245 Q 0
I $G(DA) S NODE1=$G(^XLM(8993,DA,1)) I $P(NODE1,"^",2),$E(X)'="^" S X="^"_X
;
S LOCK=X
K PARTS
S PARTS(0)=0
S PARTS("GLOBAL")=0
S BAD=0
;
I $E(LOCK)="^" D
.S LOCK=$E(LOCK,2,245)
.S PARTS("GLOBAL")=1
S PARTS("VARIABLE")=$P(LOCK,"(")
I $G(DA) S NODE0=$G(^XLM(8993,DA,0)),NODE1=$G(^XLM(8993,DA,1)) I $L(NODE1) Q:($L($P(NODE1,"^",2))&($P(NODE1,"^",2)'=PARTS("GLOBAL")))!($L($P(NODE0,"^"))&($P($P(NODE0,"^"),"(")'=PARTS("VARIABLE"))) 0
D
.N COUNT
.I '$$SNTXVAR(PARTS("VARIABLE")) S BAD=1 Q
.Q:LOCK'["("
.I $E(LOCK,$L(LOCK))'=")" S BAD=1 Q
.S LOCK=$P(LOCK,"(",2,99)
.F COUNT=1:1 S PARTS=$P(LOCK,",",COUNT) Q:PARTS="" D Q:BAD
..I $E(PARTS,$L(PARTS))=")" S PARTS=$E(PARTS,1,$L(PARTS)-1) I $P(LOCK,",",COUNT+1)'="" S BAD=1 Q
..S PARTS(COUNT)=PARTS,PARTS(0)=COUNT
..;
..D
...;PARTS is either a number, a string, or a variable
...I PARTS=+PARTS S PARTS(COUNT,"VARIABLE")=0 Q
...I $E(PARTS)="""",$E(PARTS,$L(PARTS))="""" S PARTS(COUNT,"VARIABLE")=0 Q
...I '$$SNTXVAR(PARTS) S BAD=1 Q
...S PARTS(COUNT,"VARIABLE")=1 Q
;
I BAD K PARTS S PARTS(0)=0
S PARTS=""
Q 'BAD
SNTXVAR(X) ;
;Checks the syntax for a variable. Returns 1 if ok, 0 otherwise.
;
N PATTERN,LEN
S LEN=$L(X)
Q:LEN>8 0
S PATTERN=$S(LEN>1:"1U"_(LEN-1)_"UN",1:"1U")
I X?@PATTERN Q 1
Q 0
;
ADDPARTS(IEN) ;
;Adds the parts parsed from the lock template to the dictionary
;IEN is the record in the LOCK DICTIONARY.
;PARTS is an array containing the elements parsed out of the lock template
;
N TEMPLATE,PARTS
S TEMPLATE=$$TEMPLATE^XULMU(IEN)
Q:'$$SNTXLOCK(TEMPLATE,.PARTS)
N ORDER,DATA,DA
S DATA(1.02)=PARTS("GLOBAL")
D UPD^XULMU(8993,IEN,.DATA)
K DATA
F ORDER=1:1:PARTS(0) D
.S DA(1)=IEN
.S DATA(.01)=ORDER
.S DATA(.02)=PARTS(ORDER)
.S DATA(.04)=$S($G(PARTS(ORDER,"VARIABLE")):"V",1:"L")
.S DA=$O(^XLM(8993,DA(1),2,"B",ORDER,0))
.I 'DA D
..D ADD^XULMU(8993.02,.DA,.DATA)
.E D
..D UPD^XULMU(8993.02,.DA,.DATA)
;
;delete any subscripts not found in the LOCK TEMPLATE
S ORDER=PARTS(0) F S ORDER=$O(^XLM(8993,IEN,2,"B",ORDER)) Q:'ORDER S DA=$O(^XLM(8993,IEN,2,"B",ORDER,0)) I DA S DA(1)=IEN D DELETE^XULMU(8993.02,.DA)
Q
;
SELECT() ;Select a LOCK TEMPLATE to edit
N DA,DIC,Y,DTOUT
S DA=0
S DIC=8993
S DIC(0)="AEMNO"
W !,"** You cannot enter the '^' prefix when selecting a lock template. **"
D ^DIC
S:+Y>0 DA=+Y
Q DA
;
EDIT(DA) ;Edit the lock dictionary entry ien=DA
;
Q:'$G(DA)
N DIE,DR,Y,RET,DTOUT,ORDER,D,D0,DI,DQ,QUIT
S QUIT=0
;
D
.S RET=DA
.S DR=".01;1.02;1.01;1.03//YES;W !!,""What is the purpose of the lock?"",!;4Purpose;S QUIT=0"
.S DIE=8993
.S QUIT=1
.D ^DIE
.Q:QUIT
.D ADDPARTS(RET)
.S DA(1)=RET
.F ORDER=1:1 S DA=$O(^XLM(8993,DA(1),2,"B",ORDER,0)) Q:'DA D I QUIT S QUIT=0 Q
..I ORDER=1 W !!,"Checking for variables within the LOCK TEMPLATE..."
..N NODE
..S NODE=$G(^XLM(8993,DA(1),2,DA,0))
..I $P(NODE,"^",4)="V" D
...N VARIABLE
...S VARIABLE=$P(NODE,"^",2)
...W !!,"Found variable '"_VARIABLE_"'..."
...S DIE="^XLM(8993,DA(1),2,"
...W !!,"You can optionally enter MUMPS code to verify that the variable '"_VARIABLE_"'",!,"has a permissible value. It should set Y=0 if not ok, Y=1 if ok.",!
...S DR="1Executable check logic"
...D ^DIE I $D(DTOUT)!$D(Y) S QUIT=1 Q
.;
.W !!,"You can display file identifiers for the locked record, or for a record in"
.W !,"another file related to the locked record. Most locks are related to a"
.W !,"specific patient, so most entries in the lock dictionary should include a"
.W !,"file reference to the PATIENT file (#2) and to the file of the locked record,"
.W !,"and perhaps other files as well."
.W !!,"If you would like to include file references, first select the file, and then",!,"enter the MUMPS code that will retrieve the file identifiers from that file.",!
.K DA S DA=+RET
.S DR="3"
.S DR(2,8993.03)=".01File;W !!,""Enter MUMPS code to return identifiers for the record related to the lock."",!;1MUMPS Code;W !!,""List the identifiers that are returned for this file reference."",!;2Identifiers"
.S DIE=8993
.D ^DIE
.I $D(DTOUT)!$D(Y) S QUIT=1 Q
Q QUIT
;
ASK() ;Ask user if he wants to edit an existing lock template or create
;a new one.
;
N DIR
S DIR(0)="S^A:Add a new entry;E:Edit an existing entry;D:Delete an existing entry"
S DIR("?")="Do you want to Add, Edit, or Delete an entry in the lock dictionary?"
W !,DIR("?"),!
S DIR("B")="E"
D ^DIR
I Y="E" D
.D EDIT($$SELECT)
E I Y="D" D
.D DELETE($$SELECT)
E I Y="A" D
.D EDIT($$CREATE)
Q
DELETE(IEN) ;
Q:'IEN
I $$ASKYESNO^XULMU("Are you sure","NO") D DELETE^XULMU(8993,IEN) W !,"Deleted!"
Q
;
;
CREATE() ;Ask the user to enter a LOCK TEMPLATE, then
;create a new entry in the lock dictionary.
;
N DA,QUIT
S (DA,QUIT)=0
;
F D Q:QUIT
.N I,DIR,X,Y
.N TEMPLATE,GLOBAL
.S DIR(0)="8993,.01"
.;ask user for LOCK TEMPLATE
.D ^DIR
.I $D(DIRUT) S QUIT=1 K DIRUT Q
.S GLOBAL=$S($E(X,1,2)["^":1,1:0)
.S TEMPLATE=$P(X,"^",(1+GLOBAL))
.I TEMPLATE="" S QUIT=1 QUIT
.S DA=$O(^XLM(8993,"E",GLOBAL,TEMPLATE,0))
.S:'DA DA=$O(^XLM(8993,"E",'GLOBAL,TEMPLATE,0))
.I DA S QUIT='$$ASKYESNO^XULMU("That LOCK TEMPLATE already exists! Do you want to edit it","NO") I QUIT S DA=0 Q
.;
.;create a new entry
.I 'DA D
..N DATA,ERROR
..S DATA(.01)=TEMPLATE
..S DATA(1.02)=GLOBAL
..S DA=$$ADD^XULMU(8993,,.DATA,.ERROR)
..I 'DA W !,ERROR
..S QUIT=1
;
;
Q DA
;
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXULM1 6967 printed Jun 11, 2024@21:56:47 Page 2
XULM1 ;IRMFO-ALB/CJM/SWO/RGG - KERNEL LOCK MANAGER ;12/04/2012
+1 ;;8.0;KERNEL;**608**;JUL 10, 1995;Build 84
+2 ;;Per VA Directive 6402, this routine should not be modified
+3 ;
+4 ; ******************************************************************
+5 ; * *
+6 ; * The Kernel Lock Manager is based on the VistA Lock Manager *
+7 ; * developed by Tommy Martin. *
+8 ; * *
+9 ; ******************************************************************
+10 ;Contains routines for editing and creating entries in the LOCK DICTIONARY
+11 ;
SNTXLOCK(X,PARTS) ;
+1 ;
+2 ;Checks the syntax for a lock, returns 1 if ok, 0 otherwise
+3 ;
+4 ;Input:
+5 ; X - the value of the LOCK TEMPLATE that was entered
+6 ; DA - if defined, it should be the ien of the record that is being edited
+7 ;Output:
+8 ; function returns 1 if X is syntactically correct, 0 otherwise
+9 ; PARTS - optional, pass-by-references. Returns the parsed of the LOCK TEMPLATE
+10 ; PARTS(<subscripts>):
+11 ; ("GLOBAL") =1 if the lock is on a global, 0 otherwise
+12 ; ("VARIABLE") = the locked variable, without subscripts
+13 ; (0) = count of subscripts
+14 ; (<1,2,3,...>) = the subscripts, in the order they occur
+15 ;
+16 NEW LOCK,BAD,NODE0,NODE1
+17 IF $EXTRACT(X)=" "
SET X=$EXTRACT(X,2,500)
+18 IF $LENGTH(X)>245
QUIT 0
+19 IF $GET(DA)
SET NODE1=$GET(^XLM(8993,DA,1))
IF $PIECE(NODE1,"^",2)
IF $EXTRACT(X)'="^"
SET X="^"_X
+20 ;
+21 SET LOCK=X
+22 KILL PARTS
+23 SET PARTS(0)=0
+24 SET PARTS("GLOBAL")=0
+25 SET BAD=0
+26 ;
+27 IF $EXTRACT(LOCK)="^"
Begin DoDot:1
+28 SET LOCK=$EXTRACT(LOCK,2,245)
+29 SET PARTS("GLOBAL")=1
End DoDot:1
+30 SET PARTS("VARIABLE")=$PIECE(LOCK,"(")
+31 IF $GET(DA)
SET NODE0=$GET(^XLM(8993,DA,0))
SET NODE1=$GET(^XLM(8993,DA,1))
IF $LENGTH(NODE1)
if ($LENGTH($PIECE(NODE1,"^",2))&($PIECE(NODE1,"^",2)'=PARTS("GLOBAL")))!($LENGTH($PIECE(NODE0,"^"))&($PIECE($PIECE(NODE0,"^"),"(")'=PARTS("VARIABLE")))
QUIT 0
+32 Begin DoDot:1
+33 NEW COUNT
+34 IF '$$SNTXVAR(PARTS("VARIABLE"))
SET BAD=1
QUIT
+35 if LOCK'["("
QUIT
+36 IF $EXTRACT(LOCK,$LENGTH(LOCK))'=")"
SET BAD=1
QUIT
+37 SET LOCK=$PIECE(LOCK,"(",2,99)
+38 FOR COUNT=1:1
SET PARTS=$PIECE(LOCK,",",COUNT)
if PARTS=""
QUIT
Begin DoDot:2
+39 IF $EXTRACT(PARTS,$LENGTH(PARTS))=")"
SET PARTS=$EXTRACT(PARTS,1,$LENGTH(PARTS)-1)
IF $PIECE(LOCK,",",COUNT+1)'=""
SET BAD=1
QUIT
+40 SET PARTS(COUNT)=PARTS
SET PARTS(0)=COUNT
+41 ;
+42 Begin DoDot:3
+43 ;PARTS is either a number, a string, or a variable
+44 IF PARTS=+PARTS
SET PARTS(COUNT,"VARIABLE")=0
QUIT
+45 IF $EXTRACT(PARTS)=""""
IF $EXTRACT(PARTS,$LENGTH(PARTS))=""""
SET PARTS(COUNT,"VARIABLE")=0
QUIT
+46 IF '$$SNTXVAR(PARTS)
SET BAD=1
QUIT
+47 SET PARTS(COUNT,"VARIABLE")=1
QUIT
End DoDot:3
End DoDot:2
if BAD
QUIT
End DoDot:1
+48 ;
+49 IF BAD
KILL PARTS
SET PARTS(0)=0
+50 SET PARTS=""
+51 QUIT 'BAD
SNTXVAR(X) ;
+1 ;Checks the syntax for a variable. Returns 1 if ok, 0 otherwise.
+2 ;
+3 NEW PATTERN,LEN
+4 SET LEN=$LENGTH(X)
+5 if LEN>8
QUIT 0
+6 SET PATTERN=$SELECT(LEN>1:"1U"_(LEN-1)_"UN",1:"1U")
+7 IF X?@PATTERN
QUIT 1
+8 QUIT 0
+9 ;
ADDPARTS(IEN) ;
+1 ;Adds the parts parsed from the lock template to the dictionary
+2 ;IEN is the record in the LOCK DICTIONARY.
+3 ;PARTS is an array containing the elements parsed out of the lock template
+4 ;
+5 NEW TEMPLATE,PARTS
+6 SET TEMPLATE=$$TEMPLATE^XULMU(IEN)
+7 if '$$SNTXLOCK(TEMPLATE,.PARTS)
QUIT
+8 NEW ORDER,DATA,DA
+9 SET DATA(1.02)=PARTS("GLOBAL")
+10 DO UPD^XULMU(8993,IEN,.DATA)
+11 KILL DATA
+12 FOR ORDER=1:1:PARTS(0)
Begin DoDot:1
+13 SET DA(1)=IEN
+14 SET DATA(.01)=ORDER
+15 SET DATA(.02)=PARTS(ORDER)
+16 SET DATA(.04)=$SELECT($GET(PARTS(ORDER,"VARIABLE")):"V",1:"L")
+17 SET DA=$ORDER(^XLM(8993,DA(1),2,"B",ORDER,0))
+18 IF 'DA
Begin DoDot:2
+19 DO ADD^XULMU(8993.02,.DA,.DATA)
End DoDot:2
+20 IF '$TEST
Begin DoDot:2
+21 DO UPD^XULMU(8993.02,.DA,.DATA)
End DoDot:2
End DoDot:1
+22 ;
+23 ;delete any subscripts not found in the LOCK TEMPLATE
+24 SET ORDER=PARTS(0)
FOR
SET ORDER=$ORDER(^XLM(8993,IEN,2,"B",ORDER))
if 'ORDER
QUIT
SET DA=$ORDER(^XLM(8993,IEN,2,"B",ORDER,0))
IF DA
SET DA(1)=IEN
DO DELETE^XULMU(8993.02,.DA)
+25 QUIT
+26 ;
SELECT() ;Select a LOCK TEMPLATE to edit
+1 NEW DA,DIC,Y,DTOUT
+2 SET DA=0
+3 SET DIC=8993
+4 SET DIC(0)="AEMNO"
+5 WRITE !,"** You cannot enter the '^' prefix when selecting a lock template. **"
+6 DO ^DIC
+7 if +Y>0
SET DA=+Y
+8 QUIT DA
+9 ;
EDIT(DA) ;Edit the lock dictionary entry ien=DA
+1 ;
+2 if '$GET(DA)
QUIT
+3 NEW DIE,DR,Y,RET,DTOUT,ORDER,D,D0,DI,DQ,QUIT
+4 SET QUIT=0
+5 ;
+6 Begin DoDot:1
+7 SET RET=DA
+8 SET DR=".01;1.02;1.01;1.03//YES;W !!,""What is the purpose of the lock?"",!;4Purpose;S QUIT=0"
+9 SET DIE=8993
+10 SET QUIT=1
+11 DO ^DIE
+12 if QUIT
QUIT
+13 DO ADDPARTS(RET)
+14 SET DA(1)=RET
+15 FOR ORDER=1:1
SET DA=$ORDER(^XLM(8993,DA(1),2,"B",ORDER,0))
if 'DA
QUIT
Begin DoDot:2
+16 IF ORDER=1
WRITE !!,"Checking for variables within the LOCK TEMPLATE..."
+17 NEW NODE
+18 SET NODE=$GET(^XLM(8993,DA(1),2,DA,0))
+19 IF $PIECE(NODE,"^",4)="V"
Begin DoDot:3
+20 NEW VARIABLE
+21 SET VARIABLE=$PIECE(NODE,"^",2)
+22 WRITE !!,"Found variable '"_VARIABLE_"'..."
+23 SET DIE="^XLM(8993,DA(1),2,"
+24 WRITE !!,"You can optionally enter MUMPS code to verify that the variable '"_VARIABLE_"'",!,"has a permissible value. It should set Y=0 if not ok, Y=1 if ok.",!
+25 SET DR="1Executable check logic"
+26 DO ^DIE
IF $DATA(DTOUT)!$DATA(Y)
SET QUIT=1
QUIT
End DoDot:3
End DoDot:2
IF QUIT
SET QUIT=0
QUIT
+27 ;
+28 WRITE !!,"You can display file identifiers for the locked record, or for a record in"
+29 WRITE !,"another file related to the locked record. Most locks are related to a"
+30 WRITE !,"specific patient, so most entries in the lock dictionary should include a"
+31 WRITE !,"file reference to the PATIENT file (#2) and to the file of the locked record,"
+32 WRITE !,"and perhaps other files as well."
+33 WRITE !!,"If you would like to include file references, first select the file, and then",!,"enter the MUMPS code that will retrieve the file identifiers from that file.",!
+34 KILL DA
SET DA=+RET
+35 SET DR="3"
+36 SET DR(2,8993.03)=".01File;W !!,""Enter MUMPS code to return identifiers for the record related to the lock."",!;1MUMPS Code;W !!,""List the identifiers that are returned for this file reference."",!;2Identifiers"
+37 SET DIE=8993
+38 DO ^DIE
+39 IF $DATA(DTOUT)!$DATA(Y)
SET QUIT=1
QUIT
End DoDot:1
+40 QUIT QUIT
+41 ;
ASK() ;Ask user if he wants to edit an existing lock template or create
+1 ;a new one.
+2 ;
+3 NEW DIR
+4 SET DIR(0)="S^A:Add a new entry;E:Edit an existing entry;D:Delete an existing entry"
+5 SET DIR("?")="Do you want to Add, Edit, or Delete an entry in the lock dictionary?"
+6 WRITE !,DIR("?"),!
+7 SET DIR("B")="E"
+8 DO ^DIR
+9 IF Y="E"
Begin DoDot:1
+10 DO EDIT($$SELECT)
End DoDot:1
+11 IF '$TEST
IF Y="D"
Begin DoDot:1
+12 DO DELETE($$SELECT)
End DoDot:1
+13 IF '$TEST
IF Y="A"
Begin DoDot:1
+14 DO EDIT($$CREATE)
End DoDot:1
+15 QUIT
DELETE(IEN) ;
+1 if 'IEN
QUIT
+2 IF $$ASKYESNO^XULMU("Are you sure","NO")
DO DELETE^XULMU(8993,IEN)
WRITE !,"Deleted!"
+3 QUIT
+4 ;
+5 ;
CREATE() ;Ask the user to enter a LOCK TEMPLATE, then
+1 ;create a new entry in the lock dictionary.
+2 ;
+3 NEW DA,QUIT
+4 SET (DA,QUIT)=0
+5 ;
+6 FOR
Begin DoDot:1
+7 NEW I,DIR,X,Y
+8 NEW TEMPLATE,GLOBAL
+9 SET DIR(0)="8993,.01"
+10 ;ask user for LOCK TEMPLATE
+11 DO ^DIR
+12 IF $DATA(DIRUT)
SET QUIT=1
KILL DIRUT
QUIT
+13 SET GLOBAL=$SELECT($EXTRACT(X,1,2)["^":1,1:0)
+14 SET TEMPLATE=$PIECE(X,"^",(1+GLOBAL))
+15 IF TEMPLATE=""
SET QUIT=1
QUIT
+16 SET DA=$ORDER(^XLM(8993,"E",GLOBAL,TEMPLATE,0))
+17 if 'DA
SET DA=$ORDER(^XLM(8993,"E",'GLOBAL,TEMPLATE,0))
+18 IF DA
SET QUIT='$$ASKYESNO^XULMU("That LOCK TEMPLATE already exists! Do you want to edit it","NO")
IF QUIT
SET DA=0
QUIT
+19 ;
+20 ;create a new entry
+21 IF 'DA
Begin DoDot:2
+22 NEW DATA,ERROR
+23 SET DATA(.01)=TEMPLATE
+24 SET DATA(1.02)=GLOBAL
+25 SET DA=$$ADD^XULMU(8993,,.DATA,.ERROR)
+26 IF 'DA
WRITE !,ERROR
+27 SET QUIT=1
End DoDot:2
End DoDot:1
if QUIT
QUIT
+28 ;
+29 ;
+30 QUIT DA
+31 ;
+32 ;
+33 ;
