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

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

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