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