TMGWGOJ ;TMG/kst/OO Graphic Object ;04/18/07 ;;1.0;TMG-LIB;**1**;04/18/07 ;"Kevin Toppenberg MD ;"GNU General Public License (GPL) applies ;"------------------------------------------ ;"Object oriented window object setup code below ;"------------------------------------------ Constructor(instanceName) ;"Module MUST have 'Constructor' procedure ;"Purpose -- A constructor for object Window ;"Input: instanceName -- the NAME of the type of the object to be defined. ;" This should be a variable (global or otherwise) of the object. ;"Note: This function should NOT be called directly, but instead is called ;" via new^TMGOOL ;"Result: none <--- REQUIRED TO NOT RETURN A RESULT ;"Here we define the default values for vars and functions. ;"----------------All constructors should copy this format -------------------- new TMGthis set TMGthis=instanceName ;"do inheritFrom^TMGOOL(instanceName,"TMGWSCR") ;"Examples of use: PROCEDURES/FUNCTIONS ;"Note: to evoke a procedure/function, use this format: ;" do proc^TMGOOL(instanceName,"SET TOP",MyTopVar),! ;" set MyTop=$$fn^TMGOOL(instanceName,"GET TOP") ;"--------------------------------------------------------- ;"register PROCEDURES/FUNCTIONS do regFn^TMGOOL(TMGthis,"PAINT","Paint^TMGWGOJ()") do regFn^TMGOOL(TMGthis,"MOVE TO","MoveTo^TMGWGOJ(Top,Left)") ;"note parameter variables are placeholders do regFn^TMGOOL(TMGthis,"SET TLBR","setTLBR^TMGWGOJ(Top,Left,Bottom,Right)") ;"note parameter variables are placeholders do regFn^TMGOOL(TMGthis,"SET TLHW","setTLHW^TMGWGOJ(Top,Left,Height,Width)") ;"note parameter variables are placeholders do regFn^TMGOOL(TMGthis,"MOVE OBJ","MoveObj^TMGWGOJ(cmdKey)") do regFn^TMGOOL(TMGthis,"RESIZE OBJ","ResizeObj^TMGWGOJ(flags,cmdKey)") do regFn^TMGOOL(TMGthis,"CLIP TO PARENT","ClipToParent^TMGWGOJ(TMGthis)") do regFn^TMGOOL(TMGthis,"GET SCREEN","GetScrn^TMGWGOJ()") do regFn^TMGOOL(TMGthis,"ACCEPT CHILD","AcceptChild^TMGWGOJ(Child)") do regFn^TMGOOL(TMGthis,"SET FOCUSED","setFocused^TMGWGOJ(child)") do regFn^TMGOOL(TMGthis,"IS FOCUSED","IsFocused^TMGWGOJ(child)") do regFn^TMGOOL(TMGthis,"GET FOCUSED","getFocused^TMGWGOJ()") do regFn^TMGOOL(TMGthis,"UNFOCUS CURRENT FOCUSED","UnfocusCur^TMGWGOJ()") do regFn^TMGOOL(TMGthis,"FLUSH SCREEN SAVE","FlushScrnSave^TMGWGOJ()") do regFn^TMGOOL(TMGthis,"FLUSH MOUSE SAVE","FlushMouseBuffer^TMGWGOJ()") do regFn^TMGOOL(TMGthis,"CONTAINS COORDS","Contains^TMGWGOJ(LOC)") do regFn^TMGOOL(TMGthis,"GET CONTAINED","GetContained^TMGWGOJ(LOC)") do regFn^TMGOOL(TMGthis,"CONVERT TO FRAME","Conv2Frame^TMGWGOJ(LOC,TargetFrame)") ;"--------------------------------------------------------------------- ;"Register Event Handlers do regEvent^TMGOOL(TMGthis,"MSG","HandleMsg^TMGWGOJ(cmdKey)") do regEvent^TMGOOL(TMGthis,"ALPHA KEY","HandleAlpha^TMGWGOJ(key)") do regEvent^TMGOOL(TMGthis,"CLICK","HandleClick^TMGWGOJ(LOC)") do regEvent^TMGOOL(TMGthis,"FRAME CLICK","FmClick^TMGWGOJ(LOC,Flags)") do regEvent^TMGOOL(TMGthis,"SHIFT-CLICK","HandleSClick^TMGWGOJ(LOC)") do regEvent^TMGOOL(TMGthis,"MOVE REQUEST","HndlMMove^TMGWGOJ(cmdKey)") do regEvent^TMGOOL(TMGthis,"LOOSING FOCUS","") ;"<--- implement later ;"--------------------------------------------------------------------- ;"Register Properties do regProp^TMGOOL(TMGthis,"LOC","","","$$getLOC^TMGWGOJ") ;"actually holds T,L,W,H,S,F below do regProp^TMGOOL(TMGthis,"TOP",0,"setTop^TMGWGOJ","$$getTop^TMGWGOJ") do regProp^TMGOOL(TMGthis,"LEFT",0,"setLeft^TMGWGOJ","$$getLeft^TMGWGOJ") do regProp^TMGOOL(TMGthis,"WIDTH",10,"setWidth^TMGWGOJ","$$getWidth^TMGWGOJ") do regProp^TMGOOL(TMGthis,"HEIGHT",10,"setHeight^TMGWGOJ","$$getHeight^TMGWGOJ") do regProp^TMGOOL(TMGthis,"ALIGN","NONE","","","NONE^TOP^LEFT^BOTTOM^RIGHT") do regProp^TMGOOL(TMGthis,"FRAME","SOLID","","","NONE^SOLID^SIZABLE") do regProp^TMGOOL(TMGthis,"NEEDS REPAINT",0,"","$$getNeedsRepaint^TMGWGOJ","0^1") do regProp^TMGOOL(TMGthis,"RESIZING FLAGS","","","","^[TBLR]") ;"current resizing mode do regProp^TMGOOL(TMGthis,"TITLE","") ;"default null title do regProp^TMGOOL(TMGthis,"PARENT","","setParent^TMGWGOJ","$$getParent^TMGWGOJ") do regProp^TMGOOL(TMGthis,"STATE",0,"setState^TMGWGOJ","$$getState^TMGWGOJ","SELECTED^0") do regProp^TMGOOL(TMGthis,"FOCUSED",0,"","","0^1") do regProp^TMGOOL(TMGthis,"LAST DRAW","") do regProp^TMGOOL(TMGthis,"SCREEN","") ;"--------------------------------------------------------------------- ;"Optional initialization of some instance-specific variables. ;"-------------------------------------------------------------------------------- ;"Startup code here... quit Destructor(instanceName) ;"Module MUST have 'Destructor' procedure ;"Purpose: A destructor for object Widget ;" any needed clean up code would go here first. ;"Input: instanceName -- the name of the object instance to be deleted. ;" This should be the value returned from defWidget ;"Note: Don't actually delete the object here. Just perform code needed to ;" save the object variables etc. Anything neeed before the object ;" is deleted by delete^TMGOOL ;"----------------- ;" Here I put code that needs to be called before destruction of the object. ;"----------------- ;"Here I delete any children (and they can delete their children) new num set num="" for set num=$order(@TMGthis@("CHILDREN",num)) quit:(+num'>0) do . new child set child=$order(@TMGthis@("CHILDREN",num,"")) . if child="" quit . do delete^TMGOOL(child) quit ;"------------------------------------------ ;"Object member functions below ;"------------------------------------------ ;"Note: A variable (with global scope) TMGthis is available as a 'this' pointer (this instance) ;"Note: ALL members must have QUIT xx (even if xx is meaningless, as in a procedure) Paint() ;"Purpose: To paint the current window (and all children windows) ;"Input: instanceName -- the name/ref of this instance new T,L,H,W,B,R,LOC new scrap set scrap=$$getProp^TMGOOL(TMGthis,"LOC",.LOC) set scrap=$$Conv2Frame(.LOC,"SCREEN") set T=+$get(LOC("TOP")),L=+$get(LOC("LEFT")) set B=+$get(LOC("BOTTOM")),R=+$get(LOC("RIGHT")) if $data(@TMGthis@("screen save")) do . do CLRCLIP^TMGXGF . do RESTORE^TMGXGF($name(@TMGthis@("screen save"))) . ;"note: tell children to flush their saved screens." . new num set num="" . for set num=$order(@TMGthis@("CHILDREN",num)) quit:(+num'>0) do . . new child set child=$order(@TMGthis@("CHILDREN",num,"")) . . if child="" quit . . do proc^TMGOOL(child,"FLUSH SCREEN SAVE") new selected,focused set selected=($$getProp^TMGOOL(TMGthis,"STATE")="SELECTED") ;"new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT") ;"set focused=$$fn^TMGOOL(parent,"IS FOCUSED",TMGthis) set focused=$$fn^TMGOOL(TMGthis,"IS FOCUSED") new rflags set rflags=$$getProp^TMGOOL(TMGthis,"RESIZING FLAGS") do proc^TMGOOL(TMGthis,"CLIP TO PARENT",TMGthis) if selected do CHGA^TMGXGF("I1") do WIN^TMGXGF(T,L,B,R,$name(@TMGthis@("screen save"))) if (rflags'="") do . do CHGA^TMGXGF("R1") . do FRAME^TMGXGF(T,L,B,R) . do CHGA^TMGXGF("R0") else if ('selected)&(focused) do . do CHGA^TMGXGF("I1") . do FRAME^TMGXGF(T,L,B,R) if (selected)!(focused) do CHGA^TMGXGF("I0") if rflags'="" do ;"goto P2 PMV . new msg set msg=" [" . if rflags="T" set msg=msg_"MOVING" . else set msg=msg_"RESIZING" . set msg=msg_". Press ENTER to stop] " . set W=+$get(LOC("WIDTH")) . set msg=$extract(msg,1,W-1) . do SAY^TMGXGF(T+1,L+1,msg,"") . do setProp^TMGOOL($$GetScrn(),"NEEDS REPAINT",1) ;"flag full screen repaint needed next time ;"Here I paint any children (and they can paint their children) new num set num="" for set num=$order(@TMGthis@("CHILDREN",num)) quit:(+num'>0) do X2 . new child set child=$order(@TMGthis@("CHILDREN",num,"")) . if child="" quit . do proc^TMGOOL(child,"PAINT") P2 do setProp^TMGOOL(TMGthis,"NEEDS REPAINT",0) ;"flag as painted. quit 0 MoveObj(cmdKey) ;"Purpose: To move (drag) the object based on mouse movement ;"Input: cmdKey. PASS BY REFERENCE. An array with following structure ;" cmdKey="xxx" <--- ignored ;" cmdKey("DELTA","TOP") <-- delta Y ;" cmdKey("DELTA","LEFT") <-- delta X ;"Output: returns result in cmdKey('RESULT'): -1=failure, 1=success new T,L,LOC,PLOC,dT,dL,csrT,csrL new result set result=0 new scrap set scrap=$$getProp^TMGOOL(TMGthis,"LOC",.LOC) set dT=+$get(cmdKey("DELTA","TOP")),dL=+$get(cmdKey("DELTA","LEFT")) set csrT=+$get(cmdKey("GLOBAL COORDS","TOP")) set csrL=+$get(cmdKey("GLOBAL COORDS","LEFT")) new PT,PL,PB,PR do getPCoords(TMGthis,.PT,.PL,.PB,.PR) ;"get parent coordinates (in SCREEN frame of refernce) if (dT<0)&(csrT0)&(csrT>PB) set result=-1 if (dL<0)&(csrL0)&(csrL>PR) set result=-1 if result=-1 goto MOL2 set T=$get(LOC("TOP"))+dT set L=$get(LOC("LEFT"))+dL set result=$$fn^TMGOOL(TMGthis,"MOVE TO",.T,.L) MOL2 if result>0 do . new scrap set scrap=$$FlushMouseBuffer() . do setProp^TMGOOL(TMGthis,"NEEDS REPAINT",1) ;"flag repaint of entire screen . set cmdKey("RESULT")=1 else do . set cmdKey("RESULT")=-1 quit result ResizeObj(flags,cmdKey) ;"Purpose: to resize the object based on mouse movement. ;"Input: flags ;" "T" if on top of frame ; <--- shouldn't be called here with just T ;" "B" if on bottom of frame ;" "L" if on left of frame ;" "R" if on right of frame ;" "TL","TR","BL","BR" for the corners ;" cmdKey. PASS BY REFERENCE. An array with following structure ;" cmdKey="xxx" <--- ignored ;" cmdKey("DELTA","TOP") <-- delta Y ;" cmdKey("DELTA","LEFT") <-- delta X ;"Results: none ;"Output: cmdKey("RESULT")=-1 if failure new T,L,W,H,LOC new scrap set scrap=$$getProp^TMGOOL(TMGthis,"LOC",.LOC) set T=$get(LOC("TOP")),L=$get(LOC("LEFT")) set H=$get(LOC("HEIGHT")),W=$get(LOC("WIDTH")) new dX,dY set dX=$get(cmdKey("DELTA","LEFT")) set dY=$get(cmdKey("DELTA","TOP")) if flags["T" do . set T=T+dY . set H=H-dY if flags["L" do . set L=L+dX . set W=W-dX if flags["B" do . set H=H+dY if flags["R" do . set W=W+dX new success set success=$$setTLHW(T,L,H,W) if success=0 do RO1 . set cmdKey("RESULT")=-1 ;"failure signal. else new scrap set scrap=$$FlushMouseBuffer() quit 0 MoveTo(Top,Left) ;"Purpose: position object ;"Results: 1 if change made, 0 if not change made new result set result=0 new LOC set LOC=$$getProp^TMGOOL(TMGthis,"LOC",.LOC) if $get(LOC("TOP"))'=Top do . do setProp^TMGOOL(TMGthis,"TOP",.Top) . if $$getProp^TMGOOL(TMGthis,"TOP")'=Top quit ;" set failed . set result=1 if $get(LOC("LEFT"))'=Left do . do setProp^TMGOOL(TMGthis,"LEFT",.Left) . if $$getProp^TMGOOL(TMGthis,"LEFT")'=Left quit ;" set failed . set result=1 ;"do setProp^TMGOOL(TMGthis,"TOP",.Top) ;"do setProp^TMGOOL(TMGthis,"LEFT",.Left) quit result AcceptChild(Child) ;"Purpose: to add a child to list of managed children ;"Input: Child -- name/ref of child to add ;"Note: this num will be used as a 'z-order'. Can reorder later new num set num="" for set num=$order(@TMGthis@("CHILDREN",num)) quit:(+num'=num) set num=$order(@TMGthis@("CHILDREN",num),-1) ;"get last used number set num=num+1 set @TMGthis@("CHILDREN",num,Child)="" quit 0 FlushScrnSave() ;"Purpose: To flush the saved text from under this window kill @TMGthis@("screen save") quit 0 Contains(LOC) ;"Purpose: To see if some coordinates are located inside this window ;"Input: LOC -- a location array. Pass by reference ;" LOC("TOP")=top ;" LOC("LEFT")=left ;" Coordinates (in parent's frame of reference) ;"Results: 1 if coordinates are contained, 0 otherwise new result set result=0 ;"new temp set temp=$$Conv2Local(.LOC) ;"new temp set temp=$$Conv2Frame(.LOC,TMGthis) ;"Reemmber, THISs' coordinates are in parent's frame of ref new thisLOC set thisLOC=$$getProp^TMGOOL(TMGthis,"LOC",.thisLOC) if (LOC("TOP")<$get(thisLOC("TOP")))!(LOC("LEFT")<$get(thisLOC("LEFT"))) goto CDone if LOC("TOP")>($get(thisLOC("TOP"))+$get(thisLOC("HEIGHT"))) goto CDone if LOC("LEFT")>($get(thisLOC("LEFT"))+$get(thisLOC("WIDTH"))) goto CDone set result=1 CDone quit result Conv2Frame(LOC,targetFrame) ;"Purpose: convert LOC to targetFrame's coordinate system. ;" Note: initially, targetFrame may only be the name/ref of a parent, ;" or child of TMGthis, or the word 'SCREEN' to indicate ;" a desired targetFrame to be in screen coordinates. ;"Input: LOC -- PASS BY REFERNCE. Expected input format: ;" LOC("TOP")= ;" LOC("LEFT")= ;" LOC("HEIGHT")= ;"optional ;" LOC("WIDTH")= ;"optional ;" LOC("BOTTOM")= ;" LOC("RIGHT")= ;" LOC("FRAME")=Frame of reference for these coordinates ;" Note: frame should typically be the same as ;" the PARENT of the current object ;" targetFrame=the frame of refernce to change to. ;"Results: none ;"Output: Input variables are modified as OUT PARAMETERS ;" LOC("TOP") is modified ;" LOC("LEFT") is modified ;" LOC("HEIGHT")=unchanged ;" LOC("WIDTH")=unchanged ;" LOC("BOTTOM") is updated ;" LOC("RIGHT") is updated new pathArray do getPath(.LOC,targetFrame,.pathArray) do convPath(.LOC,.pathArray) C2FDone quit 0 GetScrn() ;"Purpose: to get a ref/name/pointer to Screen. ;" Note: because all graphic objects have to have the Screen as the ;" ultimate parent, this will be found by recursively searching for parents ;"results: returns ref to Screen new result set result="" new curObj set curObj=TMGthis for do quit:(curObj="")!(result'="") . set result=$$getProp^TMGOOL(curObj,"SCREEN") . set curObj=$$getProp^TMGOOL(curObj,"PARENT") quit result ClipToParent(TMGthis,extraT,extraL,extraB,extraR) ;"Purpose: to set the clipping boundries to the parent frame of TMGthis ;"Note: because the parent frame might be partly off screen, this will also ;" clip to the screen to prevent off-screen writing. ;"Input: TMGthis -- the THIS pointer to have the clipping to ;" extraT,extraL,extraB,extraR -- OPTIONAL -- NOT IMPLEMENTED (YET) ;" was to allow shrinking of the clip area by extra amounts. new PT,PL,PB,PR do getPCoords(TMGthis,.PT,.PL,.PB,.PR) ;"get parent coordinates new pScrn set pScrn=$$GetScrn() new ST,SL,SB,SR,SLOC set SLOC=$$getProp^TMGOOL(pScrn,"LOC",.SLOC) ;"get screen coordinates set ST=+$get(SLOC("TOP")) set SL=+$get(SLOC("LEFT")) set SR=SL+$get(SLOC("WIDTH")) set SB=ST+$get(SLOC("HEIGHT")) if PT failure ;" 0 ==> OK ;" 1 ==> handled new result set result=0 set cmdKey=$get(cmdKey) set cmdKey("RESULT")=result new child set child="" new temp set temp=$$Conv2Frame(.cmdKey,TMGthis) ;"convert coordinates to TMGthis's frame if cmdKey="FULL PAINT" do . ;"Draw a frame to white out entire screen. . ;"do CLEAR^TMGXGF(0,0,IOSL,IOM) ;"clear screen portion TOP,LEFT,BOTTOM,RIGHT . new scrap set scrap=$$FlushScrnSave() . do setProp^TMGOOL(TMGthis,"NEEDS REPAINT",1) . set cmdKey="CHECK PAINT" if cmdKey="CHECK PAINT" do goto AMDone . do CheckPaint ;"note only MainWindow should be getting this event, from Screen ;"NOTE: If a CLICK occurs, check to pass the message on to newly chosen child ;" Otherwise message should go to focused child. if cmdKey["CLICK" do goto:(child'="") AMDone . ;"First find out if click should belong to a child window. If so, pass it on. . set child=$$GetContained(.cmdKey) . if child="" do UnfocusCur() quit ;"ignore click . else do FocusThis() . do fireEvent^TMGOOL(child,"MSG",.cmdKey) new focused set focused=$$getFocused() if focused'="" do goto AMDone . do fireEvent^TMGOOL(focused,"MSG",.cmdKey) ;"pass message to focused and quit ;"Message belongs to this object, so handle messages below: ;"-------------------------------------------------------- do FocusThis() if cmdKey="MOUSE-CLICK" do . set cmdKey("RESULT")=1 . do fireEvent^TMGOOL(TMGthis,"CLICK",.cmdKey) else if cmdKey="MOUSE-SHIFT-CLICK" do . do fireEvent^TMGOOL(TMGthis,"SHIFT-CLICK",.cmdKey) . set cmdKey("RESULT")=1 else if cmdKey="MOVE REQUEST" do AMMM . new flags set flags=$$getProp^TMGOOL(TMGthis,"RESIZING FLAGS") . if flags="" do fireEvent^TMGOOL(TMGthis,"MOVE REQUEST",.cmdKey) quit . new pScrn set pScrn=$$GetScrn() . do setProp^TMGOOL(pScrn,"NEEDS REPAINT",1) . new scrap set scrap=$$FlushMouseBuffer() . if flags="T" do quit . . do proc^TMGOOL(TMGthis,"MOVE OBJ",.cmdKey) ;"returns result in cmdKey . do proc^TMGOOL(TMGthis,"RESIZE OBJ",flags,.cmdKey) quit AMDone quit ;"<-- required: NO return value for event handler HndlMMove(cmdKey) ;"Handle MouseMove request ;"Purpose: Handle Mouse Move ;"Input: cmdKey -- the command input. ;" MOVE REQUEST ;" ("TOP")=Current Top ;" ("LEFT")=Current Left ;" ("DELTA","TOP")=deltaTop ;" ("DELTA","LEFT")=deltaLeft ;" i.e. TOP=1,LEFT=1 would mean that the mouse moved downward 1 and rightward 1 ;"Result: None, but result is put into cmdKey("RESULT") ;" -1 ==> failure ;" 0 ==> OK ;" 1 ==> handled new abort set abort=0 set cmdKey("RESULT")=0 new temp set temp=$$Conv2Frame(.cmdKey,TMGthis) ;"ensure coordinates in TMGthis's frame new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT") ;"if null, then this is MainWindow new newT,newL set newT=+$get(cmdKey("TOP"))+$get(cmdKey("DELTA","TOP")) set newL=+$get(cmdKey("LEFT"))+$get(cmdKey("DELTA","LEFT")) set LOC=$$getProp^TMGOOL(TMGthis,"LOC",.LOC) if (newT<0)!(newT>$get(LOC("HEIGHT")))!(newL<0)!(newL>$get(LOC("WIDTH"))) do . if parent="SCREEN" do quit ;"don't allow mouse to go off screen. . . set result=-1,abort=1 . do fireEvent^TMGOOL(TMGthis,"LOOSING FOCUS",.cmdKey) if abort goto HMMDone HMM new flags set flags=$$getProp^TMGOOL(TMGthis,"RESIZING FLAGS") if flags="" goto HMMDone if flags="T" do proc^TMGOOL(TMGthis,"MOVE OBJ",.cmdKey) goto HMMDone do proc^TMGOOL(TMGthis,"RESIZE OBJ",flags,.cmdKey) goto HMMDone HMMDone set cmdKey("RESULT")=result quit ;"<-- required: NO return value for event handler HandleClick(LOC) ;"Purpose: do something here with a mouse click. Note: descendents can ;" overwrite this function to customize their control. ;"Input: LOC -- PASS BY REFERNCE. Expected input format: ;" coordinates in LOCAL frame of refeernces. ;" LOC("TOP")= ;" LOC("LEFT")= ;" LOC("HEIGHT")= ;"optional ;" LOC("WIDTH")= ;"optional ;" LOC("BOTTOM")= ;"optional ;" LOC("RIGHT")= ;"optional ;"Note: It has already been determined that the click belongs to this window ;" (and not a child of this window), so it should be handled here.) ;"Click belongs to this window, so handle it. ;"Put default click handler code here... do FocusThis() new temp set temp=$$Conv2Frame(.LOC,TMGthis) ;"ensure coordinates in TMGthis's frame new checkFrame set checkFrame=$$ClickOnFrame(.LOC) if checkFrame'="" do goto HCDone . do fireEvent^TMGOOL(TMGthis,"FRAME CLICK",.LOC,.checkFrame) HCDone quit ;"<-- required: NO return value for event handler HandleSClick(LOC) ;"Purpose: do something here with a mouse shift click. Note: descendents can ;" overwrite this function to customize their control. ;"Input: LOC -- PASS BY REFERNCE. Expected input format: ;" coordinates in LOCAL frame of refeernces. ;" LOC("TOP")= ;" LOC("LEFT")= ;" LOC("HEIGHT")= ;"optional ;" LOC("WIDTH")= ;"optional ;" LOC("BOTTOM")= ;"optional ;" LOC("RIGHT")= ;"optional ;"Note: It has already been determined that the click belongs to this window ;" (and not a child of this window), so it should be handled here.) ;"Click belongs to this window, so handle it. ;"Put default click handler code here... new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT") do proc^TMGOOL(parent,"SET FOCUSED",TMGthis) if $$getProp^TMGOOL(TMGthis,"STATE")="SELECTED" do . do setProp^TMGOOL(TMGthis,"STATE",0) else do setProp^TMGOOL(TMGthis,"STATE","SELECTED") ADCDone quit ;"<-- required: NO return value for event handler FmClick(LOC,flags) ;"Purpose: Handle a click on the frame. ;" This sets RESIZING FLAGS property for later ;" interpretation during window paints and mouse moves ;"Input: LOC -- the coordinates of the triggering click. ;" flags, containing: ;" "T" if on top of frame ;" "B" if on bottom of frame ;" "L" if on left of frame ;" "R" if on right of frame ;" "TL","TR","BL","BR" for the corners ;" note: no gaurantee regarding order: "TL" vs "LT" if $get(flags)="" goto AFMCDone if $$getProp^TMGOOL(TMGthis,"FRAME")'="SIZABLE" goto AFMCDone ;"If not resizable, abort new curFlags set curFlags=$$getProp^TMGOOL(TMGthis,"RESIZING FLAGS") if (curFlags'="") set flags="" ;"i.e. 2nd click on frame drops resizing do setProp^TMGOOL(TMGthis,"RESIZING FLAGS",flags) do setProp^TMGOOL(TMGthis,"NEEDS REPAINT",1) new scrap set scrap=$$FlushMouseBuffer() AFMCDone quit ;"------------------------------------------ ;"Property Getters & Setters below ;"------------------------------------------ getLOC(TMGthis,PropName,outArray) ;"Purpose: to get LOC coordinates array of window ;"Input: TMGthis -- a this pointer for properter setter. ;" PropName -- the name of the property -- not used here ;" outArray -- PASSED BY REFERENCE. An standardized output array ;"Note: because sometimes the getters do special things, I will alter ;" this function so it doesn't bypass that code set outArray("TOP")=+$$getProp^TMGOOL(TMGthis,"TOP") set outArray("LEFT")=+$$getProp^TMGOOL(TMGthis,"LEFT") set outArray("WIDTH")=+$$getProp^TMGOOL(TMGthis,"WIDTH") set outArray("HEIGHT")=+$$getProp^TMGOOL(TMGthis,"HEIGHT") set outArray("STATE")=+$$getProp^TMGOOL(TMGthis,"STATE") ;"merge outArray=@TMGthis@("PROP","LOC") new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT") set outArray("FRAME")=parent quit 0 ;"discarable result. setTop(TMGthis,PropName,Top) ;"Purpose: to set TOP coordinates of window ;"Input: TMGthis -- a this pointer for properter setter. ;" PropName -- the name of the property -- not used here ;" Top -- the coordinates of the TOP. 0 is top of screen set Top=$get(Top,0) new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT") new height if parent'="SCREEN" set height=$$getProp^TMGOOL(parent,"HEIGHT") else set height=9999 if (Top>-1)&(Top'>height) do . set @TMGthis@("PROP","LOC","TOP")=Top quit ;"<-- required not return value for property setter. getTop(TMGthis,PropName,outArray) ;"Purpose: to get TOP coordinates of window ;"Input: TMGthis -- a this pointer for properter setter. ;" PropName -- the name of the property -- not used here ;" outArray -- PASSED BY REFERENCE. An standardized output array new result set result="" new align set align=$$getProp^TMGOOL(TMGthis,"ALIGN") if (align="TOP")!(align="LEFT")!(align="RIGHT") do . set result=1 else if (align="BOTTOM") do . new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT") . new PH set PH=$$getProp^TMGOOL(parent,"HEIGHT") . new H set H=$$getProp^TMGOOL(TMGthis,"HEIGHT") . set result=(PH-1)-H else do . set result=$get(@TMGthis@("PROP","LOC","TOP")) set outArray=result quit result setLeft(TMGthis,PropName,Left) ;"Window member function (with no return value, i.e. a procedure) ;"Purpose: to set LEFT coordinates of window ;"Input: TMGthis -- a this pointer for properter setter. ;" PropName -- the name of the property -- not used here ;" Left -- the coordinates of the LEFT. 0 is left of screen set Left=$get(Left,0) new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT") new width if parent'="SCREEN" set width=$$getProp^TMGOOL(parent,"WIDTH") else set width=9999 ;"if (Left>-1)&(Left-1) do . set @TMGthis@("PROP","LOC","WIDTH")=Width quit ;"<-- required not return value for property setter. getWidth(TMGthis,PropName,outArray) ;"Purpose: to get WIDTH coordinates of window ;"Input: TMGthis -- a this pointer for properter setter. ;" PropName -- the name of the property -- not used here ;" outArray -- PASSED BY REFERENCE. An standardized output array ;"NOTE: this doesn't account for overlapping alignments. For example, when ;" A Hscroll is aligned to the bottom, and a Vscroller is alligned to ;" the right, then they both think that they occupy the bottom-right ;" corner. I need to fix this later. It will need to take into account ;" the z-order (or something) of the children. new result set result="" new align set align=$$getProp^TMGOOL(TMGthis,"ALIGN") if (align="TOP")!(align="BOTTOM") do . new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT") . set result=$$getProp^TMGOOL(parent,"WIDTH") . set result=result-1 ;"shrink inside parent's frame (yes, 1 is correct) else do ;"(align="NONE")!(align="LEFT")!(align="RIGHT") . set result=$get(@TMGthis@("PROP","LOC","WIDTH")) set outArray=result quit result setHeight(TMGthis,PropName,Height) ;"Window member function (with no return value, i.e. a procedure) ;"Purpose: to set WIDTH coordinates of window ;"Input: TMGthis -- a this pointer for properter setter. ;" PropName -- the name of the property -- not used here ;" Height -- the coordinates of the HEIGHT. ;"Note: Height means ADDITIONAL rows of size in addition to top row. ;" Thus a horizontal sizer bar has a height of '0', which really ;" displays as a single row. Confusing, but necessary set Height=$get(Height) if (Height>-1) do . set @TMGthis@("PROP","LOC","HEIGHT")=Height quit ;"<-- required not return value for property setter. getHeight(TMGthis,PropName,outArray) ;"Purpose: to get HEIGHT coordinates of window ;"Input: TMGthis -- a this pointer for properter setter. ;" PropName -- the name of the property -- not used here ;" outArray -- PASSED BY REFERENCE. An standardized output array new result set result="" new align set align=$$getProp^TMGOOL(TMGthis,"ALIGN") if (align="LEFT")!(align="RIGHT") do . new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT") . new PH set PH=$$getProp^TMGOOL(parent,"HEIGHT") . ;"new H set H=$$getProp^TMGOOL(TMGthis,"HEIGHT") . ;"set result=PH-H-1 . set result=PH-1 else do ;"(align="NONE")!(align="TOP")!(align="BOTTOM") . set result=$get(@TMGthis@("PROP","LOC","HEIGHT")) set outArray=result quit result setTLBR(Top,Left,Bottom,Right) ;"Purpose to set the Top,Left,Bottom,Right vales for object new width,height set width=Right-Left set height=Bottom-Top new scrap set scrap=$$setTLHW(.Top,.Left,.height,.width) quit 0 setTLHW(Top,Left,Height,Width) ;"Purpose: to set the Top,Left,Height,Width values for object ;"Results: 1 if change made, 0 if not change made new result set result=0 if +$get(Width)<1 set Width=1 if +$get(Height)<1 set Height=1 new LOC set LOC=$$getProp^TMGOOL(TMGthis,"LOC",.LOC) if $get(LOC("TOP"))'=Top do setProp^TMGOOL(TMGthis,"TOP",.Top) set result=1 if $get(LOC("LEFT"))'=Left do setProp^TMGOOL(TMGthis,"LEFT",.Left) set result=1 if $get(LOC("WIDTH"))'=Width do setProp^TMGOOL(TMGthis,"WIDTH",Width) set result=1 if $get(LOC("HEIGHT"))'=Height do setProp^TMGOOL(TMGthis,"HEIGHT",Height) set result=1 quit result setState(TMGthis,PropName,State) ;"Purpose: to set STATE property of window ;"Input: TMGthis -- a this pointer for properter setter. ;" PropName -- the name of the property -- not used here ;" State -- object State set @TMGthis@("PROP","LOC","STATE")=$get(State) quit ;"<-- required not return value for property setter. getState(TMGthis,PropName,outArray) ;"Purpose: to get TOP coordinates of window ;"Input: TMGthis -- a this pointer for properter setter. ;" PropName -- the name of the property -- not used here ;" outArray -- PASSED BY REFERENCE. An standardized output array set outArray=$get(@TMGthis@("PROP","LOC","STATE")) quit $get(@TMGthis@("PROP","LOC","STATE")) setParent(TMGthis,PropName,Parent) ;"Purpose: to link this object to a parent object, setting PARENT property ;"Note: Do NOT set PARENT directly. Use this function, which will ;" perform additional tasks associated with linking. ;" Parents will OWN child (i.e. be responsible for their destruction), and ;" also manage the placement and painting of the children. ;"Input: Parent -- the NAME (e.g. pWin) of parent to link to do proc^TMGOOL(Parent,"ACCEPT CHILD",TMGthis) set @TMGthis@("PROP","PARENT")=Parent quit ;"<-- required not return value for property setter. getParent(TMGthis,PropName,outArray) ;"Purpose: to get TOP coordinates of window ;"Input: TMGthis -- a this pointer for properter setter. ;" PropName -- the name of the property -- not used here ;" outArray -- PASSED BY REFERENCE. An standardized output array set outArray=$get(@TMGthis@("PROP","PARENT")) if outArray="" set outArray="SCREEN" quit outArray getNeedsRepaint(TMGthis,PropName,outArray) ;"Purpose: To determine if this object, or any of it's children need repainting ;"results: 1 if TMGthis needs repainting. 2 if a child needs repainting. new result set result="" new num set num="" set result=$get(@TMGthis@("PROP","NEEDS REPAINT")) if result=1 set outArray(TMGthis)=1 goto GNRPDone ;"Here query any children and see if they need repainting for set num=$order(@TMGthis@("CHILDREN",num)) quit:(+num'>0)!(+result>0) do . new child set child=$order(@TMGthis@("CHILDREN",num,"")) . if child="" quit . new tempResult . set tempResult=$$getNeedsRepaint(child,"NEEDS REPAINT",.outArray) . if tempResult>0 set result=2 . if result>0 set outArray(child)=1 GNRPDone set outArray=result quit result ;"------------------------------------------ ;"Private functions below ;"------------------------------------------ setLOC(LOC,T,L,W,H) ;"Purpose: to create a LOC array from T (top), L(left) ... coords ;"Input: LOC -- pass by reference. The output array ;" T --> "TOP" etc. ;"results: none kill LOC set LOC("TOP")=+$get(T) set LOC("LEFT")=+$get(L) set LOC("WIDTH")=+$get(W) set LOC("HEIGHT")=+$get(H) set LOC("BOTTOM")=+$get(T)++$get(H) set LOC("RIGHT")=+$get(L)++$get(W) quit getPCoords(TMGthis,PT,PL,PB,PR) ;"Purpose: to get, in screen coordinates, the coordinates of the parent of TMGthis ;"Input: TMGthis : the THIS reference ;" PT,PL,PR,PB -- PASS BY REFERENCE, these are OUT PARAMETERS ;" note: these coordinates are in the SCREEN frame of reference ;"results: none new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT") new pScrn set pScrn=$$GetScrn() set scrap=$$getProp^TMGOOL(parent,"LOC",.PLOC) set scrap=$$Conv2Frame(.PLOC,"SCREEN") set PT=+$get(PLOC("TOP")),PL=+$get(PLOC("LEFT")) set PR=+$get(PLOC("RIGHT")),PB=$get(PLOC("BOTTOM")) if parent'=pScrn do ;"scrink to INSIDE parent . set PT=PT+1,PL=PL+1,PR=PR-1,PB=PB-1 if PT<0 set PT=0 if PL<0 set PL=0 quit ClickOnFrame(LOC) ;"Purpose: to determine IF click occured on the boundries (frame) of this object ;"Input: LOC -- PASS BY REFERNCE. Expected input format: ;" coordinates in LOCAL frame of refeernces. ;" LOC("TOP")= ;" LOC("LEFT")= ;" LOC("HEIGHT")= ;"optional ;" LOC("WIDTH")= ;"optional ;" LOC("BOTTOM")= ;"optional ;" LOC("RIGHT")= ;"optional ;"Results: "" = not on frame ;" "T" if on top of frame ;" "B" if on bottom of frame ;" "L" if on left of frame ;" "R" if on right of frame ;" "TL","TR","BL","BR" for the corners ;" note: no gaurantee regarding order: "TL" vs "LT" ;"new scrap set scrap=$$ConvInsideSelf(.LOC) set result="" if LOC("TOP")=0 set result=result_"T" if LOC("TOP")=$$getProp^TMGOOL(TMGthis,"HEIGHT") set result=result_"B" if LOC("LEFT")=0 set result=result_"L" if LOC("LEFT")=$$getProp^TMGOOL(TMGthis,"WIDTH") set result=result_"R" quit result IsFocused(child) ;"Purpose: to determine if the specified child is the focused child ;"Input: child -- OPTIONAL. the name/ref of the child to compare ;" If child="" then function will return if TMGthis is focused ;" in parent's child list. ;"Results: 1 if child is currently the focused child, 0 otherwise. ;" if child="", then 1 if TMGthis is focused, 0 otherwise ;"Note: so there are two types of use: ;" $$IsFocused(child) <-- is child focused for TMGthis ;" $$IsFocused() <---- is TMGthis focused for it's parent set child=$get(child,"") new result set result="" if child="" do . new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT") . set child=TMGthis . new TMGthis set TMGthis=parent . set result=$$IsFocused(child) else do . set result=($$getFocused()=child) quit result setFocused(child) ;"Purpose: to set a child's status to focused, and effect it ensure visible ;" by bringing it to the top of the z-order ;"Input: child -- the name/ref of the child to set as focused if $get(child)="" goto SFDone if $$getFocused()=child goto SFDone ;"don't refocus if there already. do UnfocusCur() new curZ set curZ=$$GetNumChild(child) if curZ'>0 goto SFDone new num set num="" new lastValid set lastValid=0 for do quit:(+num'>0) . set lastValid=+num . set num=$order(@TMGthis@("CHILDREN",num)) set @TMGthis@("CHILDREN",lastValid+1,child)="" kill @TMGthis@("CHILDREN",curZ) do ListPack^TMGMISC($name(@TMGthis@("CHILDREN"))) set @TMGthis@("CHILDREN","FOCUSED")=$$GetNumChild(child) do setProp^TMGOOL(child,"NEEDS REPAINT",1) SFDone quit 0 getFocused() ;"returns currently focused child name/ref new focusNum set focusNum=+$get(@TMGthis@("CHILDREN","FOCUSED")) quit $$GetChild(focusNum) FocusThis() ;"Purpose: to set TMGthis as focused for parent new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT") do proc^TMGOOL(parent,"SET FOCUSED",TMGthis) quit UnfocusCur() ;"returns: unfocuses currently focused object new focusNum set focusNum=+$get(@TMGthis@("CHILDREN","FOCUSED")) if focusNum>0 do . new child set child=$$GetChild(focusNum) . do setProp^TMGOOL(child,"NEEDS REPAINT",1) . set @TMGthis@("CHILDREN","FOCUSED")="" quit GetNumChild(child,objectName) ;"Returns the z-order for the given child ;"Input: child -- the name/ref of the child to seek ;" objectName -- OPTIONAL. Default is 'TMGthis' ;" The name of the object holding children ;"Results: the z-order, or 0 if not found new num set num="" new done set done=0 set objectName=$get(objectName,TMGthis) if (objectName="")!(+objectName=objectName) do goto GNCDone X1 . new temp set temp=1 for set num=$order(@objectName@("CHILDREN",num)) quit:(+num'>0) do quit:(done=1) . if child=$order(@objectName@("CHILDREN",num,"")) set done=1 GNCDone quit +num GetChild(num) ;"Returns child ref/name at num z-order quit $order(@TMGthis@("CHILDREN",num,"")) GetContained(LOC) ;"Purpose: To get the name/ref of the child containing coordinates ;"Input: LOC -- a location array: ;" LOC("TOP")=top ;" LOC("LEFT")=left ;"results: name/ref of the child containing coordinates new result set result="" new num set num="" for set num=$order(@TMGthis@("CHILDREN",num)) quit:(+num'>0) ;"Now count backward for set num=$order(@TMGthis@("CHILDREN",num),-1) quit:(+num'>0)!(result'="") do . new child set child=$order(@TMGthis@("CHILDREN",num,"")) . if child="" quit . if $$fn^TMGOOL(child,"CONTAINS COORDS",.LOC)=0 quit . set result=child quit result CheckPaint ;"Purpose: to see if any children need repainting. If so, repaint. ;"Note: Only MainWindow should be getting to this point. ;" Also, Paint is not called for MainWindow (i.e. don't put a border on the main screen) ;"do SETCLIP^TMGXGF(0,0,IOSL,IOM) new paintAllChildren set paintAllChildren=0 ;"Note: Every time THIS is painted, all children are also painted. ;" But there may be times with THIS doesn't need repainting, but ;" just one of the children will need painting alone. if $$getProp^TMGOOL(TMGthis,"NEEDS REPAINT")=1 do ;"1=paint this, 2=paint a child . set paintAllChildren=1 . ;"Draw a frame to white out entire screen. . do CLEAR^TMGXGF(0,0,IOSL,IOM) ;"clear screen portion TOP,LEFT,BOTTOM,RIGHT . do setProp^TMGOOL(TMGthis,"NEEDS REPAINT",0) ;"flag screen as total repainted ;"Note: 0=back-most window (bigger numbers painted last) new num set num="" for set num=$order(@TMGthis@("CHILDREN",num)) quit:(+num'>0) do . new child set child=$order(@TMGthis@("CHILDREN",num,"")) . if child="" quit . new sameLoc,LOC,ldArray . new scrap set scrap=$$getProp^TMGOOL(child,"LOC",.LOC) . set scrap=$$getProp^TMGOOL(child,"LAST DRAW",.ldArray) . set sameLoc=$$CompArray^TMGMISC("LOC","ldArray") . new tempWho . new needsPaint set needsPaint=$$getProp^TMGOOL(child,"NEEDS REPAINT",.tempWho) . if (sameLoc=0)!(needsPaint>0)!(paintAllChildren=1) do CP2 . . do proc^TMGOOL(child,"PAINT") . . do setProp^TMGOOL(child,"LAST DRAW",.LOC) quit parentPath(fromFrame,toFrame,outArray) ;"Purpose: to enumerate the successive parent when going from 'from' frame ;" to the 'to' frame. ;"Input: fromFrame,toFrame -- the name/ref of TMGWGOJ objects for frames ;" outArray -- PASS BY REFERENCE. See format below: ;"Output: outArray is filled as below: ;" outArray(1,fromFrame)="" ;" outArray(2,parent of fromFrame)="" ;" outArray(3,grandparent of fromFrame)="" ;" outArray(4,greatgrandparent of fromFrame)="" ;" ... ;"results: none kill outArray new num set num=2 new toFound set toFound=0 new curFrame set curFrame=fromFrame for do quit:(curFrame="")!(curFrame=toFrame)!(curFrame="SCREEN") . set curFrame=$$getProp^TMGOOL(curFrame,"PARENT") . if curFrame="" quit . if curFrame=toFrame set toFound=1 . set outArray(num,curFrame)="",num=num+1 if toFound=0 kill outArray if $data(outArray)>0 set outArray(1,fromFrame)="" quit convPath(LOC,pathArray) ;"Purpose: to succesively translate coordinate systems for each entry in the ;" path array (as prepaired by parentPath) ;"Input: LOC -- PASS BY REFERNCE. Expected input format: ;" LOC("TOP")= ;" LOC("LEFT")= ;" LOC("HEIGHT")= ;"optional ;" LOC("WIDTH")= ;"optional ;" LOC("BOTTOM")= ;" LOC("RIGHT")= ;" LOC("FRAME")=Frame of reference for these coordinates ;" Note: frame should typically be the same as ;" the PARENT of the current object ;" targetFrame=the frame of refernce to change to. ;"Input: pathArray -- PASS BY REFERENCE. format: ;" pathArray(1,initialFrame)="" ;" pathArray(2,parent of fromFrame)="" ;" pathArray(3,grandparent of fromFrame)="" ;" pathArray(4,greatgrandparent of fromFrame)="" ;" ... ;" ALSO: pathArray=direction (1 or -1) to effect translations ;" towards a parent frame (1) vs. a child frame (-1) ;"Results: none ;"Output: Input variables are modified as OUT PARAMETERS ;" LOC("TOP") is modified ;" LOC("LEFT") is modified ;" LOC("HEIGHT")=unchanged ;" LOC("WIDTH")=unchanged ;" LOC("BOTTOM") is updated ;" LOC("RIGHT") is updated ;" LOC("FRAME") is updated new curFrame set curFrame=$get(LOC("FRAME")) if curFrame="" goto CpDone ;"unable to convert if not initial frame specified. new direction set direction=+$get(pathArray) if direction=0 goto CpDone new Top set Top=+$get(LOC("TOP")) new Left set Left=+$get(LOC("LEFT")) new num set num=1 if direction=-1 set num=$order(pathArray(""),-1) if $order(pathArray(num,""))'=curFrame goto CpStore ;"not in correct initial frame new lfTop,lfLeft,loopFrame for do quit:(loopFrame="") . set loopFrame=$order(pathArray(num,"")),num=num+direction . if (loopFrame="") quit . if (direction=-1)&(loopFrame=curFrame) quit . set lfTop=$$getProp^TMGOOL(loopFrame,"TOP")*direction . set lfLeft=$$getProp^TMGOOL(loopFrame,"LEFT")*direction . set Top=Top+lfTop . set Left=Left+lfLeft . set LOC("FRAME")=loopFrame CpStore ;"Store data back into array set LOC("TOP")=Top set LOC("LEFT")=Left set LOC("BOTTOM")=Top+$get(LOC("HEIGHT")) set LOC("RIGHT")=Left+$get(LOC("WIDTH")) CpDone quit getPath(LOC,targetFrame,pathArray) ;"Purpose: to create a pathArray from current frame (stored in LOC) to ;" the targetFrame. targetFrame may be an ancestor, or descendent ;" of the current frame. ;"Input: LOC -- PASS BY REFERNCE. Expected input format: ;" LOC("TOP")= ;" LOC("LEFT")= ;" LOC("HEIGHT")= ;"optional ;" LOC("WIDTH")= ;"optional ;" LOC("BOTTOM")= ;" LOC("RIGHT")= ;" LOC("FRAME")=Frame of reference for these coordinates ;" Note: frame should typically be the same as ;" the PARENT of the current object ;" targetFrame=the frame of refernce to change to. ;" outArray -- PASS BY REFERENCE. See format below: ;"Output: pathArray is filled as below: ;" pathArray(1,curFrame)="" ;" pathArray(2,next translation frame (child/parent of current))="" ;" pathArray(3,next translation frame (child/parent of current))="" ;" ... new curFrame set curFrame=$get(LOC("FRAME")) if curFrame="" goto gpDone ;"First see if targetFrame is an ancestor of curFrame do parentPath(curFrame,targetFrame,.pathArray) if ($data(pathArray)>0)!(curFrame=targetFrame) do goto gpDone ;"success . set pathArray=1 ;"Now see if targetFrame is a descendent of curFrame do parentPath(targetFrame,curFrame,.pathArray) if $data(pathArray)=0 goto gpDone ;"failure set pathArray=-1 ;"reverse direction gpDone quit