source: FOIAVistA/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORLOCK.m@ 635

Last change on this file since 635 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.1 KB
Line 
1RORLOCK ;HCIOFO/SG - LOCKS AND TRANSACTIONS ; 11/17/06 11:37am
2 ;;1.5;CLINICAL CASE REGISTRIES;**1**;Feb 17, 2006;Build 24
3 ;
4 Q
5 ;
6 ;***** FINDS THE LOCK DESCRIPTOR FOR THE GLOBAL NODE
7LDSC(NODELIST) ;
8 N DESCR,IENS,L,NDX,NODE,RORMSG,SP,TMP
9 S:$D(NODELIST)<10 NODELIST(NODELIST)=""
10 S (DESCR,NODE)=""
11 F S NODE=$O(NODELIST(NODE)) Q:NODE="" D
12 . ;--- The Node itself
13 . S SP=$$XLNDX(NODE),TMP=$G(^XTMP("RORLOCK",SP))
14 . S:TMP>DESCR DESCR=TMP
15 . ;--- Left Siblings and Ancestors
16 . S NDX=SP
17 . F S NDX=$O(^XTMP("RORLOCK",NDX),-1),L=$L(NDX) Q:(NDX="")!(NDX'=$E(SP,1,L)) D
18 . . S TMP=$G(^XTMP("RORLOCK",NDX)) S:TMP>DESCR DESCR=TMP
19 . ;--- Right Siblings and Descendants
20 . S NDX=SP,L=$L(SP)
21 . F S NDX=$O(^XTMP("RORLOCK",NDX)) Q:(NDX="")!($E(NDX,1,L)'=SP) D
22 . . S TMP=$G(^XTMP("RORLOCK",NDX)) S:TMP>DESCR DESCR=TMP
23 ;--- Prepare the lock descriptor
24 S:'DESCR $P(DESCR,U)=$$NOW^XLFDT
25 D:$P(DESCR,U,3)>0
26 . S IENS=+$P(DESCR,U,3)_","
27 . S $P(DESCR,U,2)=$$GET1^DIQ(200,IENS,.01,,,"RORMSG")
28 . D:$G(DIERR) DBS^RORERR("RORMSG",-9,,,200,IENS)
29 S:$P(DESCR,U,2)="" $P(DESCR,U,2)="UNKNOWN USER"
30 Q $P(DESCR,U,1,5)
31 ;
32 ;***** LOCKS THE (SUB)FILE, RECORD OR FIELD NODE
33 ;
34 ; FILE File/subfile number
35 ; [IENS] IENS of the record or subfile
36 ; [FIELD] Field number
37 ; [TO] Timeout (1 sec, by default)
38 ; [NAME] Process name
39 ;
40 ; Return Values:
41 ; <0 Error code
42 ; 0 Ok (the object has been locked)
43 ; >0 The object is locked by another user. A lock descriptor
44 ; is returned in this case:
45 ; ^01: Date/Time (FileMan)
46 ; ^02: User/Process name
47 ; ^03: User IEN (DUZ)
48 ; ^04: $JOB
49 ; ^05: Task number
50 ;
51 ; If the third field is empty then the object is locked by a
52 ; registry background process (see the name in the 2nd field).
53 ;
54LOCK(FILE,IENS,FIELD,TO,NAME) ;
55 N DESCR,NDX,NODELIST,NODE,PI,RC,TMP
56 I $D(FILE)<10 S RC=0 D:$G(FILE)>0 Q RC
57 . S RC=$$LOCK1(FILE,$G(IENS),$G(FIELD),$G(TO),$G(NAME))
58 ;--- Compile the list of global nodes
59 S RC=$$NODELIST(.NODELIST,.FILE,$G(IENS),$G(FIELD))
60 Q:RC<0 RC Q:NODELIST="" 0
61 ;--- Try to lock the object(s)
62 X "L +("_NODELIST_"):"_$S($G(TO)>0:TO,1:3) E Q $$LDSC(.NODELIST)
63 ;--- Create the lock descriptor(s)
64 S DESCR=$$NOW^XLFDT_U_$G(NAME)_U_U_$JOB_U_$G(ZTSK)
65 S:$G(NAME)="" $P(DESCR,U,3)=$G(DUZ)
66 S NODE=""
67 F S NODE=$O(NODELIST(NODE)) Q:NODE="" D
68 . S NDX=$$XLNDX(NODE)
69 . ;--- Calculate the lock counter
70 . S TMP=$G(^XTMP("RORLOCK",NDX))
71 . S $P(DESCR,U,6)=$S($P(TMP,U,4)=$JOB:$P(TMP,U,6)+1,1:1)
72 . ;--- Store the descriptor
73 . S ^XTMP("RORLOCK",NDX)=DESCR
74 Q 0
75 ;
76LOCK1(FILE,IENS,FIELD,TO,NAME) ;
77 N DESCR,NDX,NODE,TMP
78 S NODE=$$NODE(FILE,$G(IENS),$G(FIELD))
79 Q:NODE<0 NODE
80 ;--- Try to lock the object
81 L +@NODE:$S($G(TO)>0:TO,1:3) E Q $$LDSC(NODE)
82 ;--- Create the lock descriptor
83 S DESCR=$$NOW^XLFDT_U_$G(NAME)_U_U_$JOB_U_$G(ZTSK)
84 S:$G(NAME)="" $P(DESCR,U,3)=$G(DUZ)
85 ;--- Calculate the lock counter
86 S NDX=$$XLNDX(NODE),TMP=$G(^XTMP("RORLOCK",NDX))
87 S $P(DESCR,U,6)=$S($P(TMP,U,4)=$JOB:$P(TMP,U,6)+1,1:1)
88 ;--- Store the descriptor
89 S ^XTMP("RORLOCK",NDX)=DESCR
90 Q 0
91 ;
92 ;***** RETURNS THE GLOBAL NODE OF THE OBJECT
93 ;
94 ; FILE File/subfile number
95 ; IENS IENS of the record or subfile
96 ; FIELD Field number
97 ;
98 ; Return Values:
99 ; <0 Error code
100 ; Closed root
101 ;
102NODE(FILE,IENS,FIELD) ;
103 N FGL,IEN,NODE,RC
104 S IEN=+IENS S:IEN $P(IENS,",")=""
105 ;--- Closed root of the (sub)file
106 S NODE=$$ROOT^DILFD(FILE,IENS,1)
107 I NODE="" D Q RC
108 . S RC=$$ERROR^RORERR(-98,,,,FILE,IENS)
109 Q:'IEN NODE
110 ;--- The record node
111 S NODE=$NA(@NODE@(IEN))
112 Q:'FIELD NODE
113 ;--- Field node
114 S FGL=$$GET1^DID(FILE,FIELD,,"GLOBAL SUBSCRIPT LOCATION",,"RORMSG")
115 I $G(DIERR) D Q RC
116 . S RC=$$DBS^RORERR("RORMSG",-9,,,FILE)
117 S:$P(FGL,";")'="" NODE=$NA(@NODE@($P(FGL,";")))
118 Q NODE
119 ;
120 ;***** COMPILES THE LIST OF GLOBAL NODES
121NODELIST(NODELIST,FILE,IENS,FIELD) ;
122 N NODE,PI,RC K NODELIST
123 S NODELIST="",RC=0
124 ;--- Main object
125 I $G(FILE)>0 D Q:RC<0 RC
126 . S NODE=$$NODE(FILE,IENS,FIELD)
127 . I NODE<0 S RC=+NODE Q
128 . S NODELIST=NODELIST_","_NODE
129 . S NODELIST(NODE)=""
130 ;--- Linked objects
131 S PI="FILE"
132 F S PI=$Q(@PI) Q:PI="" D Q:RC<0
133 . S NODE=$$NODE($QS(PI,1),$QS(PI,2),$QS(PI,3))
134 . I NODE<0 S RC=+NODE Q
135 . S NODELIST=NODELIST_","_NODE
136 . S NODELIST(NODE)=""
137 Q:RC<0 RC
138 ;---
139 S NODELIST=$P(NODELIST,",",2,999)
140 Q RC
141 ;
142 ;***** GENERATES A TEXT DESCRIPTION FROM THE LOCK DESCRIPTOR
143 ;
144 ; LDSC Lock descriptor returned by the $$LOCK^RORLOCK
145 ;
146TEXT(LDSC) ;
147 N LTEXT
148 S LTEXT=$P(LDSC,U,2)_" about "_$$FMTE^XLFDT(+LDSC)
149 S:$P(LDSC,U,4) LTEXT=LTEXT_"; Job #"_$P(LDSC,U,4)
150 S:$P(LDSC,U,5) LTEXT=LTEXT_"; Task #"_$P(LDSC,U,5)
151 Q LTEXT
152 ;
153 ;***** UNLOCKS THE (SUB)FILE, RECORD OR FIELD NODE
154 ;
155 ; FILE File/subfile number
156 ; [IENS] IENS of the record or subfile
157 ; [FIELD] Field number
158 ;
159 ; Return Values:
160 ; <0 Error code
161 ; 0 Ok
162 ;
163 ; NOTE: This entry point can also be called as a procedure:
164 ; D UNLOCK^RORLOCK(...) if you do not need its return value.
165 ;
166UNLOCK(FILE,IENS,FIELD) ;
167 N DESCR,NDX,NODELIST,NODE,PI,RC
168 I $D(FILE)<10 S RC=0 D:$G(FILE)>0 Q:$QUIT RC Q
169 . S RC=$$UNLOCK1(FILE,$G(IENS),$G(FIELD))
170 ;--- Compile the list of global nodes
171 S RC=$$NODELIST(.NODELIST,.FILE,$G(IENS),$G(FIELD))
172 I RC<0 Q:$QUIT RC Q
173 I NODELIST="" Q:$QUIT 0 Q
174 ;--- Remove the lock descriptor(s)
175 S NODE=""
176 F S NODE=$O(NODELIST(NODE)) Q:NODE="" D
177 . S NDX=$$XLNDX(NODE),DESCR=$G(^XTMP("RORLOCK",NDX))
178 . Q:$P(DESCR,U,4)'=$JOB
179 . I $P(DESCR,U,6)>1 D
180 . . S $P(^XTMP("RORLOCK",NDX),U,6)=$P(DESCR,U,6)-1
181 . E K ^XTMP("RORLOCK",NDX)
182 ;--- Unlock the object(s)
183 X "L -("_NODELIST_")"
184 Q:$QUIT 0 Q
185 ;
186UNLOCK1(FILE,IENS,FIELD) ;
187 N DESCR,NDX,NODE
188 S NODE=$$NODE(FILE,$G(IENS),$G(FIELD))
189 Q:NODE<0 NODE
190 ;--- Remove the lock descriptor
191 S NDX=$$XLNDX(NODE),DESCR=$G(^XTMP("RORLOCK",NDX))
192 D:$P(DESCR,U,4)=$JOB
193 . I $P(DESCR,U,6)>1 D
194 . . S $P(^XTMP("RORLOCK",NDX),U,6)=$P(DESCR,U,6)-1
195 . E K ^XTMP("RORLOCK",NDX)
196 ;--- Unlock the object
197 L -@NODE
198 Q 0
199 ;
200 ;***** RETURNS SUBSCRIPT OF THE NODE IN THE DESCRIPTOR TABLE
201XLNDX(NODE) ;
202 N L S L=$L(NODE)
203 Q $S($E(NODE,L)=")":$E(NODE,1,L-1),1:NODE)
Note: See TracBrowser for help on using the repository browser.