- 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 Feb 18, 2025@23:35:38 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)