ImagerUnit
From VistApedia
Revision as of 00:59, 10 August 2012 by NeilArmstrong (talk | contribs) (Added a glossary link to CPRS~)
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
