MAGUTL08 ;WOIFO/SG - INTERNAL LOCK UTILITIES ; 3/9/09 12:54pm
;;3.0;IMAGING;**93**;Dec 02, 2009;Build 163
;; Per VHA Directive 2004-038, this routine should not be modified.
;; +---------------------------------------------------------------+
;; | Property of the US Government. |
;; | No permission to copy or redistribute this software is given. |
;; | Use of unreleased versions of this software requires the user |
;; | to execute a written test agreement with the VistA Imaging |
;; | Development Office of the Department of Veterans Affairs, |
;; | telephone (301) 734-0100. |
;; | |
;; | The Food and Drug Administration classifies this software as |
;; | a medical device. As such, it may not be changed in any way. |
;; | Modifications to this software may result in an adulterated |
;; | medical device under 21CFR820, the use of which is considered |
;; | to be a violation of US Federal Statutes. |
;; +---------------------------------------------------------------+
;;
; Entry points of this routine use the ^XTMP("MAGLOCK",...) global
; nodes to store lock descriptors (see the MAGUTL07 routine for
; details).
;
; This routine uses the following ICRs:
;
; #10060 Read file #200 (supported)
;
Q
;
;##### DELETES STRAY LOCK DESCRIPTORS
;
; This is a service procedure. Do not call it from regular
; applications!
;
PURGE() ;
N NDX,NODE
S NDX=0
F S NDX=$O(^XTMP("MAGLOCK",NDX)) Q:$E(NDX,1)'="^" D
. S NODE=$S(NDX["(":NDX_")",1:NDX)
. D LOCK^DILF(NODE) E Q
. K ^XTMP("MAGLOCK",NDX) L -@NODE
. Q
Q
;
;+++++ RETURNS THE LOCK DESCRIPTOR FOR THE GLOBAL NODE(S)
;
; This is an internal entry point. Do not call it from any routines
; except MAGUTL07 and MAGUTL08.
;
LDSC(NODELIST) ;
N DESCR,IENS,L,MAGMSG,NDX,NODE,SP,TMP
S:$D(NODELIST)<10 NODELIST(NODELIST)=""
;
;=== Search for the most appropriate descriptor
S (DESCR,NODE)=""
F S NODE=$O(NODELIST(NODE)) Q:NODE="" D
. ;--- The node itself
. S SP=$$XLNDX(NODE),TMP=$G(^XTMP("MAGLOCK",SP))
. S:TMP>DESCR DESCR=TMP
. ;--- Left siblings and ancestors
. S NDX=SP
. F S NDX=$O(^XTMP("MAGLOCK",NDX),-1),L=$L(NDX) Q:(NDX="")!(NDX'=$E(SP,1,L)) D
. . S TMP=$G(^XTMP("MAGLOCK",NDX)) S:TMP>DESCR DESCR=TMP
. . Q
. ;--- Right siblings and descendants
. S NDX=SP,L=$L(SP)
. F S NDX=$O(^XTMP("MAGLOCK",NDX)) Q:(NDX="")!($E(NDX,1,L)'=SP) D
. . S TMP=$G(^XTMP("MAGLOCK",NDX)) S:TMP>DESCR DESCR=TMP
. . Q
. Q
;
;=== Populate as many fields of the descriptor as possible
S:'DESCR $P(DESCR,U)=$$NOW^XLFDT
;--- Get the user name if the DUZ is available
D:$P(DESCR,U,3)>0
. S IENS=+$P(DESCR,U,3)_","
. S $P(DESCR,U,2)=$$GET1^DIQ(200,IENS,.01,,,"MAGMSG")
. Q
;--- If the originator of the lock is unknown, indicate this fact
S:$P(DESCR,U,2)="" $P(DESCR,U,2)="UNKNOWN"
;
;=== Return the lock descriptor
Q $P(DESCR,U,1,5)
;
;+++++ LOCKS THE SINGLE NODE
;
; Return Values
; =============
; <0 Error descriptor (see the $$ERROR^MAGUERR)
; 0 Ok
; >0 Lock descriptor
;
; Notes
; =====
;
; This is an internal entry point. Do not call it from any routines
; except MAGUTL07 and MAGUTL08.
;
LOCK1(FILE,IENS,FIELD,TO,NAME,FLAGS) ;
N DESCR,NDX,NODE,TMP
S NODE=$$NODE(FILE,IENS,FIELD)
Q:NODE<0 NODE
;--- Try to lock the object
I FLAGS'["D" L +@NODE:TO E Q $$LDSC(NODE)
;--- Create the lock descriptor
S DESCR=$$NOW^XLFDT_U_NAME_U_U_$JOB_U_$G(ZTSK)
S:NAME="" $P(DESCR,U,3)=$G(DUZ)
;--- Calculate the lock counter
S NDX=$$XLNDX(NODE),TMP=$G(^XTMP("MAGLOCK",NDX))
S $P(DESCR,U,6)=$S($P(TMP,U,4)=$JOB:$P(TMP,U,6)+1,1:1)
;--- Store the descriptor
S ^XTMP("MAGLOCK",NDX)=DESCR
Q 0
;
;+++++ RETURNS THE GLOBAL NODE OF THE OBJECT
;
; FILE File/subfile number
; IENS IENS of the record or subfile
; FIELD Field number
;
; Return Values
; =============
; <0 Error descriptor (see the $$ERROR^MAGUERR)
; ... Closed root
;
; Notes
; =====
;
; This is an internal entry point. Do not call it from any routines
; except MAGUTL07 and MAGUTL08.
;
NODE(FILE,IENS,FIELD) ;
N FGL,IEN,MAGMSG,NODE,RC
I IENS'="" Q:'$$VALIENS^MAGUTL05(IENS,"S") $$IPVE^MAGUERR("IENS")
S IEN=+IENS
I IEN S $P(IENS,",")="" S:IENS="," IENS=""
;--- Closed root of the (sub)file
S NODE=$$ROOT^DILFD(FILE,IENS,1)
Q:NODE="" $$ERROR^MAGUERR(-48,,FILE,IENS)
Q:'IEN NODE
;--- The record node
S NODE=$NA(@NODE@(IEN))
Q:'FIELD NODE
;--- Field node
S FGL=$$GET1^DID(FILE,FIELD,,"GLOBAL SUBSCRIPT LOCATION",,"MAGMSG")
Q:$G(DIERR) $$DBS^MAGUERR("MAGMSG",FILE)
S:$P(FGL,";")'="" NODE=$NA(@NODE@($P(FGL,";")))
Q NODE
;
;+++++ COMPILES THE LIST OF GLOBAL NODES
;
; Return Values
; =============
; <0 Error descriptor (see the $$ERROR^MAGUERR)
; 0 Ok
;
; Notes
; =====
;
; This is an internal entry point. Do not call it from any routines
; except MAGUTL07 and MAGUTL08.
;
NODELIST(NODELIST,FILE,IENS,FIELD) ;
N NODE,PI,RC K NODELIST
S NODELIST="",RC=0
;--- Main object
I $G(FILE)>0 D Q:RC<0 RC
. S NODE=$$NODE(FILE,IENS,FIELD)
. I NODE<0 S RC=NODE Q
. S NODELIST=NODELIST_","_NODE
. S NODELIST(NODE)=""
. Q
;--- Linked objects
S PI="FILE"
F S PI=$Q(@PI) Q:PI="" D Q:RC<0
. S NODE=$$NODE($QS(PI,1),$QS(PI,2),$QS(PI,3))
. I NODE<0 S RC=NODE Q
. S NODELIST=NODELIST_","_NODE
. S NODELIST(NODE)=""
. Q
Q:RC<0 RC
;---
S NODELIST=$P(NODELIST,",",2,999)
Q RC
;
;+++++ UNLOCKS THE SINGLE NODE
;
; Return Values
; =============
; <0 Error descriptor (see the $$ERROR^MAGUERR)
; 0 Ok
;
; Notes
; =====
;
; This is an internal entry point. Do not call it from any routines
; except MAGUTL07 and MAGUTL08.
;
UNLOCK1(FILE,IENS,FIELD) ;
N DESCR,NDX,NODE
S NODE=$$NODE(FILE,IENS,FIELD)
Q:NODE<0 NODE
;--- Remove the lock descriptor
S NDX=$$XLNDX(NODE),DESCR=$G(^XTMP("MAGLOCK",NDX))
D:$P(DESCR,U,4)=$JOB
. I $P(DESCR,U,6)>1 D
. . S $P(^XTMP("MAGLOCK",NDX),U,6)=$P(DESCR,U,6)-1
. . Q
. E K ^XTMP("MAGLOCK",NDX)
. Q
;--- Unlock the object
L -@NODE
Q 0
;
;+++++ RETURNS SUBSCRIPT OF THE NODE IN THE DESCRIPTOR TABLE
;
; This is an internal entry point. Do not call it from any routines
; except MAGUTL07 and MAGUTL08.
;
XLNDX(NODE) ;
N L S L=$L(NODE)
Q $S($E(NODE,L)=")":$E(NODE,1,L-1),1:NODE)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGUTL08 6710 printed Sep 23, 2025@19:45:27 Page 2
MAGUTL08 ;WOIFO/SG - INTERNAL LOCK UTILITIES ; 3/9/09 12:54pm
+1 ;;3.0;IMAGING;**93**;Dec 02, 2009;Build 163
+2 ;; Per VHA Directive 2004-038, this routine should not be modified.
+3 ;; +---------------------------------------------------------------+
+4 ;; | Property of the US Government. |
+5 ;; | No permission to copy or redistribute this software is given. |
+6 ;; | Use of unreleased versions of this software requires the user |
+7 ;; | to execute a written test agreement with the VistA Imaging |
+8 ;; | Development Office of the Department of Veterans Affairs, |
+9 ;; | telephone (301) 734-0100. |
+10 ;; | |
+11 ;; | The Food and Drug Administration classifies this software as |
+12 ;; | a medical device. As such, it may not be changed in any way. |
+13 ;; | Modifications to this software may result in an adulterated |
+14 ;; | medical device under 21CFR820, the use of which is considered |
+15 ;; | to be a violation of US Federal Statutes. |
+16 ;; +---------------------------------------------------------------+
+17 ;;
+18 ; Entry points of this routine use the ^XTMP("MAGLOCK",...) global
+19 ; nodes to store lock descriptors (see the MAGUTL07 routine for
+20 ; details).
+21 ;
+22 ; This routine uses the following ICRs:
+23 ;
+24 ; #10060 Read file #200 (supported)
+25 ;
+26 QUIT
+27 ;
+28 ;##### DELETES STRAY LOCK DESCRIPTORS
+29 ;
+30 ; This is a service procedure. Do not call it from regular
+31 ; applications!
+32 ;
PURGE() ;
+1 NEW NDX,NODE
+2 SET NDX=0
+3 FOR
SET NDX=$ORDER(^XTMP("MAGLOCK",NDX))
if $EXTRACT(NDX,1)'="^"
QUIT
Begin DoDot:1
+4 SET NODE=$SELECT(NDX["(":NDX_")",1:NDX)
+5 DO LOCK^DILF(NODE)
IF '$TEST
QUIT
+6 KILL ^XTMP("MAGLOCK",NDX)
LOCK -@NODE
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
+10 ;+++++ RETURNS THE LOCK DESCRIPTOR FOR THE GLOBAL NODE(S)
+11 ;
+12 ; This is an internal entry point. Do not call it from any routines
+13 ; except MAGUTL07 and MAGUTL08.
+14 ;
LDSC(NODELIST) ;
+1 NEW DESCR,IENS,L,MAGMSG,NDX,NODE,SP,TMP
+2 if $DATA(NODELIST)<10
SET NODELIST(NODELIST)=""
+3 ;
+4 ;=== Search for the most appropriate descriptor
+5 SET (DESCR,NODE)=""
+6 FOR
SET NODE=$ORDER(NODELIST(NODE))
if NODE=""
QUIT
Begin DoDot:1
+7 ;--- The node itself
+8 SET SP=$$XLNDX(NODE)
SET TMP=$GET(^XTMP("MAGLOCK",SP))
+9 if TMP>DESCR
SET DESCR=TMP
+10 ;--- Left siblings and ancestors
+11 SET NDX=SP
+12 FOR
SET NDX=$ORDER(^XTMP("MAGLOCK",NDX),-1)
SET L=$LENGTH(NDX)
if (NDX="")!(NDX'=$EXTRACT(SP,1,L))
QUIT
Begin DoDot:2
+13 SET TMP=$GET(^XTMP("MAGLOCK",NDX))
if TMP>DESCR
SET DESCR=TMP
+14 QUIT
End DoDot:2
+15 ;--- Right siblings and descendants
+16 SET NDX=SP
SET L=$LENGTH(SP)
+17 FOR
SET NDX=$ORDER(^XTMP("MAGLOCK",NDX))
if (NDX="")!($EXTRACT(NDX,1,L)'=SP)
QUIT
Begin DoDot:2
+18 SET TMP=$GET(^XTMP("MAGLOCK",NDX))
if TMP>DESCR
SET DESCR=TMP
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 ;
+22 ;=== Populate as many fields of the descriptor as possible
+23 if 'DESCR
SET $PIECE(DESCR,U)=$$NOW^XLFDT
+24 ;--- Get the user name if the DUZ is available
+25 if $PIECE(DESCR,U,3)>0
Begin DoDot:1
+26 SET IENS=+$PIECE(DESCR,U,3)_","
+27 SET $PIECE(DESCR,U,2)=$$GET1^DIQ(200,IENS,.01,,,"MAGMSG")
+28 QUIT
End DoDot:1
+29 ;--- If the originator of the lock is unknown, indicate this fact
+30 if $PIECE(DESCR,U,2)=""
SET $PIECE(DESCR,U,2)="UNKNOWN"
+31 ;
+32 ;=== Return the lock descriptor
+33 QUIT $PIECE(DESCR,U,1,5)
+34 ;
+35 ;+++++ LOCKS THE SINGLE NODE
+36 ;
+37 ; Return Values
+38 ; =============
+39 ; <0 Error descriptor (see the $$ERROR^MAGUERR)
+40 ; 0 Ok
+41 ; >0 Lock descriptor
+42 ;
+43 ; Notes
+44 ; =====
+45 ;
+46 ; This is an internal entry point. Do not call it from any routines
+47 ; except MAGUTL07 and MAGUTL08.
+48 ;
LOCK1(FILE,IENS,FIELD,TO,NAME,FLAGS) ;
+1 NEW DESCR,NDX,NODE,TMP
+2 SET NODE=$$NODE(FILE,IENS,FIELD)
+3 if NODE<0
QUIT NODE
+4 ;--- Try to lock the object
+5 IF FLAGS'["D"
LOCK +@NODE:TO
IF '$TEST
QUIT $$LDSC(NODE)
+6 ;--- Create the lock descriptor
+7 SET DESCR=$$NOW^XLFDT_U_NAME_U_U_$JOB_U_$G(ZTSK)
+8 if NAME=""
SET $PIECE(DESCR,U,3)=$GET(DUZ)
+9 ;--- Calculate the lock counter
+10 SET NDX=$$XLNDX(NODE)
SET TMP=$GET(^XTMP("MAGLOCK",NDX))
+11 SET $PIECE(DESCR,U,6)=$SELECT($PIECE(TMP,U,4)=$JOB:$PIECE(TMP,U,6)+1,1:1)
+12 ;--- Store the descriptor
+13 SET ^XTMP("MAGLOCK",NDX)=DESCR
+14 QUIT 0
+15 ;
+16 ;+++++ RETURNS THE GLOBAL NODE OF THE OBJECT
+17 ;
+18 ; FILE File/subfile number
+19 ; IENS IENS of the record or subfile
+20 ; FIELD Field number
+21 ;
+22 ; Return Values
+23 ; =============
+24 ; <0 Error descriptor (see the $$ERROR^MAGUERR)
+25 ; ... Closed root
+26 ;
+27 ; Notes
+28 ; =====
+29 ;
+30 ; This is an internal entry point. Do not call it from any routines
+31 ; except MAGUTL07 and MAGUTL08.
+32 ;
NODE(FILE,IENS,FIELD) ;
+1 NEW FGL,IEN,MAGMSG,NODE,RC
+2 IF IENS'=""
if '$$VALIENS^MAGUTL05(IENS,"S")
QUIT $$IPVE^MAGUERR("IENS")
+3 SET IEN=+IENS
+4 IF IEN
SET $PIECE(IENS,",")=""
if IENS=","
SET IENS=""
+5 ;--- Closed root of the (sub)file
+6 SET NODE=$$ROOT^DILFD(FILE,IENS,1)
+7 if NODE=""
QUIT $$ERROR^MAGUERR(-48,,FILE,IENS)
+8 if 'IEN
QUIT NODE
+9 ;--- The record node
+10 SET NODE=$NAME(@NODE@(IEN))
+11 if 'FIELD
QUIT NODE
+12 ;--- Field node
+13 SET FGL=$$GET1^DID(FILE,FIELD,,"GLOBAL SUBSCRIPT LOCATION",,"MAGMSG")
+14 if $GET(DIERR)
QUIT $$DBS^MAGUERR("MAGMSG",FILE)
+15 if $PIECE(FGL,";")'=""
SET NODE=$NAME(@NODE@($PIECE(FGL,";")))
+16 QUIT NODE
+17 ;
+18 ;+++++ COMPILES THE LIST OF GLOBAL NODES
+19 ;
+20 ; Return Values
+21 ; =============
+22 ; <0 Error descriptor (see the $$ERROR^MAGUERR)
+23 ; 0 Ok
+24 ;
+25 ; Notes
+26 ; =====
+27 ;
+28 ; This is an internal entry point. Do not call it from any routines
+29 ; except MAGUTL07 and MAGUTL08.
+30 ;
NODELIST(NODELIST,FILE,IENS,FIELD) ;
+1 NEW NODE,PI,RC
KILL NODELIST
+2 SET NODELIST=""
SET RC=0
+3 ;--- Main object
+4 IF $GET(FILE)>0
Begin DoDot:1
+5 SET NODE=$$NODE(FILE,IENS,FIELD)
+6 IF NODE<0
SET RC=NODE
QUIT
+7 SET NODELIST=NODELIST_","_NODE
+8 SET NODELIST(NODE)=""
+9 QUIT
End DoDot:1
if RC<0
QUIT RC
+10 ;--- Linked objects
+11 SET PI="FILE"
+12 FOR
SET PI=$QUERY(@PI)
if PI=""
QUIT
Begin DoDot:1
+13 SET NODE=$$NODE($QSUBSCRIPT(PI,1),$QSUBSCRIPT(PI,2),$QSUBSCRIPT(PI,3))
+14 IF NODE<0
SET RC=NODE
QUIT
+15 SET NODELIST=NODELIST_","_NODE
+16 SET NODELIST(NODE)=""
+17 QUIT
End DoDot:1
if RC<0
QUIT
+18 if RC<0
QUIT RC
+19 ;---
+20 SET NODELIST=$PIECE(NODELIST,",",2,999)
+21 QUIT RC
+22 ;
+23 ;+++++ UNLOCKS THE SINGLE NODE
+24 ;
+25 ; Return Values
+26 ; =============
+27 ; <0 Error descriptor (see the $$ERROR^MAGUERR)
+28 ; 0 Ok
+29 ;
+30 ; Notes
+31 ; =====
+32 ;
+33 ; This is an internal entry point. Do not call it from any routines
+34 ; except MAGUTL07 and MAGUTL08.
+35 ;
UNLOCK1(FILE,IENS,FIELD) ;
+1 NEW DESCR,NDX,NODE
+2 SET NODE=$$NODE(FILE,IENS,FIELD)
+3 if NODE<0
QUIT NODE
+4 ;--- Remove the lock descriptor
+5 SET NDX=$$XLNDX(NODE)
SET DESCR=$GET(^XTMP("MAGLOCK",NDX))
+6 if $PIECE(DESCR,U,4)=$JOB
Begin DoDot:1
+7 IF $PIECE(DESCR,U,6)>1
Begin DoDot:2
+8 SET $PIECE(^XTMP("MAGLOCK",NDX),U,6)=$PIECE(DESCR,U,6)-1
+9 QUIT
End DoDot:2
+10 IF '$TEST
KILL ^XTMP("MAGLOCK",NDX)
+11 QUIT
End DoDot:1
+12 ;--- Unlock the object
+13 LOCK -@NODE
+14 QUIT 0
+15 ;
+16 ;+++++ RETURNS SUBSCRIPT OF THE NODE IN THE DESCRIPTOR TABLE
+17 ;
+18 ; This is an internal entry point. Do not call it from any routines
+19 ; except MAGUTL07 and MAGUTL08.
+20 ;
XLNDX(NODE) ;
+1 NEW L
SET L=$LENGTH(NODE)
+2 QUIT $SELECT($EXTRACT(NODE,L)=")":$EXTRACT(NODE,1,L-1),1:NODE)
