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

RALOCK01.m

Go to the documentation of this file. 
  1. RALOCK01 ;HCIOFO/SG - INTERNAL LOCK UTILITIES ; 5/14/08 3:22pm
  1.  ;;5.0;Radiology/Nuclear Medicine;**90**;Mar 16, 1998;Build 20
  1.  ;
  1.  ; Entry points of this routine use the ^XTMP("RALOCK",...) global
  1.  ; nodes to store lock descriptors (see ^RALOCK routine for details).
  1.  ;
  1.  Q
  1.  ;
  1.  ;***** DELETES STRAY LOCK DESCRIPTORS
  1.  ;
  1.  ; NOTE: This is a service procedure. Do not call it from
  1.  ;       regular applications!
  1.  ;
  1. PURGE() ;
  1.  N NDX,NODE
  1.  S NDX=0
  1.  F  S NDX=$O(^XTMP("RALOCK",NDX))  Q:$E(NDX,1)'="^"  D
  1.  . S NODE=$S(NDX["(":NDX_")",1:NDX)
  1.  . D LOCK^DILF(NODE)  E  Q
  1.  . K ^XTMP("RALOCK",NDX)  L -@NODE
  1.  Q
  1.  ;
  1.  ;+++++ FINDS THE LOCK DESCRIPTOR FOR THE GLOBAL NODE(S)
  1.  ;
  1.  ; NOTE: This is an internal entry point. Do not call it from
  1.  ;       any routines except RALOCK and RALOCK01
  1.  ;
  1. LDSC(NODELIST) ;
  1.  N DESCR,IENS,L,NDX,NODE,RAMSG,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("RALOCK",SP))
  1.  . S:TMP>DESCR DESCR=TMP
  1.  . ;--- Left Siblings and Ancestors
  1.  . S NDX=SP
  1.  . F  S NDX=$O(^XTMP("RALOCK",NDX),-1),L=$L(NDX)  Q:(NDX="")!(NDX'=$E(SP,1,L))  D
  1.  . . S TMP=$G(^XTMP("RALOCK",NDX))  S:TMP>DESCR DESCR=TMP
  1.  . ;--- Right Siblings and Descendants
  1.  . S NDX=SP,L=$L(SP)
  1.  . F  S NDX=$O(^XTMP("RALOCK",NDX))  Q:(NDX="")!($E(NDX,1,L)'=SP)  D
  1.  . . S TMP=$G(^XTMP("RALOCK",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,,,"RAMSG")  ; User Name
  1.  S:$P(DESCR,U,2)="" $P(DESCR,U,2)="UNKNOWN"
  1.  Q $P(DESCR,U,1,5)
  1.  ;
  1.  ;+++++ LOCKS THE SINGLE NODE
  1.  ;
  1.  ; NOTE: This is an internal entry point. Do not call it from
  1.  ;       any routines except RALOCK and RALOCK01
  1.  ;
  1. LOCK1(FILE,IENS,FIELD,TO,NAME,FLAGS) ;
  1.  N DESCR,NDX,NODE,TMP
  1.  S NODE=$$NODE(FILE,IENS,FIELD)
  1.  Q:NODE<0 NODE
  1.  ;--- Try to lock the object
  1.  I FLAGS'["D"  L +@NODE:TO  E  Q $$LDSC(NODE)
  1.  ;--- Create the lock descriptor
  1.  S DESCR=$$NOW^XLFDT_U_NAME_U_U_$JOB_U_$G(ZTSK)
  1.  S:NAME="" $P(DESCR,U,3)=$G(DUZ)
  1.  ;--- Calculate the lock counter
  1.  S NDX=$$XLNDX(NODE),TMP=$G(^XTMP("RALOCK",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("RALOCK",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.  ; NOTE: This is an internal entry point. Do not call it from
  1.  ;       any routines except RALOCK and RALOCK01
  1.  ;
  1. NODE(FILE,IENS,FIELD) ;
  1.  N FGL,IEN,NODE,RAMSG,RC
  1.  I IENS'=""  Q:'$$VALIENS^RAUTL22(IENS,"S") $$IPVE^RAERR("IENS")
  1.  S IEN=+IENS
  1.  I IEN  S $P(IENS,",")=""  S:IENS="," 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^RAERR(-50,,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",,"RAMSG")
  1.  I $G(DIERR)  D  Q RC
  1.  . S RC=$$DBS^RAERR("RAMSG",-9,FILE)
  1.  S:$P(FGL,";")'="" NODE=$NA(@NODE@($P(FGL,";")))
  1.  Q NODE
  1.  ;
  1.  ;+++++ COMPILES THE LIST OF GLOBAL NODES
  1.  ;
  1.  ; NOTE: This is an internal entry point. Do not call it from
  1.  ;       any routines except RALOCK and RALOCK01
  1.  ;
  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.  ;+++++ UNLOCKS THE SINGLE NODE
  1.  ;
  1.  ; NOTE: This is an internal entry point. Do not call it from
  1.  ;       any routines except RALOCK and RALOCK01
  1.  ;
  1. UNLOCK1(FILE,IENS,FIELD) ;
  1.  N DESCR,NDX,NODE
  1.  S NODE=$$NODE(FILE,IENS,FIELD)
  1.  Q:NODE<0 NODE
  1.  ;--- Remove the lock descriptor
  1.  S NDX=$$XLNDX(NODE),DESCR=$G(^XTMP("RALOCK",NDX))
  1.  D:$P(DESCR,U,4)=$JOB
  1.  . I $P(DESCR,U,6)>1  D
  1.  . . S $P(^XTMP("RALOCK",NDX),U,6)=$P(DESCR,U,6)-1
  1.  . E  K ^XTMP("RALOCK",NDX)
  1.  ;--- Unlock the object
  1.  L -@NODE
  1.  Q 0
  1.  ;
  1.  ;+++++ RETURNS SUBSCRIPT OF THE NODE IN THE DESCRIPTOR TABLE
  1.  ;
  1.  ; NOTE: This is an internal entry point. Do not call it from
  1.  ;       any routines except RALOCK and RALOCK01
  1.  ;
  1. XLNDX(NODE) ;
  1.  N L  S L=$L(NODE)
  1.  Q $S($E(NODE,L)=")":$E(NODE,1,L-1),1:NODE)