source: cprs/branches/tmg-cprs/m_files/TMGUSRIF.m@ 1381

Last change on this file since 1381 was 896, checked in by Kevin Toppenberg, 14 years ago

replacing soft links with actual files
File size: 57.0 KB
Line 
1TMGUSRIF ;TMG/kst/USER INTERFACE API FUNCTIONS ;03/25/06, 5/28/10
2 ;;1.0;TMG-LIB;**1**;07/12/05
3
4 ;"TMG USER INTERFACE API FUNCTIONS
5 ;"Kevin Toppenberg MD
6 ;"GNU General Public License (GPL) applies
7 ;"7-12-2005
8
9 ;"=======================================================================
10 ;" API -- Public Functions.
11 ;"=======================================================================
12
13 ;"PopupArray^TMGUSRIF(IndentW,Width,Array,Modal)
14 ;"PopupBox^TMGUSRIF(Header,Text,[Width])
15 ;"ProgressBar^TMGUSRIF(value,label,min,max,width,startTime)
16 ;"PRESSTOCONT^TMGUSRIF
17 ;"PressToCont^TMGUSRIF
18 ;"$$KeyPressed^TMGUSRIF(wantChar,waitTime)
19 ;"$$Read^TMGUSRIF(Terminators,timeOut,Num,initialVal) -- custom read function with custom terminators
20 ;"$$UserAborted^TMGUSRIF()
21 ;"Selector(pArray,pResults,Header) -- select from an array
22 ;"Slctor2(pArray,pResults,Header) -- select from an array (different input)
23 ;"IENSelector(pIENArray,pResults,File,Field,Header,Sort)
24 ;"MENU(Options,defChoice,.UserRaw)
25 ;"Menu(Options,defChoice,.UserRaw)
26 ;"Scroller(pArray,Option) -- Provide a scroll box interfact
27
28 ;"=======================================================================
29 ;"Private Functions
30 ;"=======================================================================
31 ;"XPopupArray(Array,Modal)
32 ;"ProgTest
33
34 ;"=======================================================================
35 ;"=======================================================================
36 ;"DEPENDENCIES
37 ;"TMGDEBUG,TMGSTUTL,TMGXDLG
38 ;"=======================================================================
39
40PopupArray(IndentW,Width,Array,Modal)
41 ;"PUBLIC FUNCTION
42 ;"Purpose: To draw a box, of specified Width, and display text
43 ;"Input: IndentW = width of indent amount (how far from left margin)
44 ;" Width = desired width of box.
45 ;" Header = one line of text to put in header of popup box
46 ;" Array: an array in following format:
47 ;" Array(0)=Header
48 ;" Array(1)=Text line 1
49 ;" Array(2)=Text line 2
50 ;" ...
51 ;" Array(n)=Text line n
52 ;" Modal - really only has meaning for those time when
53 ;" box will be passed to GUI X dialog box.
54 ;" Modal=1 means stays in foreground,
55 ;" 0 means leave box up, continue script execution.
56 ;"Note: Text will be clipped to fit in box.
57
58 if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"PopupArray")
59
60 set cModal=$get(cModal,"MODAL")
61 set cDialog=$get(cModal,"UseDialog")
62 set Modal=$get(Modal,cModal)
63 new Header
64 new Text set Text=""
65 new index,i,S
66
67 ;"Scan array for any needed data substitution i.e. {{...}}
68 new tempresult
69 set index=$order(Array(""))
70 for do quit:index=""
71 . set S=Array(index)
72 . ;"set tempresult=$$CheckSubstituteData(.S) ;"Do any data lookup needed
73 . set Array(index)=S
74 . set index=$order(Array(index))
75
76 if $get(DispMode(cDialog)) do goto PUADone
77 . do XPopupArray(.Array,Modal)
78
79 set IndentW=$get(IndentW,1) ;"default indent=1
80 set Header=$get(Array(0)," ")
81 set Width=$get(Width,40) ;"default=40
82
83 write !
84 ;"Draw top line
85 for i=1:1:IndentW write " "
86 write "+"
87 for i=1:1:(Width-2) write "="
88 write "+",!
89
90 ;"Draw Header line
91 do SetStrLen^TMGSTUTL(.Header,Width-4)
92 for i=1:1:IndentW write " "
93 write "| ",Header," |..",!
94
95 ;"Draw divider line
96 for i=1:1:IndentW write " "
97 write "+"
98 for i=1:1:(Width-2) write "-"
99 write "+ :",!
100
101 ;"Put out message
102 set index=$order(Array(0))
103PUBLoop
104 if index="" goto BtmLine
105 set S=$get(Array(index)," ")
106 do SetStrLen^TMGSTUTL(.S,Width-4)
107 for i=1:1:IndentW write " "
108 write "| ",S," | :",!
109 set index=$order(Array(index))
110 goto PUBLoop
111
112BtmLine
113 ;"Draw Bottom line
114 for i=1:1:IndentW write " "
115 write "+"
116 for i=1:1:(Width-2) write "="
117 write "+ :",!
118
119 ;"Draw bottom shaddow
120 for i=1:1:IndentW write " "
121 write " "
122 write ":"
123 for i=1:1:(Width-2) write "."
124 write ".",!
125
126 write !
127
128PUADone
129 if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"PopupArray")
130 quit
131
132
133
134XPopupArray(Array,Modal)
135 ;"Purpose -- to pass the older text popup box onto a X GUI box
136
137 new Title
138 new Text
139 new index
140 new S set S=""
141 new OneLine
142 new result
143
144 set cOKToCont=$get(cOKToCont,1)
145 set cAbort=$get(cAbort,0)
146 set cModal=$get(cModal,"MODAL")
147
148
149 if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"XPopupArray")
150
151 set Title=$get(Array(0))
152 set index=$order(Array(0))
153 set Modal=$get(Modal,cModalMode)
154XPL1
155 if index="" goto XPL2
156 set OneLine=$get(Array(index)," ")
157 set OneLine=$translate(OneLine,"""","'")
158 set S=S_OneLine_"\n"
159 set index=$order(Array(index))
160 goto XPL1
161XPL2
162 if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Title=",Title)
163 if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Text=",S)
164 set result=$$Msg^TMGXDLG(Title,S,0,0,Modal)
165 if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"XPopupArray")
166 quit
167
168
169
170
171PopupBox(Header,Text,Width)
172 ;"PUBLIC FUNCTION
173 ;"Purpose: To provide easy text output box
174 ;"Input: Header -- a short string for header
175 ;" Text - the text to display
176 ;" [Width] -- optional width specifier. Value=0 same as not specified
177 ;" (DBIndent) -- uses a var with global scope (if defined) for indent amount
178 ;"Note: If text width not specified, and Text is <= 60,
179 ;" then all will be put on one line.
180 ;" Otherwise, width is set to 60, and text is wrapped.
181 ;" Also, text of the message can contain "\n", which will be interpreted
182 ;" as a new-line character.
183 ;"Result: none
184
185
186 ;"Note: This function can't be exported to a separate package because of dependancies
187
188
189 if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"PopupBox")
190
191 set cNewLn=$get(cNewLn,"\n")
192 new TextOut
193 new TextI set TextI=0
194 new PartB set PartB=""
195 new PartB1 set PartB1=""
196 set Width=+$get(Width,0)
197
198 set TextOut(TextI)=Header
199 set TextI=TextI+1
200
201 if Width=0 do
202 . new HeaderBased
203 . new NumLines
204 . new HLen set HLen=$length(Header)+4
205 . new TLen set TLen=$length(Text)+4
206 . if TLen>HLen do
207 . . set Width=TLen
208 . . set HeaderBased=0
209 . else do
210 . . set Width=HLen
211 . . set HeaderBased=1
212 . if Width>75 set Width=75
213 . set NumLines=TLen/Width
214 . if TLen#Width>0 set NumLines=NumLines+1
215 . if (NumLines>1)&(HeaderBased=0) do
216 . . set Width=(TLen\NumLines)+4
217 . . if Width<HLen set Width=HLen
218 . if Width>75 set Width=75
219
220PUWBLoop ;"Load string up into Text array, to pass to PopupArray
221 if Text[cNewLn do
222 . do CleaveStr^TMGSTUTL(.Text,cNewLn,.PartB1)
223 do SplitStr^TMGSTUTL(.Text,(Width-4),.PartB)
224 set PartB=PartB_PartB1 set PartB1=""
225 set TextOut(TextI)=Text
226 set TextI=TextI+1
227 if $length(PartB)>0 do goto PUWBLoop
228 . set Text=PartB
229 . set PartB=""
230
231 do PopupArray(.DBIndent,Width,.TextOut)
232
233 if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"PopupBox")
234 quit
235
236
237ProgressBar(value,label,min,max,width,startTime)
238 ;"Purpose: to draw a progress bar on a line of the screen
239 ;"Input:
240 ;" value -- the current value to graph out
241 ;" label -- OPTIONAL -- a label to describe progres. Default="Progress"
242 ;" max -- OPTIONAL -- the max number that value will be. Default is 100
243 ;" if max=-1 and min=-1 then turn on spin mode (see below)
244 ;" min -- OPTIONAL -- the minimal number that value will be. Default is 0
245 ;" if max=-1 and min=-1 then turn on spin mode (see below)
246 ;" width -- OPTIONAL -- the number of characters that the progress bar
247 ;" will be in width. Default is 70
248 ;" startTime -- OPTIONAL -- start time of process. If provided, it will
249 ;" be used to determine remaining time. Format should be same as $H
250 ;"Note: will use global ^TMP("TMG","PROGRESS-BAR",$J)
251 ;"Note: bar will look like this:
252 ;" Progress: 27%-------->|-----------------------------------| (Time)
253 ;"Note--Spin Mode: To show motion without knowing the max amount, a spin mode is needed.
254 ;" Progress: |-----<==>--------------------------------------|
255 ;" And the bar will move back and forth.
256 ;" In this mode, value is ignored and is thus optional.
257 ;" To use this mode, set max=-1,min=-1
258 ;"Result: None
259
260 ;"FYI -- The preexisting way to do this, from Dave Whitten
261 ;"
262 ;"Did you try using the already existing function to do this?
263 ;"ie: try out this 'mini program'
264 ;">; need to set up vars like DUZ,DTIME, IO, IO(0), etc.
265 ;" D INIT^XPDID
266 ;" S XPDIDTOT=100
267 ;" D TITLE^XPDID("hello world")
268 ;" D UPDATE^XPDID(50)
269 ;" F AJJ=90:1:100 D UPDATE^XPDID(I)
270 ;" D EXIT^XPDID()
271 ;"
272 ;"The XPDID routine does modify the scroll region and make the
273 ;"application seem a bit more "GUI"-like, by the way...
274 ;"
275 ;"David
276
277 new NakedRef set NakedRef=$$LGR^TMGIDE ;"save naked reference
278 do ;"Turn off cursor display, to prevent flickering
279 . new $etrap set $etrap=""
280 . xecute ^%ZOSF("TRMOFF")
281
282 new premark,i,postmark,pct
283 new pRefCt set pRefCt=$name(^TMP("TMG","PROGRESS-BAR",$J))
284 set max=+$get(max,100),min=+$get(min,0)
285 set width=+$get(width,70)
286 set label=$get(label,"Progress")
287
288 new spinMode set spinMode=((max=-1)&(min=-1))
289 if spinMode goto Spin1 ;"<-- skip all this for spin mode
290
291 if (max-min)=0 set pct=0
292 else set pct=(value-min)/(max-min)
293 if pct>1 set pct=1
294 if pct<0 set pct=0
295 if (pct<1)&($get(startTime)="") set startTime=$H
296
297 set startTime=$get(startTime) ;" +$get 61053,61748 --> 61053
298
299 new barberPole set barberPole=+$get(@pRefCt@("BARBER POLE"))
300 if $get(@pRefCt@("BARBER POLE","LAST INC"))'=$H do
301 . set barberPole=(barberPole-1)#4
302 . set @pRefCt@("BARBER POLE")=barberPole ;"should be 0,1,2, or 3)
303 . set @pRefCt@("BARBER POLE","LAST INC")=$H
304
305 new curRate set curRate=""
306 if $get(@pRefCt@("START-TIME"))=startTime do
307 . new interval set interval=$get(@pRefCt@("SAMPLING","INTERVAL"),10)
308 . set curRate=$get(@pRefCt@("LATEST-RATE"))
309 . new count set count=$get(@pRefCt@("SAMPLING","COUNT"))+1
310 . if count#interval=0 do
311 . . new deltaT,deltaV
312 . . set deltaT=$$HDIFF^XLFDT($H,$get(@pRefCt@("SAMPLING","REF-TIME")),2)
313 . . if deltaT=0 set interval=interval*2
314 . . else if deltaT>1000 set interval=interval\1.5
315 . . set deltaV=value-$get(@pRefCt@("SAMPLING","VALUE COUNT"))
316 . . if deltaV>0 set curRate=deltaT/deltaV ;"dT/dValue
317 . . else set curRate=""
318 . . set @pRefCt@("LATEST-RATE")=curRate
319 . . set @pRefCt@("SAMPLING","REF-TIME")=$H
320 . . set @pRefCt@("SAMPLING","VALUE COUNT")=value
321 . set @pRefCt@("SAMPLING","COUNT")=count#interval
322 . set @pRefCt@("SAMPLING","INTERVAL")=interval
323 else do
324 . kill @pRefCt
325 . set @pRefCt@("START-TIME")=startTime
326 . set @pRefCt@("SAMPLING","COUNT")=0
327 . set @pRefCt@("SAMPLING","REF-TIME")=$H
328 . set @pRefCt@("SAMPLING","VALUE COUNT")=value
329
330 new timeStr set timeStr=" "
331 new remainingT set remainingT=""
332 new delta set delta=0
333
334 if curRate'="" do
335 . new remainV set remainV=(max-value)
336 . if remainV'<0 do
337 . . set remainingT=curRate*remainV
338 . else do
339 . . set delta=-1,remainingT=$$HDIFF^XLFDT($H,startTime,2)
340 else if $data(startTime) do
341 . if pct=0 quit
342 . set timeStr=""
343 . set delta=$$HDIFF^XLFDT($H,startTime,2)
344 . if delta<0 set remainingT=-delta ;"just report # sec's overrun.
345 . set remainingT=delta*((1/pct)-1)
346
347 if remainingT'="" do
348 . new days set days=remainingT\86400 ;"86400 sec per day.
349 . if days>5 set timeStr="<Stalled> " quit
350 . set remainingT=remainingT#86400
351 . new hours set hours=remainingT\3600 ;"3600 sec per hour
352 . set remainingT=remainingT#3600
353 . new mins set mins=remainingT\60 ;"60 sec per min
354 . new secs set secs=(remainingT#60)\1
355 . if days>0 set timeStr=timeStr_days_"d, "
356 . if hours>0 set timeStr=timeStr_hours_"h:"
357 . if (min=0)&(secs=0) do
358 . . set timeStr=" "
359 . else do
360 . . set timeStr=timeStr_mins_":"
361 . . if secs<10 set timeStr=timeStr_"0"
362 . . set timeStr=timeStr_secs_" "
363 . if delta<0 set timeStr="+"_timeStr ;"just report # sec's overrun.
364 else set timeStr="?? Time"
365
366 set width=width-$length(label)-($length(timeStr)+1)
367 set premark=(width*pct)\1
368 set postmark=width-premark
369
370 if (max-min)=0 set pct=0
371 else set pct=(value-min)/(max-min)
372 if pct>1 set pct=1
373 if pct<0 set pct=0
374 if (pct<1)&($get(startTime)="") set startTime=$H
375
376
377 write label,":"
378 if pct<1 write " "
379 if pct<0.1 write " "
380 write (pct*100)\1,"% "
381 for i=0:1:premark-1 do
382 . if (barberPole+i)#4=0 write "~"
383 . else write "-"
384 write ">|"
385 for i=1:1:(postmark-1) write "-"
386 if postmark>0 write "| "
387 write timeStr
388
389 goto PBD1
390
391Spin1
392 new spinBar set spinBar=+$get(@pRefCt@("SPIN BAR"))
393 new spinDir set spinDir=+$get(@pRefCt@("SPIN BAR","DIR")) ;"1=forward, -1=backwards
394 if spinDir=0 set spinDir=1
395 set spinBar=spinBar+spinDir
396 if spinBar>100 do
397 . set spinDir=-1
398 . set spinBar=100
399 if spinBar<0 do
400 . set spinDir=1
401 . set spinBar=0
402 set @pRefCt@("SPIN BAR")=spinBar
403 set @pRefCt@("SPIN BAR","DIR")=spinDir
404 set @pRefCt@("SPIN BAR","LAST INC")=$H
405
406 new marker set marker="<=>"
407 set width=width-$length(label)-$length(marker)
408 set pct=spinBar/100
409 set premark=(width*pct)\1
410 set postmark=width-premark
411
412 write label," |"
413 for i=0:1:premark-1 write "-"
414 write marker
415 for i=1:1:(postmark-1) write "-"
416 if pct<1 write "-"
417 write "|"
418
419PBD1
420 ;"write $char(13) set $X=0
421 write !
422 do CUU^TMGTERM(1)
423
424PBDone
425 do ;"Turn cursor display back on.
426 . ;"new $etrap set $etrap=""
427 . ;"xecute ^%ZOSF("TRMON")
428 . ;"U $I:(TERMINATOR=$C(13,127))
429
430 ;"new discard set discard=$get(@NakedRef) ;"reset naked reference.
431 quit
432
433PRESSTOCONT ;" Alternative entry point
434PressToCont ;
435 ;"Purpose: to provide a 'press key to continue' action
436 ;"result: none
437 ;"Output: will set TMGPTCABORT=1 if user entered ^
438
439 write "----- Press Key To Continue -----"
440 new ch set ch=$$KeyPressed^TMGUSRIF(0,240)
441 if (ch=94) set TMGPTCABORT=1 ;"set abort user entered ^
442 else kill TMGPTCABORT
443 write !
444 quit
445
446
447UserAborted(AbortLabel)
448 ;"Purpose: Checks if user pressed ESC key. If so, then ask if abort wanted
449 ;"Note: return is immediate.
450 ;"Returns: 1 if user aborted, 0 if not.
451
452 new result set result=0
453 if $$KeyPressed=27 do
454 . new % set %=2
455 . write !,"Abort"
456 . if $get(AbortLabel)'="" do
457 . . write " "_AbortLabel
458 . do YN^DICN write !
459 . set result=(%=1)
460
461 quit result
462
463
464KeyPressed(wantChar,waitTime)
465 ;"Purpose: to check for a keypress
466 ;"Input: wantChar -- OPTIONAL, if 1, then Character is returned, not ASCII value
467 ;" waitTime -- OPTIONAL, default is 0 (immediate return)
468 ;"Result: ASCII value of key, if pressed, -1 otherwise ("" if wantChar=1)
469 ;"Note: this does NOT wait for user to press key
470
471 new temp
472 set waitTime=$get(waitTime,0)
473 read *temp:waitTime
474 if $get(wantChar)=1 set temp=$char(temp)
475 quit temp
476
477
478Read(Terminators,timeOut,Num,initialVal,EscKey)
479 ;"Purpose: a custom read function with custom terminators
480 ;"Input: Terminators -- OPTIONAL Flags to specify characters that will signal that
481 ;" the user is done with input. Flags as follows:
482 ;" r = return/enter
483 ;" t = tab
484 ;" s = space
485 ;" e = escape
486 ;" b = backspace
487 ;" NONE = no terminators
488 ;" e.g. 'rte' means that if user enters a return, tab, or escape
489 ;" then input it ended, and characters (up to, but not including
490 ;" terminator) entered are returned.
491 ;" e.g. 'NONE' --> NO terminators. NOTE: MUST supply a number
492 ;" characters to read, or endless loop will result.
493 ;" If Terminator="", then default value of 'r' is used
494 ;" timeOut -- Optional -- the allowed lengh of time to wait before timeout.
495 ;" default value is 999,999 seconds (~11 days)
496 ;" Num -- OPTIONAL -- a number of characters to read, e.g. 5 to read just
497 ;" 5 characters (or less than 5 if terminator encountered)
498 ;" initialVal-- OPTIONAL -- This can be a value that presents the output
499 ;" It also allows editing of former inputs. Note: this function
500 ;" assumes that initialValue has been printed to the screen before
501 ;" calling this function.
502 ;" EscKey-- OPTIONAL -- PASS BY REFERENCE, an OUT PARAMETER
503 ;" if Terminator includes "e", then EscKey will be filled
504 ;" with a translated value for esc sequence, e.g. UP
505 ;" (as found in ^XUTL("XGKB",*))
506 ;"
507 ;"Result: returns characters read.
508
509 new result set result=$get(initialVal)
510 new tmgZB
511 set timeOut=+$get(timeOut,999999)
512 new len set len=0
513 set Num=$get(Num)
514 set Terminators=$get(Terminators)
515 if Terminators="" set Terminators="r"
516 else if Terminators="NONE" set Terminators=""
517 new temp
518 new done set done=0
519 set EscKey=""
520
521 ;"NOTE, I could rewrite this to use built in terminators functions...
522 ;"e.g. U $I:(TERMINATOR=$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,127))"
523
524RLoop xecute ^%ZOSF("EOFF") ;"echo off
525 if Terminators["e" use $I:ESCAPE
526 read *temp:timeOut ;"reads the ascii number of key (92, instead of 'a')
527 set tmgZB=$ZB
528 ;"write " $l(tmgZB)=",$l(tmgZB)," tmgZB=" f i=1:1:$l(tmgZB) w $ascii($E(tmgZB,i)),","
529 if Terminators["e" use $I:NOESCAPE
530 xecute ^%ZOSF("EON")
531 if (temp=13)&(Terminators["r") do
532 . set done=1
533 else if (temp=9)&(Terminators["t") do
534 . set done=1
535 else if (temp=32)&(Terminators["s") do
536 . set done=1
537 else if (temp=27)&(Terminators["e") do
538 . set EscKey=$get(^XUTL("XGKB",tmgZB))
539 . if EscKey="" do
540 . . do FixEscTable
541 . . set EscKey=$get(^XUTL("XGKB",tmgZB))
542 . set done=1
543 else if (temp=127)&(Terminators["b") do
544 . set done=1
545 else if (temp'=-1) do
546 . if temp=127 do quit
547 . . if result="" quit
548 . . set result=$extract(result,1,$length(result)-1)
549 . . write $char(8)," ",$char(8)
550 . set result=result_$char(temp)
551 . write $char(temp)
552 . if Num="" quit
553 . if $length(result)'<+Num set done=1
554
555 if 'done goto RLoop
556
557 quit result
558
559FixEscTable
560 ;"Purpose: There is a difference between my old system and the new. I
561 ;" don't know why, but this will fix it for me, and anyone else.
562T1 ;;$C(1))="^A"
563 ;;$C(2))="^B"
564 ;;$C(3))="^C"
565 ;;$C(4))="^D"
566 ;;$C(5))="^E"
567 ;;$C(6))="^F"
568 ;;$C(7))="^G"
569 ;;$C(8))="^H"
570 ;;$C(9))="TAB"
571 ;;$C(10))="^J"
572 ;;$C(11))="^K"
573 ;;$C(12))="^L"
574 ;;$C(13))="CR"
575 ;;$C(14))="^N"
576 ;;$C(15))="^O"
577 ;;$C(16))="^P"
578 ;;$C(17))="^Q"
579 ;;$C(18))="^R"
580 ;;$C(19))="^S"
581 ;;$C(20))="^T"
582 ;;$C(21))="^U"
583 ;;$C(22))="^V"
584 ;;$C(23))="^W"
585 ;;$C(24))="^X"
586 ;;$C(25))="^Y"
587 ;;$C(26))="^Z"
588 ;;$C(27)_"OM")="KPENTER"
589 ;;$C(27)_"OP")="PF1"
590 ;;$C(27)_"OQ")="PF2"
591 ;;$C(27)_"OR")="PF3"
592 ;;$C(27)_"OS")="PF4"
593 ;;$C(27)_"Ol")="KP+"
594 ;;$C(27)_"Om")="KP-"
595 ;;$C(27)_"On")="KP."
596 ;;$C(27)_"Op")="KP0"
597 ;;$C(27)_"Oq")="KP1"
598 ;;$C(27)_"Or")="KP2"
599 ;;$C(27)_"Os")="KP3"
600 ;;$C(27)_"Ot")="KP4"
601 ;;$C(27)_"Ou")="KP5"
602 ;;$C(27)_"Ov")="KP6"
603 ;;$C(27)_"Ow")="KP7"
604 ;;$C(27)_"Ox")="KP8"
605 ;;$C(27)_"Oy")="KP9"
606 ;;$C(27)_"[15~")="F5"
607 ;;$C(27)_"[17~")="F6"
608 ;;$C(27)_"[18~")="F7"
609 ;;$C(27)_"[19~")="F8"
610 ;;$C(27)_"[1~")="FIND"
611 ;;$C(27)_"[20~")="F9"
612 ;;$C(27)_"[21~")="F10"
613 ;;$C(27)_"[23~")="F11"
614 ;;$C(27)_"[24~")="F12"
615 ;;$C(27)_"[25~")="F13"
616 ;;$C(27)_"[26~")="F14"
617 ;;$C(27)_"[28~")="HELP"
618 ;;$C(27)_"[29~")="DO"
619 ;;$C(27)_"[2~")="INSERT"
620 ;;$C(27)_"[31~")="F17"
621 ;;$C(27)_"[32~")="F18"
622 ;;$C(27)_"[33~")="F19"
623 ;;$C(27)_"[34~")="F20"
624 ;;$C(27)_"[3~")="REMOVE"
625 ;;$C(27)_"[4~")="SELECT"
626 ;;$C(27)_"[5~")="PREV"
627 ;;$C(27)_"[6~")="NEXT"
628 ;;$C(27)_"[A")="UP"
629 ;;$C(27)_"[B")="DOWN"
630 ;;$C(27)_"[C")="RIGHT"
631 ;;$C(27)_"[D")="LEFT"
632 ;;$C(28))="^\"
633 ;;$C(29))="^]"
634 ;;$C(30))="^6"
635 ;;$C(31))="^_"
636 ;;#DONE#
637 ;
638 new i,s
639 for i=0:1 do quit:(s["#DONE#")
640 . set s=$TEXT(T1+i^TMGUSRIF)
641 . quit:(s["#DONE#")
642 . set s=$piece(s,";;",2)
643 . new x set x="s ^XUTL(""XGKB"","_s
644 . write x,!
645 . xecute x
646 quit
647
648IENSelector(pIENArray,pResults,File,Fields,Widths,Header,SortFlds,SaveArray)
649 ;"Purpose: to allow selecting records from an IEN array
650 ;"Input: pIENArray, PASS BY NAME. An array of IENS to select from
651 ;" format:
652 ;" @pIENArray@(IEN)=""
653 ;" @pIENArray@(IEN)=""
654 ;" @pIENArray@(IEN,"SEL")="" ;"<-- Optional marker to have this preselected
655 ;" pResults -- NAME OF array to have results returned in
656 ;" ** Note: Prior contents of array WILL be KILLED first
657 ;" Format of returned array: Only those valuse that user selected will
658 ;" be aded to list
659 ;" @pResults@(IEN)=DisplayLineNumber
660 ;" @pResults@(IEN)=DisplayLineNumber
661 ;" File: The file number that IEN's are from.
662 ;" Fields: OPTIONAL. The Field(s) that should be shown for record. .01 is Default
663 ;" Fields may also be a ';' delimited list of Fields, e.g. ".01;.02;1".
664 ;" Widths: Optional. The widths of the columns to display Fields in.
665 ;" Format: e.g. "10;12;24" for three colums of widths:
666 ;" Sequence must match sequence given in Fields
667 ;" Default is to evenly space colums
668 ;" Header -- OPTIONAL -- A header text to show.
669 ;" SortFlds -- OPTIONAL -- Provide sorting fields
670 ;" Format: 'FldNum1;FldNum2;FldNum3...'
671 ;" SaveArray -- OPTIONAL -- PASS BY REFERENCE,
672 ;" This variable will be filled with the NAME of the array
673 ;" used for displaying the array. The FIRST time this function
674 ;" is called, this variable should = "". On SUBSEQUENT calls,
675 ;" if this variable holds the name of a variable (a reference), then
676 ;" that array will be used, rather than taking the time to create
677 ;" the display array again. Format of array:
678 ;" @SaveArray(LineNumber)=IEN_$C(9)_Field1_"|"_Field2...
679 ;" @SaveArray(LineNumber)=IEN_$C(9)_Field1_"|"_Field2...
680 ;" Note: The LineNumber is the same number as the DisplayLineNumber
681 ;" returned in @pResults@(IEN)=DisplayLineNUmber
682 ;"Results: none
683
684 if $get(pResults)'="" kill @pResults
685 new PreSelArray
686 new ref
687 if $get(SaveArray)="" do
688 . set ref=$name(^TMP("VEE",$J))
689 . kill @ref
690 . set SaveArray=ref
691 else do goto IS1 ;"Skip recreating array if SaveArray holds reference
692 . set ref=SaveArray
693
694 new ref2 set ref2=$name(^TMG("TMP",$J,"IEN-SELECT"))
695 kill @ref2
696 if $get(Header)'="" set @ref@("HD")=Header
697 set Sort=$get(Sort,0)
698 set IOM=$get(IOM,80)
699 set Fields=$get(Fields,".01")
700 set Widths=$get(Widths)
701 new Sort set Sort=($data(SortFlds)'=0)
702 set File=$get(File)
703 ;"Setup FldArray. Format:
704 ;" FldArray=number of colums
705 ;" FldArray(Sequence#)=field;fieldWidth
706 ;" FldArray(Sequence#)=field;fieldWidth
707 ;" FldArray(Sequence#)=field;fieldWidth
708 new FldArray,i
709 set FldArray=0
710 new WRemain set WRemain=IOM
711 for i=1:1:$length(Fields,";") do
712 . new Fld,W
713 . set Fld=$piece(Fields,";",i)
714 . if Fld="" quit
715 . set W=+$piece(Widths,";",i)
716 . if W=0 do
717 . . if FldArray>0 set W=IOM/FldArray
718 . . else set W=20 ;"some arbitrary number
719 . if W>WRemain set W=WRemain ;"this isn't perfect
720 . set WRemain=WRemain-W
721 . if WRemain<1 set WRemain=1
722 . set FldArray(i)=Fld_";"_W
723 . set FldArray=FldArray+1
724
725 new Itr,IEN,name,PriorErrorFound
726 new abort set abort=0
727 new order set order=1
728 new IENPreSelected
729 write "Prepairing list to display..."
730 set IEN=$$ItrAInit^TMGITR(pIENArray,.Itr)
731 do PrepProgress^TMGITR(.Itr,100,0,"IEN")
732 write !
733 if IEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN)="")!(abort=1)
734 . new TMGOUT,TMGMSG,IENS,showS,i
735 . set showS=""
736 . set IENS=IEN_","
737 . new tempFields
738 . set IENPreSelected=($data(@pIENArray@(IEN,"SEL"))>0)
739 . new i for i=1:1:FldArray do
740 . . if showS'="" set showS=showS_"|"
741 . . new Fld,tempS
742 . . set Fld=$piece(FldArray(i),";",1)
743 . . set tempS=$$GET1^DIQ(File,IENS,Fld,,"TMGOUT","TMGMSG")
744 . . if $piece($get(^DD(File,Fld,0)),"^",2)["D" do ;"format dates for sorting if in column 1
745 . . . new %DT,X,Y
746 . . . set X=tempS
747 . . . do ^%DT ;"X in, Y out
748 . . . set tempS=$$DTFormat^TMGMISC(Y,"yyyy mm/dd") ;"make dates sort numerically
749 . . if $data(TMGMSG("DIERR")) do set abort=1 quit
750 . . . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound)
751 . . new W set W=$piece(FldArray(i),";",2)
752 . . set tempS=$extract(tempS,1,W)
753 . . if Sort set tempFields(Fld)=tempS
754 . . set showS=showS_$$LJ^XLFSTR(tempS,W," ")
755 . if Sort=0 do
756 . . set @ref@(order)=IEN_$char(9)_showS
757 . . if IENPreSelected set PreSelArray(order)=""
758 . . set order=order+1
759 . else do
760 . . new tempRef set tempRef=ref2
761 . . for i=1:1:$length(SortFlds,";") do
762 . . . new oneFld set oneFld=$piece(SortFlds,";",i)
763 . . . new F set F=$get(tempFields(oneFld))
764 . . . if F="" quit
765 . . . set tempRef=$name(@tempRef@(F))
766 . . set @tempRef@(IEN)=IEN_$char(9)_showS
767 . . if IENPreSelected set @tempRef@(IEN,"SEL")=""
768 . . ;"Sets up sorted variable as follows:
769 . . ;" @tempRef@(sortFld1,sortFld2,sortFld3,IEN)='IEN_$char(9)_showS'
770 . . ;" @tempRef@(sortFld1,sortFld2,sortFld3,IEN)='IEN_$char(9)_showS'
771 . . ;" @tempRef@(sortFld1,sortFld2,sortFld3,IEN)='IEN_$char(9)_showS'
772 do ProgressDone^TMGITR(.Itr)
773 write !
774
775 if abort=1 goto ISDone
776
777IES1 if Sort=1 do
778 . write "Sorting... "
779 . set order=1
780 . new tempRef2 set tempRef2=ref2
781 . new showS,NumNodes,Done
782 . set Done=0
783 . for do quit:(tempRef2="")!(Done=1)
784 . . set tempRef2=$query(@tempRef2)
785 . . if (tempRef2="") quit
786 . . if $qsubscript(tempRef2,$qlength(tempRef2))="SEL" do quit
787 . . . set PreSelArray(order-1)=""
788 . . if (tempRef2'[$$OREF^DILF(ref2)) set Done=1 quit
789 . . set showS=$get(@tempRef2)
790 . . set @ref@(order)=showS
791 . . set order=order+1
792
793 ;"Note: Rules of use:
794 ;" ref must=^TMP("VEE",$J)
795 ;" Each line should be in this format:
796 ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue
797 ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue
798 ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue
799 ;" Note: if DisplayValue is to be divided into colums, then
800 ;" use | character to separate
801 ;" @ref@("HD")=Header to display
802 ;" Results come back in:
803 ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue
804 ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue
805 ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue
806 ;" To preselect entries, provide an array like this:
807 ;" array(number)="" <-- number is same number as above, shows selected
808 ;" array(number)=""
809 ;" array(number)=""
810 ;" pass array by name: SELECT^%ZVEMKT(ref,,"array")
811IS1
812 new NumberLines set NumberLines=0 ;"1--> number each line
813 new AddNew set AddNew=0 ;"1-> Allow adding new entry
814
815 write "Passing off to selector..."
816 D SELECT^%ZVEMKT(ref,NumberLines,AddNew,"PreSelArray")
817
818 ;"Format results
819 new Itr2,index
820 set index=$$ItrAInit^TMGITR($name(^TMP("VPE","SELECT",$J)),.Itr2)
821 if index'="" for do quit:($$ItrANext^TMGITR(.Itr2,.index)="")
822 . new s set s=$piece($get(^TMP("VPE","SELECT",$J,index)),$char(9),1)
823 . set @pResults@(s)=index
824
825 kill ^TMP("VPE","SELECT",$J)
826 if $get(ref2) kill @ref2 ;"i.e. ^TMG("TMP",$J,"IEN-SELECT")
827
828ISDone
829 quit
830
831
832Selector(pArray,pResults,Header)
833 ;"Purpose: Interface with VPE Selector code to select from an array
834 ;"Input: pArray -- NAME OF array holding items to be selected from
835 ;" Expected format:
836 ;" @pArray@("Display Choice Words")=ReturnValue <-- ReturnValue is optional
837 ;" @pArray@("Display Choice Words")=ReturnValue
838 ;" @pArray@("Display Choice Words")=ReturnValue
839 ;" @pArray@("Display Choice Words","SEL")="" <-- optional preselection indicator
840 ;" pResults -- NAME OF array to have results returned in
841 ;" ** Note: Prior contents of array will NOT be KILLED first
842 ;" Format of returned array: Only those valuse that user selected will be returned
843 ;" @pResults@("Display Choice Words")=ReturnValue <-- ReturnValue is optional
844 ;" @pResults@("Display Choice Words")=ReturnValue
845 ;" @pResults@("Display Choice Words")=ReturnValue
846 ;" Header -- OPTIONAL -- A header text to show.
847 ;"Results: None
848 new ref set ref=$name(^TMP("VEE",$J))
849 kill @ref
850 if $get(pArray)="" goto SelDone
851 if $get(pResults)="" goto SelDone
852
853 new PreSelArray
854
855 ;"First set up array of options
856 new DispWords,RtnValue
857 new order set order=1
858 set DispWords=$order(@pArray@(""))
859 if DispWords'="" for do quit:(DispWords="")
860 . set RtnValue=$get(@pArray@(DispWords),"<NONE>")
861 . set @ref@(order)=RtnValue_$char(9)_$extract(DispWords,1,$get(IOM,80))
862 . if $data(@pArray@(DispWords,"SEL")) set PreSelArray(order)="" ;"mark as preselected
863 . set order=order+1
864 . set DispWords=$order(@pArray@(DispWords))
865
866 if $get(Header)'="" set @ref@("HD")=Header
867
868 ;"Note: Rules of use:
869 ;" ref must=^TMP("VEE",$J)
870 ;" Each line should be in this format:
871 ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue
872 ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue
873 ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue
874 ;" Note: if DisplayValue is to be divided into colums, then
875 ;" use | character to separate
876 ;" Results come back in:
877 ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue
878 ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue
879 ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue
880 ;" To preselect entries, provide an array like this:
881 ;" array(number)="" <-- number is same number as above, shows selected
882 ;" array(number)=""
883 ;" array(number)=""
884 ;" pass array by name: SELECT^%ZVEMKT(ref,,"array")
885
886 new NumberLines set NumberLines=0 ;"1--> number each line
887 new AddNew set AddNew=0 ;"1-> Allow adding new entry
888
889 D SELECT^%ZVEMKT(ref,NumberLines,AddNew,"PreSelArray")
890
891 ;"Format selected options.
892 new index set index=$order(^TMP("VPE","SELECT",$J,""))
893 if index'="" for do quit:(index="")
894 . new s,s1,s2
895 . set s=$get(^TMP("VPE","SELECT",$J,index))
896 . set s1=$piece(s,$char(9),1)
897 . set s2=$piece(s,$char(9),2)
898 . set @pResults@(s2)=s1
899 . set index=$order(^TMP("VPE","SELECT",$J,index))
900
901 kill ^TMP("VPE","SELECT",$J)
902 kill @ref
903
904SelDone
905 quit
906
907
908Slctor2(pArray,pResults,Header)
909 ;"Purpose: Interface with VPE Selector code to select from an array
910 ;" Note: This allows a different format of input. In Selector() above,
911 ;" it is NOT possible to have two similar Display Words with
912 ;" different return values. E.g. two drugs with LISINOPRIL, but
913 ;" different IEN return values. This fn allows this
914 ;"Input: pArray -- NAME OF array holding items to be selected from
915 ;" Expected format:
916 ;" @pArray@("Display Choice Words",ReturnValue)="" <-- return value IS required
917 ;" @pArray@("Display Choice Words",ReturnValue)=""
918 ;" @pArray@("Display Choice Words",ReturnValue)=""
919 ;" @pArray@("Display Choice Words",ReturnValue,"SEL")="" <-- optional preselection indicator
920 ;" pResults -- NAME OF array to have results returned in
921 ;" ** Note: Prior contents of array will NOT be KILLED first
922 ;" Format of returned array: Only those values that user selected will be returned
923 ;" @pResults@("Display Choice Words",ReturnValue)=""
924 ;" @pResults@("Display Choice Words",ReturnValue)=""
925 ;" @pResults@("Display Choice Words",ReturnValue)=""
926 ;" Header -- OPTIONAL -- A header text to show.
927
928 new ref set ref=$name(^TMP("VEE",$J))
929 kill @ref
930 if $get(pArray)="" goto Sl2Done
931 if $get(pResults)="" goto Sl2Done
932
933 new PreSelArray
934
935 ;"First set up array of options
936 new DispWords,RtnValue
937 new order set order=1
938 set DispWords=""
939 for set DispWords=$order(@pArray@(DispWords)) quit:(DispWords="") do
940 . set RtnValue=""
941 . for set RtnValue=$order(@pArray@(DispWords,RtnValue)) quit:(RtnValue="") do
942 . . set @ref@(order)=RtnValue_$char(9)_$extract(DispWords,1,$get(IOM,80))
943 . . if $data(@pArray@(DispWords,RtnValue,"SEL")) set PreSelArray(order)="" ;"mark as preselected
944 . . set order=order+1
945
946 if $get(Header)'="" set @ref@("HD")=Header
947
948 ;"Note: Rules of use:
949 ;" ref must=^TMP("VEE",$J)
950 ;" Each line should be in this format:
951 ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue
952 ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue
953 ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue
954 ;" Note: if DisplayValue is to be divided into colums, then
955 ;" use | character to separate
956 ;" Results come back in:
957 ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue
958 ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue
959 ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue
960 ;" To preselect entries, provide an array like this:
961 ;" array(number)="" <-- number is same number as above, shows selected
962 ;" array(number)=""
963 ;" array(number)=""
964 ;" pass array by name: SELECT^%ZVEMKT(ref,,"array")
965
966 new NumberLines set NumberLines=0 ;"1--> number each line
967 new AddNew set AddNew=0 ;"1-> Allow adding new entry
968
969 D SELECT^%ZVEMKT(ref,NumberLines,AddNew,"PreSelArray")
970
971 ;"Format selected options.
972 new index set index=$order(^TMP("VPE","SELECT",$J,""))
973 if index'="" for do quit:(index="")
974 . new s,s1,s2
975 . set s=$get(^TMP("VPE","SELECT",$J,index))
976 . set s1=$piece(s,$char(9),1)
977 . set s2=$piece(s,$char(9),2)
978 . set @pResults@(s2,s1)=""
979 . set index=$order(^TMP("VPE","SELECT",$J,index))
980
981 kill ^TMP("VPE","SELECT",$J)
982 kill @ref
983
984Sl2Done
985 quit
986
987
988
989MENU(Options,defChoice,UserRaw)
990 QUIT $$Menu(.Options,.defChoice,.UserRaw)
991
992Menu(Options,defChoice,UserRaw)
993 ;"Purpose: to provide a simple menuing system
994 ;"Input: Options -- PASS BY REFERENCE
995 ;" Format:
996 ;" Options(0)=Header Text <--- optional, default is MENU
997 ;" Options(DispNumber)=MenuText_$C(9)_ReturnValue <-- _$C(9)_ReturnValue OPTIONAL, default is DispNumber
998 ;" Options(DispNumber)=MenuText_$C(9)_ReturnValue
999 ;" Options(DispNumber)=MenuText_$C(9)_ReturnValue
1000 ;" defChoice: OPTIONAL, the default menu value
1001 ;" UserRaw : OPTIONAL, PASS BY REFERENCE, an OUT PARAMETER. Returns users raw input
1002 ;"Results: The selected ReturnValue (or DispNumber if no ReturnValue provided), or ^ for abort
1003
1004 new result set result="^"
1005 new s,fg,bg
1006 new width set width=50
1007 new line set $piece(line,"=",width+1)=""
1008MNU1
1009 if $data(Options(-1,"COLOR")) do
1010 . set fg=$get(Options(-1,"COLOR","fg"),0)
1011 . set bg=$get(Options(-1,"COLOR","bg"),1)
1012 . do VCOLORS^TMGTERM(fg,bg)
1013 write line,!
1014 write $get(Options(0),"MENU"),$$Pad2Pos^TMGSTUTL(width),!
1015 write line,!
1016 write "Options:",$$Pad2Pos^TMGSTUTL(width),!
1017
1018 new DispNumber set DispNumber=$order(Options(0))
1019 if DispNumber'="" for do quit:(DispNumber="")
1020 . set s=$get(Options(DispNumber))
1021 . write $$RJ^XLFSTR(DispNumber,4),".",$$Pad2Pos^TMGSTUTL(6)
1022 . if $data(Options(DispNumber,"COLOR")) do
1023 . . set fg=$get(Options(DispNumber,"COLOR","fg"),0)
1024 . . set bg=$get(Options(DispNumber,"COLOR","bg"),1)
1025 . . do VCOLORS^TMGTERM(fg,bg)
1026 . write $piece(s,$char(9),1),$$Pad2Pos^TMGSTUTL(width-1)
1027 . if $data(Options(DispNumber,"COLOR")) do
1028 . . do VTATRIB^TMGTERM(0) ;"Reset colors
1029 . write " ",!
1030 . set DispNumber=$order(Options(DispNumber))
1031
1032 write line,!
1033
1034 set defChoice=$get(defChoice,"^")
1035 new input
1036 write "Enter selection (^ to abort): ",defChoice,"// "
1037 read input:$get(DTIME,3600),!
1038 if input="" set input=defChoice
1039 set UserRaw=input
1040 if input="^" goto MNUDone
1041
1042 set s=$get(Options(input))
1043 if s="" set s=$get(Options($$UP^XLFSTR(input)))
1044 ;"if s="" write "??",!! goto MNU1
1045 set result=$piece(s,$char(9),2)
1046 if result="" set result=input
1047
1048MNUDone
1049 if $data(Options(-1,"COLOR")) do VTATRIB^TMGTERM(0) ;"Reset colors
1050 quit result
1051
1052
1053ProgTest
1054 ;"Purpose: test progress bar.
1055 new i,u,max
1056 set max=100
1057 for i=0:1:max do
1058 . do ProgressBar(i,"%",1,max)
1059 . hang 0.25
1060 quit
1061
1062
1063SpinTest
1064 ;"Purpose: test progress bar.
1065 new i,u,max
1066 set max=3000
1067 for i=0:10:max do
1068 . do ProgressBar(i,"<A Label> "_i,-1,-1)
1069 . hang 0.1
1070 quit
1071
1072
1073Scroller(pArray,Option)
1074 ;"Purpose: Provide a scroll box
1075 ;"Input: pArray -- PASS BY NAME. format:
1076 ;" @pArray@(1,DisplayText)=Return Text <-- note: must be numbered 1,2,3 etc.
1077 ;" @pArray@(2,DisplayText)=Return Text
1078 ;" @pArray@(3,DisplayText)=Return Text
1079 ;" NOTE: if Display text contains {{name}} then name is taken as color directive
1080 ;" Example: 'Here is {{BOLD}}something{{NORM}} to see.'
1081 ;" if NAME is not defined in Option("COLORS",NAME), it is ignored
1082 ;" Option -- PASS BY REFERENCE. format:
1083 ;" Option("HEADER",1)=Header line text
1084 ;" Option("HEADER",2)=More Header line text (any number of lines)
1085 ;" Option("FOOTER",1)=Footer line text <--- Option 1
1086 ;" Option("FOOTER",1,1)=linePart <--- Option 2 (these will be all strung together to make one footer line.
1087 ;" Option("FOOTER",1,2)=linePart (can be used to display switches etc)
1088 ;" Option("FOOTER",2)=More footer line text (any number of lines)
1089 ;" Option("SHOW INDEX")=1 Optional. If 1, then index is shown.
1090 ;" Option("SCRN WIDTH")= Optional screen width. (default is terminal width)
1091 ;" ---- Colors (optional) ------
1092 ;" Option("COLORS","NORM")=FG^BG -- default foreground (FG) and background(colors)
1093 ;" If not provided, White on Blue used.
1094 ;" Option("COLORS","HIGH")=FG^BG -- Highlight colors. If not provided, White on Cyan used.
1095 ;" Option("COLORS","HEADER")=FG^BG Header color. NORM used if not provided
1096 ;" Option("COLORS","FOOTER")=FG^BG Footer color. NORM used if not provided
1097 ;" Option("COLORS","TOP LINE")=FG^BG Top line color. NORM used if not provided
1098 ;" Option("COLORS","BOTTOM LINE")=FG^BG Bottom line color. NORM used if not provided
1099 ;" Option("COLORS","INDEX")=FG^BG Index color. NORM used if not provided
1100 ;" Option("COLORS",SomeName)=FG^BG e.g. :
1101 ;" Option("COLORS","BOLD")=15^0 (Any arbitrary name OK, matched to {{name}} in text)
1102 ;" Option("COLORS","HIGH")=10^@
1103 ;" If BG="@", then default BG used. This may be used anywhere except for defining NORM
1104 ;" ---- events ----
1105 ;" Option("ON SELECT")="FnName^Module" -- code to call based on user input
1106 ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line
1107 ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line
1108 ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line
1109 ;" Option("ON CHANGING")="FnName^Module" -- code to execute for number entry
1110 ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line
1111 ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line
1112 ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line
1113 ;" Info("NEXT LINE","NUMBER")=next line number. Used for ON CHANGING to show the line about to be selected
1114 ;" Info("ALLOW CHANGE")=1, <--- RETURN RESULT. Change to 0 to disallow move.
1115 ;" Option("ON CMD")="FnName^Module" -- code to execute for number entry
1116 ;" Info("USER INPUT")=UserTypedInput
1117 ;" NOTES about events. Functions will be called as follows:
1118 ;" do FnName^Module(pArray,.Option,.Info)
1119 ;" pArray and Option are the same data received by this function
1120 ;" -- thus Option can be used to can other custom information.
1121 ;" Info has extra info as outlined above.
1122 ;" If functions may set a globally-scoped var named TMGSCLRMSG to communicate back
1123 ;" if TMGSCLRMSG="^" then Scroller will exit
1124 ;"Result: none
1125
1126 new scrnW,scrnH,scrnLine,spaceLine,topLine,sizeHdr,sizeFtr
1127 new entryCt,lineCt,EscKey,dispHt,highLine,showIdx
1128 new needRefresh,Info
1129 set topLine=1
1130 set highLine=5
1131 new TMGSCLRMSG set TMGSCLRMSG=""
1132
1133 set scrnW=+$get(Option("SCRN WIDTH"))
1134 if scrnW'>0 do
1135 . if $$GetScrnSize^TMGKERNL(,.scrnW)
1136 . set scrnW=+scrnW-4
1137 if scrnW'>0 set scrnW=$get(IOM,66)-2
1138 ;"set scrnW=$get(IOM,60)-2
1139 set scrnH=$get(IOSL,25)-2
1140
1141 if $get(Option("COLORS","NORM"))="" set Option("COLORS","NORM")="14^4" ;"white on blue
1142 if $get(Option("COLORS","HIGH"))="" set Option("COLORS","HIGH")="14^6" ;"white on cyan
1143 if $get(Option("COLORS","HEADER"))="" set Option("COLORS","HEADER")=Option("COLORS","NORM")
1144 if $get(Option("COLORS","FOOTER"))="" set Option("COLORS","FOOTER")=Option("COLORS","NORM")
1145 if $get(Option("COLORS","TOP LINE"))="" set Option("COLORS","TOP LINE")=Option("COLORS","NORM")
1146 if $get(Option("COLORS","BOTTOM LINE"))="" set Option("COLORS","BOTTOM LINE")=Option("COLORS","NORM")
1147 if $get(Option("COLORS","INDEX"))="" set Option("COLORS","INDEX")=Option("COLORS","NORM")
1148
1149 new i set i=""
1150 for set i=$order(Option("COLORS",i)) quit:(i="") do
1151 . new colors set colors=$get(Option("COLORS",i))
1152 . new FG set FG=$piece(colors,"^",1) if FG="" set FG=0
1153 . new BG set BG=$piece(colors,"^",2) if BG="" set BG=1
1154 . set Option("COLORS",i,"FG")=FG
1155 . set Option("COLORS",i,"BG")=BG
1156
1157Full set scrnLine="" set $piece(scrnLine,"-",scrnW)="-"
1158 set spaceLine="" set $piece(spaceLine," ",scrnW)=" "
1159 set sizeHdr=$$ListCt^TMGMISC($name(Option("HEADER")))+1
1160 set sizeFtr=$$ListCt^TMGMISC($name(Option("FOOTER")))+1
1161 set entryCt=$$ListCt^TMGMISC(pArray)
1162 set EscKey=""
1163 set dispHt=scrnH-sizeHdr-sizeFtr
1164 if topLine>entryCt set topLine=entryCt
1165 if highLine>entryCt set highLine=entryCt
1166 set showIdx=($get(Option("SHOW INDEX"))=1)
1167
1168Draw do HOME^TMGTERM
1169 if $data(Option("HEADER")) do
1170 . do SetColor("HEADER",.Option)
1171 . new i set i=""
1172 . for set i=$order(Option("HEADER",i)) quit:(i="") do
1173 . . write $$CJ^XLFSTR($get(Option("HEADER",i)),scrnW),!
1174 set lineCt=topLine
1175
1176 ;"do VCOLORS^TMGTERM(14,4) ;"bright white on blue background
1177 do SetColor("TOP LINE",.Option)
1178 write scrnLine,!
1179 do SetColor("NORM",.Option)
1180 for quit:(lineCt=(dispHt+topLine-1)) do
1181 . ;"if lineCt=highLine do VCOLORS^TMGTERM(14,6) ;"bright white on cyan background
1182 . ;"else do VCOLORS^TMGTERM(14,4) ;"bright white on blue background
1183 . if lineCt=highLine do SetColor("HIGH",.Option)
1184 . else do SetColor("NORM",.Option)
1185 . new s set s=""
1186 . if showIdx do
1187 . . do SetColor("INDEX",.Option)
1188 . . write $$RJ^XLFSTR(lineCt,3)_"."
1189 . . if lineCt=highLine do SetColor("HIGH",.Option)
1190 . . else do SetColor("NORM",.Option)
1191 . . write " "
1192 . new text,textA,textB,textColor
1193 . set text=$order(@pArray@(lineCt,""))
1194 . for quit:(text'["{{")!($X'<scrnW) do
1195 . . set textColor=$$ParseColor(.text,.textA) ;" Text --> TextA{{Color}}Text
1196 . . if $X+$length(textA)>scrnW do
1197 . . . write $extract(textA,1,(scrnW-$X-3))_"..."
1198 . . else write textA
1199 . . do SetColor(textColor,.Option)
1200 . write text
1201 . write $extract(spaceLine,1,(scrnW-$X))
1202 . do SetColor("RESET") write !
1203 . ;"if showIdx set s=$$RJ^XLFSTR(lineCt,3)_". "
1204 . ;"set s=$$LJ^XLFSTR(s_$order(@pArray@(lineCt,"")),scrnW)
1205 . ;"if $length(s)>scrnW set s=$extract(s,1,scrnW-3)_"..."
1206 . ;"write s,!
1207 . set lineCt=lineCt+1
1208 ;"do VCOLORS^TMGTERM(14,4) ;"bright white on blue background
1209 do SetColor("BOTTOM LINE",.Option)
1210 write scrnLine,!
1211 do SetColor("FOOTER",.Option)
1212 ;"do VTATRIB^TMGTERM(0) ;"reset colors
1213 if $data(Option("FOOTER")) do
1214 . new i set i=""
1215 . for set i=$order(Option("FOOTER",i)) quit:(i="") do
1216 . . new j set j=$order(Option("FOOTER",i,""))
1217 . . if j'="" do
1218 . . . new oneLine set oneLine="",j=""
1219 . . . for set j=$order(Option("FOOTER",i,j)) quit:(j="") do
1220 . . . . set oneLine=oneLine_$get(Option("FOOTER",i,j))_" | "
1221 . . . write $$LJ^XLFSTR(oneLine,scrnW),!
1222 . . else write $$LJ^XLFSTR($get(Option("FOOTER",i)),scrnW),!
1223
1224 set Info("CURRENT LINE","NUMBER")=highLine
1225 set Info("CURRENT LINE","TEXT")=$order(@pArray@(highLine,""))
1226 set Info("CURRENT LINE","RETURN")=$get(@pArray@(highLine,Info("CURRENT LINE","TEXT")))
1227
1228 do SetColor("RESET")
1229 write $$LJ^XLFSTR(": ",scrnW),!
1230 do CUU^TMGTERM(1) write ": "
1231 set needRefresh=0
1232UsrIn set input=$$Read("re",,,,.EscKey)
1233 if (input="")&(EscKey="") set EscKey="CR"
1234 if EscKey="UP" set input="UP^1"
1235 if EscKey="PREV" set input="UP^15"
1236 if EscKey="DOWN" set input="DOWN^1"
1237 if EscKey="NEXT" set input="DOWN^15"
1238 if EscKey="CR" do goto Lp2
1239 . new codeFn set codeFn=$get(Option("ON SELECT")) quit:(codeFn="")
1240 . set codeFn="do "_codeFn_"(pArray,.Option,.Info)"
1241 . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode="""""
1242 . xecute codeFn
1243 . set needRefresh=2
1244 if input="^" goto ScrlDone
1245 if (input["^") do goto Lp2
1246 . if $piece(input,"^",1)="UP" do
1247 . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode="""""
1248 . . new codeFn set codeFn=$get(Option("ON CHANGING"))
1249 . . if codeFn'="" set codeFn="do "_codeFn_"(pArray,.Option,.Info)"
1250 . . set Info("ALLOW CHANGE")=1
1251 . . set needRefresh=1
1252 . . new j for j=1:1:+$piece(input,"^",2) do
1253 . . . if highLine>topLine do
1254 . . . . set Info("NEXT LINE","NUMBER")=(highLine-1)
1255 . . . . if codeFn'="" xecute codeFn quit:'$get(Info("ALLOW CHANGE")) set needRefresh=2
1256 . . . . set highLine=highLine-1
1257 . . . else if topLine>1 do
1258 . . . . set Info("NEXT LINE","NUMBER")=(topLine-1)
1259 . . . . if codeFn'="" xecute codeFn quit:'$get(Info("ALLOW CHANGE")) set needRefresh=2
1260 . . . . set topLine=topLine-1,highLine=topLine
1261 . else if $piece(input,"^",1)="DOWN" do
1262 . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode="""""
1263 . . new codeFn set codeFn=$get(Option("ON CHANGING"))
1264 . . if codeFn'="" set codeFn="do "_codeFn_"(pArray,.Option,.Info)"
1265 . . set Info("ALLOW CHANGE")=1
1266 . . set needRefresh=1
1267 . . new j for j=1:1:+$piece(input,"^",2) do
1268 . . . if highLine<(topLine+dispHt-2) do
1269 . . . . set Info("NEXT LINE","NUMBER")=(highLine-1)
1270 . . . . if codeFn'="" xecute codeFn quit:'$get(Info("ALLOW CHANGE")) set needRefresh=2
1271 . . . . set highLine=highLine+1
1272 . . . else if (topLine+dispHt-2)<entryCt do
1273 . . . . set Info("NEXT LINE","NUMBER")=(highLine+1)
1274 . . . . if codeFn'="" xecute codeFn quit:'$get(Info("ALLOW CHANGE")) set needRefresh=2
1275 . . . . set topLine=topLine+1,highLine=highLine+1
1276 else if input="=" do
1277 . set needRefresh=2
1278 . new DIR set DIR(0)="N^10:"_IOM
1279 . set DIR("B")=scrnW
1280 . write "Enter Screen Width (# of columns): " do ^DIR write !
1281 . if $data(DIRUT) write # quit
1282 . set scrnW=Y
1283 . set DIR(0)="N^5:"_(IOSL-2)
1284 . set DIR("B")=scrnH
1285 . write "Enter Screen Height (# of rows): " do ^DIR write !
1286 . if $data(DIRUT) write # quit
1287 . set scrnH=Y
1288 . write #
1289 else do
1290 . set needRefresh=1
1291 . if (input="")&(EscKey'="") set input="{"_EscKey_"}"
1292 . new codeFn set codeFn=$get(Option("ON CMD")) quit:(codeFn="")
1293 . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode="""""
1294 . if codeFn'="" set codeFn="do "_codeFn_"(pArray,.Option,.Info)"
1295 . set Info("USER INPUT")=input
1296 . xecute codeFn
1297 . set needRefresh=2
1298
1299Lp2 if TMGSCLRMSG="^" goto ScrlDone
1300 if needRefresh=2 goto Full
1301 if needRefresh=1 goto Draw
1302 goto UsrIn
1303
1304ScrlDone
1305 quit
1306
1307SetColor(Label,Option)
1308 ;"Purpose: to set color, based on Label name. (A utility function for Scroller)
1309 ;"Input: Label -- the name of the color, i.e. NORM, HIGH, etc.
1310 ;" If Label=REST, then special ResetTerminal function called.
1311 ;" Option -- PASS BY REFERENCE. The same option array passed to Scroller, with color info
1312 ;" Specifically used: Option('COLORS',SomeName,'FG')=foregroundColor
1313 ;" Option('COLORS',SomeName,'BG')=backgroundColor
1314 ;"Note: if color label not found, then no color change is made.
1315 ;
1316 if Label="RESET" do VTATRIB^TMGTERM(0) quit ;"reset colors
1317 if $data(Option("COLORS",Label))=0 quit
1318 new FG set FG=$get(Option("COLORS",Label,"FG"),1) ;"default to black
1319 new BG set BG=$get(Option("COLORS",Label,"BG"),0) ;"default to white
1320 if BG="@" set BG=$get(Option("COLORS","NORM","BG"),0) ;"default to white
1321 do VCOLORS^TMGTERM(FG,BG)
1322 quit
1323
1324ParseColor(text,textA)
1325 ;"Purpose: To extract a color code from text
1326 ;"Example: Input text = 'This is {{HIGH}}something{{NORM}} to see.'
1327 ;" Output text = 'something{{NORM}} to see.'
1328 ;" Output textA = 'This is '
1329 ;" function result = 'NORM'
1330 ;"Input: text -- PASS BY REFERENCE
1331 ;" textA -- PASS BY REFERENCE, and OUT PARAMETER
1332 ;"Result: the color name inside brackets.
1333 new s,result
1334 set s=text
1335 set textA=$piece(s,"{{",1)
1336 set result=$piece(s,"{{",2)
1337 set result=$piece(result,"}}",1)
1338 set text=$piece(s,"}}",2,99)
1339 quit result
1340
1341TestScrl
1342 new Array,Option
1343 new i for i=1:1:136 do
1344 . set Array(i,"Line "_i)="Result for "_i
1345 set Option("HEADER",1)=" - < Here is a header line > -"
1346 set Option("FOOTER",1)="Enter ^ to exit"
1347 set Option("ON SELECT")="HndOnSel^TMGUSRIF"
1348 set Option("ON CMD")="HandOnCmd^TMGUSRIF"
1349
1350 set Option("COLORS","NORM")="14^4" ;"white on blue
1351 set Option("COLORS","HIGH")="14^6" ;"white on cyan
1352 set Option("COLORS","HEADER")="14^5"
1353 set Option("COLORS","FOOTER")="14^5"
1354 set Option("COLORS","TOP LINE")="5^1"
1355 set Option("COLORS","BOTTOM LINE")="5^1"
1356 set Option("COLORS","INDEX")="0^1"
1357 set Option("SHOW INDEX")=1
1358
1359 do Scroller("Array",.Option)
1360 quit
1361
1362HndOnSel(pArray,Option,Info) ;"Part of TestScrl
1363 ;"Purpose: handle ON SELECT event from Scroller
1364 ;"Input: pArray,Option,Info -- see documentation in Scroller
1365 ;" Info has this:
1366 ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line
1367 ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line
1368 ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line
1369
1370 write $get(Info("CURRENT LINE","TEXT")),!
1371 do PressToCont
1372 quit
1373
1374
1375HandOnCmd(pArray,Option,Info) ;"Part of TestScrl
1376 ;"Purpose: handle ON SELECT event from Scroller
1377 ;"Input: pArray,Option,Info -- see documentation in Scroller
1378 ;" Info has this:
1379 ;" Info("USER INPUT")=input
1380 ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line
1381 ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line
1382 ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line
1383
1384
1385 write $get(Info("USER INPUT")),!
1386 do PressToCont
1387 quit
Note: See TracBrowser for help on using the repository browser.