source: cprs/branches/tmg-cprs/CPRS-Chart/UploadImages.pas@ 454

Last change on this file since 454 was 453, checked in by Kevin Toppenberg, 16 years ago

Initial upload of TMG-CPRS 1.0.26.69
File size: 14.3 KB
RevLine 
[453]1//kt -- Modified with SourceScanner on 8/7/2007
2unit UploadImages;
3
4interface
5
6uses
7 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
8 Dialogs, StdCtrls, Buttons, ExtCtrls, pngimage, ExtDlgs, OleCtrls,
9 SHDocVw, DKLang;
10
11type
12 TUploadImageInfo = class
13 private
14 public
15 TIUIEN : int64; //IEN in file# 8925
16 DFN : AnsiString; //IEN in Patient File (#2)
17 UploadDUZ : int64;
18 ThumbFPathName : AnsiString; // local file path name
19 ImageFPathName : AnsiString;
20 ServerPath : AnsiString;
21 ServerFName : AnsiString;
22 ServerThumbFName: AnsiString;
23 ShortDesc : String[60];
24 Extension : String[16];
25 ImageDateTime : AnsiString;
26 UploadDateTime: AnsiString;
27 ObjectType : Integer; //pointer to file 2005.02
28 ProcName : String[10]; //server limit is 10 chars.
29 //AcquisitionSite
30 pLongDesc : TStrings;
31 published
32 end;
33
34
35
36type
37 TUploadForm = class(TForm)
38 OpenFileDialog: TOpenDialog;
39 Image1: TImage;
40 PickImagesButton: TBitBtn;
41 Label1: TLabel;
42 CancelButton: TBitBtn;
43 UploadButton: TBitBtn;
44 Label2: TLabel;
45 Label4: TLabel;
46 ShortDescEdit: TEdit;
47 LongDescMemo: TMemo;
48 Label3: TLabel;
49 Label5: TLabel;
50 DateTimeEdit: TEdit;
51 ClearImagesButton: TBitBtn;
52 OpenDialog: TOpenPictureDialog;
53 FilesToUploadList: TListBox;
54 NoteEdit: TEdit;
55 PickOtherButton: TBitBtn;
56 Panel1: TPanel;
57 WebBrowser: TWebBrowser;
58 Label6: TLabel;
59 MoveCheckBox: TCheckBox;
60 DKLanguageController1: TDKLanguageController;
61 procedure UploadButtonClick(Sender: TObject);
62 procedure PickImagesButtonClick(Sender: TObject);
63 procedure FormShow(Sender: TObject);
64 procedure ShortDescEditChange(Sender: TObject);
65 procedure ClearImagesButtonClick(Sender: TObject);
66 procedure FormCreate(Sender: TObject);
67 procedure FormDestroy(Sender: TObject);
68 procedure FilesToUploadListClick(Sender: TObject);
69 procedure PickOtherButtonClick(Sender: TObject);
70 procedure FormRefresh(Sender: TObject);
71
72 private
73 { Private declarations }
74 Bitmap : TBitmap;
75 Picture : TPicture;
76 function MakeThumbNail(Info: TUploadImageInfo): boolean;
77
78 procedure LoadNotesEdit();
79 //procedure LoadNotesList();
80 function UploadFile(Info: TUploadImageInfo): boolean;
81 procedure UploadChosenFiles();
82
83 public
84 { Public declarations }
85 end;
86
87var
88 UploadForm: TUploadForm;
89
90implementation
91
92{$R *.dfm}
93
94 uses fNotes,
95 StrUtils, //for MidStr etc.
96 ORFn, //for PIECE etc.
97 uCore, // for User.DUZ etc
98 Trpcb, //for .PType enum
99 fImages, //for upload/download files etc.
100 //Targa, //for TGA graphic save
101 ORNet //for RPCBrokerV
102 ;
103
104// const
105// DefShortDesc = '(Short Image Description)'; <-- original line. //kt 8/7/2007
106
107 var
108 DefShortDesc : string; //kt
109
110 procedure SetupVars;
111 begin
112 DefShortDesc := DKLangConstW('UploadImages_xShort_Image_Descriptionx'); //kt added 8/7/2007
113 end;
114
115 //-------------------------------------------------------------------------
116 //-------------------------------------------------------------------------
117 function TUploadForm.MakeThumbNail(Info: TUploadImageInfo) : boolean;
118 //This takes Info.ImageFPathName and creates a 64x64 .bmp file with
119 //this same name, and saves in cache directory.
120 //saves name of this thumbnail in info.ThumbFPathName
121
122 var
123 Rect : TRect;
124 ThumbFName : AnsiString;
125 begin
126 Rect.Top := 0; Rect.Left:=0; Rect.Right:=63; Rect.Bottom:=63;
127 result := false; //default of failure
128 try
129 Picture.LoadFromFile(Info.ImageFPathName);
130 Bitmap.Canvas.StretchDraw(Rect,Picture.Graphic);
131 ThumbFName := frmImages.CacheDir + '\Thumb-' + ExtractFileName(Info.ImageFPathName);
132 ThumbFName := ChangeFileExt(ThumbFName,'.bmp');
133 Bitmap.SaveToFile(ThumbFName); //save to local cache (for upload)
134 Info.ThumbFPathName := ThumbFName; //pass info back out.
135 Info.ServerThumbFName := ChangeFileExt(Info.ServerFName,'.ABS'); //format is .bmp
136 result := true
137 except
138 on E: Exception do exit;
139 end;
140 end;
141
142
143 function TUploadForm.UploadFile(Info: TUploadImageInfo): boolean;
144 //result: true if success, false if failure
145 var
146 RPCResult,index : AnsiString;
147 ImageIEN : AnsiString;
148 MsgNum : AnsiString;
149 ErrorMsg : AnsiString;
150 i : integer;
151
152 begin
153 RPCBrokerV.remoteprocedure := 'MAGGADDIMAGE';
154 RPCBrokerV.Param[0].Value := '.X';
155 RPCBrokerV.Param[0].PType := list;
156 RPCBrokerV.Param[0].Mult['"NETLOCABS"'] := 'ABS^STUFFONLY';
157 RPCBrokerV.Param[0].Mult['"magDFN"'] := '5^' + Info.DFN; {patient dfn}
158 RPCBrokerV.Param[0].Mult['"DATETIME"'] := '7^NOW'; {date/time image collected}
159 RPCBrokerV.Param[0].Mult['"DATETIMEPROC"'] := '15^' + Info.ImageDateTime; {Date/Time of Procedure}
160 if Info.ProcName <> '' then
161 RPCBrokerV.Param[0].Mult['"PROC"'] := '6^' + Info.ProcName; {procedure}
162 RPCBrokerV.Param[0].Mult['"DESC"'] := '10^(Hard coded Short Description)'; {image description}
163 if Info.ShortDesc <> '' then
164 RPCBrokerV.Param[0].Mult['"DESC"'] := '10^' + Info.ShortDesc; {image description}
165 RPCBrokerV.Param[0].Mult['"DUZ"'] := '8^' + IntToStr(Info.UploadDUZ); {Duz}
166
167 //The field (#14) below is used for images that are part of a group,
168 //for example a CT exam might contain 30 images. This field
169 //contains a pointer back to the Image file (2005), to the
170 //object whose type is "GROUP" that points to this object as
171 //a member of its group. A pointer to this object will be
172 //found in the Object Group multiple of the parent GROUP
173 //object.
174 //RPCBrokerV.Param[0].Mult['"GROUP"'] := '14^' + group;
175
176 RPCBrokerV.Param[0].Mult['"OBJTYPE"'] := '3^' + IntToStr(Info.ObjectType);
177 RPCBrokerV.Param[0].Mult['"FileExt"'] := 'EXT^' + Info.Extension;
178
179 for i := 0 to Info.pLongDesc.Count - 1 do begin
180 index := IntToStr(i);
181 while length(index) < 3 do index := '0' + index;
182 index :='"LongDescr' + index + '"';
183 RPCBrokerV.Param[0].Mult[index] := '11^' + Info.pLongDesc.Strings[i];
184 end;
185
186 RPCResult := RPCBrokerV.STRcall; { returns ImageIEN^directory/filename }
187
188 ImageIEN := Piece(RPCResult,'^',1);
189 result := ((ImageIEN <> '0') and (ImageIEN <> '')); // function result.
190 if result=false then begin
191// ErrorMsg :='Server Error -- Couldn''t store image information'; <-- original line. //kt 8/7/2007
192 ErrorMsg :=DKLangConstW('UploadImages_Server_Error_xx_Couldnxxt_store_image_information'); //kt added 8/7/2007
193 MessageDlg(ErrorMsg,mtWarning,[mbOK],0);
194 end;
195 if result then begin
196 Info.ServerPath := Piece(RPCResult,'^',2);
197 Info.ServerFName := Piece(RPCResult,'^',3);
198 result := frmImages.UploadFile(Info.ImageFPathName,Info.ServerPath,Info.ServerFName);
199 if result=false then begin
200// ErrorMsg :='Error uploading image to server'; <-- original line. //kt 8/7/2007
201 ErrorMsg :=DKLangConstW('UploadImages_Error_uploading_image_to_server'); //kt added 8/7/2007
202 //Application.MessageBox(@ErrorMsg,'Error Uploading Image');
203 MessageDlg(ErrorMsg,mtWarning,[mbCancel],0);
204 end;
205 //Later, put code that also copies the file into the cache directory,
206 //so that we don't have to turn around and download it again.
207 if result then begin
208 RPCBrokerV.remoteprocedure := 'MAG3 TIU IMAGE';
209 RPCBrokerV.param[0].ptype := literal;
210 RPCBrokerV.param[0].value := ImageIEN;
211 RPCBrokerV.Param[1].ptype := literal;
212 RPCBrokerV.param[1].value := IntToStr(Info.TIUIEN);
213 RPCBrokerV.Call;
214 RPCResult := RPCBrokerV.Results[0];
215 //returns: success: 1^message; or error: 0^error message
216 MsgNum := Piece(RPCResult,'^',1);
217 result := (MsgNum = '1');
218 if result=false then begin
219// ErrorMsg :='Error associating image with note:' + #13 + Piece(RPCResult,'^',2); <-- original line. //kt 8/7/2007
220 ErrorMsg :=DKLangConstW('UploadImages_Error_associating_image_with_notex') + #13 + Piece(RPCResult,'^',2); //kt added 8/7/2007
221 MessageDlg(ErrorMsg,mtWarning,[mbCancel],0);
222 end;
223 end;
224 if (result=true) and (MoveCheckBox.Checked) then begin
225 DeleteFile(Info.ImageFPathName);
226 end;
227 if result then begin
228 if MakeThumbNail(Info) then begin;
229 result := frmImages.UploadFile(Info.ThumbFPathName,Info.ServerPath,Info.ServerThumbFName);
230 if result=false then begin
231// ErrorMsg :='Error sending thumbnail image to server.'; <-- original line. //kt 8/7/2007
232 ErrorMsg :=DKLangConstW('UploadImages_Error_sending_thumbnail_image_to_serverx'); //kt added 8/7/2007
233 MessageDlg(ErrorMsg,mtWarning,[mbOK],0);
234 end;
235 end;
236 end;
237 end;
238 //returns: result
239 end;
240
241
242
243 procedure TUploadForm.UploadChosenFiles();
244 var i : integer;
245 Info: TUploadImageInfo;
246
247 begin
248 SetupVars;
249 Info := TUploadImageInfo.Create();
250 Info.pLongDesc := nil;
251
252 //Load up info class/record
253 Info.ShortDesc := MidStr(ShortDescEdit.Text,1,60);
254 if Info.ShortDesc = DefShortDesc then Info.ShortDesc := ' ';
255 Info.UploadDUZ := User.DUZ;
256 if LongDescMemo.Lines.Count>0 then begin
257 Info.pLongDesc := LongDescMemo.Lines;
258 end;
259 Info.ObjectType := 1; //type 1 is Still Image (jpg). OK to use with .bmp??
260 Info.ProcName := 'Picture'; //max length is 10 characters
261 Info.ImageDateTime := DateTimeEdit.Text;
262 Info.TIUIEN := frmNotes.lstNotes.ItemID;
263 Info.UploadDateTime := 'NOW';
264 Info.DFN := Patient.DFN;
265
266 for i:= 0 to FilesToUploadList.Items.Count-1 do begin
267 Info.ImageFPathName := FilesToUploadList.Items.Strings[i];
268 Info.Extension := ExtractFileExt(Info.ImageFPathName); //includes '.'
269 Info.Extension := MidStr(Info.Extension,2,17); //remove '.'
270
271 if not UploadFile(Info) then begin //Upload function passes back filename info in Info class
272 //Application.MessageBox('Error uploading image file!','Error');
273 end;
274
275 end;
276 Info.Free;
277 end;
278
279 procedure TUploadForm.LoadNotesEdit();
280 begin
281 NoteEdit.Text := frmNotes.tvNotes.Selected.Text;
282 end;
283
284 {
285 procedure TUploadForm.LoadNotesList();
286 var
287 NoteInfo,s,dateS : AnsiString;
288 i : integer;
289 const
290 U='^';
291 begin
292 NoteComboBox.Items.Clear;
293
294 for i := 0 to frmNotes.lstNotes.Count-1 do with frmNotes.lstNotes do begin
295 NoteInfo := Items[i];
296 (* example NoteInfo:
297 piece# 1: 14321^ //TIU IEN
298 piece# 2: PRESCRIPTION CALL IN^ //Document Title
299 piece# 3: 3050713.0947^ //Date/Time
300 piece# 4: TEST, KILLME D (T0101)^ //Patient
301 piece# 5: 133;JANE A DOE;DOE,JANE A^ //Author
302 piece# 6: Main_Office^ //Location of Visit
303 piece# 7: completed^ //Status of Document
304 piece# 8: Visit: 07/13/05;3050713.094721^ //Date/Time
305 piece# 9...: ;^^1^^^1^' //?
306 *)
307 dateS := Piece(Piece(NoteInfo, U, 8), ';', 2);
308 s := FormatFMDateTime('mmm dd,yy@hh:nn', MakeFMDateTime(dateS)) + ' -- ';
309 // s := Piece(Piece(NoteInfo, U, 8), ';', 1) + ' -- ';
310 s := s + Piece(NoteInfo, U, 2) + '; ';
311 s := s + 'Author: ' + Piece(Piece(NoteInfo, U, 5), ';', 2) + ', ';
312 s := s + Piece(NoteInfo, U, 6);
313 NoteComboBox.Items.Add(s);
314 end;
315 NoteComboBox.ItemIndex := frmNotes.lstNotes.ItemIndex;
316 end;
317 }
318 //Delphi events etc.------------------------------------------------
319
320 procedure TUploadForm.UploadButtonClick(Sender: TObject);
321 begin
322 try
323 WebBrowser.Navigate(frmImages.NullImageName);
324 except
325 on E: Exception do exit;
326 end;
327 UploadChosenFiles();
328 end;
329
330 procedure TUploadForm.PickImagesButtonClick(Sender: TObject);
331 var i : integer;
332 begin
333 If OpenDialog.Execute then begin
334 for i := 0 to OpenDialog.Files.Count-1 do begin
335 FilesToUploadList.Items.Add(OpenDialog.Files.Strings[i]);
336 end;
337 end;
338 end;
339
340 procedure TUploadForm.PickOtherButtonClick(Sender: TObject);
341 var i : integer;
342 begin
343 If OpenFileDialog.Execute then begin
344 for i := 0 to OpenFileDialog.Files.Count-1 do begin
345 FilesToUploadList.Items.Add(OpenFileDialog.Files.Strings[i]);
346 end;
347 end;
348 end;
349
350 procedure TUploadForm.FormShow(Sender: TObject);
351 begin
352 FormRefresh(self);
353 FilesToUploadList.Items.Clear;
354 LoadNotesEdit();
355 SetupVars;
356 ShortDescEdit.Text := DefShortDesc;
357 end;
358
359 procedure TUploadForm.ShortDescEditChange(Sender: TObject);
360 begin
361 if Length(ShortDescEdit.Text)> 60 then begin
362 ShortDescEdit.Text := MidStr(ShortDescEdit.Text,1,60);
363 end;
364 end;
365
366 procedure TUploadForm.ClearImagesButtonClick(Sender: TObject);
367 begin
368 FilesToUploadList.Items.Clear;
369 FilesToUploadListClick(self);
370 end;
371
372 procedure TUploadForm.FormCreate(Sender: TObject);
373 begin
374 Bitmap := TBitmap.Create;
375 Bitmap.Height := 64;
376 Bitmap.Width := 64;
377 Picture := TPicture.Create;
378 end;
379
380 procedure TUploadForm.FormDestroy(Sender: TObject);
381 begin
382 Bitmap.Free;
383 Picture.Free;
384 end;
385
386 procedure TUploadForm.FilesToUploadListClick(Sender: TObject);
387 var
388 FileName: AnsiString;
389 SelectedItem: integer;
390 begin
391 SelectedItem := FilesToUploadList.ItemIndex;
392 if SelectedItem > -1 then begin
393 FileName := FilesToUploadList.Items[SelectedItem];
394 //Application.MessageBox('Here I would pass to IE','NOte');
395 end else begin
396 FileName := frmImages.NullImageName;
397 end;
398 try
399 WebBrowser.Navigate(FileName);
400 except
401 on E: Exception do exit;
402 end;
403 end;
404
405 procedure TUploadForm.FormRefresh(Sender: TObject);
406 begin
407 try
408 WebBrowser.Navigate(frmImages.NullImageName);
409 except
410 on E: Exception do exit;
411 end;
412 end;
413
414end.
Note: See TracBrowser for help on using the repository browser.