source: cprs/branches/tmg-cprs/Server_KIDS/TMG-CPRS-TEXTOBJ-PARAM-1.0-1.KIDS

Last change on this file was 730, checked in by Kevin Toppenberg, 14 years ago

Ensure all RPCS are provided
File size: 19.3 KB
Line 
1KIDS Distribution saved on Mar 31, 2010@15:54:29
2TMG-CPRS-TEXTOBJ-PARAM*1.0*1
3**KIDS**:TMG-CPRS-TEXTOBJ-PARAM*1.0*1^
4
5**INSTALL NAME**
6TMG-CPRS-TEXTOBJ-PARAM*1.0*1
7"BLD",7629,0)
8TMG-CPRS-TEXTOBJ-PARAM*1.0*1^^0^3100331^n
9"BLD",7629,4,0)
10^9.64PA^^
11"BLD",7629,6.3)
121
13"BLD",7629,"KRN",0)
14^9.67PA^8989.52^19
15"BLD",7629,"KRN",.4,0)
16.4
17"BLD",7629,"KRN",.401,0)
18.401
19"BLD",7629,"KRN",.402,0)
20.402
21"BLD",7629,"KRN",.403,0)
22.403
23"BLD",7629,"KRN",.5,0)
24.5
25"BLD",7629,"KRN",.84,0)
26.84
27"BLD",7629,"KRN",3.6,0)
283.6
29"BLD",7629,"KRN",3.8,0)
303.8
31"BLD",7629,"KRN",9.2,0)
329.2
33"BLD",7629,"KRN",9.8,0)
349.8
35"BLD",7629,"KRN",9.8,"NM",0)
36^9.68A^1^1
37"BLD",7629,"KRN",9.8,"NM",1,0)
38TIUSRVD^^0^B93130374
39"BLD",7629,"KRN",9.8,"NM","B","TIUSRVD",1)
40
41"BLD",7629,"KRN",19,0)
4219
43"BLD",7629,"KRN",19.1,0)
4419.1
45"BLD",7629,"KRN",101,0)
46101
47"BLD",7629,"KRN",409.61,0)
48409.61
49"BLD",7629,"KRN",771,0)
50771
51"BLD",7629,"KRN",870,0)
52870
53"BLD",7629,"KRN",8989.51,0)
548989.51
55"BLD",7629,"KRN",8989.52,0)
568989.52
57"BLD",7629,"KRN",8994,0)
588994
59"BLD",7629,"KRN","B",.4,.4)
60
61"BLD",7629,"KRN","B",.401,.401)
62
63"BLD",7629,"KRN","B",.402,.402)
64
65"BLD",7629,"KRN","B",.403,.403)
66
67"BLD",7629,"KRN","B",.5,.5)
68
69"BLD",7629,"KRN","B",.84,.84)
70
71"BLD",7629,"KRN","B",3.6,3.6)
72
73"BLD",7629,"KRN","B",3.8,3.8)
74
75"BLD",7629,"KRN","B",9.2,9.2)
76
77"BLD",7629,"KRN","B",9.8,9.8)
78
79"BLD",7629,"KRN","B",19,19)
80
81"BLD",7629,"KRN","B",19.1,19.1)
82
83"BLD",7629,"KRN","B",101,101)
84
85"BLD",7629,"KRN","B",409.61,409.61)
86
87"BLD",7629,"KRN","B",771,771)
88
89"BLD",7629,"KRN","B",870,870)
90
91"BLD",7629,"KRN","B",8989.51,8989.51)
92
93"BLD",7629,"KRN","B",8989.52,8989.52)
94
95"BLD",7629,"KRN","B",8994,8994)
96
97"MBREQ")
980
99"QUES","XPF1",0)
100Y
101"QUES","XPF1","??")
102^D REP^XPDH
103"QUES","XPF1","A")
104Shall I write over your |FLAG| File
105"QUES","XPF1","B")
106YES
107"QUES","XPF1","M")
108D XPF1^XPDIQ
109"QUES","XPF2",0)
110Y
111"QUES","XPF2","??")
112^D DTA^XPDH
113"QUES","XPF2","A")
114Want my data |FLAG| yours
115"QUES","XPF2","B")
116YES
117"QUES","XPF2","M")
118D XPF2^XPDIQ
119"QUES","XPI1",0)
120YO
121"QUES","XPI1","??")
122^D INHIBIT^XPDH
123"QUES","XPI1","A")
124Want KIDS to INHIBIT LOGONs during the install
125"QUES","XPI1","B")
126NO
127"QUES","XPI1","M")
128D XPI1^XPDIQ
129"QUES","XPM1",0)
130PO^VA(200,:EM
131"QUES","XPM1","??")
132^D MG^XPDH
133"QUES","XPM1","A")
134Enter the Coordinator for Mail Group '|FLAG|'
135"QUES","XPM1","B")
136
137"QUES","XPM1","M")
138D XPM1^XPDIQ
139"QUES","XPO1",0)
140Y
141"QUES","XPO1","??")
142^D MENU^XPDH
143"QUES","XPO1","A")
144Want KIDS to Rebuild Menu Trees Upon Completion of Install
145"QUES","XPO1","B")
146NO
147"QUES","XPO1","M")
148D XPO1^XPDIQ
149"QUES","XPZ1",0)
150Y
151"QUES","XPZ1","??")
152^D OPT^XPDH
153"QUES","XPZ1","A")
154Want to DISABLE Scheduled Options, Menu Options, and Protocols
155"QUES","XPZ1","B")
156NO
157"QUES","XPZ1","M")
158D XPZ1^XPDIQ
159"QUES","XPZ2",0)
160Y
161"QUES","XPZ2","??")
162^D RTN^XPDH
163"QUES","XPZ2","A")
164Want to MOVE routines to other CPUs
165"QUES","XPZ2","B")
166NO
167"QUES","XPZ2","M")
168D XPZ2^XPDIQ
169"RTN")
1701
171"RTN","TIUSRVD")
1720^1^B93130374
173"RTN","TIUSRVD",1,0)
174TIUSRVD ; SLC/JER - RPC's for document definition ; 09/12/2003 [6/8/05 8:07am]
175"RTN","TIUSRVD",2,0)
176 ;;1.0;TEXT INTEGRATION UTILITIES;**1,7,22,47,103,100,115,164,112,186,201**;Jun 20, 1997;Build 1
177"RTN","TIUSRVD",3,0)
178NOTES(TIUY) ; Get list of PN Titles
179"RTN","TIUSRVD",4,0)
180 D LIST(.TIUY,3)
181"RTN","TIUSRVD",5,0)
182 Q
183"RTN","TIUSRVD",6,0)
184SUMMARY(TIUY) ; Get list of DS Titles
185"RTN","TIUSRVD",7,0)
186 D LIST(.TIUY,244)
187"RTN","TIUSRVD",8,0)
188 Q
189"RTN","TIUSRVD",9,0)
190LIST(TIUY,CLASS,TYPE,TIUK) ; Get list of document titles
191"RTN","TIUSRVD",10,0)
192 N TIUDFLT
193"RTN","TIUSRVD",11,0)
194 ; TIUK is STATIC
195"RTN","TIUSRVD",12,0)
196 S TIUK=+$G(TIUK)
197"RTN","TIUSRVD",13,0)
198 I $G(TYPE)']"" S TYPE="DOC"
199"RTN","TIUSRVD",14,0)
200 ; If the user has a preferred list of titles for the CLASS, get it
201"RTN","TIUSRVD",15,0)
202 I +$O(^TIU(8925.98,"AC",DUZ,CLASS,0)) D PERSLIST(.TIUY,DUZ,CLASS,.TIUK,1)
203"RTN","TIUSRVD",16,0)
204 S TIUK=+$G(TIUK)+1 S TIUY(TIUK)="~LONG LIST"
205"RTN","TIUSRVD",17,0)
206 D TRAVERSE(.TIUY,CLASS,$G(TYPE),.TIUK)
207"RTN","TIUSRVD",18,0)
208 S TIUDFLT=$$PERSDOC^TIULE(DUZ,+CLASS)
209"RTN","TIUSRVD",19,0)
210 I +TIUDFLT S TIUK=+$G(TIUK)+1,TIUY(TIUK)="d"_$P(TIUDFLT,U,2)
211"RTN","TIUSRVD",20,0)
212 Q
213"RTN","TIUSRVD",21,0)
214TRAVERSE(TIUY,CLASS,TYPE,TIUK) ; Get all selectable titles for the CLASS
215"RTN","TIUSRVD",22,0)
216 N I,J,X,CURTYP,Y,TIUI,TIUC,TYPMATCH S (TIUC,TIUI)=0
217"RTN","TIUSRVD",23,0)
218 S TIUK=+$G(TIUK)
219"RTN","TIUSRVD",24,0)
220 I $S(+$$CANENTR^TIULP(CLASS)'>0:1,+$$CANPICK^TIULP(CLASS)'>0:1,1:0) Q
221"RTN","TIUSRVD",25,0)
222 S CURTYP=$P(^TIU(8925.1,+CLASS,0),U,4)
223"RTN","TIUSRVD",26,0)
224 S TYPMATCH=$$TYPMATCH^TIULA1(TYPE,CURTYP)
225"RTN","TIUSRVD",27,0)
226 I +TYPMATCH S TIUK=+$G(TIUK)+1
227"RTN","TIUSRVD",28,0)
228 I S TIUY(TIUK)="i"_+CLASS_U_$$PNAME^TIULC1(+CLASS)
229"RTN","TIUSRVD",29,0)
230 S I=0 F S I=$O(^TIU(8925.1,+CLASS,10,I)) Q:+I'>0 D
231"RTN","TIUSRVD",30,0)
232 . N J
233"RTN","TIUSRVD",31,0)
234 . S J=+$G(^TIU(8925.1,+CLASS,10,+I,0)) Q:+J'>0
235"RTN","TIUSRVD",32,0)
236 . D TRAVERSE(.TIUY,+J,TYPE,.TIUK)
237"RTN","TIUSRVD",33,0)
238 Q
239"RTN","TIUSRVD",34,0)
240PERSLIST(TIUY,DUZ,CLASS,TIUC,TIUFLG) ; Get personal list for a user
241"RTN","TIUSRVD",35,0)
242 N TIUI,TIUDA,TIUDFLT,INLST
243"RTN","TIUSRVD",36,0)
244 S TIUDA=+$O(^TIU(8925.98,"AC",DUZ,CLASS,0))
245"RTN","TIUSRVD",37,0)
246 Q:+TIUDA'>0
247"RTN","TIUSRVD",38,0)
248 I +$G(TIUFLG) S TIUC=1,TIUY(TIUC)="~SHORT LIST"
249"RTN","TIUSRVD",39,0)
250 S TIUI=0,TIUC=+$G(TIUC)
251"RTN","TIUSRVD",40,0)
252 F S TIUI=$O(^TIU(8925.98,TIUDA,10,TIUI)) Q:+TIUI'>0 D
253"RTN","TIUSRVD",41,0)
254 . N TIUPL,TIUTNM,TIUDTYP,TIUSEQ
255"RTN","TIUSRVD",42,0)
256 . S TIUPL=$G(^TIU(8925.98,TIUDA,10,TIUI,0))
257"RTN","TIUSRVD",43,0)
258 . S TIUDTYP=$P(TIUPL,U)
259"RTN","TIUSRVD",44,0)
260 . I $S(+$$CANENTR^TIULP(TIUDTYP)'>0:1,+$$CANPICK^TIULP(TIUDTYP)'>0:1,1:0) Q
261"RTN","TIUSRVD",45,0)
262 . S TIUTNM=$S($P(TIUPL,U,3)]"":$P(TIUPL,U,3),1:$$PNAME^TIULC1(+TIUDTYP))
263"RTN","TIUSRVD",46,0)
264 . S TIUSEQ=+$P(TIUPL,U,2),TIUC=+$G(TIUC)+1
265"RTN","TIUSRVD",47,0)
266 . S TIUSEQ=$S(+TIUSEQ:$S('$D(TIUY(TIUSEQ)):TIUSEQ,1:(TIUSEQ+1)),1:TIUC)
267"RTN","TIUSRVD",48,0)
268 . S TIUY(TIUSEQ)="i"_TIUDTYP_U_TIUTNM,TIUC=+TIUSEQ
269"RTN","TIUSRVD",49,0)
270 I +$G(TIUFLG) Q
271"RTN","TIUSRVD",50,0)
272 S TIUDFLT=$$PERSDOC^TIULE(DUZ,+CLASS)
273"RTN","TIUSRVD",51,0)
274 S (TIUI,TIUC)=0
275"RTN","TIUSRVD",52,0)
276 F S TIUI=$O(TIUY(TIUI)) Q:+TIUI'>0 D
277"RTN","TIUSRVD",53,0)
278 . S TIUC=TIUI
279"RTN","TIUSRVD",54,0)
280 . I +TIUDFLT,($P($G(TIUY(TIUI)),U)=("i"_+TIUDFLT)) S $P(TIUDFLT,U,2)=$P(TIUY(TIUI),U,2),INLST=TIUI
281"RTN","TIUSRVD",55,0)
282 I +TIUDFLT D
283"RTN","TIUSRVD",56,0)
284 . ;if default isn't in list, append it as an item
285"RTN","TIUSRVD",57,0)
286 . I '$G(INLST) S TIUC=+$G(TIUC)+1,TIUY(TIUC)="i"_TIUDFLT
287"RTN","TIUSRVD",58,0)
288 . ;otherwise, just append as default
289"RTN","TIUSRVD",59,0)
290 . S TIUC=+$G(TIUC)+1,TIUY(TIUC)="d"_TIUDFLT
291"RTN","TIUSRVD",60,0)
292 Q
293"RTN","TIUSRVD",61,0)
294BLRSHELL(TIUY,TITLE,DFN,VSTR) ; Shell for boilerplate RPC
295"RTN","TIUSRVD",62,0)
296 K ^TMP("TIUBOIL",$J)
297"RTN","TIUSRVD",63,0)
298 D BLRPLT(.TIUY,TITLE,DFN,$G(VSTR))
299"RTN","TIUSRVD",64,0)
300 K ^TMP("TIUBOIL",$J,0)
301"RTN","TIUSRVD",65,0)
302 Q
303"RTN","TIUSRVD",66,0)
304BLRPLT(TIUY,TITLE,DFN,VSTR,ROOT) ; Load/Execute the Boilerplate for TITLE
305"RTN","TIUSRVD",67,0)
306 ; or ROOT
307"RTN","TIUSRVD",68,0)
308 N TIU,TIUI,TIUJ,TIUK,TIUL,VADM,VAIN,VA,VAERR S TIUI=0
309"RTN","TIUSRVD",69,0)
310 S:'$D(TIUY) TIUY=$NA(^TMP("TIUBOIL",$J))
311"RTN","TIUSRVD",70,0)
312 S:'$D(ROOT) ROOT=$NA(^TIU(8925.1,+TITLE,"DFLT")) ; **47**
313"RTN","TIUSRVD",71,0)
314 I $L($G(VSTR)) D PATVADPT^TIULV(.TIU,DFN,"",$G(VSTR)) ; **47**
315"RTN","TIUSRVD",72,0)
316 S TIUJ=+$P($G(^TMP("TIUBOIL",$J,0)),U,3)+1
317"RTN","TIUSRVD",73,0)
318 ; --- Set component header ---
319"RTN","TIUSRVD",74,0)
320 I ROOT["^TIU(8925.1," D
321"RTN","TIUSRVD",75,0)
322 . S ^TMP("TIUBOIL",$J,TIUJ,0)=$S($P($G(^TIU(8925.1,+TITLE,0)),U,4)="CO":$P(^TIU(8925.1,+TITLE,0),U)_": ",1:"")
323"RTN","TIUSRVD",76,0)
324 I +TIUJ=1,($G(^TMP("TIUBOIL",$J,TIUJ,0))']"") K ^TMP("TIUBOIL",$J,TIUJ,0) S TIUJ=0
325"RTN","TIUSRVD",77,0)
326 S ^TMP("TIUBOIL",$J,0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
327"RTN","TIUSRVD",78,0)
328 F S TIUI=$O(@ROOT@(TIUI)) Q:+TIUI'>0 D
329"RTN","TIUSRVD",79,0)
330 . S TIUJ=TIUJ+1,X=$G(@ROOT@(TIUI,0))
331"RTN","TIUSRVD",80,0)
332 . I $L($T(DOLMLINE^TIUSRVF1)),'$D(XWBOS),(X["{FLD:") S X=$$DOLMLINE^TIUSRVF1(X)
333"RTN","TIUSRVD",81,0)
334 . I X["|" S X=$$BOIL(X,TIUJ)
335"RTN","TIUSRVD",82,0)
336 . I X["~@" D INSMULT(X,"^TMP(""TIUBOIL"",$J)",.TIUJ) I 1
337"RTN","TIUSRVD",83,0)
338 . E S ^TMP("TIUBOIL",$J,TIUJ,0)=X
339"RTN","TIUSRVD",84,0)
340 . S ^TMP("TIUBOIL",$J,0)="^^"_TIUJ_U_TIUJ_U_DT_"^^"
341"RTN","TIUSRVD",85,0)
342 I ROOT["^TIU(8925.1,",+$O(^TIU(8925.1,+TITLE,10,0)) D
343"RTN","TIUSRVD",86,0)
344 . N TIUFITEM,TIUI D ITEMS^TIUFLT(+TITLE)
345"RTN","TIUSRVD",87,0)
346 . S TIUI=0 F S TIUI=$O(TIUFITEM(TIUI)) Q:+TIUI'>0 D
347"RTN","TIUSRVD",88,0)
348 . . S TIUL=+$G(TIUFITEM(+TIUI)) D BLRPLT(.TIUY,TIUL,DFN,$G(VSTR))
349"RTN","TIUSRVD",89,0)
350 Q
351"RTN","TIUSRVD",90,0)
352BOIL0(LINE,COUNT) ; Execute Boilerplates ;"//kt original function name was BOIL (mod is below)
353"RTN","TIUSRVD",91,0)
354 N TIUNEWG,TIUNEWR,TIUOLDG,TIUOLDR
355"RTN","TIUSRVD",92,0)
356 N TIUI,DIC,X,Y,TIUFPRIV S TIUFPRIV=1
357"RTN","TIUSRVD",93,0)
358 S DIC=8925.1,DIC(0)="FMXZ"
359"RTN","TIUSRVD",94,0)
360 S DIC("S")="I $P($G(^TIU(8925.1,+Y,0)),U,4)=""O"""
361"RTN","TIUSRVD",95,0)
362 F TIUI=2:2:$L(LINE,"|") S X=$P(LINE,"|",TIUI) D
363"RTN","TIUSRVD",96,0)
364 . D ^DIC
365"RTN","TIUSRVD",97,0)
366 . I +Y'>0 S X="The OBJECT "_X_" was NOT found...Contact IRM."
367"RTN","TIUSRVD",98,0)
368 . I +Y>0 D
369"RTN","TIUSRVD",99,0)
370 . . I $D(^TIU(8925.1,+Y,9)),+$$CANXEC(+Y) X ^(9) S:X["~@" X=$$APPEND(X) I 1
371"RTN","TIUSRVD",100,0)
372 . . E S X="The OBJECT "_X_" is INACTIVE...Contact IRM."
373"RTN","TIUSRVD",101,0)
374 . . I X["~@" D
375"RTN","TIUSRVD",102,0)
376 . . . I X'["^" D
377"RTN","TIUSRVD",103,0)
378 . . . . S TIUOLDR=$P(X,"~@",2),TIUNEWR=TIUOLDR_TIUI
379"RTN","TIUSRVD",104,0)
380 . . . . M @TIUNEWR=@TIUOLDR K @TIUOLDR
381"RTN","TIUSRVD",105,0)
382 . . . . S $P(X,"~@",2)=TIUNEWR
383"RTN","TIUSRVD",106,0)
384 . . . I X["^" D
385"RTN","TIUSRVD",107,0)
386 . . . . S TIUOLDG=$P(X,"~@",2),TIUNEWG="^TMP("_"""TIU201"""_","_$J_","_TIUI_")"
387"RTN","TIUSRVD",108,0)
388 . . . . M @TIUNEWG=@TIUOLDG K @TIUOLDG
389"RTN","TIUSRVD",109,0)
390 . . . . S $P(X,"~@",2)=TIUNEWG
391"RTN","TIUSRVD",110,0)
392 . S LINE=$$REPLACE(LINE,X,TIUI)
393"RTN","TIUSRVD",111,0)
394 Q $TR(LINE,"|","")
395"RTN","TIUSRVD",112,0)
396 ;
397"RTN","TIUSRVD",113,0)
398BOIL(LINE,COUNT) ; Execute Boilerplates ;"//kt modification
399"RTN","TIUSRVD",114,0)
400 ;"Purpose: Resolve Text Objects. Function is modified to allow |TEXT OBJECT{Parameters}|
401"RTN","TIUSRVD",115,0)
402 ;"Input: LINE -- One line of text that has one or more text objects
403"RTN","TIUSRVD",116,0)
404 ;" COUNT -- (not used)
405"RTN","TIUSRVD",117,0)
406 ;"Results: Returns line of text with text objects resolved.
407"RTN","TIUSRVD",118,0)
408 ;"NOTE: [Parameter] may itself be a nested text object (arbitrary depth allowed)
409"RTN","TIUSRVD",119,0)
410 ;"Usage -- in text object definition, code may be like this:
411"RTN","TIUSRVD",120,0)
412 ;" S X=$$MYFN^MYMOD(X)
413"RTN","TIUSRVD",121,0)
414 ;" The value for X being passed into the object's code will hold the
415"RTN","TIUSRVD",122,0)
416 ;" parameter found between { }
417"RTN","TIUSRVD",123,0)
418 ;" This is backwards compatible. If no parameter is specified, then X=""
419"RTN","TIUSRVD",124,0)
420 N TIUNEWG,TIUNEWR,TIUOLDG,TIUOLDR,TMGX
421"RTN","TIUSRVD",125,0)
422 N TIUI,DIC,X,Y,TIUFPRIV S TIUFPRIV=1
423"RTN","TIUSRVD",126,0)
424 S DIC=8925.1,DIC(0)="FMXZ"
425"RTN","TIUSRVD",127,0)
426 S DIC("S")="I $P($G(^TIU(8925.1,+Y,0)),U,4)=""O"""
427"RTN","TIUSRVD",128,0)
428 F TIUI=2:2:$L(LINE,"|") D
429"RTN","TIUSRVD",129,0)
430 . NEW SA,SB
431"RTN","TIUSRVD",130,0)
432 . SET X=$$MXTRACT(LINE,"|",.SA,.SB)
433"RTN","TIUSRVD",131,0)
434 . IF X["{" DO
435"RTN","TIUSRVD",132,0)
436 . . NEW X1,X2
437"RTN","TIUSRVD",133,0)
438 . . SET TMGX=$$MXTRACT(X,"{",.X1,.X2)
439"RTN","TIUSRVD",134,0)
440 . . IF TMGX["|" SET TMGX=$$BOIL(TMGX)
441"RTN","TIUSRVD",135,0)
442 . . SET X=X1_X2
443"RTN","TIUSRVD",136,0)
444 . ELSE SET TMGX=""
445"RTN","TIUSRVD",137,0)
446 . D ^DIC
447"RTN","TIUSRVD",138,0)
448 . I +Y>0 DO
449"RTN","TIUSRVD",139,0)
450 . . I $D(^TIU(8925.1,+Y,9)),+$$CANXEC(+Y) DO
451"RTN","TIUSRVD",140,0)
452 . . . SET X=TMGX ;"Load passed parameter (or "" if none) into X
453"RTN","TIUSRVD",141,0)
454 . . . X ^(9)
455"RTN","TIUSRVD",142,0)
456 . . . S:X["~@" X=$$APPEND(X)
457"RTN","TIUSRVD",143,0)
458 . . E S X="The OBJECT "_X_" is INACTIVE...Contact IRM."
459"RTN","TIUSRVD",144,0)
460 . . I X["~@" D
461"RTN","TIUSRVD",145,0)
462 . . . I X'["^" D
463"RTN","TIUSRVD",146,0)
464 . . . . S TIUOLDR=$P(X,"~@",2),TIUNEWR=TIUOLDR_TIUI
465"RTN","TIUSRVD",147,0)
466 . . . . M @TIUNEWR=@TIUOLDR K @TIUOLDR
467"RTN","TIUSRVD",148,0)
468 . . . . S $P(X,"~@",2)=TIUNEWR
469"RTN","TIUSRVD",149,0)
470 . . . I X["^" D
471"RTN","TIUSRVD",150,0)
472 . . . . S TIUOLDG=$P(X,"~@",2),TIUNEWG="^TMP("_"""TIU201"""_","_$J_","_TIUI_")"
473"RTN","TIUSRVD",151,0)
474 . . . . M @TIUNEWG=@TIUOLDG K @TIUOLDG
475"RTN","TIUSRVD",152,0)
476 . . . . S $P(X,"~@",2)=TIUNEWG
477"RTN","TIUSRVD",153,0)
478 . ELSE S X="The OBJECT "_X_" was NOT found...Contact IRM."
479"RTN","TIUSRVD",154,0)
480 . SET LINE=SA_X_SB
481"RTN","TIUSRVD",155,0)
482 Q LINE
483"RTN","TIUSRVD",156,0)
484 ;
485"RTN","TIUSRVD",157,0)
486MXTRACT(S,DIVCH,SA,SB,MAP) ;"//kst added this function
487"RTN","TIUSRVD",158,0)
488 ;" Extract matched encapsulators
489"RTN","TIUSRVD",159,0)
490 ;" NOTE: see TMGSTUTL for a more robust version of function.
491"RTN","TIUSRVD",160,0)
492 IF '$DATA(MAP) DO MAPMATCH(S,.MAP)
493"RTN","TIUSRVD",161,0)
494 NEW RESULT SET RESULT=""
495"RTN","TIUSRVD",162,0)
496 NEW I SET I=0
497"RTN","TIUSRVD",163,0)
498 FOR S I=$O(MAP(1,I)) QUIT:(I="")!(RESULT'="") DO
499"RTN","TIUSRVD",164,0)
500 . IF DIVCH'=$G(MAP(1,I)) QUIT
501"RTN","TIUSRVD",165,0)
502 . NEW P,J
503"RTN","TIUSRVD",166,0)
504 . FOR J=1,2 SET P(J)=+$G(MAP(1,I,"P",J))
505"RTN","TIUSRVD",167,0)
506 . SET RESULT=$EXTRACT(S,P(1)+1,P(2)-1)
507"RTN","TIUSRVD",168,0)
508 . SET SA=$EXTRACT(S,1,P(1)-1),SB=$EXTRACT(S,P(2)+1,9999)
509"RTN","TIUSRVD",169,0)
510 IF RESULT="" SET SA=S,SB=""
511"RTN","TIUSRVD",170,0)
512 QUIT RESULT
513"RTN","TIUSRVD",171,0)
514 ;
515"RTN","TIUSRVD",172,0)
516MAPMATCH(S,MAP) ;"//kst added this function
517"RTN","TIUSRVD",173,0)
518 ;" Map out a string for matched encapsulators
519"RTN","TIUSRVD",174,0)
520 ;" NOTE: see TMGSTUTL.m for a more robust version of function.
521"RTN","TIUSRVD",175,0)
522 N MATCH,DEPTH,I,GRP,CH
523"RTN","TIUSRVD",176,0)
524 S MATCH("{")="}",MATCH("|")="|"
525"RTN","TIUSRVD",177,0)
526 K MAP
527"RTN","TIUSRVD",178,0)
528 S DEPTH=0,GRP=1
529"RTN","TIUSRVD",179,0)
530 F I=1:1:$L(S) D Q:(GRP>1) ;"Only deal with 1st entry
531"RTN","TIUSRVD",180,0)
532 . S CH=$EXTRACT(S,I)
533"RTN","TIUSRVD",181,0)
534 . I CH=$G(MAP(GRP,DEPTH,"End")) D QUIT
535"RTN","TIUSRVD",182,0)
536 . . S MAP(GRP,DEPTH,"P",2)=I
537"RTN","TIUSRVD",183,0)
538 . . K MAP(GRP,DEPTH,"End")
539"RTN","TIUSRVD",184,0)
540 . . S DEPTH=DEPTH-1
541"RTN","TIUSRVD",185,0)
542 . . I DEPTH=0 S GRP=GRP+1
543"RTN","TIUSRVD",186,0)
544 . I $D(MATCH(CH))=0 QUIT
545"RTN","TIUSRVD",187,0)
546 . S DEPTH=DEPTH+1
547"RTN","TIUSRVD",188,0)
548 . S MAP(GRP,DEPTH)=CH
549"RTN","TIUSRVD",189,0)
550 . S MAP(GRP,DEPTH,"End")=MATCH(CH)
551"RTN","TIUSRVD",190,0)
552 . S MAP(GRP,DEPTH,"P",1)=I
553"RTN","TIUSRVD",191,0)
554 QUIT
555"RTN","TIUSRVD",192,0)
556 ;
557"RTN","TIUSRVD",193,0)
558CANXEC(TIUODA) ; Evaluate Object Status
559"RTN","TIUSRVD",194,0)
560 N TIUOST,TIUY S TIUOST=+$P($G(^TIU(8925.1,+TIUODA,0)),U,7)
561"RTN","TIUSRVD",195,0)
562 S TIUY=$S(TIUOST=11:1,+$G(NOSAVE):1,1:0)
563"RTN","TIUSRVD",196,0)
564 Q +$G(TIUY)
565"RTN","TIUSRVD",197,0)
566APPEND(X) ;
567"RTN","TIUSRVD",198,0)
568 N TIUXL S TIUXL=$L(X)
569"RTN","TIUSRVD",199,0)
570 I $E(X,TIUXL-1,TIUXL)'="~@" S X=X_"~@"
571"RTN","TIUSRVD",200,0)
572 Q X
573"RTN","TIUSRVD",201,0)
574REPLACE(LINE,X,TIUI) ; Replace the TIUIth object in LINE w/X
575"RTN","TIUSRVD",202,0)
576 S $P(LINE,"|",TIUI)=X
577"RTN","TIUSRVD",203,0)
578 Q LINE
579"RTN","TIUSRVD",204,0)
580INSMULT(LINE,TARGET,TIULCNT) ; Mult-valued results
581"RTN","TIUSRVD",205,0)
582 N TIUPC,TIULGTH
583"RTN","TIUSRVD",206,0)
584 ; TIU*1*164 ;
585"RTN","TIUSRVD",207,0)
586 S TIULGTH=73 ; 2 replacements of 73 below for TIULGTH
587"RTN","TIUSRVD",208,0)
588 S:$$BROKER^XWBLIB TIULGTH=80
589"RTN","TIUSRVD",209,0)
590 F TIUPC=2:2:$L(LINE,"~@") D
591"RTN","TIUSRVD",210,0)
592 . N TIUI,TIULINE,TIUX,TIUSRC,TIUSCNT,TIUTAIL
593"RTN","TIUSRVD",211,0)
594 . S TIUSRC=$P(LINE,"~@",TIUPC)
595"RTN","TIUSRVD",212,0)
596 . S TIUTAIL=$P(LINE,"~@",TIUPC+1)
597"RTN","TIUSRVD",213,0)
598 . S TIULINE=$P(LINE,"~@",(TIUPC-1)),(TIUI,TIUSCNT)=0
599"RTN","TIUSRVD",214,0)
600 . I $E(TIULINE)=" ",(TIUPC>2) S $E(TIULINE)=""
601"RTN","TIUSRVD",215,0)
602 . F S TIUI=$O(@TIUSRC@(TIUI)) Q:+TIUI'>0 D
603"RTN","TIUSRVD",216,0)
604 . . N TIUSLINE
605"RTN","TIUSRVD",217,0)
606 . . S TIUSCNT=TIUSCNT+1
607"RTN","TIUSRVD",218,0)
608 . . S TIUSLINE=$G(@TIUSRC@(TIUI,0))
609"RTN","TIUSRVD",219,0)
610 . . S:'+$O(@TIUSRC@(TIUI))&(TIUPC+2>$L(LINE,"~@")) TIUSLINE=TIUSLINE_TIUTAIL
611"RTN","TIUSRVD",220,0)
612 . . I TIUSCNT=1,($L(TIULINE_TIUSLINE)>TIULGTH) D Q
613"RTN","TIUSRVD",221,0)
614 . . . S:$D(@TARGET@(TIULCNT,0)) TIULCNT=TIULCNT+1
615"RTN","TIUSRVD",222,0)
616 . . . S @TARGET@(TIULCNT,0)=TIULINE
617"RTN","TIUSRVD",223,0)
618 . . . S TIULCNT=TIULCNT+1
619"RTN","TIUSRVD",224,0)
620 . . . S @TARGET@(TIULCNT,0)=TIUSLINE
621"RTN","TIUSRVD",225,0)
622 . . I TIUSCNT=1,($L(TIULINE_TIUSLINE)'>TIULGTH) D Q
623"RTN","TIUSRVD",226,0)
624 . . . S:$D(@TARGET@(TIULCNT,0)) TIULCNT=TIULCNT+1
625"RTN","TIUSRVD",227,0)
626 . . . S @TARGET@(TIULCNT,0)=TIULINE_TIUSLINE
627"RTN","TIUSRVD",228,0)
628 . . S:$D(@TARGET@(TIULCNT,0)) TIULCNT=TIULCNT+1
629"RTN","TIUSRVD",229,0)
630 . . S @TARGET@(TIULCNT,0)=$G(TIUSLINE)
631"RTN","TIUSRVD",230,0)
632 . K @TIUSRC
633"RTN","TIUSRVD",231,0)
634 Q
635"RTN","TIUSRVD",232,0)
636LNGCNSLT(Y,FROM,DIR) ; Handle long list of titles for CONSULTS
637"RTN","TIUSRVD",233,0)
638 N CLASS S CLASS=+$$CLASS^TIUCNSLT Q:+CLASS'>0
639"RTN","TIUSRVD",234,0)
640 D LONGLIST(.Y,CLASS,$G(FROM),$G(DIR,1))
641"RTN","TIUSRVD",235,0)
642 Q
643"RTN","TIUSRVD",236,0)
644LNGSURG(Y,FROM,DIR,CLNAME) ; long list SURGICAL REPORT titles
645"RTN","TIUSRVD",237,0)
646 ; CLNAME = "SURGICAL REPORTS" or "PROCEDURE REPORTS (NON-O.R.)"
647"RTN","TIUSRVD",238,0)
648 ; depending on context
649"RTN","TIUSRVD",239,0)
650 N CLASS S CLNAME=$S($G(CLNAME)]"":CLNAME,1:"OPERATION REPORTS")
651"RTN","TIUSRVD",240,0)
652 S CLASS=$$CLASS^TIUSROI(CLNAME) Q:+CLASS'>0
653"RTN","TIUSRVD",241,0)
654 D LONGLIST(.Y,CLASS,$G(FROM),$G(DIR,1))
655"RTN","TIUSRVD",242,0)
656 Q
657"RTN","TIUSRVD",243,0)
658LONGLIST(Y,CLASS,FROM,DIR,IDNOTE) ; long list of titles for a class
659"RTN","TIUSRVD",244,0)
660 ; .Y=returned list, CLASS=ptr to class in 8925.1, FROM=text to $O from,
661"RTN","TIUSRVD",245,0)
662 ; DIR=$O direction, IDNOTE=flag to indicate selection for ID Entry
663"RTN","TIUSRVD",246,0)
664 N I,DA,CNT S I=0,CNT=44,DIR=$G(DIR,1)
665"RTN","TIUSRVD",247,0)
666 F Q:I'<CNT S FROM=$O(^TIU(8925.1,"ACL",CLASS,FROM),DIR) Q:FROM="" D
667"RTN","TIUSRVD",248,0)
668 . S DA=0
669"RTN","TIUSRVD",249,0)
670 . F Q:I'<CNT S DA=$O(^TIU(8925.1,"ACL",CLASS,FROM,DA)) Q:+DA'>0 D
671"RTN","TIUSRVD",250,0)
672 . . I $S(+$$CANENTR^TIULP(DA)'>0:1,+$$CANPICK^TIULP(DA)'>0:1,1:0) Q
673"RTN","TIUSRVD",251,0)
674 . . I +$L($T(CANLINK^TIULP)),+$G(IDNOTE),(+$$CANLINK^TIULP(DA)'>0) Q
675"RTN","TIUSRVD",252,0)
676 . . S I=I+1,Y(I)=DA_"^"_FROM
677"RTN","TIUSRVD",253,0)
678 Q
679"RTN","TIUSRVD",254,0)
680CNSLCLAS(Y) ; RPC to identify class CONSULTS
681"RTN","TIUSRVD",255,0)
682 S Y=$$CLASS^TIUCNSLT
683"RTN","TIUSRVD",256,0)
684 Q
685"RTN","TIUSRVD",257,0)
686SURGCLAS(Y,CLNAME) ; RPC to identify class
687"RTN","TIUSRVD",258,0)
688 ; CLNAME = "SURGICAL REPORTS" or "PROCEDURE REPORTS (NON-O.R.)"
689"RTN","TIUSRVD",259,0)
690 S CLNAME=$G(CLNAME,"SURGICAL REPORTS")
691"RTN","TIUSRVD",260,0)
692 S Y=$$CLASS^TIUSROI(CLNAME)
693"RTN","TIUSRVD",261,0)
694 Q
695"RTN","TIUSRVD",262,0)
696CANLINK(Y,TIUTTL) ; Wrap call to $$CANLINK^TIULP
697"RTN","TIUSRVD",263,0)
698 S Y=$$CANLINK^TIULP(TIUTTL)
699"RTN","TIUSRVD",264,0)
700 Q
701"VER")
7028.0^22.0
703**END**
704**END**
Note: See TracBrowser for help on using the repository browser.