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

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

Initial upload
File size: 54.3 KB
Line 
1TMGUSRIF ;TMG/kst/USER INTERFACE API FUNCTIONS ;03/25/06
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 set timeOut=+$get(timeOut,999999)
511 new len set len=0
512 set Num=$get(Num)
513 set Terminators=$get(Terminators)
514 if Terminators="" set Terminators="r"
515 else if Terminators="NONE" set Terminators=""
516 new temp
517 new done set done=0
518 set EscKey=""
519
520 ;"NOTE, I could rewrite this to use built in terminators functions...
521 ;"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))"
522
523RLoop xecute ^%ZOSF("EOFF") ;"echo off
524 if Terminators["e" use $I:ESCAPE
525 read *temp:timeOut ;"reads the ascii number of key (92, instead of 'a')
526 if Terminators["e" use $I:NOESCAPE
527 xecute ^%ZOSF("EON")
528 if (temp=13)&(Terminators["r") do
529 . set done=1
530 else if (temp=9)&(Terminators["t") do
531 . set done=1
532 else if (temp=32)&(Terminators["s") do
533 . set done=1
534 else if (temp=27)&(Terminators["e") do
535 . set EscKey=$get(^XUTL("XGKB",$ZB))
536 . set done=1
537 else if (temp=127)&(Terminators["b") do
538 . set done=1
539 else if (temp'=-1) do
540 . if temp=127 do quit
541 . . if result="" quit
542 . . set result=$extract(result,1,$length(result)-1)
543 . . write $char(8)," ",$char(8)
544 . set result=result_$char(temp)
545 . write $char(temp)
546 . if Num="" quit
547 . if $length(result)'<+Num set done=1
548
549 if 'done goto RLoop
550
551 quit result
552
553
554IENSelector(pIENArray,pResults,File,Fields,Widths,Header,SortFlds,SaveArray)
555 ;"Purpose: to allow selecting records from an IEN array
556 ;"Input: pIENArray, PASS BY NAME. An array of IENS to select from
557 ;" format:
558 ;" @pIENArray@(IEN)=""
559 ;" @pIENArray@(IEN)=""
560 ;" @pIENArray@(IEN,"SEL")="" ;"<-- Optional marker to have this preselected
561 ;" pResults -- NAME OF array to have results returned in
562 ;" ** Note: Prior contents of array WILL be KILLED first
563 ;" Format of returned array: Only those valuse that user selected will
564 ;" be aded to list
565 ;" @pResults@(IEN)=DisplayLineNumber
566 ;" @pResults@(IEN)=DisplayLineNumber
567 ;" File: The file number that IEN's are from.
568 ;" Fields: OPTIONAL. The Field(s) that should be shown for record. .01 is Default
569 ;" Fields may also be a ';' delimited list of Fields, e.g. ".01;.02;1".
570 ;" Widths: Optional. The widths of the columns to display Fields in.
571 ;" Format: e.g. "10;12;24" for three colums of widths:
572 ;" Sequence must match sequence given in Fields
573 ;" Default is to evenly space colums
574 ;" Header -- OPTIONAL -- A header text to show.
575 ;" SortFlds -- OPTIONAL -- Provide sorting fields
576 ;" Format: 'FldNum1;FldNum2;FldNum3...'
577 ;" SaveArray -- OPTIONAL -- PASS BY REFERENCE,
578 ;" This variable will be filled with the NAME of the array
579 ;" used for displaying the array. The FIRST time this function
580 ;" is called, this variable should = "". On SUBSEQUENT calls,
581 ;" if this variable holds the name of a variable (a reference), then
582 ;" that array will be used, rather than taking the time to create
583 ;" the display array again. Format of array:
584 ;" @SaveArray(LineNumber)=IEN_$C(9)_Field1_"|"_Field2...
585 ;" @SaveArray(LineNumber)=IEN_$C(9)_Field1_"|"_Field2...
586 ;" Note: The LineNumber is the same number as the DisplayLineNumber
587 ;" returned in @pResults@(IEN)=DisplayLineNUmber
588 ;"Results: none
589
590 if $get(pResults)'="" kill @pResults
591 new PreSelArray
592 new ref
593 if $get(SaveArray)="" do
594 . set ref=$name(^TMP("VEE",$J))
595 . kill @ref
596 . set SaveArray=ref
597 else do goto IS1 ;"Skip recreating array if SaveArray holds reference
598 . set ref=SaveArray
599
600 new ref2 set ref2=$name(^TMG("TMP",$J,"IEN-SELECT"))
601 kill @ref2
602 if $get(Header)'="" set @ref@("HD")=Header
603 set Sort=$get(Sort,0)
604 set IOM=$get(IOM,80)
605 set Fields=$get(Fields,".01")
606 set Widths=$get(Widths)
607 new Sort set Sort=($data(SortFlds)'=0)
608 set File=$get(File)
609 ;"Setup FldArray. Format:
610 ;" FldArray=number of colums
611 ;" FldArray(Sequence#)=field;fieldWidth
612 ;" FldArray(Sequence#)=field;fieldWidth
613 ;" FldArray(Sequence#)=field;fieldWidth
614 new FldArray,i
615 set FldArray=0
616 new WRemain set WRemain=IOM
617 for i=1:1:$length(Fields,";") do
618 . new Fld,W
619 . set Fld=$piece(Fields,";",i)
620 . if Fld="" quit
621 . set W=+$piece(Widths,";",i)
622 . if W=0 do
623 . . if FldArray>0 set W=IOM/FldArray
624 . . else set W=20 ;"some arbitrary number
625 . if W>WRemain set W=WRemain ;"this isn't perfect
626 . set WRemain=WRemain-W
627 . if WRemain<1 set WRemain=1
628 . set FldArray(i)=Fld_";"_W
629 . set FldArray=FldArray+1
630
631 new Itr,IEN,name,PriorErrorFound
632 new abort set abort=0
633 new order set order=1
634 new IENPreSelected
635 write "Prepairing list to display..."
636 set IEN=$$ItrAInit^TMGITR(pIENArray,.Itr)
637 do PrepProgress^TMGITR(.Itr,100,0,"IEN")
638 write !
639 if IEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN)="")!(abort=1)
640 . new TMGOUT,TMGMSG,IENS,showS,i
641 . set showS=""
642 . set IENS=IEN_","
643 . new tempFields
644 . set IENPreSelected=($data(@pIENArray@(IEN,"SEL"))>0)
645 . new i for i=1:1:FldArray do
646 . . if showS'="" set showS=showS_"|"
647 . . new Fld,tempS
648 . . set Fld=$piece(FldArray(i),";",1)
649 . . set tempS=$$GET1^DIQ(File,IENS,Fld,,"TMGOUT","TMGMSG")
650 . . if (i=1),$piece($get(^DD(File,Fld,0)),"^",2)["D" do ;"format dates for sorting if in column 1
651 . . . new %DT,X,Y
652 . . . set X=tempS
653 . . . do ^%DT ;"X in, Y out
654 . . . set tempS=$$DTFormat^TMGMISC(Y,"yyyy mm/dd") ;"make dates sort numerically
655 . . if $data(TMGMSG("DIERR")) do set abort=1 quit
656 . . . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound)
657 . . new W set W=$piece(FldArray(i),";",2)
658 . . set tempS=$extract(tempS,1,W)
659 . . if Sort set tempFields(Fld)=tempS
660 . . set showS=showS_$$LJ^XLFSTR(tempS,W," ")
661 . if Sort=0 do
662 . . set @ref@(order)=IEN_$char(9)_showS
663 . . if IENPreSelected set PreSelArray(order)=""
664 . . set order=order+1
665 . else do
666 . . new tempRef set tempRef=ref2
667 . . for i=1:1:$length(SortFlds,";") do
668 . . . new oneFld set oneFld=$piece(SortFlds,";",i)
669 . . . new F set F=$get(tempFields(oneFld))
670 . . . if F="" quit
671 . . . set tempRef=$name(@tempRef@(F))
672 . . set @tempRef@(IEN)=IEN_$char(9)_showS
673 . . if IENPreSelected set @tempRef@(IEN,"SEL")=""
674 . . ;"Sets up sorted variable as follows:
675 . . ;" @tempRef@(sortFld1,sortFld2,sortFld3,IEN)='IEN_$char(9)_showS'
676 . . ;" @tempRef@(sortFld1,sortFld2,sortFld3,IEN)='IEN_$char(9)_showS'
677 . . ;" @tempRef@(sortFld1,sortFld2,sortFld3,IEN)='IEN_$char(9)_showS'
678 do ProgressDone^TMGITR(.Itr)
679 write !
680
681 if abort=1 goto ISDone
682
683IES1 if Sort=1 do
684 . write "Sorting... "
685 . set order=1
686 . new tempRef2 set tempRef2=ref2
687 . new showS,NumNodes,Done
688 . set Done=0
689 . for do quit:(tempRef2="")!(Done=1)
690 . . set tempRef2=$query(@tempRef2)
691 . . if (tempRef2="") quit
692 . . if $qsubscript(tempRef2,$qlength(tempRef2))="SEL" do quit
693 . . . set PreSelArray(order-1)=""
694 . . if (tempRef2'[$$OREF^DILF(ref2)) set Done=1 quit
695 . . set showS=$get(@tempRef2)
696 . . set @ref@(order)=showS
697 . . set order=order+1
698
699 ;"Note: Rules of use:
700 ;" ref must=^TMP("VEE",$J)
701 ;" Each line should be in this format:
702 ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue
703 ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue
704 ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue
705 ;" Note: if DisplayValue is to be divided into colums, then
706 ;" use | character to separate
707 ;" @ref@("HD")=Header to display
708 ;" Results come back in:
709 ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue
710 ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue
711 ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue
712 ;" To preselect entries, provide an array like this:
713 ;" array(number)="" <-- number is same number as above, shows selected
714 ;" array(number)=""
715 ;" array(number)=""
716 ;" pass array by name: SELECT^%ZVEMKT(ref,,"array")
717IS1
718 new NumberLines set NumberLines=0 ;"1--> number each line
719 new AddNew set AddNew=0 ;"1-> Allow adding new entry
720
721 write "Passing off to selector..."
722 D SELECT^%ZVEMKT(ref,NumberLines,AddNew,"PreSelArray")
723
724 ;"Format results
725 new Itr2,index
726 set index=$$ItrAInit^TMGITR($name(^TMP("VPE","SELECT",$J)),.Itr2)
727 if index'="" for do quit:($$ItrANext^TMGITR(.Itr2,.index)="")
728 . new s set s=$piece($get(^TMP("VPE","SELECT",$J,index)),$char(9),1)
729 . set @pResults@(s)=index
730
731 kill ^TMP("VPE","SELECT",$J)
732 if $get(ref2) kill @ref2 ;"i.e. ^TMG("TMP",$J,"IEN-SELECT")
733
734ISDone
735 quit
736
737
738Selector(pArray,pResults,Header)
739 ;"Purpose: Interface with VPE Selector code to select from an array
740 ;"Input: pArray -- NAME OF array holding items to be selected from
741 ;" Expected format:
742 ;" @pArray@("Display Choice Words")=ReturnValue <-- ReturnValue is optional
743 ;" @pArray@("Display Choice Words")=ReturnValue
744 ;" @pArray@("Display Choice Words")=ReturnValue
745 ;" @pArray@("Display Choice Words","SEL")="" <-- optional preselection indicator
746 ;" pResults -- NAME OF array to have results returned in
747 ;" ** Note: Prior contents of array will NOT be KILLED first
748 ;" Format of returned array: Only those valuse that user selected will be returned
749 ;" @pResults@("Display Choice Words")=ReturnValue <-- ReturnValue is optional
750 ;" @pResults@("Display Choice Words")=ReturnValue
751 ;" @pResults@("Display Choice Words")=ReturnValue
752 ;" Header -- OPTIONAL -- A header text to show.
753 ;"Results: None
754 new ref set ref=$name(^TMP("VEE",$J))
755 kill @ref
756 if $get(pArray)="" goto SelDone
757 if $get(pResults)="" goto SelDone
758
759 new PreSelArray
760
761 ;"First set up array of options
762 new DispWords,RtnValue
763 new order set order=1
764 set DispWords=$order(@pArray@(""))
765 if DispWords'="" for do quit:(DispWords="")
766 . set RtnValue=$get(@pArray@(DispWords),"<NONE>")
767 . set @ref@(order)=RtnValue_$char(9)_$extract(DispWords,1,$get(IOM,80))
768 . if $data(@pArray@(DispWords,"SEL")) set PreSelArray(order)="" ;"mark as preselected
769 . set order=order+1
770 . set DispWords=$order(@pArray@(DispWords))
771
772 if $get(Header)'="" set @ref@("HD")=Header
773
774 ;"Note: Rules of use:
775 ;" ref must=^TMP("VEE",$J)
776 ;" Each line should be in this format:
777 ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue
778 ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue
779 ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue
780 ;" Note: if DisplayValue is to be divided into colums, then
781 ;" use | character to separate
782 ;" Results come back in:
783 ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue
784 ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue
785 ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue
786 ;" To preselect entries, provide an array like this:
787 ;" array(number)="" <-- number is same number as above, shows selected
788 ;" array(number)=""
789 ;" array(number)=""
790 ;" pass array by name: SELECT^%ZVEMKT(ref,,"array")
791
792 new NumberLines set NumberLines=0 ;"1--> number each line
793 new AddNew set AddNew=0 ;"1-> Allow adding new entry
794
795 D SELECT^%ZVEMKT(ref,NumberLines,AddNew,"PreSelArray")
796
797 ;"Format selected options.
798 new index set index=$order(^TMP("VPE","SELECT",$J,""))
799 if index'="" for do quit:(index="")
800 . new s,s1,s2
801 . set s=$get(^TMP("VPE","SELECT",$J,index))
802 . set s1=$piece(s,$char(9),1)
803 . set s2=$piece(s,$char(9),2)
804 . set @pResults@(s2)=s1
805 . set index=$order(^TMP("VPE","SELECT",$J,index))
806
807 kill ^TMP("VPE","SELECT",$J)
808 kill @ref
809
810SelDone
811 quit
812
813
814Slctor2(pArray,pResults,Header)
815 ;"Purpose: Interface with VPE Selector code to select from an array
816 ;" Note: This allows a different format of input. In Selector() above,
817 ;" it is NOT possible to have two similar Display Words with
818 ;" different return values. E.g. two drugs with LISINOPRIL, but
819 ;" different IEN return values. This fn allows this
820 ;"Input: pArray -- NAME OF array holding items to be selected from
821 ;" Expected format:
822 ;" @pArray@("Display Choice Words",ReturnValue)="" <-- return value IS required
823 ;" @pArray@("Display Choice Words",ReturnValue)=""
824 ;" @pArray@("Display Choice Words",ReturnValue)=""
825 ;" @pArray@("Display Choice Words",ReturnValue,"SEL")="" <-- optional preselection indicator
826 ;" pResults -- NAME OF array to have results returned in
827 ;" ** Note: Prior contents of array will NOT be KILLED first
828 ;" Format of returned array: Only those values that user selected will be returned
829 ;" @pResults@("Display Choice Words",ReturnValue)=""
830 ;" @pResults@("Display Choice Words",ReturnValue)=""
831 ;" @pResults@("Display Choice Words",ReturnValue)=""
832 ;" Header -- OPTIONAL -- A header text to show.
833
834 new ref set ref=$name(^TMP("VEE",$J))
835 kill @ref
836 if $get(pArray)="" goto Sl2Done
837 if $get(pResults)="" goto Sl2Done
838
839 new PreSelArray
840
841 ;"First set up array of options
842 new DispWords,RtnValue
843 new order set order=1
844 set DispWords=""
845 for set DispWords=$order(@pArray@(DispWords)) quit:(DispWords="") do
846 . set RtnValue=""
847 . for set RtnValue=$order(@pArray@(DispWords,RtnValue)) quit:(RtnValue="") do
848 . . set @ref@(order)=RtnValue_$char(9)_$extract(DispWords,1,$get(IOM,80))
849 . . if $data(@pArray@(DispWords,RtnValue,"SEL")) set PreSelArray(order)="" ;"mark as preselected
850 . . set order=order+1
851
852 if $get(Header)'="" set @ref@("HD")=Header
853
854 ;"Note: Rules of use:
855 ;" ref must=^TMP("VEE",$J)
856 ;" Each line should be in this format:
857 ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue
858 ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue
859 ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue
860 ;" Note: if DisplayValue is to be divided into colums, then
861 ;" use | character to separate
862 ;" Results come back in:
863 ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue
864 ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue
865 ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue
866 ;" To preselect entries, provide an array like this:
867 ;" array(number)="" <-- number is same number as above, shows selected
868 ;" array(number)=""
869 ;" array(number)=""
870 ;" pass array by name: SELECT^%ZVEMKT(ref,,"array")
871
872 new NumberLines set NumberLines=0 ;"1--> number each line
873 new AddNew set AddNew=0 ;"1-> Allow adding new entry
874
875 D SELECT^%ZVEMKT(ref,NumberLines,AddNew,"PreSelArray")
876
877 ;"Format selected options.
878 new index set index=$order(^TMP("VPE","SELECT",$J,""))
879 if index'="" for do quit:(index="")
880 . new s,s1,s2
881 . set s=$get(^TMP("VPE","SELECT",$J,index))
882 . set s1=$piece(s,$char(9),1)
883 . set s2=$piece(s,$char(9),2)
884 . set @pResults@(s2,s1)=""
885 . set index=$order(^TMP("VPE","SELECT",$J,index))
886
887 kill ^TMP("VPE","SELECT",$J)
888 kill @ref
889
890Sl2Done
891 quit
892
893
894
895MENU(Options,defChoice,UserRaw)
896 QUIT $$Menu(.Options,.defChoice,.UserRaw)
897
898Menu(Options,defChoice,UserRaw)
899 ;"Purpose: to provide a simple menuing system
900 ;"Input: Options -- PASS BY REFERENCE
901 ;" Format:
902 ;" Options(0)=Header Text <--- optional, default is MENU
903 ;" Options(DispNumber)=MenuText_$C(9)_ReturnValue <-- _$C(9)_ReturnValue OPTIONAL, default is DispNumber
904 ;" Options(DispNumber)=MenuText_$C(9)_ReturnValue
905 ;" Options(DispNumber)=MenuText_$C(9)_ReturnValue
906 ;" defChoice: OPTIONAL, the default menu value
907 ;" UserRaw : OPTIONAL, PASS BY REFERENCE, an OUT PARAMETER. Returns users raw input
908 ;"Results: The selected ReturnValue (or DispNumber if no ReturnValue provided), or ^ for abort
909
910 new result set result="^"
911 new s,fg,bg
912 new width set width=50
913 new line set $piece(line,"=",width+1)=""
914MNU1
915 if $data(Options(-1,"COLOR")) do
916 . set fg=$get(Options(-1,"COLOR","fg"),0)
917 . set bg=$get(Options(-1,"COLOR","bg"),1)
918 . do VCOLORS^TMGTERM(fg,bg)
919 write line,!
920 write $get(Options(0),"MENU"),$$Pad2Pos^TMGSTUTL(width),!
921 write line,!
922 write "Options:",$$Pad2Pos^TMGSTUTL(width),!
923
924 new DispNumber set DispNumber=$order(Options(0))
925 if DispNumber'="" for do quit:(DispNumber="")
926 . set s=$get(Options(DispNumber))
927 . write $$RJ^XLFSTR(DispNumber,4),".",$$Pad2Pos^TMGSTUTL(6)
928 . if $data(Options(DispNumber,"COLOR")) do
929 . . set fg=$get(Options(DispNumber,"COLOR","fg"),0)
930 . . set bg=$get(Options(DispNumber,"COLOR","bg"),1)
931 . . do VCOLORS^TMGTERM(fg,bg)
932 . write $piece(s,$char(9),1),$$Pad2Pos^TMGSTUTL(width-1)
933 . if $data(Options(DispNumber,"COLOR")) do
934 . . do VTATRIB^TMGTERM(0) ;"Reset colors
935 . write " ",!
936 . set DispNumber=$order(Options(DispNumber))
937
938 write line,!
939
940 set defChoice=$get(defChoice,"^")
941 new input
942 write "Enter selection (^ to abort): ",defChoice,"// "
943 read input:$get(DTIME,3600),!
944 if input="" set input=defChoice
945 set UserRaw=input
946 if input="^" goto MNUDone
947
948 set s=$get(Options(input))
949 if s="" set s=$get(Options($$UP^XLFSTR(input)))
950 ;"if s="" write "??",!! goto MNU1
951 set result=$piece(s,$char(9),2)
952 if result="" set result=input
953
954MNUDone
955 if $data(Options(-1,"COLOR")) do VTATRIB^TMGTERM(0) ;"Reset colors
956 quit result
957
958
959ProgTest
960 ;"Purpose: test progress bar.
961 new i,u,max
962 set max=100
963 for i=0:1:max do
964 . do ProgressBar(i,"%",1,max)
965 . hang 0.25
966 quit
967
968
969SpinTest
970 ;"Purpose: test progress bar.
971 new i,u,max
972 set max=3000
973 for i=0:10:max do
974 . do ProgressBar(i,"<A Label> "_i,-1,-1)
975 . hang 0.1
976 quit
977
978
979Scroller(pArray,Option)
980 ;"Purpose: Provide a scroll box
981 ;"Input: pArray -- PASS BY NAME. format:
982 ;" @pArray@(1,DisplayText)=Return Text <-- note: must be numbered 1,2,3 etc.
983 ;" @pArray@(2,DisplayText)=Return Text
984 ;" @pArray@(3,DisplayText)=Return Text
985 ;" NOTE: if Display text contains {{name}} then name is taken as color directive
986 ;" Example: 'Here is {{BOLD}}something{{NORM}} to see.'
987 ;" if NAME is not defined in Option("COLORS",NAME), it is ignored
988 ;" Option -- PASS BY REFERENCE. format:
989 ;" Option("HEADER",1)=Header line text
990 ;" Option("HEADER",2)=More Header line text (any number of lines)
991 ;" Option("FOOTER",1)=Footer line text <--- Option 1
992 ;" Option("FOOTER",1,1)=linePart <--- Option 2 (these will be all strung together to make one footer line.
993 ;" Option("FOOTER",1,2)=linePart (can be used to display switches etc)
994 ;" Option("FOOTER",2)=More footer line text (any number of lines)
995 ;" Option("SHOW INDEX")=1 Optional. If 1, then index is shown.
996 ;" Option("SCRN WIDTH")= Optional screen width. (default is terminal width)
997 ;" ---- Colors (optional) ------
998 ;" Option("COLORS","NORM")=FG^BG -- default foreground (FG) and background(colors)
999 ;" If not provided, White on Blue used.
1000 ;" Option("COLORS","HIGH")=FG^BG -- Highlight colors. If not provided, White on Cyan used.
1001 ;" Option("COLORS","HEADER")=FG^BG Header color. NORM used if not provided
1002 ;" Option("COLORS","FOOTER")=FG^BG Footer color. NORM used if not provided
1003 ;" Option("COLORS","TOP LINE")=FG^BG Top line color. NORM used if not provided
1004 ;" Option("COLORS","BOTTOM LINE")=FG^BG Bottom line color. NORM used if not provided
1005 ;" Option("COLORS","INDEX")=FG^BG Index color. NORM used if not provided
1006 ;" Option("COLORS",SomeName)=FG^BG e.g. :
1007 ;" Option("COLORS","BOLD")=15^0 (Any arbitrary name OK, matched to {{name}} in text)
1008 ;" Option("COLORS","HIGH")=10^@
1009 ;" If BG="@", then default BG used. This may be used anywhere except for defining NORM
1010 ;" ---- events ----
1011 ;" Option("ON SELECT")="FnName^Module" -- code to call based on user input
1012 ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line
1013 ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line
1014 ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line
1015 ;" Option("ON CHANGING")="FnName^Module" -- code to execute for number entry
1016 ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line
1017 ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line
1018 ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line
1019 ;" Info("NEXT LINE","NUMBER")=next line number. Used for ON CHANGING to show the line about to be selected
1020 ;" Info("ALLOW CHANGE")=1, <--- RETURN RESULT. Change to 0 to disallow move.
1021 ;" Option("ON CMD")="FnName^Module" -- code to execute for number entry
1022 ;" Info("USER INPUT")=UserTypedInput
1023 ;" NOTES about events. Functions will be called as follows:
1024 ;" do FnName^Module(pArray,.Option,.Info)
1025 ;" pArray and Option are the same data received by this function
1026 ;" -- thus Option can be used to can other custom information.
1027 ;" Info has extra info as outlined above.
1028 ;" If functions may set a globally-scoped var named TMGSCLRMSG to communicate back
1029 ;" if TMGSCLRMSG="^" then Scroller will exit
1030 ;"Result: none
1031
1032 new scrnW,scrnH,scrnLine,spaceLine,topLine,sizeHdr,sizeFtr
1033 new entryCt,lineCt,EscKey,dispHt,highLine,showIdx
1034 new needRefresh,Info
1035 set topLine=1
1036 set highLine=5
1037 new TMGSCLRMSG set TMGSCLRMSG=""
1038
1039 set scrnW=+$get(Option("SCRN WIDTH"))
1040 if scrnW'>0 do
1041 . if $$GetScrnSize^TMGKERNL(,.scrnW)
1042 . set scrnW=+scrnW-4
1043 if scrnW'>0 set scrnW=$get(IOM,66)-2
1044 ;"set scrnW=$get(IOM,60)-2
1045 set scrnH=$get(IOSL,25)-2
1046
1047 if $get(Option("COLORS","NORM"))="" set Option("COLORS","NORM")="14^4" ;"white on blue
1048 if $get(Option("COLORS","HIGH"))="" set Option("COLORS","HIGH")="14^6" ;"white on cyan
1049 if $get(Option("COLORS","HEADER"))="" set Option("COLORS","HEADER")=Option("COLORS","NORM")
1050 if $get(Option("COLORS","FOOTER"))="" set Option("COLORS","FOOTER")=Option("COLORS","NORM")
1051 if $get(Option("COLORS","TOP LINE"))="" set Option("COLORS","TOP LINE")=Option("COLORS","NORM")
1052 if $get(Option("COLORS","BOTTOM LINE"))="" set Option("COLORS","BOTTOM LINE")=Option("COLORS","NORM")
1053 if $get(Option("COLORS","INDEX"))="" set Option("COLORS","INDEX")=Option("COLORS","NORM")
1054
1055 new i set i=""
1056 for set i=$order(Option("COLORS",i)) quit:(i="") do
1057 . new colors set colors=$get(Option("COLORS",i))
1058 . new FG set FG=$piece(colors,"^",1) if FG="" set FG=0
1059 . new BG set BG=$piece(colors,"^",2) if BG="" set BG=1
1060 . set Option("COLORS",i,"FG")=FG
1061 . set Option("COLORS",i,"BG")=BG
1062
1063Full set scrnLine="" set $piece(scrnLine,"-",scrnW)="-"
1064 set spaceLine="" set $piece(spaceLine," ",scrnW)=" "
1065 set sizeHdr=$$ListCt^TMGMISC($name(Option("HEADER")))+1
1066 set sizeFtr=$$ListCt^TMGMISC($name(Option("FOOTER")))+1
1067 set entryCt=$$ListCt^TMGMISC(pArray)
1068 set EscKey=""
1069 set dispHt=scrnH-sizeHdr-sizeFtr
1070 if topLine>entryCt set topLine=entryCt
1071 if highLine>entryCt set highLine=entryCt
1072 set showIdx=($get(Option("SHOW INDEX"))=1)
1073
1074Draw do HOME^TMGTERM
1075 if $data(Option("HEADER")) do
1076 . do SetColor("HEADER",.Option)
1077 . new i set i=""
1078 . for set i=$order(Option("HEADER",i)) quit:(i="") do
1079 . . write $$CJ^XLFSTR($get(Option("HEADER",i)),scrnW),!
1080 set lineCt=topLine
1081
1082 ;"do VCOLORS^TMGTERM(14,4) ;"bright white on blue background
1083 do SetColor("TOP LINE",.Option)
1084 write scrnLine,!
1085 do SetColor("NORM",.Option)
1086 for quit:(lineCt=(dispHt+topLine-1)) do
1087 . ;"if lineCt=highLine do VCOLORS^TMGTERM(14,6) ;"bright white on cyan background
1088 . ;"else do VCOLORS^TMGTERM(14,4) ;"bright white on blue background
1089 . if lineCt=highLine do SetColor("HIGH",.Option)
1090 . else do SetColor("NORM",.Option)
1091 . new s set s=""
1092 . if showIdx do
1093 . . do SetColor("INDEX",.Option)
1094 . . write $$RJ^XLFSTR(lineCt,3)_"."
1095 . . if lineCt=highLine do SetColor("HIGH",.Option)
1096 . . else do SetColor("NORM",.Option)
1097 . . write " "
1098 . new text,textA,textB,textColor
1099 . set text=$order(@pArray@(lineCt,""))
1100 . for quit:(text'["{{")!($X'<scrnW) do
1101 . . set textColor=$$ParseColor(.text,.textA) ;" Text --> TextA{{Color}}Text
1102 . . if $X+$length(textA)>scrnW do
1103 . . . write $extract(textA,1,(scrnW-$X-3))_"..."
1104 . . else write textA
1105 . . do SetColor(textColor,.Option)
1106 . write text
1107 . write $extract(spaceLine,1,(scrnW-$X))
1108 . do SetColor("RESET") write !
1109 . ;"if showIdx set s=$$RJ^XLFSTR(lineCt,3)_". "
1110 . ;"set s=$$LJ^XLFSTR(s_$order(@pArray@(lineCt,"")),scrnW)
1111 . ;"if $length(s)>scrnW set s=$extract(s,1,scrnW-3)_"..."
1112 . ;"write s,!
1113 . set lineCt=lineCt+1
1114 ;"do VCOLORS^TMGTERM(14,4) ;"bright white on blue background
1115 do SetColor("BOTTOM LINE",.Option)
1116 write scrnLine,!
1117 do SetColor("FOOTER",.Option)
1118 ;"do VTATRIB^TMGTERM(0) ;"reset colors
1119 if $data(Option("FOOTER")) do
1120 . new i set i=""
1121 . for set i=$order(Option("FOOTER",i)) quit:(i="") do
1122 . . new j set j=$order(Option("FOOTER",i,""))
1123 . . if j'="" do
1124 . . . new oneLine set oneLine="",j=""
1125 . . . for set j=$order(Option("FOOTER",i,j)) quit:(j="") do
1126 . . . . set oneLine=oneLine_$get(Option("FOOTER",i,j))_" | "
1127 . . . write $$LJ^XLFSTR(oneLine,scrnW),!
1128 . . else write $$LJ^XLFSTR($get(Option("FOOTER",i)),scrnW),!
1129
1130 set Info("CURRENT LINE","NUMBER")=highLine
1131 set Info("CURRENT LINE","TEXT")=$order(@pArray@(highLine,""))
1132 set Info("CURRENT LINE","RETURN")=$get(@pArray@(highLine,Info("CURRENT LINE","TEXT")))
1133
1134 do SetColor("RESET")
1135 write $$LJ^XLFSTR(": ",scrnW),!
1136 do CUU^TMGTERM(1) write ": "
1137 set needRefresh=0
1138UsrIn set input=$$Read("re",,,,.EscKey)
1139 if (input="")&(EscKey="") set EscKey="CR"
1140 if EscKey="UP" set input="UP^1"
1141 if EscKey="PREV" set input="UP^15"
1142 if EscKey="DOWN" set input="DOWN^1"
1143 if EscKey="NEXT" set input="DOWN^15"
1144 if EscKey="CR" do goto Lp2
1145 . new codeFn set codeFn=$get(Option("ON SELECT")) quit:(codeFn="")
1146 . set codeFn="do "_codeFn_"(pArray,.Option,.Info)"
1147 . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode="""""
1148 . xecute codeFn
1149 . set needRefresh=2
1150 if input="^" goto ScrlDone
1151 if (input["^") do goto Lp2
1152 . if $piece(input,"^",1)="UP" do
1153 . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode="""""
1154 . . new codeFn set codeFn=$get(Option("ON CHANGING"))
1155 . . if codeFn'="" set codeFn="do "_codeFn_"(pArray,.Option,.Info)"
1156 . . set Info("ALLOW CHANGE")=1
1157 . . set needRefresh=1
1158 . . new j for j=1:1:+$piece(input,"^",2) do
1159 . . . if highLine>topLine do
1160 . . . . set Info("NEXT LINE","NUMBER")=(highLine-1)
1161 . . . . if codeFn'="" xecute codeFn quit:'$get(Info("ALLOW CHANGE")) set needRefresh=2
1162 . . . . set highLine=highLine-1
1163 . . . else if topLine>1 do
1164 . . . . set Info("NEXT LINE","NUMBER")=(topLine-1)
1165 . . . . if codeFn'="" xecute codeFn quit:'$get(Info("ALLOW CHANGE")) set needRefresh=2
1166 . . . . set topLine=topLine-1,highLine=topLine
1167 . else if $piece(input,"^",1)="DOWN" do
1168 . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode="""""
1169 . . new codeFn set codeFn=$get(Option("ON CHANGING"))
1170 . . if codeFn'="" set codeFn="do "_codeFn_"(pArray,.Option,.Info)"
1171 . . set Info("ALLOW CHANGE")=1
1172 . . set needRefresh=1
1173 . . new j for j=1:1:+$piece(input,"^",2) do
1174 . . . if highLine<(topLine+dispHt-2) do
1175 . . . . set Info("NEXT LINE","NUMBER")=(highLine-1)
1176 . . . . if codeFn'="" xecute codeFn quit:'$get(Info("ALLOW CHANGE")) set needRefresh=2
1177 . . . . set highLine=highLine+1
1178 . . . else if (topLine+dispHt-2)<entryCt do
1179 . . . . set Info("NEXT LINE","NUMBER")=(highLine+1)
1180 . . . . if codeFn'="" xecute codeFn quit:'$get(Info("ALLOW CHANGE")) set needRefresh=2
1181 . . . . set topLine=topLine+1,highLine=highLine+1
1182 else if input="=" do
1183 . set needRefresh=2
1184 . new DIR set DIR(0)="N^10:"_IOM
1185 . set DIR("B")=scrnW
1186 . write "Enter Screen Width (# of columns): " do ^DIR write !
1187 . if $data(DIRUT) write # quit
1188 . set scrnW=Y
1189 . set DIR(0)="N^5:"_(IOSL-2)
1190 . set DIR("B")=scrnH
1191 . write "Enter Screen Height (# of rows): " do ^DIR write !
1192 . if $data(DIRUT) write # quit
1193 . set scrnH=Y
1194 . write #
1195 else do
1196 . set needRefresh=1
1197 . if (input="")&(EscKey'="") set input="{"_EscKey_"}"
1198 . new codeFn set codeFn=$get(Option("ON CMD")) quit:(codeFn="")
1199 . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode="""""
1200 . if codeFn'="" set codeFn="do "_codeFn_"(pArray,.Option,.Info)"
1201 . set Info("USER INPUT")=input
1202 . xecute codeFn
1203 . set needRefresh=2
1204
1205Lp2 if TMGSCLRMSG="^" goto ScrlDone
1206 if needRefresh=2 goto Full
1207 if needRefresh=1 goto Draw
1208 goto UsrIn
1209
1210ScrlDone
1211 quit
1212
1213SetColor(Label,Option)
1214 ;"Purpose: to set color, based on Label name. (A utility function for Scroller)
1215 ;"Input: Label -- the name of the color, i.e. NORM, HIGH, etc.
1216 ;" If Label=REST, then special ResetTerminal function called.
1217 ;" Option -- PASS BY REFERENCE. The same option array passed to Scroller, with color info
1218 ;" Specifically used: Option('COLORS',SomeName,'FG')=foregroundColor
1219 ;" Option('COLORS',SomeName,'BG')=backgroundColor
1220 ;"Note: if color label not found, then no color change is made.
1221 ;
1222 if Label="RESET" do VTATRIB^TMGTERM(0) quit ;"reset colors
1223 if $data(Option("COLORS",Label))=0 quit
1224 new FG set FG=$get(Option("COLORS",Label,"FG"),1) ;"default to black
1225 new BG set BG=$get(Option("COLORS",Label,"BG"),0) ;"default to white
1226 if BG="@" set BG=$get(Option("COLORS","NORM","BG"),0) ;"default to white
1227 do VCOLORS^TMGTERM(FG,BG)
1228 quit
1229
1230ParseColor(text,textA)
1231 ;"Purpose: To extract a color code from text
1232 ;"Example: Input text = 'This is {{HIGH}}something{{NORM}} to see.'
1233 ;" Output text = 'something{{NORM}} to see.'
1234 ;" Output textA = 'This is '
1235 ;" function result = 'NORM'
1236 ;"Input: text -- PASS BY REFERENCE
1237 ;" textA -- PASS BY REFERENCE, and OUT PARAMETER
1238 ;"Result: the color name inside brackets.
1239 new s,result
1240 set s=text
1241 set textA=$piece(s,"{{",1)
1242 set result=$piece(s,"{{",2)
1243 set result=$piece(result,"}}",1)
1244 set text=$piece(s,"}}",2,99)
1245 quit result
1246
1247TestScrl
1248 new Array,Option
1249 new i for i=1:1:136 do
1250 . set Array(i,"Line "_i)="Result for "_i
1251 set Option("HEADER",1)=" - < Here is a header line > -"
1252 set Option("FOOTER",1)="Enter ^ to exit"
1253 set Option("ON SELECT")="HndOnSel^TMGUSRIF"
1254 set Option("ON CMD")="HandOnCmd^TMGUSRIF"
1255
1256 set Option("COLORS","NORM")="14^4" ;"white on blue
1257 set Option("COLORS","HIGH")="14^6" ;"white on cyan
1258 set Option("COLORS","HEADER")="14^5"
1259 set Option("COLORS","FOOTER")="14^5"
1260 set Option("COLORS","TOP LINE")="5^1"
1261 set Option("COLORS","BOTTOM LINE")="5^1"
1262 set Option("COLORS","INDEX")="0^1"
1263 set Option("SHOW INDEX")=1
1264
1265 do Scroller("Array",.Option)
1266 quit
1267
1268HndOnSel(pArray,Option,Info) ;"Part of TestScrl
1269 ;"Purpose: handle ON SELECT event from Scroller
1270 ;"Input: pArray,Option,Info -- see documentation in Scroller
1271 ;" Info has this:
1272 ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line
1273 ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line
1274 ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line
1275
1276 write $get(Info("CURRENT LINE","TEXT")),!
1277 do PressToCont
1278 quit
1279
1280
1281HandOnCmd(pArray,Option,Info) ;"Part of TestScrl
1282 ;"Purpose: handle ON SELECT event from Scroller
1283 ;"Input: pArray,Option,Info -- see documentation in Scroller
1284 ;" Info has this:
1285 ;" Info("USER INPUT")=input
1286 ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line
1287 ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line
1288 ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line
1289
1290
1291 write $get(Info("USER INPUT")),!
1292 do PressToCont
1293 quit
Note: See TracBrowser for help on using the repository browser.