NeilArmstrong: Added a glossary link to CPRS~

2012-08-10T00:59:53Z

Added a glossary link to CPRS~

← Older revision		Revision as of 00:59, 10 August 2012
Line 63:		Line 63:
	ImageSignal : string = '^IMAGE^';		ImageSignal : string = '^IMAGE^';
	NewDocSignal : string = '^TIU';		NewDocSignal : string = '^TIU';
	NewPatientSignal : string = 'XPT^CPRS';		NewPatientSignal : string = 'XPT^[[CPRS~\|CPRS]]';
	~~EndCPRSSignal~~ : string = 'END^CPRS^';		End[[CPRS~\|CPRS]]Signal : string = 'END^[[CPRS~\|CPRS]]^';
	begin		begin
	// do the default message handling		// do the default message handling
Line 83:		Line 83:
	or (Pos (NewPatientSignal, Data) > 0)then begin		or (Pos (NewPatientSignal, Data) > 0)then begin
	ClearAllImages;		ClearAllImages;
	end else if (Pos (~~ENDCPRSSignal~~, Data) > 0) then begin		end else if (Pos (END[[CPRS~\|CPRS]]Signal, Data) > 0) then begin
	[[Application~\|Application]].Terminate;		[[Application~\|Application]].Terminate;
	end;		end;
Line 272:		Line 272:
	Width = 701		Width = 701
	Height = 567		Height = 567
	Caption = 'OpenVistA CPRS Imager'		Caption = 'OpenVistA [[CPRS~\|CPRS]] Imager'
	Color = clBtnFace		Color = clBtnFace
	Font.Charset = DEFAULT_CHARSET		Font.Charset = DEFAULT_CHARSET

NeilArmstrong: Added Glossary link to Action~

2012-07-10T11:20:11Z

Added Glossary link to Action~

← Older revision		Revision as of 11:20, 10 July 2012
Line 30:		Line 30:
	procedure FormDestroy(Sender: TObject);		procedure FormDestroy(Sender: TObject);
	procedure FormResize(Sender: TObject);		procedure FormResize(Sender: TObject);
	procedure FormClose(Sender: TObject; var Action: ~~TCloseAction~~);		procedure FormClose(Sender: TObject; var [[Action~\|Action]]: TClose[[Action~\|Action]]);
	procedure HideLog1Click(Sender: TObject);		procedure HideLog1Click(Sender: TObject);
	procedure ShowLog1Click(Sender: TObject);		procedure ShowLog1Click(Sender: TObject);
Line 88:		Line 88:
	end;		end;
	end;		end;
	procedure TImagerForm.FormClose(Sender: TObject; var Action: ~~TCloseAction~~);		procedure TImagerForm.FormClose(Sender: TObject; var [[Action~\|Action]]: TClose[[Action~\|Action]]);
	begin		begin
	ClearAllImages();		ClearAllImages();

NeilArmstrong: Added Glossary Link to Historical~

2012-03-03T00:47:05Z

Added Glossary Link to Historical~

← Older revision		Revision as of 00:47, 3 March 2012
Line 1:		Line 1:
	===ImagerUnit===		===ImagerUnit===

	This page uses the historical meaning of the term "OpenVistA" [[VistA Trademark Issues]]		This page uses the [[historical~\| 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)		Here is the code for the main imager unit of the program. Below that is the code for the form itself (in text format)

NeilArmstrong: Added glossary link to Application~

2012-02-22T12:24:39Z

Added glossary link to Application~

← Older revision		Revision as of 12:24, 22 February 2012
Line 84:		Line 84:
	ClearAllImages;		ClearAllImages;
	end else if (Pos (ENDCPRSSignal, Data) > 0) then begin		end else if (Pos (ENDCPRSSignal, Data) > 0) then begin
	Application.Terminate;		[[Application~\|Application]].Terminate;
	end;		end;
	end;		end;
Line 113:		Line 113:
	procedure TImagerForm.Button2Click(Sender: TObject);		procedure TImagerForm.Button2Click(Sender: TObject);
	begin		begin
	Application.Terminate;		[[Application~\|Application]].Terminate;
	end;		end;
	procedure TImagerForm.Exit1Click(Sender: TObject);		procedure TImagerForm.Exit1Click(Sender: TObject);
	begin		begin
	Application.Terminate;		[[Application~\|Application]].Terminate;
	end;		end;
	procedure TImagerForm.FormResize(Sender: TObject);		procedure TImagerForm.FormResize(Sender: TObject);

Ftrotter: trademark

2007-03-07T16:23:42Z

trademark

← Older revision		Revision as of 16:23, 7 March 2007
Line 1:		Line 1:
	===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)		Here is the code for the main imager unit of the program. Below that is the code for the form itself (in text format)

Kdtop at 21:04, 23 April 2005

2005-04-23T21:04:19Z

New page

===ImagerUnit===

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

ImagerUnit - Revision history

NeilArmstrong: Added a glossary link to CPRS~

NeilArmstrong: Added Glossary link to Action~

NeilArmstrong: Added Glossary Link to Historical~

NeilArmstrong: Added glossary link to Application~

Ftrotter: trademark

Kdtop at 21:04, 23 April 2005