Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RORLOCK

RORLOCK.m

Go to the documentation of this file.
  1. RORLOCK ;HCIOFO/SG - LOCKS AND TRANSACTIONS ;17 Mar 2015 11:45 AM
  1. ;;1.5;CLINICAL CASE REGISTRIES;**1,27**;Feb 17, 2006;Build 58
  1. ;
  1. ; This routine uses the following IAs:
  1. ; #2052 GET1^DID (supported)
  1. ; #2055 ROOT^DILFD (supported)
  1. ; #2056 GET1^DIQ (supported)
  1. ; #10103 FMTE^XLFDT (supported)
  1. ; #10103 NOW^XLFDT (supported)
  1. ;
  1. ;******************************************************************************
  1. ; --- ROUTINE MODIFICATION LOG ---
  1. ;
  1. ;PKG/PATCH DATE DEVELOPER MODIFICATION
  1. ;----------- ---------- ----------- ----------------------------------------
  1. ;ROR*1.5*27 FEB 2015 T KOPP Changed default lock time from 3 to
  1. ; DILOCKTM if DILOCKTM > 3
  1. ;******************************************************************************
  1. Q
  1. ;
  1. ;***** FINDS THE LOCK DESCRIPTOR FOR THE GLOBAL NODE
  1. LDSC(NODELIST) ;
  1. N DESCR,IENS,L,NDX,NODE,RORMSG,SP,TMP
  1. S:$D(NODELIST)<10 NODELIST(NODELIST)=""
  1. S (DESCR,NODE)=""
  1. F S NODE=$O(NODELIST(NODE)) Q:NODE="" D
  1. . ;--- The Node itself
  1. . S SP=$$XLNDX(NODE),TMP=$G(^XTMP("RORLOCK",SP))
  1. . S:TMP>DESCR DESCR=TMP
  1. . ;--- Left Siblings and Ancestors
  1. . S NDX=SP
  1. . F S NDX=$O(^XTMP("RORLOCK",NDX),-1),L=$L(NDX) Q:(NDX="")!(NDX'=$E(SP,1,L)) D
  1. . . S TMP=$G(^XTMP("RORLOCK",NDX)) S:TMP>DESCR DESCR=TMP
  1. . ;--- Right Siblings and Descendants
  1. . S NDX=SP,L=$L(SP)
  1. . F S NDX=$O(^XTMP("RORLOCK",NDX)) Q:(NDX="")!($E(NDX,1,L)'=SP) D
  1. . . S TMP=$G(^XTMP("RORLOCK",NDX)) S:TMP>DESCR DESCR=TMP
  1. ;--- Prepare the lock descriptor
  1. S:'DESCR $P(DESCR,U)=$$NOW^XLFDT
  1. D:$P(DESCR,U,3)>0
  1. . S IENS=+$P(DESCR,U,3)_","
  1. . S $P(DESCR,U,2)=$$GET1^DIQ(200,IENS,.01,,,"RORMSG")
  1. . D:$G(DIERR) DBS^RORERR("RORMSG",-9,,,200,IENS)
  1. S:$P(DESCR,U,2)="" $P(DESCR,U,2)="UNKNOWN USER"
  1. Q $P(DESCR,U,1,5)
  1. ;
  1. ;***** LOCKS THE (SUB)FILE, RECORD OR FIELD NODE
  1. ;
  1. ; FILE File/subfile number
  1. ; [IENS] IENS of the record or subfile
  1. ; [FIELD] Field number
  1. ; [TO] Timeout (DILOCKTM sec, by default)
  1. ; [NAME] Process name
  1. ;
  1. ; Return Values:
  1. ; <0 Error code
  1. ; 0 Ok (the object has been locked)
  1. ; >0 The object is locked by another user. A lock descriptor
  1. ; is returned in this case:
  1. ; ^01: Date/Time (FileMan)
  1. ; ^02: User/Process name
  1. ; ^03: User IEN (DUZ)
  1. ; ^04: $JOB
  1. ; ^05: Task number
  1. ;
  1. ; If the third field is empty then the object is locked by a
  1. ; registry background process (see the name in the 2nd field).
  1. ;
  1. LOCK(FILE,IENS,FIELD,TO,NAME) ;
  1. N DESCR,NDX,NODELIST,NODE,PI,RC,TMP
  1. I $D(FILE)<10 S RC=0 D:$G(FILE)>0 Q RC
  1. . S RC=$$LOCK1(FILE,$G(IENS),$G(FIELD),$G(TO),$G(NAME))
  1. ;--- Compile the list of global nodes
  1. S RC=$$NODELIST(.NODELIST,.FILE,$G(IENS),$G(FIELD))
  1. Q:RC<0 RC Q:NODELIST="" 0
  1. ;--- Try to lock the object(s)
  1. X "L +("_NODELIST_"):"_$S($G(TO)>0:TO,$G(DILOCKTM)>3:DILOCKTM,1:3) E Q $$LDSC(.NODELIST)
  1. ;--- Create the lock descriptor(s)
  1. S DESCR=$$NOW^XLFDT_U_$G(NAME)_U_U_$JOB_U_$G(ZTSK)
  1. S:$G(NAME)="" $P(DESCR,U,3)=$G(DUZ)
  1. S NODE=""
  1. F S NODE=$O(NODELIST(NODE)) Q:NODE="" D
  1. . S NDX=$$XLNDX(NODE)
  1. . ;--- Calculate the lock counter
  1. . S TMP=$G(^XTMP("RORLOCK",NDX))
  1. . S $P(DESCR,U,6)=$S($P(TMP,U,4)=$JOB:$P(TMP,U,6)+1,1:1)
  1. . ;--- Store the descriptor
  1. . S ^XTMP("RORLOCK",NDX)=DESCR
  1. Q 0
  1. ;
  1. LOCK1(FILE,IENS,FIELD,TO,NAME) ;
  1. N DESCR,NDX,NODE,TMP,RORLTM
  1. S NODE=$$NODE(FILE,$G(IENS),$G(FIELD)),RORLTM=$S($G(DILOCKTM)>3:DILOCKTM,1:3)
  1. Q:NODE<0 NODE
  1. ;--- Try to lock the object
  1. L +@NODE:$S($G(TO)>0:TO,1:RORLTM) E Q $$LDSC(NODE)
  1. ;--- Create the lock descriptor
  1. S DESCR=$$NOW^XLFDT_U_$G(NAME)_U_U_$JOB_U_$G(ZTSK)
  1. S:$G(NAME)="" $P(DESCR,U,3)=$G(DUZ)
  1. ;--- Calculate the lock counter
  1. S NDX=$$XLNDX(NODE),TMP=$G(^XTMP("RORLOCK",NDX))
  1. S $P(DESCR,U,6)=$S($P(TMP,U,4)=$JOB:$P(TMP,U,6)+1,1:1)
  1. ;--- Store the descriptor
  1. S ^XTMP("RORLOCK",NDX)=DESCR
  1. Q 0
  1. ;
  1. ;***** RETURNS THE GLOBAL NODE OF THE OBJECT
  1. ;
  1. ; FILE File/subfile number
  1. ; IENS IENS of the record or subfile
  1. ; FIELD Field number
  1. ;
  1. ; Return Values:
  1. ; <0 Error code
  1. ; Closed root
  1. ;
  1. NODE(FILE,IENS,FIELD) ;
  1. N FGL,IEN,NODE,RC
  1. S IEN=+IENS S:IEN $P(IENS,",")=""
  1. ;--- Closed root of the (sub)file
  1. S NODE=$$ROOT^DILFD(FILE,IENS,1)
  1. I NODE="" D Q RC
  1. . S RC=$$ERROR^RORERR(-98,,,,FILE,IENS)
  1. Q:'IEN NODE
  1. ;--- The record node
  1. S NODE=$NA(@NODE@(IEN))
  1. Q:'FIELD NODE
  1. ;--- Field node
  1. S FGL=$$GET1^DID(FILE,FIELD,,"GLOBAL SUBSCRIPT LOCATION",,"RORMSG")
  1. I $G(DIERR) D Q RC
  1. . S RC=$$DBS^RORERR("RORMSG",-9,,,FILE)
  1. S:$P(FGL,";")'="" NODE=$NA(@NODE@($P(FGL,";")))
  1. Q NODE
  1. ;
  1. ;***** COMPILES THE LIST OF GLOBAL NODES
  1. NODELIST(NODELIST,FILE,IENS,FIELD) ;
  1. N NODE,PI,RC K NODELIST
  1. S NODELIST="",RC=0
  1. ;--- Main object
  1. I $G(FILE)>0 D Q:RC<0 RC
  1. . S NODE=$$NODE(FILE,IENS,FIELD)
  1. . I NODE<0 S RC=+NODE Q
  1. . S NODELIST=NODELIST_","_NODE
  1. . S NODELIST(NODE)=""
  1. ;--- Linked objects
  1. S PI="FILE"
  1. F S PI=$Q(@PI) Q:PI="" D Q:RC<0
  1. . S NODE=$$NODE($QS(PI,1),$QS(PI,2),$QS(PI,3))
  1. . I NODE<0 S RC=+NODE Q
  1. . S NODELIST=NODELIST_","_NODE
  1. . S NODELIST(NODE)=""
  1. Q:RC<0 RC
  1. ;---
  1. S NODELIST=$P(NODELIST,",",2,999)
  1. Q RC
  1. ;
  1. ;***** GENERATES A TEXT DESCRIPTION FROM THE LOCK DESCRIPTOR
  1. ;
  1. ; LDSC Lock descriptor returned by the $$LOCK^RORLOCK
  1. ;
  1. TEXT(LDSC) ;
  1. N LTEXT
  1. S LTEXT=$P(LDSC,U,2)_" about "_$$FMTE^XLFDT(+LDSC)
  1. S:$P(LDSC,U,4) LTEXT=LTEXT_"; Job #"_$P(LDSC,U,4)
  1. S:$P(LDSC,U,5) LTEXT=LTEXT_"; Task #"_$P(LDSC,U,5)
  1. Q LTEXT
  1. ;
  1. ;***** UNLOCKS THE (SUB)FILE, RECORD OR FIELD NODE
  1. ;
  1. ; FILE File/subfile number
  1. ; [IENS] IENS of the record or subfile
  1. ; [FIELD] Field number
  1. ;
  1. ; Return Values:
  1. ; <0 Error code
  1. ; 0 Ok
  1. ;
  1. ; NOTE: This entry point can also be called as a procedure:
  1. ; D UNLOCK^RORLOCK(...) if you do not need its return value.
  1. ;
  1. UNLOCK(FILE,IENS,FIELD) ;
  1. N DESCR,NDX,NODELIST,NODE,PI,RC
  1. I $D(FILE)<10 S RC=0 D:$G(FILE)>0 Q:$QUIT RC Q
  1. . S RC=$$UNLOCK1(FILE,$G(IENS),$G(FIELD))
  1. ;--- Compile the list of global nodes
  1. S RC=$$NODELIST(.NODELIST,.FILE,$G(IENS),$G(FIELD))
  1. I RC<0 Q:$QUIT RC Q
  1. I NODELIST="" Q:$QUIT 0 Q
  1. ;--- Remove the lock descriptor(s)
  1. S NODE=""
  1. F S NODE=$O(NODELIST(NODE)) Q:NODE="" D
  1. . S NDX=$$XLNDX(NODE),DESCR=$G(^XTMP("RORLOCK",NDX))
  1. . Q:$P(DESCR,U,4)'=$JOB
  1. . I $P(DESCR,U,6)>1 D
  1. . . S $P(^XTMP("RORLOCK",NDX),U,6)=$P(DESCR,U,6)-1
  1. . E K ^XTMP("RORLOCK",NDX)
  1. ;--- Unlock the object(s)
  1. X "L -("_NODELIST_")"
  1. Q:$QUIT 0 Q
  1. ;
  1. UNLOCK1(FILE,IENS,FIELD) ;
  1. N DESCR,NDX,NODE
  1. S NODE=$$NODE(FILE,$G(IENS),$G(FIELD))
  1. Q:NODE<0 NODE
  1. ;--- Remove the lock descriptor
  1. S NDX=$$XLNDX(NODE),DESCR=$G(^XTMP("RORLOCK",NDX))
  1. D:$P(DESCR,U,4)=$JOB
  1. . I $P(DESCR,U,6)>1 D
  1. . . S $P(^XTMP("RORLOCK",NDX),U,6)=$P(DESCR,U,6)-1
  1. . E K ^XTMP("RORLOCK",NDX)
  1. ;--- Unlock the object
  1. L -@NODE
  1. Q 0
  1. ;
  1. ;***** RETURNS SUBSCRIPT OF THE NODE IN THE DESCRIPTOR TABLE
  1. XLNDX(NODE) ;
  1. N L S L=$L(NODE)
  1. Q $S($E(NODE,L)=")":$E(NODE,1,L-1),1:NODE)