RALOCK ;HCIOFO/SG - FILE/RECORD/FIELD LOCK ; 5/21/08 12:44pm
;;5.0;Radiology/Nuclear Medicine;**90**;Mar 16, 1998;Build 20
;
; Entry points of this routine use the ^XTMP("RALOCK",...) global
; nodes to store lock descriptors:
;
; ^XTMP("RALOCK",
; 0) Standard node descriptor
; ^1: Purge date (FileMan)
; ^2: Create date (FileMan)
; ^3: Description
;
; NodeNdx) Internal lock descriptor
; ^01: Date/Time (FileMan)
; ^02: User/Process name
; ^03: User IEN (DUZ)
; ^04: $JOB
; ^05: Task number
; ^06: Lock counter
;
; The NodeNdx is calculated by the $$XLNDX^RALOCK01 as the name
; reference to the locked node without the closing parenthesis.
;
Q
;
;***** LOCKS THE (SUB)FILE, RECORD OR FIELD NODE
;
; [.]FILE File/subfile number
; [IENS] IENS of the record or subfile
; [FIELD] Field number
;
; If just the FILE has a value, then the whole file is
; locked. If the FILE references a subfile, then the
; subfile IENS (the 1st ","-piece is empty) should be
; passed in the IENS parameter.
;
; If the IENS references a record of a file/subfile
; (the 1st ","-piece is not empty), then this record
; is locked.
;
; If the IENS references a record and the FIELD is
; also defined, then only the node that stores this
; field is locked.
;
; In addition (or instead) to the main locked object
; defined by the FILE, IENS, and FIELD, you can define
; several additional objects using subscripts of the
; FILE parameter:
;
; ;--- Lock the whole file #72
; S FILE(72)=""
; ;--- Lock the EXAMINATIONS multiple
; S FILE(70.02,",6928784.9143,398,")=""
; ;--- Lock 2 exams
; S FILE(70.03,"1,6828784.9143,398,")=""
; S FILE(70.03,"3,6828784.9143,398,")=""
; ;--- Lock just the "BA" node of the order
; S FILE(75.1,"123,",91)=""
; ;--- Lock the objects
; S RC=$$LOCKFM^RALOCK(.FILE)
;
; All these objects are locked at the same time. If
; even one of them cannot be locked, then nothing
; is locked.
;
; [TO] Timeout (value of DILOCKTM, by default)
;
; [NAME] Process name. If this parameter is defined and not
; empty, then its value will be returned in the lock
; descriptor instead of the user name.
;
; [FLAGS] Flags that control the execution (can be combined):
;
; D Do not actually lock the node(s); just create
; the lock descriptor(s).
;
; Return Values:
; <0 Error code
; 0 Ok (the objects have been locked)
; >0 The object is locked by another user or task and
; a lock descriptor is returned.
; ^01: Date/Time (FileMan)
; ^02: User/Process name
; ^03: User IEN (DUZ)
; ^04: $JOB
; ^05: Task number
;
; If the third piece is empty then check the 2nd one for the
; custom process name.
;
LOCKFM(FILE,IENS,FIELD,TO,NAME,FLAGS) ;
N DESCR,NDX,NODELIST,NODE,PI,RC,TMP
S:$G(TO,-1)<0 TO=$G(DILOCKTM,3)
S FLAGS=$G(FLAGS)
;--- Update the ^XTMP("RALOCK",0) once per session
I '$D(RAPARAMS("XTMPLOCK")) D S RAPARAMS("XTMPLOCK")=""
. D XTMPHDR^RAUTL22("RALOCK",30,"Radiology LOCK Descriptors")
;--- Check if a single object should be locked
I $D(FILE)<10 S RC=0 D:$G(FILE)>0 Q RC
. S RC=$$LOCK1^RALOCK01(FILE,$G(IENS),$G(FIELD),TO,$G(NAME),FLAGS)
;--- Compile the list of global nodes
S RC=$$NODELIST^RALOCK01(.NODELIST,.FILE,$G(IENS),$G(FIELD))
Q:RC<0 RC Q:NODELIST="" 0
;--- Try to lock the object(s)
I FLAGS'["D" D X TMP E Q $$LDSC^RALOCK01(.NODELIST)
. S TMP="L +("_NODELIST_"):"_TO
;--- Create the lock descriptor(s)
S DESCR=$$NOW^XLFDT_U_$G(NAME)_U_U_$JOB_U_$G(ZTSK)
S:$G(NAME)="" $P(DESCR,U,3)=$G(DUZ)
S NODE=""
F S NODE=$O(NODELIST(NODE)) Q:NODE="" D
. S NDX=$$XLNDX^RALOCK01(NODE)
. ;--- Calculate the lock counter
. S TMP=$G(^XTMP("RALOCK",NDX))
. S $P(DESCR,U,6)=$S($P(TMP,U,4)=$JOB:$P(TMP,U,6)+1,1:1)
. ;--- Store the descriptor
. S ^XTMP("RALOCK",NDX)=DESCR
Q 0
;
;***** GENERATES A TEXT DESCRIPTION FROM THE LOCK DESCRIPTOR
;
; LDSC Lock descriptor returned by the $$LOCKFM^RALOCK
;
; Return Values:
; "" If the 1st "^"-piece is not greater than 0,
; then an empty string is returned.
; ... Otherwise, a text describing who/what and when
; locked the object according to the descriptor
;
TEXT(LDSC) ;
Q:LDSC'>0 ""
N LTEXT,PARAMS,RABUF
S PARAMS("LDT")=$$FMTE^XLFDT(+LDSC) ; Lock date/time
S PARAMS("NAME")=$P(LDSC,U,2) ; User/process name
S PARAMS("JOB")=$P(LDSC,U,4) ; Job number
S PARAMS("TASK")=$P(LDSC,U,5) ; Task number
D BLD^DIALOG(700005.002,.PARAMS,,"RABUF","S")
Q RABUF(1)_$S(PARAMS("TASK")'="":$G(RABUF(2)),1:"")
;
;***** UNLOCKS THE (SUB)FILE, RECORD OR FIELD NODE
;
; [.]FILE File/subfile number
; [IENS] IENS of the record or subfile
; [FIELD] Field number
;
; See description of the LOCKFM^RALOCK for details
; about the FILE, IENS, and FIELD parameters.
;
; Return Values:
; <0 Error code
; 0 Ok
;
; NOTE: This entry point can also be called as a procedure:
; D UNLOCKFM^RALOCK(...) if you do not need its return value.
;
UNLOCKFM(FILE,IENS,FIELD) ;
N DESCR,NDX,NODELIST,NODE,PI,RC
I $D(FILE)<10 S RC=0 D:$G(FILE)>0 Q:$QUIT RC Q
. S RC=$$UNLOCK1^RALOCK01(FILE,$G(IENS),$G(FIELD))
;--- Compile the list of global nodes
S RC=$$NODELIST^RALOCK01(.NODELIST,.FILE,$G(IENS),$G(FIELD))
I RC<0 Q:$QUIT RC Q
I NODELIST="" Q:$QUIT 0 Q
;--- Remove the lock descriptor(s)
S NODE=""
F S NODE=$O(NODELIST(NODE)) Q:NODE="" D
. S NDX=$$XLNDX^RALOCK01(NODE),DESCR=$G(^XTMP("RALOCK",NDX))
. Q:$P(DESCR,U,4)'=$JOB
. I $P(DESCR,U,6)>1 D
. . S $P(^XTMP("RALOCK",NDX),U,6)=$P(DESCR,U,6)-1
. E K ^XTMP("RALOCK",NDX)
;--- Unlock the object(s)
X "L -("_NODELIST_")"
Q:$QUIT 0 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRALOCK 6741 printed Sep 02, 2024@19:21:56 Page 2
RALOCK ;HCIOFO/SG - FILE/RECORD/FIELD LOCK ; 5/21/08 12:44pm
+1 ;;5.0;Radiology/Nuclear Medicine;**90**;Mar 16, 1998;Build 20
+2 ;
+3 ; Entry points of this routine use the ^XTMP("RALOCK",...) global
+4 ; nodes to store lock descriptors:
+5 ;
+6 ; ^XTMP("RALOCK",
+7 ; 0) Standard node descriptor
+8 ; ^1: Purge date (FileMan)
+9 ; ^2: Create date (FileMan)
+10 ; ^3: Description
+11 ;
+12 ; NodeNdx) Internal lock descriptor
+13 ; ^01: Date/Time (FileMan)
+14 ; ^02: User/Process name
+15 ; ^03: User IEN (DUZ)
+16 ; ^04: $JOB
+17 ; ^05: Task number
+18 ; ^06: Lock counter
+19 ;
+20 ; The NodeNdx is calculated by the $$XLNDX^RALOCK01 as the name
+21 ; reference to the locked node without the closing parenthesis.
+22 ;
+23 QUIT
+24 ;
+25 ;***** LOCKS THE (SUB)FILE, RECORD OR FIELD NODE
+26 ;
+27 ; [.]FILE File/subfile number
+28 ; [IENS] IENS of the record or subfile
+29 ; [FIELD] Field number
+30 ;
+31 ; If just the FILE has a value, then the whole file is
+32 ; locked. If the FILE references a subfile, then the
+33 ; subfile IENS (the 1st ","-piece is empty) should be
+34 ; passed in the IENS parameter.
+35 ;
+36 ; If the IENS references a record of a file/subfile
+37 ; (the 1st ","-piece is not empty), then this record
+38 ; is locked.
+39 ;
+40 ; If the IENS references a record and the FIELD is
+41 ; also defined, then only the node that stores this
+42 ; field is locked.
+43 ;
+44 ; In addition (or instead) to the main locked object
+45 ; defined by the FILE, IENS, and FIELD, you can define
+46 ; several additional objects using subscripts of the
+47 ; FILE parameter:
+48 ;
+49 ; ;--- Lock the whole file #72
+50 ; S FILE(72)=""
+51 ; ;--- Lock the EXAMINATIONS multiple
+52 ; S FILE(70.02,",6928784.9143,398,")=""
+53 ; ;--- Lock 2 exams
+54 ; S FILE(70.03,"1,6828784.9143,398,")=""
+55 ; S FILE(70.03,"3,6828784.9143,398,")=""
+56 ; ;--- Lock just the "BA" node of the order
+57 ; S FILE(75.1,"123,",91)=""
+58 ; ;--- Lock the objects
+59 ; S RC=$$LOCKFM^RALOCK(.FILE)
+60 ;
+61 ; All these objects are locked at the same time. If
+62 ; even one of them cannot be locked, then nothing
+63 ; is locked.
+64 ;
+65 ; [TO] Timeout (value of DILOCKTM, by default)
+66 ;
+67 ; [NAME] Process name. If this parameter is defined and not
+68 ; empty, then its value will be returned in the lock
+69 ; descriptor instead of the user name.
+70 ;
+71 ; [FLAGS] Flags that control the execution (can be combined):
+72 ;
+73 ; D Do not actually lock the node(s); just create
+74 ; the lock descriptor(s).
+75 ;
+76 ; Return Values:
+77 ; <0 Error code
+78 ; 0 Ok (the objects have been locked)
+79 ; >0 The object is locked by another user or task and
+80 ; a lock descriptor is returned.
+81 ; ^01: Date/Time (FileMan)
+82 ; ^02: User/Process name
+83 ; ^03: User IEN (DUZ)
+84 ; ^04: $JOB
+85 ; ^05: Task number
+86 ;
+87 ; If the third piece is empty then check the 2nd one for the
+88 ; custom process name.
+89 ;
LOCKFM(FILE,IENS,FIELD,TO,NAME,FLAGS) ;
+1 NEW DESCR,NDX,NODELIST,NODE,PI,RC,TMP
+2 if $GET(TO,-1)<0
SET TO=$GET(DILOCKTM,3)
+3 SET FLAGS=$GET(FLAGS)
+4 ;--- Update the ^XTMP("RALOCK",0) once per session
+5 IF '$DATA(RAPARAMS("XTMPLOCK"))
Begin DoDot:1
+6 DO XTMPHDR^RAUTL22("RALOCK",30,"Radiology LOCK Descriptors")
End DoDot:1
SET RAPARAMS("XTMPLOCK")=""
+7 ;--- Check if a single object should be locked
+8 IF $DATA(FILE)<10
SET RC=0
if $GET(FILE)>0
Begin DoDot:1
+9 SET RC=$$LOCK1^RALOCK01(FILE,$GET(IENS),$GET(FIELD),TO,$GET(NAME),FLAGS)
End DoDot:1
QUIT RC
+10 ;--- Compile the list of global nodes
+11 SET RC=$$NODELIST^RALOCK01(.NODELIST,.FILE,$GET(IENS),$GET(FIELD))
+12 if RC<0
QUIT RC
if NODELIST=""
QUIT 0
+13 ;--- Try to lock the object(s)
+14 IF FLAGS'["D"
Begin DoDot:1
+15 SET TMP="L +("_NODELIST_"):"_TO
End DoDot:1
XECUTE TMP
IF '$TEST
QUIT $$LDSC^RALOCK01(.NODELIST)
+16 ;--- Create the lock descriptor(s)
+17 SET DESCR=$$NOW^XLFDT_U_$G(NAME)_U_U_$JOB_U_$GET(ZTSK)
+18 if $GET(NAME)=""
SET $PIECE(DESCR,U,3)=$GET(DUZ)
+19 SET NODE=""
+20 FOR
SET NODE=$ORDER(NODELIST(NODE))
if NODE=""
QUIT
Begin DoDot:1
+21 SET NDX=$$XLNDX^RALOCK01(NODE)
+22 ;--- Calculate the lock counter
+23 SET TMP=$GET(^XTMP("RALOCK",NDX))
+24 SET $PIECE(DESCR,U,6)=$SELECT($PIECE(TMP,U,4)=$JOB:$PIECE(TMP,U,6)+1,1:1)
+25 ;--- Store the descriptor
+26 SET ^XTMP("RALOCK",NDX)=DESCR
End DoDot:1
+27 QUIT 0
+28 ;
+29 ;***** GENERATES A TEXT DESCRIPTION FROM THE LOCK DESCRIPTOR
+30 ;
+31 ; LDSC Lock descriptor returned by the $$LOCKFM^RALOCK
+32 ;
+33 ; Return Values:
+34 ; "" If the 1st "^"-piece is not greater than 0,
+35 ; then an empty string is returned.
+36 ; ... Otherwise, a text describing who/what and when
+37 ; locked the object according to the descriptor
+38 ;
TEXT(LDSC) ;
+1 if LDSC'>0
QUIT ""
+2 NEW LTEXT,PARAMS,RABUF
+3 ; Lock date/time
SET PARAMS("LDT")=$$FMTE^XLFDT(+LDSC)
+4 ; User/process name
SET PARAMS("NAME")=$PIECE(LDSC,U,2)
+5 ; Job number
SET PARAMS("JOB")=$PIECE(LDSC,U,4)
+6 ; Task number
SET PARAMS("TASK")=$PIECE(LDSC,U,5)
+7 DO BLD^DIALOG(700005.002,.PARAMS,,"RABUF","S")
+8 QUIT RABUF(1)_$SELECT(PARAMS("TASK")'="":$GET(RABUF(2)),1:"")
+9 ;
+10 ;***** UNLOCKS THE (SUB)FILE, RECORD OR FIELD NODE
+11 ;
+12 ; [.]FILE File/subfile number
+13 ; [IENS] IENS of the record or subfile
+14 ; [FIELD] Field number
+15 ;
+16 ; See description of the LOCKFM^RALOCK for details
+17 ; about the FILE, IENS, and FIELD parameters.
+18 ;
+19 ; Return Values:
+20 ; <0 Error code
+21 ; 0 Ok
+22 ;
+23 ; NOTE: This entry point can also be called as a procedure:
+24 ; D UNLOCKFM^RALOCK(...) if you do not need its return value.
+25 ;
UNLOCKFM(FILE,IENS,FIELD) ;
+1 NEW DESCR,NDX,NODELIST,NODE,PI,RC
+2 IF $DATA(FILE)<10
SET RC=0
if $GET(FILE)>0
Begin DoDot:1
+3 SET RC=$$UNLOCK1^RALOCK01(FILE,$GET(IENS),$GET(FIELD))
End DoDot:1
if $QUIT
QUIT RC
QUIT
+4 ;--- Compile the list of global nodes
+5 SET RC=$$NODELIST^RALOCK01(.NODELIST,.FILE,$GET(IENS),$GET(FIELD))
+6 IF RC<0
if $QUIT
QUIT RC
QUIT
+7 IF NODELIST=""
if $QUIT
QUIT 0
QUIT
+8 ;--- Remove the lock descriptor(s)
+9 SET NODE=""
+10 FOR
SET NODE=$ORDER(NODELIST(NODE))
if NODE=""
QUIT
Begin DoDot:1
+11 SET NDX=$$XLNDX^RALOCK01(NODE)
SET DESCR=$GET(^XTMP("RALOCK",NDX))
+12 if $PIECE(DESCR,U,4)'=$JOB
QUIT
+13 IF $PIECE(DESCR,U,6)>1
Begin DoDot:2
+14 SET $PIECE(^XTMP("RALOCK",NDX),U,6)=$PIECE(DESCR,U,6)-1
End DoDot:2
+15 IF '$TEST
KILL ^XTMP("RALOCK",NDX)
End DoDot:1
+16 ;--- Unlock the object(s)
+17 XECUTE "L -("_NODELIST_")"
+18 if $QUIT
QUIT 0
QUIT
