TMGUSRIF ;TMG/kst/USER INTERFACE API FUNCTIONS ;03/25/06, 5/28/10 ;;1.0;TMG-LIB;**1**;07/12/05 ;"TMG USER INTERFACE API FUNCTIONS ;"Kevin Toppenberg MD ;"GNU General Public License (GPL) applies ;"7-12-2005 ;"======================================================================= ;" API -- Public Functions. ;"======================================================================= ;"PopupArray^TMGUSRIF(IndentW,Width,Array,Modal) ;"PopupBox^TMGUSRIF(Header,Text,[Width]) ;"ProgressBar^TMGUSRIF(value,label,min,max,width,startTime) ;"PRESSTOCONT^TMGUSRIF ;"PressToCont^TMGUSRIF ;"$$KeyPressed^TMGUSRIF(wantChar,waitTime) ;"$$Read^TMGUSRIF(Terminators,timeOut,Num,initialVal) -- custom read function with custom terminators ;"$$UserAborted^TMGUSRIF() ;"Selector(pArray,pResults,Header) -- select from an array ;"Slctor2(pArray,pResults,Header) -- select from an array (different input) ;"IENSelector(pIENArray,pResults,File,Field,Header,Sort) ;"MENU(Options,defChoice,.UserRaw) ;"Menu(Options,defChoice,.UserRaw) ;"Scroller(pArray,Option) -- Provide a scroll box interfact ;"======================================================================= ;"Private Functions ;"======================================================================= ;"XPopupArray(Array,Modal) ;"ProgTest ;"======================================================================= ;"======================================================================= ;"DEPENDENCIES ;"TMGDEBUG,TMGSTUTL,TMGXDLG ;"======================================================================= PopupArray(IndentW,Width,Array,Modal) ;"PUBLIC FUNCTION ;"Purpose: To draw a box, of specified Width, and display text ;"Input: IndentW = width of indent amount (how far from left margin) ;" Width = desired width of box. ;" Header = one line of text to put in header of popup box ;" Array: an array in following format: ;" Array(0)=Header ;" Array(1)=Text line 1 ;" Array(2)=Text line 2 ;" ... ;" Array(n)=Text line n ;" Modal - really only has meaning for those time when ;" box will be passed to GUI X dialog box. ;" Modal=1 means stays in foreground, ;" 0 means leave box up, continue script execution. ;"Note: Text will be clipped to fit in box. if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"PopupArray") set cModal=$get(cModal,"MODAL") set cDialog=$get(cModal,"UseDialog") set Modal=$get(Modal,cModal) new Header new Text set Text="" new index,i,S ;"Scan array for any needed data substitution i.e. {{...}} new tempresult set index=$order(Array("")) for do quit:index="" . set S=Array(index) . ;"set tempresult=$$CheckSubstituteData(.S) ;"Do any data lookup needed . set Array(index)=S . set index=$order(Array(index)) if $get(DispMode(cDialog)) do goto PUADone . do XPopupArray(.Array,Modal) set IndentW=$get(IndentW,1) ;"default indent=1 set Header=$get(Array(0)," ") set Width=$get(Width,40) ;"default=40 write ! ;"Draw top line for i=1:1:IndentW write " " write "+" for i=1:1:(Width-2) write "=" write "+",! ;"Draw Header line do SetStrLen^TMGSTUTL(.Header,Width-4) for i=1:1:IndentW write " " write "| ",Header," |..",! ;"Draw divider line for i=1:1:IndentW write " " write "+" for i=1:1:(Width-2) write "-" write "+ :",! ;"Put out message set index=$order(Array(0)) PUBLoop if index="" goto BtmLine set S=$get(Array(index)," ") do SetStrLen^TMGSTUTL(.S,Width-4) for i=1:1:IndentW write " " write "| ",S," | :",! set index=$order(Array(index)) goto PUBLoop BtmLine ;"Draw Bottom line for i=1:1:IndentW write " " write "+" for i=1:1:(Width-2) write "=" write "+ :",! ;"Draw bottom shaddow for i=1:1:IndentW write " " write " " write ":" for i=1:1:(Width-2) write "." write ".",! write ! PUADone if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"PopupArray") quit XPopupArray(Array,Modal) ;"Purpose -- to pass the older text popup box onto a X GUI box new Title new Text new index new S set S="" new OneLine new result set cOKToCont=$get(cOKToCont,1) set cAbort=$get(cAbort,0) set cModal=$get(cModal,"MODAL") if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"XPopupArray") set Title=$get(Array(0)) set index=$order(Array(0)) set Modal=$get(Modal,cModalMode) XPL1 if index="" goto XPL2 set OneLine=$get(Array(index)," ") set OneLine=$translate(OneLine,"""","'") set S=S_OneLine_"\n" set index=$order(Array(index)) goto XPL1 XPL2 if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Title=",Title) if $get(TMGDEBUG)>0 do DebugMsg^TMGDEBUG(.DBIndent,"Text=",S) set result=$$Msg^TMGXDLG(Title,S,0,0,Modal) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"XPopupArray") quit PopupBox(Header,Text,Width) ;"PUBLIC FUNCTION ;"Purpose: To provide easy text output box ;"Input: Header -- a short string for header ;" Text - the text to display ;" [Width] -- optional width specifier. Value=0 same as not specified ;" (DBIndent) -- uses a var with global scope (if defined) for indent amount ;"Note: If text width not specified, and Text is <= 60, ;" then all will be put on one line. ;" Otherwise, width is set to 60, and text is wrapped. ;" Also, text of the message can contain "\n", which will be interpreted ;" as a new-line character. ;"Result: none ;"Note: This function can't be exported to a separate package because of dependancies if $get(TMGDEBUG)>0 do DebugEntry^TMGDEBUG(.DBIndent,"PopupBox") set cNewLn=$get(cNewLn,"\n") new TextOut new TextI set TextI=0 new PartB set PartB="" new PartB1 set PartB1="" set Width=+$get(Width,0) set TextOut(TextI)=Header set TextI=TextI+1 if Width=0 do . new HeaderBased . new NumLines . new HLen set HLen=$length(Header)+4 . new TLen set TLen=$length(Text)+4 . if TLen>HLen do . . set Width=TLen . . set HeaderBased=0 . else do . . set Width=HLen . . set HeaderBased=1 . if Width>75 set Width=75 . set NumLines=TLen/Width . if TLen#Width>0 set NumLines=NumLines+1 . if (NumLines>1)&(HeaderBased=0) do . . set Width=(TLen\NumLines)+4 . . if Width75 set Width=75 PUWBLoop ;"Load string up into Text array, to pass to PopupArray if Text[cNewLn do . do CleaveStr^TMGSTUTL(.Text,cNewLn,.PartB1) do SplitStr^TMGSTUTL(.Text,(Width-4),.PartB) set PartB=PartB_PartB1 set PartB1="" set TextOut(TextI)=Text set TextI=TextI+1 if $length(PartB)>0 do goto PUWBLoop . set Text=PartB . set PartB="" do PopupArray(.DBIndent,Width,.TextOut) if $get(TMGDEBUG)>0 do DebugExit^TMGDEBUG(.DBIndent,"PopupBox") quit ProgressBar(value,label,min,max,width,startTime) ;"Purpose: to draw a progress bar on a line of the screen ;"Input: ;" value -- the current value to graph out ;" label -- OPTIONAL -- a label to describe progres. Default="Progress" ;" max -- OPTIONAL -- the max number that value will be. Default is 100 ;" if max=-1 and min=-1 then turn on spin mode (see below) ;" min -- OPTIONAL -- the minimal number that value will be. Default is 0 ;" if max=-1 and min=-1 then turn on spin mode (see below) ;" width -- OPTIONAL -- the number of characters that the progress bar ;" will be in width. Default is 70 ;" startTime -- OPTIONAL -- start time of process. If provided, it will ;" be used to determine remaining time. Format should be same as $H ;"Note: will use global ^TMP("TMG","PROGRESS-BAR",$J) ;"Note: bar will look like this: ;" Progress: 27%-------->|-----------------------------------| (Time) ;"Note--Spin Mode: To show motion without knowing the max amount, a spin mode is needed. ;" Progress: |-----<==>--------------------------------------| ;" And the bar will move back and forth. ;" In this mode, value is ignored and is thus optional. ;" To use this mode, set max=-1,min=-1 ;"Result: None ;"FYI -- The preexisting way to do this, from Dave Whitten ;" ;"Did you try using the already existing function to do this? ;"ie: try out this 'mini program' ;">; need to set up vars like DUZ,DTIME, IO, IO(0), etc. ;" D INIT^XPDID ;" S XPDIDTOT=100 ;" D TITLE^XPDID("hello world") ;" D UPDATE^XPDID(50) ;" F AJJ=90:1:100 D UPDATE^XPDID(I) ;" D EXIT^XPDID() ;" ;"The XPDID routine does modify the scroll region and make the ;"application seem a bit more "GUI"-like, by the way... ;" ;"David new NakedRef set NakedRef=$$LGR^TMGIDE ;"save naked reference do ;"Turn off cursor display, to prevent flickering . new $etrap set $etrap="" . xecute ^%ZOSF("TRMOFF") new premark,i,postmark,pct new pRefCt set pRefCt=$name(^TMP("TMG","PROGRESS-BAR",$J)) set max=+$get(max,100),min=+$get(min,0) set width=+$get(width,70) set label=$get(label,"Progress") new spinMode set spinMode=((max=-1)&(min=-1)) if spinMode goto Spin1 ;"<-- skip all this for spin mode if (max-min)=0 set pct=0 else set pct=(value-min)/(max-min) if pct>1 set pct=1 if pct<0 set pct=0 if (pct<1)&($get(startTime)="") set startTime=$H set startTime=$get(startTime) ;" +$get 61053,61748 --> 61053 new barberPole set barberPole=+$get(@pRefCt@("BARBER POLE")) if $get(@pRefCt@("BARBER POLE","LAST INC"))'=$H do . set barberPole=(barberPole-1)#4 . set @pRefCt@("BARBER POLE")=barberPole ;"should be 0,1,2, or 3) . set @pRefCt@("BARBER POLE","LAST INC")=$H new curRate set curRate="" if $get(@pRefCt@("START-TIME"))=startTime do . new interval set interval=$get(@pRefCt@("SAMPLING","INTERVAL"),10) . set curRate=$get(@pRefCt@("LATEST-RATE")) . new count set count=$get(@pRefCt@("SAMPLING","COUNT"))+1 . if count#interval=0 do . . new deltaT,deltaV . . set deltaT=$$HDIFF^XLFDT($H,$get(@pRefCt@("SAMPLING","REF-TIME")),2) . . if deltaT=0 set interval=interval*2 . . else if deltaT>1000 set interval=interval\1.5 . . set deltaV=value-$get(@pRefCt@("SAMPLING","VALUE COUNT")) . . if deltaV>0 set curRate=deltaT/deltaV ;"dT/dValue . . else set curRate="" . . set @pRefCt@("LATEST-RATE")=curRate . . set @pRefCt@("SAMPLING","REF-TIME")=$H . . set @pRefCt@("SAMPLING","VALUE COUNT")=value . set @pRefCt@("SAMPLING","COUNT")=count#interval . set @pRefCt@("SAMPLING","INTERVAL")=interval else do . kill @pRefCt . set @pRefCt@("START-TIME")=startTime . set @pRefCt@("SAMPLING","COUNT")=0 . set @pRefCt@("SAMPLING","REF-TIME")=$H . set @pRefCt@("SAMPLING","VALUE COUNT")=value new timeStr set timeStr=" " new remainingT set remainingT="" new delta set delta=0 if curRate'="" do . new remainV set remainV=(max-value) . if remainV'<0 do . . set remainingT=curRate*remainV . else do . . set delta=-1,remainingT=$$HDIFF^XLFDT($H,startTime,2) else if $data(startTime) do . if pct=0 quit . set timeStr="" . set delta=$$HDIFF^XLFDT($H,startTime,2) . if delta<0 set remainingT=-delta ;"just report # sec's overrun. . set remainingT=delta*((1/pct)-1) if remainingT'="" do . new days set days=remainingT\86400 ;"86400 sec per day. . if days>5 set timeStr=" " quit . set remainingT=remainingT#86400 . new hours set hours=remainingT\3600 ;"3600 sec per hour . set remainingT=remainingT#3600 . new mins set mins=remainingT\60 ;"60 sec per min . new secs set secs=(remainingT#60)\1 . if days>0 set timeStr=timeStr_days_"d, " . if hours>0 set timeStr=timeStr_hours_"h:" . if (min=0)&(secs=0) do . . set timeStr=" " . else do . . set timeStr=timeStr_mins_":" . . if secs<10 set timeStr=timeStr_"0" . . set timeStr=timeStr_secs_" " . if delta<0 set timeStr="+"_timeStr ;"just report # sec's overrun. else set timeStr="?? Time" set width=width-$length(label)-($length(timeStr)+1) set premark=(width*pct)\1 set postmark=width-premark if (max-min)=0 set pct=0 else set pct=(value-min)/(max-min) if pct>1 set pct=1 if pct<0 set pct=0 if (pct<1)&($get(startTime)="") set startTime=$H write label,":" if pct<1 write " " if pct<0.1 write " " write (pct*100)\1,"% " for i=0:1:premark-1 do . if (barberPole+i)#4=0 write "~" . else write "-" write ">|" for i=1:1:(postmark-1) write "-" if postmark>0 write "| " write timeStr goto PBD1 Spin1 new spinBar set spinBar=+$get(@pRefCt@("SPIN BAR")) new spinDir set spinDir=+$get(@pRefCt@("SPIN BAR","DIR")) ;"1=forward, -1=backwards if spinDir=0 set spinDir=1 set spinBar=spinBar+spinDir if spinBar>100 do . set spinDir=-1 . set spinBar=100 if spinBar<0 do . set spinDir=1 . set spinBar=0 set @pRefCt@("SPIN BAR")=spinBar set @pRefCt@("SPIN BAR","DIR")=spinDir set @pRefCt@("SPIN BAR","LAST INC")=$H new marker set marker="<=>" set width=width-$length(label)-$length(marker) set pct=spinBar/100 set premark=(width*pct)\1 set postmark=width-premark write label," |" for i=0:1:premark-1 write "-" write marker for i=1:1:(postmark-1) write "-" if pct<1 write "-" write "|" PBD1 ;"write $char(13) set $X=0 write ! do CUU^TMGTERM(1) PBDone do ;"Turn cursor display back on. . ;"new $etrap set $etrap="" . ;"xecute ^%ZOSF("TRMON") . ;"U $I:(TERMINATOR=$C(13,127)) ;"new discard set discard=$get(@NakedRef) ;"reset naked reference. quit PRESSTOCONT ;" Alternative entry point PressToCont ; ;"Purpose: to provide a 'press key to continue' action ;"result: none ;"Output: will set TMGPTCABORT=1 if user entered ^ write "----- Press Key To Continue -----" new ch set ch=$$KeyPressed^TMGUSRIF(0,240) if (ch=94) set TMGPTCABORT=1 ;"set abort user entered ^ else kill TMGPTCABORT write ! quit UserAborted(AbortLabel) ;"Purpose: Checks if user pressed ESC key. If so, then ask if abort wanted ;"Note: return is immediate. ;"Returns: 1 if user aborted, 0 if not. new result set result=0 if $$KeyPressed=27 do . new % set %=2 . write !,"Abort" . if $get(AbortLabel)'="" do . . write " "_AbortLabel . do YN^DICN write ! . set result=(%=1) quit result KeyPressed(wantChar,waitTime) ;"Purpose: to check for a keypress ;"Input: wantChar -- OPTIONAL, if 1, then Character is returned, not ASCII value ;" waitTime -- OPTIONAL, default is 0 (immediate return) ;"Result: ASCII value of key, if pressed, -1 otherwise ("" if wantChar=1) ;"Note: this does NOT wait for user to press key new temp set waitTime=$get(waitTime,0) read *temp:waitTime if $get(wantChar)=1 set temp=$char(temp) quit temp Read(Terminators,timeOut,Num,initialVal,EscKey) ;"Purpose: a custom read function with custom terminators ;"Input: Terminators -- OPTIONAL Flags to specify characters that will signal that ;" the user is done with input. Flags as follows: ;" r = return/enter ;" t = tab ;" s = space ;" e = escape ;" b = backspace ;" NONE = no terminators ;" e.g. 'rte' means that if user enters a return, tab, or escape ;" then input it ended, and characters (up to, but not including ;" terminator) entered are returned. ;" e.g. 'NONE' --> NO terminators. NOTE: MUST supply a number ;" characters to read, or endless loop will result. ;" If Terminator="", then default value of 'r' is used ;" timeOut -- Optional -- the allowed lengh of time to wait before timeout. ;" default value is 999,999 seconds (~11 days) ;" Num -- OPTIONAL -- a number of characters to read, e.g. 5 to read just ;" 5 characters (or less than 5 if terminator encountered) ;" initialVal-- OPTIONAL -- This can be a value that presents the output ;" It also allows editing of former inputs. Note: this function ;" assumes that initialValue has been printed to the screen before ;" calling this function. ;" EscKey-- OPTIONAL -- PASS BY REFERENCE, an OUT PARAMETER ;" if Terminator includes "e", then EscKey will be filled ;" with a translated value for esc sequence, e.g. UP ;" (as found in ^XUTL("XGKB",*)) ;" ;"Result: returns characters read. new result set result=$get(initialVal) new tmgZB set timeOut=+$get(timeOut,999999) new len set len=0 set Num=$get(Num) set Terminators=$get(Terminators) if Terminators="" set Terminators="r" else if Terminators="NONE" set Terminators="" new temp new done set done=0 set EscKey="" ;"NOTE, I could rewrite this to use built in terminators functions... ;"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))" RLoop xecute ^%ZOSF("EOFF") ;"echo off if Terminators["e" use $I:ESCAPE read *temp:timeOut ;"reads the ascii number of key (92, instead of 'a') set tmgZB=$ZB ;"write " $l(tmgZB)=",$l(tmgZB)," tmgZB=" f i=1:1:$l(tmgZB) w $ascii($E(tmgZB,i)),"," if Terminators["e" use $I:NOESCAPE xecute ^%ZOSF("EON") if (temp=13)&(Terminators["r") do . set done=1 else if (temp=9)&(Terminators["t") do . set done=1 else if (temp=32)&(Terminators["s") do . set done=1 else if (temp=27)&(Terminators["e") do . set EscKey=$get(^XUTL("XGKB",tmgZB)) . if EscKey="" do . . do FixEscTable . . set EscKey=$get(^XUTL("XGKB",tmgZB)) . set done=1 else if (temp=127)&(Terminators["b") do . set done=1 else if (temp'=-1) do . if temp=127 do quit . . if result="" quit . . set result=$extract(result,1,$length(result)-1) . . write $char(8)," ",$char(8) . set result=result_$char(temp) . write $char(temp) . if Num="" quit . if $length(result)'<+Num set done=1 if 'done goto RLoop quit result FixEscTable ;"Purpose: There is a difference between my old system and the new. I ;" don't know why, but this will fix it for me, and anyone else. T1 ;;$C(1))="^A" ;;$C(2))="^B" ;;$C(3))="^C" ;;$C(4))="^D" ;;$C(5))="^E" ;;$C(6))="^F" ;;$C(7))="^G" ;;$C(8))="^H" ;;$C(9))="TAB" ;;$C(10))="^J" ;;$C(11))="^K" ;;$C(12))="^L" ;;$C(13))="CR" ;;$C(14))="^N" ;;$C(15))="^O" ;;$C(16))="^P" ;;$C(17))="^Q" ;;$C(18))="^R" ;;$C(19))="^S" ;;$C(20))="^T" ;;$C(21))="^U" ;;$C(22))="^V" ;;$C(23))="^W" ;;$C(24))="^X" ;;$C(25))="^Y" ;;$C(26))="^Z" ;;$C(27)_"OM")="KPENTER" ;;$C(27)_"OP")="PF1" ;;$C(27)_"OQ")="PF2" ;;$C(27)_"OR")="PF3" ;;$C(27)_"OS")="PF4" ;;$C(27)_"Ol")="KP+" ;;$C(27)_"Om")="KP-" ;;$C(27)_"On")="KP." ;;$C(27)_"Op")="KP0" ;;$C(27)_"Oq")="KP1" ;;$C(27)_"Or")="KP2" ;;$C(27)_"Os")="KP3" ;;$C(27)_"Ot")="KP4" ;;$C(27)_"Ou")="KP5" ;;$C(27)_"Ov")="KP6" ;;$C(27)_"Ow")="KP7" ;;$C(27)_"Ox")="KP8" ;;$C(27)_"Oy")="KP9" ;;$C(27)_"[15~")="F5" ;;$C(27)_"[17~")="F6" ;;$C(27)_"[18~")="F7" ;;$C(27)_"[19~")="F8" ;;$C(27)_"[1~")="FIND" ;;$C(27)_"[20~")="F9" ;;$C(27)_"[21~")="F10" ;;$C(27)_"[23~")="F11" ;;$C(27)_"[24~")="F12" ;;$C(27)_"[25~")="F13" ;;$C(27)_"[26~")="F14" ;;$C(27)_"[28~")="HELP" ;;$C(27)_"[29~")="DO" ;;$C(27)_"[2~")="INSERT" ;;$C(27)_"[31~")="F17" ;;$C(27)_"[32~")="F18" ;;$C(27)_"[33~")="F19" ;;$C(27)_"[34~")="F20" ;;$C(27)_"[3~")="REMOVE" ;;$C(27)_"[4~")="SELECT" ;;$C(27)_"[5~")="PREV" ;;$C(27)_"[6~")="NEXT" ;;$C(27)_"[A")="UP" ;;$C(27)_"[B")="DOWN" ;;$C(27)_"[C")="RIGHT" ;;$C(27)_"[D")="LEFT" ;;$C(28))="^\" ;;$C(29))="^]" ;;$C(30))="^6" ;;$C(31))="^_" ;;#DONE# ; new i,s for i=0:1 do quit:(s["#DONE#") . set s=$TEXT(T1+i^TMGUSRIF) . quit:(s["#DONE#") . set s=$piece(s,";;",2) . new x set x="s ^XUTL(""XGKB"","_s . write x,! . xecute x quit IENSelector(pIENArray,pResults,File,Fields,Widths,Header,SortFlds,SaveArray) ;"Purpose: to allow selecting records from an IEN array ;"Input: pIENArray, PASS BY NAME. An array of IENS to select from ;" format: ;" @pIENArray@(IEN)="" ;" @pIENArray@(IEN)="" ;" @pIENArray@(IEN,"SEL")="" ;"<-- Optional marker to have this preselected ;" pResults -- NAME OF array to have results returned in ;" ** Note: Prior contents of array WILL be KILLED first ;" Format of returned array: Only those valuse that user selected will ;" be aded to list ;" @pResults@(IEN)=DisplayLineNumber ;" @pResults@(IEN)=DisplayLineNumber ;" File: The file number that IEN's are from. ;" Fields: OPTIONAL. The Field(s) that should be shown for record. .01 is Default ;" Fields may also be a ';' delimited list of Fields, e.g. ".01;.02;1". ;" Widths: Optional. The widths of the columns to display Fields in. ;" Format: e.g. "10;12;24" for three colums of widths: ;" Sequence must match sequence given in Fields ;" Default is to evenly space colums ;" Header -- OPTIONAL -- A header text to show. ;" SortFlds -- OPTIONAL -- Provide sorting fields ;" Format: 'FldNum1;FldNum2;FldNum3...' ;" SaveArray -- OPTIONAL -- PASS BY REFERENCE, ;" This variable will be filled with the NAME of the array ;" used for displaying the array. The FIRST time this function ;" is called, this variable should = "". On SUBSEQUENT calls, ;" if this variable holds the name of a variable (a reference), then ;" that array will be used, rather than taking the time to create ;" the display array again. Format of array: ;" @SaveArray(LineNumber)=IEN_$C(9)_Field1_"|"_Field2... ;" @SaveArray(LineNumber)=IEN_$C(9)_Field1_"|"_Field2... ;" Note: The LineNumber is the same number as the DisplayLineNumber ;" returned in @pResults@(IEN)=DisplayLineNUmber ;"Results: none if $get(pResults)'="" kill @pResults new PreSelArray new ref if $get(SaveArray)="" do . set ref=$name(^TMP("VEE",$J)) . kill @ref . set SaveArray=ref else do goto IS1 ;"Skip recreating array if SaveArray holds reference . set ref=SaveArray new ref2 set ref2=$name(^TMG("TMP",$J,"IEN-SELECT")) kill @ref2 if $get(Header)'="" set @ref@("HD")=Header set Sort=$get(Sort,0) set IOM=$get(IOM,80) set Fields=$get(Fields,".01") set Widths=$get(Widths) new Sort set Sort=($data(SortFlds)'=0) set File=$get(File) ;"Setup FldArray. Format: ;" FldArray=number of colums ;" FldArray(Sequence#)=field;fieldWidth ;" FldArray(Sequence#)=field;fieldWidth ;" FldArray(Sequence#)=field;fieldWidth new FldArray,i set FldArray=0 new WRemain set WRemain=IOM for i=1:1:$length(Fields,";") do . new Fld,W . set Fld=$piece(Fields,";",i) . if Fld="" quit . set W=+$piece(Widths,";",i) . if W=0 do . . if FldArray>0 set W=IOM/FldArray . . else set W=20 ;"some arbitrary number . if W>WRemain set W=WRemain ;"this isn't perfect . set WRemain=WRemain-W . if WRemain<1 set WRemain=1 . set FldArray(i)=Fld_";"_W . set FldArray=FldArray+1 new Itr,IEN,name,PriorErrorFound new abort set abort=0 new order set order=1 new IENPreSelected write "Prepairing list to display..." set IEN=$$ItrAInit^TMGITR(pIENArray,.Itr) do PrepProgress^TMGITR(.Itr,100,0,"IEN") write ! if IEN'="" for do quit:($$ItrANext^TMGITR(.Itr,.IEN)="")!(abort=1) . new TMGOUT,TMGMSG,IENS,showS,i . set showS="" . set IENS=IEN_"," . new tempFields . set IENPreSelected=($data(@pIENArray@(IEN,"SEL"))>0) . new i for i=1:1:FldArray do . . if showS'="" set showS=showS_"|" . . new Fld,tempS . . set Fld=$piece(FldArray(i),";",1) . . set tempS=$$GET1^DIQ(File,IENS,Fld,,"TMGOUT","TMGMSG") . . if $piece($get(^DD(File,Fld,0)),"^",2)["D" do ;"format dates for sorting if in column 1 . . . new %DT,X,Y . . . set X=tempS . . . do ^%DT ;"X in, Y out . . . set tempS=$$DTFormat^TMGMISC(Y,"yyyy mm/dd") ;"make dates sort numerically . . if $data(TMGMSG("DIERR")) do set abort=1 quit . . . do ShowDIERR^TMGDEBUG(.TMGMSG,.PriorErrorFound) . . new W set W=$piece(FldArray(i),";",2) . . set tempS=$extract(tempS,1,W) . . if Sort set tempFields(Fld)=tempS . . set showS=showS_$$LJ^XLFSTR(tempS,W," ") . if Sort=0 do . . set @ref@(order)=IEN_$char(9)_showS . . if IENPreSelected set PreSelArray(order)="" . . set order=order+1 . else do . . new tempRef set tempRef=ref2 . . for i=1:1:$length(SortFlds,";") do . . . new oneFld set oneFld=$piece(SortFlds,";",i) . . . new F set F=$get(tempFields(oneFld)) . . . if F="" quit . . . set tempRef=$name(@tempRef@(F)) . . set @tempRef@(IEN)=IEN_$char(9)_showS . . if IENPreSelected set @tempRef@(IEN,"SEL")="" . . ;"Sets up sorted variable as follows: . . ;" @tempRef@(sortFld1,sortFld2,sortFld3,IEN)='IEN_$char(9)_showS' . . ;" @tempRef@(sortFld1,sortFld2,sortFld3,IEN)='IEN_$char(9)_showS' . . ;" @tempRef@(sortFld1,sortFld2,sortFld3,IEN)='IEN_$char(9)_showS' do ProgressDone^TMGITR(.Itr) write ! if abort=1 goto ISDone IES1 if Sort=1 do . write "Sorting... " . set order=1 . new tempRef2 set tempRef2=ref2 . new showS,NumNodes,Done . set Done=0 . for do quit:(tempRef2="")!(Done=1) . . set tempRef2=$query(@tempRef2) . . if (tempRef2="") quit . . if $qsubscript(tempRef2,$qlength(tempRef2))="SEL" do quit . . . set PreSelArray(order-1)="" . . if (tempRef2'[$$OREF^DILF(ref2)) set Done=1 quit . . set showS=$get(@tempRef2) . . set @ref@(order)=showS . . set order=order+1 ;"Note: Rules of use: ;" ref must=^TMP("VEE",$J) ;" Each line should be in this format: ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue ;" Note: if DisplayValue is to be divided into colums, then ;" use | character to separate ;" @ref@("HD")=Header to display ;" Results come back in: ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue ;" To preselect entries, provide an array like this: ;" array(number)="" <-- number is same number as above, shows selected ;" array(number)="" ;" array(number)="" ;" pass array by name: SELECT^%ZVEMKT(ref,,"array") IS1 new NumberLines set NumberLines=0 ;"1--> number each line new AddNew set AddNew=0 ;"1-> Allow adding new entry write "Passing off to selector..." D SELECT^%ZVEMKT(ref,NumberLines,AddNew,"PreSelArray") ;"Format results new Itr2,index set index=$$ItrAInit^TMGITR($name(^TMP("VPE","SELECT",$J)),.Itr2) if index'="" for do quit:($$ItrANext^TMGITR(.Itr2,.index)="") . new s set s=$piece($get(^TMP("VPE","SELECT",$J,index)),$char(9),1) . set @pResults@(s)=index kill ^TMP("VPE","SELECT",$J) if $get(ref2) kill @ref2 ;"i.e. ^TMG("TMP",$J,"IEN-SELECT") ISDone quit Selector(pArray,pResults,Header) ;"Purpose: Interface with VPE Selector code to select from an array ;"Input: pArray -- NAME OF array holding items to be selected from ;" Expected format: ;" @pArray@("Display Choice Words")=ReturnValue <-- ReturnValue is optional ;" @pArray@("Display Choice Words")=ReturnValue ;" @pArray@("Display Choice Words")=ReturnValue ;" @pArray@("Display Choice Words","SEL")="" <-- optional preselection indicator ;" pResults -- NAME OF array to have results returned in ;" ** Note: Prior contents of array will NOT be KILLED first ;" Format of returned array: Only those valuse that user selected will be returned ;" @pResults@("Display Choice Words")=ReturnValue <-- ReturnValue is optional ;" @pResults@("Display Choice Words")=ReturnValue ;" @pResults@("Display Choice Words")=ReturnValue ;" Header -- OPTIONAL -- A header text to show. ;"Results: None new ref set ref=$name(^TMP("VEE",$J)) kill @ref if $get(pArray)="" goto SelDone if $get(pResults)="" goto SelDone new PreSelArray ;"First set up array of options new DispWords,RtnValue new order set order=1 set DispWords=$order(@pArray@("")) if DispWords'="" for do quit:(DispWords="") . set RtnValue=$get(@pArray@(DispWords),"") . set @ref@(order)=RtnValue_$char(9)_$extract(DispWords,1,$get(IOM,80)) . if $data(@pArray@(DispWords,"SEL")) set PreSelArray(order)="" ;"mark as preselected . set order=order+1 . set DispWords=$order(@pArray@(DispWords)) if $get(Header)'="" set @ref@("HD")=Header ;"Note: Rules of use: ;" ref must=^TMP("VEE",$J) ;" Each line should be in this format: ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue ;" Note: if DisplayValue is to be divided into colums, then ;" use | character to separate ;" Results come back in: ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue ;" To preselect entries, provide an array like this: ;" array(number)="" <-- number is same number as above, shows selected ;" array(number)="" ;" array(number)="" ;" pass array by name: SELECT^%ZVEMKT(ref,,"array") new NumberLines set NumberLines=0 ;"1--> number each line new AddNew set AddNew=0 ;"1-> Allow adding new entry D SELECT^%ZVEMKT(ref,NumberLines,AddNew,"PreSelArray") ;"Format selected options. new index set index=$order(^TMP("VPE","SELECT",$J,"")) if index'="" for do quit:(index="") . new s,s1,s2 . set s=$get(^TMP("VPE","SELECT",$J,index)) . set s1=$piece(s,$char(9),1) . set s2=$piece(s,$char(9),2) . set @pResults@(s2)=s1 . set index=$order(^TMP("VPE","SELECT",$J,index)) kill ^TMP("VPE","SELECT",$J) kill @ref SelDone quit Slctor2(pArray,pResults,Header) ;"Purpose: Interface with VPE Selector code to select from an array ;" Note: This allows a different format of input. In Selector() above, ;" it is NOT possible to have two similar Display Words with ;" different return values. E.g. two drugs with LISINOPRIL, but ;" different IEN return values. This fn allows this ;"Input: pArray -- NAME OF array holding items to be selected from ;" Expected format: ;" @pArray@("Display Choice Words",ReturnValue)="" <-- return value IS required ;" @pArray@("Display Choice Words",ReturnValue)="" ;" @pArray@("Display Choice Words",ReturnValue)="" ;" @pArray@("Display Choice Words",ReturnValue,"SEL")="" <-- optional preselection indicator ;" pResults -- NAME OF array to have results returned in ;" ** Note: Prior contents of array will NOT be KILLED first ;" Format of returned array: Only those values that user selected will be returned ;" @pResults@("Display Choice Words",ReturnValue)="" ;" @pResults@("Display Choice Words",ReturnValue)="" ;" @pResults@("Display Choice Words",ReturnValue)="" ;" Header -- OPTIONAL -- A header text to show. new ref set ref=$name(^TMP("VEE",$J)) kill @ref if $get(pArray)="" goto Sl2Done if $get(pResults)="" goto Sl2Done new PreSelArray ;"First set up array of options new DispWords,RtnValue new order set order=1 set DispWords="" for set DispWords=$order(@pArray@(DispWords)) quit:(DispWords="") do . set RtnValue="" . for set RtnValue=$order(@pArray@(DispWords,RtnValue)) quit:(RtnValue="") do . . set @ref@(order)=RtnValue_$char(9)_$extract(DispWords,1,$get(IOM,80)) . . if $data(@pArray@(DispWords,RtnValue,"SEL")) set PreSelArray(order)="" ;"mark as preselected . . set order=order+1 if $get(Header)'="" set @ref@("HD")=Header ;"Note: Rules of use: ;" ref must=^TMP("VEE",$J) ;" Each line should be in this format: ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue ;" @ref@(number)=ReturnValue_$char(9)_DisplayValue ;" Note: if DisplayValue is to be divided into colums, then ;" use | character to separate ;" Results come back in: ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue ;" ^TMP("VPE","SELECT",$J,number)=ReturnValue_$char(9)_DisplayValue ;" To preselect entries, provide an array like this: ;" array(number)="" <-- number is same number as above, shows selected ;" array(number)="" ;" array(number)="" ;" pass array by name: SELECT^%ZVEMKT(ref,,"array") new NumberLines set NumberLines=0 ;"1--> number each line new AddNew set AddNew=0 ;"1-> Allow adding new entry D SELECT^%ZVEMKT(ref,NumberLines,AddNew,"PreSelArray") ;"Format selected options. new index set index=$order(^TMP("VPE","SELECT",$J,"")) if index'="" for do quit:(index="") . new s,s1,s2 . set s=$get(^TMP("VPE","SELECT",$J,index)) . set s1=$piece(s,$char(9),1) . set s2=$piece(s,$char(9),2) . set @pResults@(s2,s1)="" . set index=$order(^TMP("VPE","SELECT",$J,index)) kill ^TMP("VPE","SELECT",$J) kill @ref Sl2Done quit MENU(Options,defChoice,UserRaw) QUIT $$Menu(.Options,.defChoice,.UserRaw) Menu(Options,defChoice,UserRaw) ;"Purpose: to provide a simple menuing system ;"Input: Options -- PASS BY REFERENCE ;" Format: ;" Options(0)=Header Text <--- optional, default is MENU ;" Options(DispNumber)=MenuText_$C(9)_ReturnValue <-- _$C(9)_ReturnValue OPTIONAL, default is DispNumber ;" Options(DispNumber)=MenuText_$C(9)_ReturnValue ;" Options(DispNumber)=MenuText_$C(9)_ReturnValue ;" defChoice: OPTIONAL, the default menu value ;" UserRaw : OPTIONAL, PASS BY REFERENCE, an OUT PARAMETER. Returns users raw input ;"Results: The selected ReturnValue (or DispNumber if no ReturnValue provided), or ^ for abort new result set result="^" new s,fg,bg new width set width=50 new line set $piece(line,"=",width+1)="" MNU1 if $data(Options(-1,"COLOR")) do . set fg=$get(Options(-1,"COLOR","fg"),0) . set bg=$get(Options(-1,"COLOR","bg"),1) . do VCOLORS^TMGTERM(fg,bg) write line,! write $get(Options(0),"MENU"),$$Pad2Pos^TMGSTUTL(width),! write line,! write "Options:",$$Pad2Pos^TMGSTUTL(width),! new DispNumber set DispNumber=$order(Options(0)) if DispNumber'="" for do quit:(DispNumber="") . set s=$get(Options(DispNumber)) . write $$RJ^XLFSTR(DispNumber,4),".",$$Pad2Pos^TMGSTUTL(6) . if $data(Options(DispNumber,"COLOR")) do . . set fg=$get(Options(DispNumber,"COLOR","fg"),0) . . set bg=$get(Options(DispNumber,"COLOR","bg"),1) . . do VCOLORS^TMGTERM(fg,bg) . write $piece(s,$char(9),1),$$Pad2Pos^TMGSTUTL(width-1) . if $data(Options(DispNumber,"COLOR")) do . . do VTATRIB^TMGTERM(0) ;"Reset colors . write " ",! . set DispNumber=$order(Options(DispNumber)) write line,! set defChoice=$get(defChoice,"^") new input write "Enter selection (^ to abort): ",defChoice,"// " read input:$get(DTIME,3600),! if input="" set input=defChoice set UserRaw=input if input="^" goto MNUDone set s=$get(Options(input)) if s="" set s=$get(Options($$UP^XLFSTR(input))) ;"if s="" write "??",!! goto MNU1 set result=$piece(s,$char(9),2) if result="" set result=input MNUDone if $data(Options(-1,"COLOR")) do VTATRIB^TMGTERM(0) ;"Reset colors quit result ProgTest ;"Purpose: test progress bar. new i,u,max set max=100 for i=0:1:max do . do ProgressBar(i,"%",1,max) . hang 0.25 quit SpinTest ;"Purpose: test progress bar. new i,u,max set max=3000 for i=0:10:max do . do ProgressBar(i," "_i,-1,-1) . hang 0.1 quit Scroller(pArray,Option) ;"Purpose: Provide a scroll box ;"Input: pArray -- PASS BY NAME. format: ;" @pArray@(1,DisplayText)=Return Text <-- note: must be numbered 1,2,3 etc. ;" @pArray@(2,DisplayText)=Return Text ;" @pArray@(3,DisplayText)=Return Text ;" NOTE: if Display text contains {{name}} then name is taken as color directive ;" Example: 'Here is {{BOLD}}something{{NORM}} to see.' ;" if NAME is not defined in Option("COLORS",NAME), it is ignored ;" Option -- PASS BY REFERENCE. format: ;" Option("HEADER",1)=Header line text ;" Option("HEADER",2)=More Header line text (any number of lines) ;" Option("FOOTER",1)=Footer line text <--- Option 1 ;" Option("FOOTER",1,1)=linePart <--- Option 2 (these will be all strung together to make one footer line. ;" Option("FOOTER",1,2)=linePart (can be used to display switches etc) ;" Option("FOOTER",2)=More footer line text (any number of lines) ;" Option("SHOW INDEX")=1 Optional. If 1, then index is shown. ;" Option("SCRN WIDTH")= Optional screen width. (default is terminal width) ;" ---- Colors (optional) ------ ;" Option("COLORS","NORM")=FG^BG -- default foreground (FG) and background(colors) ;" If not provided, White on Blue used. ;" Option("COLORS","HIGH")=FG^BG -- Highlight colors. If not provided, White on Cyan used. ;" Option("COLORS","HEADER")=FG^BG Header color. NORM used if not provided ;" Option("COLORS","FOOTER")=FG^BG Footer color. NORM used if not provided ;" Option("COLORS","TOP LINE")=FG^BG Top line color. NORM used if not provided ;" Option("COLORS","BOTTOM LINE")=FG^BG Bottom line color. NORM used if not provided ;" Option("COLORS","INDEX")=FG^BG Index color. NORM used if not provided ;" Option("COLORS",SomeName)=FG^BG e.g. : ;" Option("COLORS","BOLD")=15^0 (Any arbitrary name OK, matched to {{name}} in text) ;" Option("COLORS","HIGH")=10^@ ;" If BG="@", then default BG used. This may be used anywhere except for defining NORM ;" ---- events ---- ;" Option("ON SELECT")="FnName^Module" -- code to call based on user input ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line ;" Option("ON CHANGING")="FnName^Module" -- code to execute for number entry ;" Info("CURRENT LINE","NUMBER")=number currently highlighted line ;" Info("CURRENT LINE","TEXT")=Text of currently highlighted line ;" Info("CURRENT LINE","RETURN")=return value of currently highlighted line ;" Info("NEXT LINE","NUMBER")=next line number. Used for ON CHANGING to show the line about to be selected ;" Info("ALLOW CHANGE")=1, <--- RETURN RESULT. Change to 0 to disallow move. ;" Option("ON CMD")="FnName^Module" -- code to execute for number entry ;" Info("USER INPUT")=UserTypedInput ;" NOTES about events. Functions will be called as follows: ;" do FnName^Module(pArray,.Option,.Info) ;" pArray and Option are the same data received by this function ;" -- thus Option can be used to can other custom information. ;" Info has extra info as outlined above. ;" If functions may set a globally-scoped var named TMGSCLRMSG to communicate back ;" if TMGSCLRMSG="^" then Scroller will exit ;"Result: none new scrnW,scrnH,scrnLine,spaceLine,topLine,sizeHdr,sizeFtr new entryCt,lineCt,EscKey,dispHt,highLine,showIdx new needRefresh,Info set topLine=1 set highLine=5 new TMGSCLRMSG set TMGSCLRMSG="" set scrnW=+$get(Option("SCRN WIDTH")) if scrnW'>0 do . if $$GetScrnSize^TMGKERNL(,.scrnW) . set scrnW=+scrnW-4 if scrnW'>0 set scrnW=$get(IOM,66)-2 ;"set scrnW=$get(IOM,60)-2 set scrnH=$get(IOSL,25)-2 if $get(Option("COLORS","NORM"))="" set Option("COLORS","NORM")="14^4" ;"white on blue if $get(Option("COLORS","HIGH"))="" set Option("COLORS","HIGH")="14^6" ;"white on cyan if $get(Option("COLORS","HEADER"))="" set Option("COLORS","HEADER")=Option("COLORS","NORM") if $get(Option("COLORS","FOOTER"))="" set Option("COLORS","FOOTER")=Option("COLORS","NORM") if $get(Option("COLORS","TOP LINE"))="" set Option("COLORS","TOP LINE")=Option("COLORS","NORM") if $get(Option("COLORS","BOTTOM LINE"))="" set Option("COLORS","BOTTOM LINE")=Option("COLORS","NORM") if $get(Option("COLORS","INDEX"))="" set Option("COLORS","INDEX")=Option("COLORS","NORM") new i set i="" for set i=$order(Option("COLORS",i)) quit:(i="") do . new colors set colors=$get(Option("COLORS",i)) . new FG set FG=$piece(colors,"^",1) if FG="" set FG=0 . new BG set BG=$piece(colors,"^",2) if BG="" set BG=1 . set Option("COLORS",i,"FG")=FG . set Option("COLORS",i,"BG")=BG Full set scrnLine="" set $piece(scrnLine,"-",scrnW)="-" set spaceLine="" set $piece(spaceLine," ",scrnW)=" " set sizeHdr=$$ListCt^TMGMISC($name(Option("HEADER")))+1 set sizeFtr=$$ListCt^TMGMISC($name(Option("FOOTER")))+1 set entryCt=$$ListCt^TMGMISC(pArray) set EscKey="" set dispHt=scrnH-sizeHdr-sizeFtr if topLine>entryCt set topLine=entryCt if highLine>entryCt set highLine=entryCt set showIdx=($get(Option("SHOW INDEX"))=1) Draw do HOME^TMGTERM if $data(Option("HEADER")) do . do SetColor("HEADER",.Option) . new i set i="" . for set i=$order(Option("HEADER",i)) quit:(i="") do . . write $$CJ^XLFSTR($get(Option("HEADER",i)),scrnW),! set lineCt=topLine ;"do VCOLORS^TMGTERM(14,4) ;"bright white on blue background do SetColor("TOP LINE",.Option) write scrnLine,! do SetColor("NORM",.Option) for quit:(lineCt=(dispHt+topLine-1)) do . ;"if lineCt=highLine do VCOLORS^TMGTERM(14,6) ;"bright white on cyan background . ;"else do VCOLORS^TMGTERM(14,4) ;"bright white on blue background . if lineCt=highLine do SetColor("HIGH",.Option) . else do SetColor("NORM",.Option) . new s set s="" . if showIdx do . . do SetColor("INDEX",.Option) . . write $$RJ^XLFSTR(lineCt,3)_"." . . if lineCt=highLine do SetColor("HIGH",.Option) . . else do SetColor("NORM",.Option) . . write " " . new text,textA,textB,textColor . set text=$order(@pArray@(lineCt,"")) . for quit:(text'["{{")!($X' TextA{{Color}}Text . . if $X+$length(textA)>scrnW do . . . write $extract(textA,1,(scrnW-$X-3))_"..." . . else write textA . . do SetColor(textColor,.Option) . write text . write $extract(spaceLine,1,(scrnW-$X)) . do SetColor("RESET") write ! . ;"if showIdx set s=$$RJ^XLFSTR(lineCt,3)_". " . ;"set s=$$LJ^XLFSTR(s_$order(@pArray@(lineCt,"")),scrnW) . ;"if $length(s)>scrnW set s=$extract(s,1,scrnW-3)_"..." . ;"write s,! . set lineCt=lineCt+1 ;"do VCOLORS^TMGTERM(14,4) ;"bright white on blue background do SetColor("BOTTOM LINE",.Option) write scrnLine,! do SetColor("FOOTER",.Option) ;"do VTATRIB^TMGTERM(0) ;"reset colors if $data(Option("FOOTER")) do . new i set i="" . for set i=$order(Option("FOOTER",i)) quit:(i="") do . . new j set j=$order(Option("FOOTER",i,"")) . . if j'="" do . . . new oneLine set oneLine="",j="" . . . for set j=$order(Option("FOOTER",i,j)) quit:(j="") do . . . . set oneLine=oneLine_$get(Option("FOOTER",i,j))_" | " . . . write $$LJ^XLFSTR(oneLine,scrnW),! . . else write $$LJ^XLFSTR($get(Option("FOOTER",i)),scrnW),! set Info("CURRENT LINE","NUMBER")=highLine set Info("CURRENT LINE","TEXT")=$order(@pArray@(highLine,"")) set Info("CURRENT LINE","RETURN")=$get(@pArray@(highLine,Info("CURRENT LINE","TEXT"))) do SetColor("RESET") write $$LJ^XLFSTR(": ",scrnW),! do CUU^TMGTERM(1) write ": " set needRefresh=0 UsrIn set input=$$Read("re",,,,.EscKey) if (input="")&(EscKey="") set EscKey="CR" if EscKey="UP" set input="UP^1" if EscKey="PREV" set input="UP^15" if EscKey="DOWN" set input="DOWN^1" if EscKey="NEXT" set input="DOWN^15" if EscKey="CR" do goto Lp2 . new codeFn set codeFn=$get(Option("ON SELECT")) quit:(codeFn="") . set codeFn="do "_codeFn_"(pArray,.Option,.Info)" . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode=""""" . xecute codeFn . set needRefresh=2 if input="^" goto ScrlDone if (input["^") do goto Lp2 . if $piece(input,"^",1)="UP" do . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode=""""" . . new codeFn set codeFn=$get(Option("ON CHANGING")) . . if codeFn'="" set codeFn="do "_codeFn_"(pArray,.Option,.Info)" . . set Info("ALLOW CHANGE")=1 . . set needRefresh=1 . . new j for j=1:1:+$piece(input,"^",2) do . . . if highLine>topLine do . . . . set Info("NEXT LINE","NUMBER")=(highLine-1) . . . . if codeFn'="" xecute codeFn quit:'$get(Info("ALLOW CHANGE")) set needRefresh=2 . . . . set highLine=highLine-1 . . . else if topLine>1 do . . . . set Info("NEXT LINE","NUMBER")=(topLine-1) . . . . if codeFn'="" xecute codeFn quit:'$get(Info("ALLOW CHANGE")) set needRefresh=2 . . . . set topLine=topLine-1,highLine=topLine . else if $piece(input,"^",1)="DOWN" do . . new $etrap set $etrap="write ""(Invalid M Code!. Error Trapped.)"",! set $etrap="""",$ecode=""""" . . new codeFn set codeFn=$get(Option("ON CHANGING")) . . if codeFn'="" set codeFn="do "_codeFn_"(pArray,.Option,.Info)" . . set Info("ALLOW CHANGE")=1 . . set needRefresh=1 . . new j for j=1:1:+$piece(input,"^",2) do . . . if highLine<(topLine+dispHt-2) do . . . . set Info("NEXT LINE","NUMBER")=(highLine-1) . . . . if codeFn'="" xecute codeFn quit:'$get(Info("ALLOW CHANGE")) set needRefresh=2 . . . . set highLine=highLine+1 . . . else if (topLine+dispHt-2)