- 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 Jan 18, 2025@03:37:38 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