ImagerUnit

ImagerUnit
This page uses the Historical meaning of the term "OpenVistA" VistA Trademark Issues

Here is the code for the main imager unit of the program. Below that is the code for the form itself (in text format)

unit ImagerUnit; interface uses\ Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,\ Dialogs, StdCtrls, StrUtils, BrowserUnit, ExtCtrls, Menus, OleCtrls,\ SHDocVw, ComCtrls, ToolWin; type TImagerForm = class(TForm) PageControl: TPageControl; LogPage: TTabSheet; MsgMemo: TMemo; MainMenu: TMainMenu; File1: TMenuItem; Exit1: TMenuItem; ToolBar1: TToolBar; View1: TMenuItem; ShowLog1: TMenuItem; HideLog1: TMenuItem; procedure FormCreate(Sender: TObject); procedure HideButtonClick(Sender: TObject); procedure Button2Click(Sender: TObject); procedure Exit1Click(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure FormResize(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure HideLog1Click(Sender: TObject); procedure ShowLog1Click(Sender: TObject); private { Private declarations } FVistaMsg: Word; BrowserList : TStringList; Running : boolean; procedure DefaultHandler(var Message); override; procedure ShowImage (var Data : string); function GetBetween (var Text : String; OpenTag,CloseTag : string;                        KeepTags : Boolean) : string; procedure CutStringInThree(var Text : AnsiString; p1, p2 : Integer; var s1,s2,s3 : AnsiString); procedure AddImage (var URL, Title : string); procedure ClearAllImages; public { Public declarations } end; var ImagerForm: TImagerForm; const cLog : string[5] = 'Log'; implementation {$R *.dfm} procedure TImagerForm.DefaultHandler(var Message); { adds check to the message handling for this form to get a registered message } var buf: array[0..255] of Char; Data : string; p1 : integer; const ImageSignal : string = '^IMAGE^'; NewDocSignal : string = '^TIU'; NewPatientSignal : string = 'XPT^CPRS'; EndCPRSSignal : string = 'END^CPRS^'; begin // do the default message handling inherited DefaultHandler(Message); // if the message is 'VistA Event - Clinical' and not posted from self... // wParam=Handle of message sender, lParam=entry in global atom table with TMessage(Message) do if (Msg = FVistaMsg) and (wParam <> Handle) then begin // retrieve the text pointed to by lParam into a buffer GlobalGetAtomName(lParam, buf, 255); Data := StrPas(buf); MsgMemo.Lines.Add(Data); p1 := Pos (ImageSignal,Data); if p1 > 0 then begin Data := MidStr(Data, p1 + Length(ImageSignal), Length(Data)); ShowImage (Data); end else if (Pos (NewDocSignal, Data) > 0) or (Pos (NewPatientSignal, Data) > 0)then begin ClearAllImages; end else if (Pos (ENDCPRSSignal, Data) > 0) then begin Application.Terminate; end; end; end; procedure TImagerForm.FormClose(Sender: TObject; var Action: TCloseAction); begin ClearAllImages; end; procedure TImagerForm.FormCreate(Sender: TObject); begin // register the message with windows to get a unique message number FVistaMsg := RegisterWindowMessage('VistA Event - Clinical'); MsgMemo.Lines.clear; BrowserList := TStringList.Create; BrowserList.AddObject(cLog,nil); Running := true; end; procedure TImagerForm.FormDestroy(Sender: TObject); begin ClearAllImages; If BrowserList <> nil then BrowserList.Free; Running := false; end; procedure TImagerForm.HideButtonClick(Sender: TObject); begin Visible := false; end; procedure TImagerForm.Button2Click(Sender: TObject); begin Application.Terminate; end; procedure TImagerForm.Exit1Click(Sender: TObject); begin Application.Terminate; end; procedure TImagerForm.FormResize(Sender: TObject); var i : integer; Page : TTabSheet; begin //Note: I was getting a FormResize event after form destroyed->error. Avoid via Running... if (PageControl <> nil) and (BrowserList <> nil) and (Running = true) then begin Page := PageControl.ActivePage; for i := 0 to BrowserList.Count-1 do begin if BrowserList.Objects[i] <> nil then begin (BrowserList.Objects[i] as TWebBrowser).Height := Page.Height; (BrowserList.Objects[i] as TWebBrowser).Width := Page.Width; end; end; end; end; procedure TImagerForm.HideLog1Click(Sender: TObject); begin LogPage.Visible := false; end; procedure TImagerForm.ShowLog1Click(Sender: TObject); begin LogPage.Visible := true; end; procedure TImagerForm.CutStringInThree(var Text : AnsiString; p1, p2 : Integer;                                   var s1,s2,s3 : AnsiString); {Purpose: Cut input string Text into 3 parts, with cut points given by p1 & p2. p1 points to first character to be in s2           p2 points to last character to be in s2        } begin s1 := ; s2 := ; s3 := ''; if p1 > 1 then s1 := MidStr(Text, 1, p1-1); s2 := MidStr(Text, p1, p2-p1+1); s3 := MidStr(Text, p2+1, Length(Text)-p2); end; function TImagerForm.GetBetween (var Text : String; OpenTag,CloseTag : string;                                   KeepTags : Boolean) : string; {Purpose: Gets text between Open and Close tags. Removes any CR's or LF's  Input: Text - the text to work on. It IS changed as code is removed KeepTags - true if want tag return in result false if tag not in result (still is removed from Text) Output: Text IS changed. Result=the code between the opening and closing tags Note: Both OpenTag and CloseTag MUST be present for anything to happen. } var p1,p2 : integer; s1,s2,s3 : AnsiString; begin Result := ''; //default of no result. p1 := Pos(UpperCase(OpenTag), UpperCase(Text)); if (p1 > 0) then begin p2 := PosEx(UpperCase(CloseTag),UpperCase(Text),p1+Length(OpenTag)) + Length(CloseTag) -1; if ((p2 > 0) and (p2 > p1)) then begin CutStringInThree (Text, p1,p2, s1,Result,s3); Text := s1+s3; //Now, remove any CR's or LF's       repeat p1 := Pos (Chr(13),Result); if p1= 0 then p1 := Pos (Chr(10),Result); if (p1 > 0) then begin CutStringInThree (Result, p1,p1, s1,s2,s3); Result := s1+s3; end; until (p1=0); //Now cut off boundry tags if requested. if not KeepTags then begin p1 := Length(OpenTag) + 1; p2 := Length (Result) - Length (CloseTag); CutStringInThree (Result, p1,p2, s1,s2,s3); Result := s2; end; end; end; end; procedure TImagerForm.ShowImage (var Data : string); {expected input: data is expected in the following format:  } var URL, Title : string; begin Data := GetBetween(Data,'', false); URL := GetBetween (Data, 'src="', '"', false); Title := GetBetween (Data, 'alt="', '"', false); if URL <> '' then begin AddImage(URL, Title); end; end; procedure TImagerForm.AddImage (var URL, Title : string); var NewTabSheet : TTabSheet; Browser    : TWebBrowser; CaptionName : string; begin NewTabSheet := TTabSheet.Create(PageControl); NewTabSheet.PageControl := PageControl; if Title = '' then Title := 'Image'; CaptionName := IntToStr(PageControl.PageCount-1) + '. ' + Title; NewTabSheet.Caption := CaptionName; NewTabSheet.Align := alClient; PageControl.ActivePage := NewTabSheet; Browser := TWebBrowser.Create(self); Browser.ParentWindow := NewTabSheet.Handle; Browser.Align := alClient; Browser.Width := NewTabSheet.Width; Browser.Height := NewTabSheet.Height; BrowserList.AddObject(CaptionName,Browser); Browser.Navigate(URL); BringWindowToTop(ImagerForm.Handle); end; procedure TImagerForm.ClearAllImages; var i,j : integer; PageName : string; p : ^TObject; Browser : ^TWebBrowser; //a pointer begin if (PageControl <> nil) and (BrowserList <> nil) then begin for i := 0 to PageControl.PageCount-1 do begin PageName := PageControl.Pages[i].Caption; if PageName <> cLog then begin for j := 0 to BrowserList.Count-1 do begin if BrowserList.Strings[j]=PageName then begin if BrowserList.Objects[i] <> nil then begin (BrowserList.Objects[i] as TWebBrowser).Free; break; end; end; end; end; end; i := BrowserList.Count-1; while i >= 0 do begin if PageControl.Pages[i].Caption <> cLog then begin If PageControl.Pages[i] <> nil then PageControl.Pages[i].Free; BrowserList.Delete(i); end; i := i - 1; end; end; end; end. -- -- This is the form associated with ImagerUnit (viewed as text) -- object ImagerForm: TImagerForm Left = 223 Top = 116 Width = 701 Height = 567 Caption = 'OpenVistA CPRS Imager' Color = clBtnFace Font.Charset = DEFAULT_CHARSET Font.Color = clWindowText Font.Height = -11 Font.Name = 'MS Sans Serif' Font.Style = [] Menu = MainMenu OldCreateOrder = False Visible = True OnClose = FormClose OnCreate = FormCreate OnDestroy = FormDestroy OnResize = FormResize PixelsPerInch = 96 TextHeight = 13 object PageControl: TPageControl Left = 0 Top = 29 Width = 693 Height = 484 ActivePage = LogPage Align = alClient TabOrder = 0 TabPosition = tpBottom object LogPage: TTabSheet Caption = 'Log' ImageIndex = 1 object MsgMemo: TMemo Left = 0 Top = 0 Width = 685 Height = 458 Align = alClient ScrollBars = ssBoth TabOrder = 0 end end end object ToolBar1: TToolBar Left = 0 Top = 0 Width = 693 Height = 29 Caption = 'ToolBar1' TabOrder = 1 end object MainMenu: TMainMenu Left = 256 Top = 192 object File1: TMenuItem Caption = '&File' object Exit1: TMenuItem Caption = 'E&xit' OnClick = Exit1Click end end object View1: TMenuItem Caption = '&View' object ShowLog1: TMenuItem Caption = '&Show Log' OnClick = ShowLog1Click end object HideLog1: TMenuItem Caption = '&Hide Log' OnClick = HideLog1Click end end end end

Edit Page - Page History - Printable View - Recent Changes - WikiHelp - SearchWiki Page last modified on June 11, 2004, at 05:05 PM