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:
       <img src="http://www.geocities.com/kdtop3/pic1.jpg" alt="Title 1">
 }
 var
   URL, Title : string;
 begin
   Data := GetBetween(Data,'<img ', '>', 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