source: cprs/branches/tmg-cprs/CPRS-Chart/fImages.pas@ 1806

Last change on this file since 1806 was 877, checked in by Kevin Toppenberg, 14 years ago

Dual sync of source code enabled: SVN + BZR
File size: 55.8 KB
Line 
1unit fImages; //kt Entire unit and form added 8/19/05
2{$O-}
3
4interface
5
6uses
7 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
8 fPage, StdCtrls, ExtCtrls, Menus, ComCtrls, ORCtrls, ORFn, uConst, ORDtTm,
9 uPCE, ORClasses, fDrawers, ImgList, rTIU, uTIU, uDocTree, fRptBox, fPrintList,
10 OleCtrls, SHDocVw,
11 ORNet, TRPCB, fHSplit, Buttons, ExtDlgs, DKLang;
12
13type
14 TImgDelMode = (idmNone,idmDelete,idmRetract); //NOTE: DO NOT change order
15 TImageInfo = class
16 private
17 public
18 IEN : int64; //IEN in file# 2005
19 ServerPathName : AnsiString;
20 ServerFName : AnsiString;
21 ServerThumbPathName: AnsiString;
22 ServerThumbFName : AnsiString;
23 //Note: if there is no thumbnail to download, CacheThumbFName will still
24 // contain a file name and path, but a test for FileExists() will wail.
25 CacheThumbFName : AnsiString; // local cache path and File name of thumbnail image
26 CacheFName : AnsiString; // local cache path and File name of image
27 ShortDesc : AnsiString;
28 LongDesc : TStringList; //will be nil unless holds data.
29 DateTime : AnsiString; //fileman format
30 ImageType : Integer;
31 ProcName : AnsiString;
32 DisplayDate : AnsiString;
33 ParentDataFileIEN: int64;
34 AbsType : char; //'M' magnetic 'W' worm 'O' offline
35 Accessibility : char; //'A' accessable or 'O' offline
36 DicomSeriesNum : int64;
37 DicomImageNum : int64;
38 GroupCount : integer;
39 TabIndex : integer;
40 TabImageIndex : integer;
41
42 published
43 end;
44
45 TImgTransferMethod = (itmDropbox,itmDirect,itmRPC);
46
47 TfrmImages = class(TfrmPage)
48 mnuNotes: TMainMenu;
49 mnuView: TMenuItem;
50 mnuViewChart: TMenuItem;
51 mnuChartReports: TMenuItem;
52 mnuChartLabs: TMenuItem;
53 mnuChartDCSumm: TMenuItem;
54 mnuChartCslts: TMenuItem;
55 mnuChartNotes: TMenuItem;
56 mnuChartOrders: TMenuItem;
57 mnuChartMeds: TMenuItem;
58 mnuChartProbs: TMenuItem;
59 mnuChartCover: TMenuItem;
60 mnuAct: TMenuItem;
61 Z3: TMenuItem;
62 mnuOptions: TMenuItem;
63 timLoadImages: TTimer;
64 N3: TMenuItem;
65 mnuIconLegend: TMenuItem;
66 mnuChartSurgery: TMenuItem;
67 ThumbsImageList: TImageList;
68 CurrentNoteMemo: TMemo;
69 pnlTop: TPanel;
70 HorizSplitter: TSplitter;
71 Splitter2: TSplitter;
72 UploadImagesButton: TBitBtn;
73 OpenPictureDialog: TOpenPictureDialog;
74 ButtonPanel: TPanel;
75 CurrentImageMemo: TMemo;
76 MemosPanel: TPanel;
77 UploadImagesMnuAction: TMenuItem;
78 pnlBottom: TPanel;
79 TabControl: TTabControl;
80 WebBrowser: TWebBrowser;
81 AutoScanUpload: TMenuItem;
82 PickScanFolder: TMenuItem;
83 OpenDialog: TOpenDialog;
84 mnuPopup: TPopupMenu;
85 mnuPopDeleteImage: TMenuItem;
86 mnuDeleteImage: TMenuItem;
87 procedure mnuChartTabClick(Sender: TObject);
88 procedure mnuActNewClick(Sender: TObject);
89 procedure timLoadImagesTimer(Sender: TObject);
90 procedure FormCreate(Sender: TObject);
91 procedure FormDestroy(Sender: TObject);
92 procedure FormShow(Sender: TObject);
93 procedure mnuActClick(Sender: TObject);
94 procedure UploadImagesButtonClick(Sender: TObject);
95 procedure FormHide(Sender: TObject);
96 procedure TabControlChange(Sender: TObject);
97 procedure TabControlGetImageIndex(Sender: TObject; TabIndex: Integer;
98 var ImageIndex: Integer);
99 procedure TabControlResize(Sender: TObject);
100 procedure EnableAutoScanUploadClick(Sender: TObject);
101 procedure PickScanFolderClick(Sender: TObject);
102 procedure TabControlMouseUp(Sender: TObject; Button: TMouseButton;
103 Shift: TShiftState; X, Y: Integer);
104 procedure mnuPopupPopup(Sender: TObject);
105 procedure mnuPopDeleteImageClick(Sender: TObject);
106 procedure mnuDeleteImageClick(Sender: TObject);
107 private
108 ImageInfoList : TList;
109 LastDisplayedTIUIEN : AnsiString;
110 ImageIndexLastDownloaded : integer;
111 FDeleteImageIndex : integer;
112 FEditIsActive : boolean;
113 FImageDeleteMode : TImgDelMode;
114 procedure EnsureImageListLoaded();
115 procedure ClearImageList();
116 procedure DownloadToCache(ImageIndex : integer);
117 procedure EmptyCache();
118 procedure ClearTabPages();
119 procedure SetupTab(i : integer);
120 procedure UpdateNoteInfoMemo();
121 procedure UpdateImageInfoMemo(Rec: TImageInfo);
122 function FileSize(fileName : wideString) : Int64;
123 function GetImagesCount : integer;
124 function GetImageInfo(Index : integer) : TImageInfo;
125 procedure SetupTimer;
126 function CanDeleteImages : boolean;
127 procedure DeleteImageIndex(ImageIndex : integer; DeleteMode : TImgDelMode; boolPromptUser: boolean);
128 procedure DeleteImage(var DeleteSts: TActionRec; ImageFileName: string; ImageIEN, DocIEN: Integer;
129 DeleteMode : TImgDelMode; const Reason: string);
130 public
131 CacheDir : AnsiString;
132 TransferMethod : TImgTransferMethod;
133 DropBoxDir : string;
134 NullImageName : AnsiString;
135 NumImagesAvailableOnServer : integer;
136 DownloadImagesInBackground : boolean;
137 function Decode(input: AnsiString) : AnsiString;
138 function Encode(input: AnsiString) : AnsiString;
139 function DownloadFileViaDropbox(FPath,FName,LocalSaveFNamePath: AnsiString;CurrentImage,TotalImages: Integer): boolean;
140 function DownloadFile(FPath,FName,LocalSaveFNamePath: AnsiString;CurrentImage,TotalImages: Integer): boolean;
141 function UploadFileViaDropBox(LocalFNamePath,FPath,FName: AnsiString;CurrentImage,TotalImages: Integer): boolean;
142 function UploadFile(LocalFNamePath,FPath,FName: AnsiString;CurrentImage,TotalImages: Integer): boolean;
143 procedure SplitLinuxFilePath(FullPathName : AnsiString;
144 var Path : AnsiString;
145 var FName : AnsiString);
146 procedure GetImageList();
147 procedure NewNoteSelected(EditIsActive : boolean);
148 function CreateBarcode(MsgStr: AnsiString; ImageType: AnsiString): AnsiString;
149 function DecodeBarcode(LocalFNamePath,ImageType: AnsiString): AnsiString;
150 procedure EnsureImagesDownloaded(ImagesList : TStringList);
151 procedure EnsureALLImagesDownloaded;
152 procedure DeleteAll(DeleteMode: TImgDelMode);
153 property ImagesCount : integer read GetImagesCount;
154 property ImageInfo[index : integer] : TImageInfo read GetImageInfo;
155 procedure GetThumbnailBitmapForFName (FName : string; Bitmap : TBitmap);
156 function ThumbnailIndexForFName (FName : string) : integer;
157 published
158 end;
159
160Const
161 IMAGE_TRANSFER_METHODS : Array[itmDropbox..itmRPC] of string[32] = (
162 'Dropbox Transfer', 'Direct Access', 'Embedded in RPCs');
163 IMAGE_DOWNLOAD_DELAY_BACKGROUND = 30000;
164 IMAGE_DOWNLOAD_DELAY_FOREGROUND = 100;
165 NOT_YET_CHECKED_SERVER = -2;
166
167 //NOTE: If order is changed in ThumbsImageList, these numbers should be changed
168 IMAGE_INDEX_IMAGE = 0;
169 IMAGE_INDEX_ADOBE = 1;
170 IMAGE_INDEX_VIDEO = 2;
171 IMAGE_INDEX_SOUND = 3;
172 IMAGE_INDEX_MISC = 4;
173
174var
175 frmImages: TfrmImages;
176
177
178implementation
179
180{$R *.DFM}
181
182uses fFrame, fVisit, fEncnt, rCore, uCore, fNoteBA, fNoteBD, fSignItem, fEncounterFrame,
183 rPCE, Clipbrd, fNoteCslt, fNotePrt, rVitals, fAddlSigners, fNoteDR, fConsults, uSpell,
184 fTIUView, fTemplateEditor, uReminders, fReminderDialog, uOrders, rConsults, fReminderTree,
185 fNoteProps, fNotesBP, fTemplateFieldEditor, dShared, rTemplates,
186 FIconLegend, fPCEEdit, fNoteIDParents, rSurgery, uSurgery, uTemplates,
187 uAccessibleTreeView, uAccessibleTreeNode, fTemplateDialog, DateUtils,
188 StrUtils, mshtml, UploadImages,
189 uTMGOptions, //kt 3/10/10
190 rHTMLTools, fNotes, frmImageTransferProgress, fImagePickExisting; {//kt added 5-27-05 for IsHTMLDocument}
191
192
193procedure TfrmImages.FormCreate(Sender: TObject);
194//var i : integer;
195begin
196 inherited;
197 LastDisplayedTIUIEN := '0';
198 FDeleteImageIndex := -1;
199 ImageInfoList := TList.Create;
200 ClearImageList(); //sets up other needed variables.
201 DownloadImagesInBackground := true;
202 CacheDir := ExtractFilePath(ParamStr(0))+ 'Cache';
203 NullImageName := 'about:blank';
204 if not DirectoryExists(CacheDir) then ForceDirectories(CacheDir);
205
206 TransferMethod := TImgTransferMethod(uTMGOptions.ReadInteger('ImageTransferMethod',2));
207 DropBoxDir := uTMGOptions.ReadString('Dropbox directory','??');
208 if DropBoxDir='??' then begin //just on first run.
209 uTMGOptions.WriteBool('Use dropbox directory for transfers',false);
210 uTMGOptions.WriteString('Dropbox directory','');
211 end;
212 AutoScanUpload.Checked := uTMGOptions.ReadBool('Scan Enabled',false);
213end;
214
215procedure TfrmImages.FormDestroy(Sender: TObject);
216begin
217 inherited;
218 ClearImageList;
219 ImageInfoList.Free;
220 EmptyCache;
221end;
222
223procedure TfrmImages.FormShow(Sender: TObject);
224var TIUIEN : AnsiString;
225begin
226 inherited;
227 mnuDeleteImage.Enabled := CanDeleteImages;
228 TIUIEN := IntToStr(frmNotes.lstNotes.ItemID);
229 DownloadImagesInBackground := false;
230 SetupTimer;
231 if LastDisplayedTIUIEN <> TIUIEN then begin
232 UpdateNoteInfoMemo();
233 LastDisplayedTIUIEN := TIUIEN;
234 end;
235end;
236
237
238procedure TfrmImages.timLoadImagesTimer(Sender: TObject);
239//This function's goal is to download images in the background,
240// with one image to be downloaded each time the timer fires
241begin
242 inherited;
243 timLoadImages.Enabled := false;
244 EnsureImageListLoaded();
245 if NumImagesAvailableOnServer = 0 then exit;
246 if (ImageIndexLastDownloaded >= (ImageInfoList.Count-1)) then exit;
247 ImageTransferForm.ProgressMsg.Caption := 'Downloading Images';
248 DownloadToCache(ImageIndexLastDownloaded+1); //Only load 1 image per timer firing.
249 SetupTab(ImageIndexLastDownloaded+1);
250 Inc(ImageIndexLastDownloaded);
251 if TabControl.TabIndex < 0 then TabControl.TabIndex := 0;
252 TabControlChange(self);
253 SetupTimer;
254end;
255
256procedure TfrmImages.SetupTimer;
257begin
258 if DownloadImagesInBackground then begin
259 timLoadImages.Interval := IMAGE_DOWNLOAD_DELAY_BACKGROUND;
260 end else begin
261 timLoadImages.Interval := IMAGE_DOWNLOAD_DELAY_FOREGROUND;
262 end;
263 timLoadImages.Enabled := true;
264end;
265
266procedure TfrmImages.EnsureImagesDownloaded(ImagesList : TStringList);
267//This function's goal is to download images in the FOREground,
268// But only images matching those passed in ImagesList will be downloaded;
269// The intent is to only download images that have links to them in HTML source
270//Thus, if note has a large amount of images attached to it, but not referenced
271// in HTML code, then they will not be downloaded here. (But will be downloaded
272// later via timLoadImagesTimer
273var i : integer;
274 Rec : TImageInfo;
275
276begin
277 if ImagesList.Count = 0 then exit;
278 GetImageList();
279 if ImageInfoList.Count = 0 then exit;
280 if ImageInfoList.Count > 1 then begin
281 ImageTransferForm.ProgressMsg.Caption := 'Downloading Images';
282 ImageTransferForm.ProgressBar.Min := 0;
283 ImageTransferForm.ProgressBar.Position := 0;
284 ImageTransferForm.ProgressBar.Max := ImageInfoList.Count-1;
285 ImageTransferForm.Show;
286 end;
287 for i := 0 to ImageInfoList.Count-1 do begin
288 ImageTransferForm.ProgressBar.Position := i;
289 Rec := TImageInfo(ImageInfoList[i]);
290 if ImagesList.IndexOf(Rec.ServerFName)>-1 then begin
291 DownloadToCache(i);
292 end;
293 end;
294 ImageTransferForm.Hide;
295end;
296
297procedure TfrmImages.EnsureALLImagesDownloaded;
298//This function's goal is to download ALL images in the FOREground.
299begin
300 EnsureImageListLoaded();
301 if NumImagesAvailableOnServer = 0 then exit;
302 ImageTransferForm.ProgressMsg.Caption := 'Downloading Images';
303 while (ImageIndexLastDownloaded < (ImageInfoList.Count-1)) do begin
304 DownloadToCache(ImageIndexLastDownloaded+1); //Only load 1 image per timer firing.
305 SetupTab(ImageIndexLastDownloaded+1);
306 Inc(ImageIndexLastDownloaded);
307 if TabControl.TabIndex < 0 then TabControl.TabIndex := 0;
308 TabControlChange(self);
309 end;
310end;
311
312{ TPage common methods --------------------------------------------------------------------- }
313procedure TfrmImages.mnuChartTabClick(Sender: TObject);
314{ reroute to Chart Tab menu of the parent form: frmFrame }
315begin
316 inherited;
317 frmFrame.mnuChartTabClick(Sender);
318end;
319
320
321procedure TfrmImages.mnuActNewClick(Sender: TObject);
322const
323 IS_ID_CHILD = False;
324{ switches to current new note or creates a new note if none is being edited already }
325begin
326 inherited;
327end;
328
329procedure TfrmImages.mnuActClick(Sender: TObject);
330begin
331 inherited;
332
333end;
334
335{ General procedures ----------------------------------------------------------------------- }
336
337procedure TfrmImages.UpdateImageInfoMemo(Rec : TImageInfo);
338var s : AnsiString;
339 i : integer;
340begin
341 CurrentImageMemo.Lines.Clear;
342 if Rec=nil then exit;
343 s := Trim(Rec.ShortDesc);
344 if s <> '' then CurrentImageMemo.Lines.Add('Description: ' + s);
345 s := Rec.ProcName;
346 if s <> '' then CurrentImageMemo.Lines.Add('Procedure: ' + s);
347 s := Rec.DisplayDate;
348 if s <> '' then CurrentImageMemo.Lines.Add('Upload Date: ' + s);
349 //s := Rec.DateTime;
350 //if s <> '' then CurrentImageMemo.Lines.Add('Date/Time: ' + s);
351 if Rec.LongDesc <> nil then begin
352 CurrentImageMemo.Lines.Add('Long Description:');
353 for i := 0 to Rec.LongDesc.Count-1 do begin
354 CurrentImageMemo.Lines.Add(' ' + Rec.LongDesc.Strings[i]);
355 end;
356 end;
357end;
358
359
360procedure TfrmImages.UpdateNoteInfoMemo();
361var
362 NoteInfo,s : AnsiString;
363 //dateS : AnsiString;
364const
365 U='^';
366begin
367 CurrentNoteMemo.Lines.Clear;
368 with frmNotes.lstNotes do begin
369 if ItemIndex > -1 then begin
370 NoteInfo := Items[ItemIndex]
371 (* example NoteInfo:
372 piece# 1: 14321^ //TIU IEN
373 piece# 2: PRESCRIPTION CALL IN^ //Document Title
374 piece# 3: 3050713.0947^ //Date/Time
375 piece# 4: TEST, KILLME D (T0101)^ //Patient
376 piece# 5: 133;JANE A DOE;DOE,JANE A^ //Author
377 piece# 6: Main_Office^ //Location of Visit
378 piece# 7: completed^ //Status of Document
379 piece# 8: Visit: 07/13/05;3050713.094721^ //Date/Time
380 piece# 9...: ;^^1^^^1^' //?
381 *)
382 end else NoteInfo := '';
383 end;
384 if NoteInfo <>'' then begin
385 s := Piece(NoteInfo, U, 2) + ' -- ';
386 s := s + Piece(Piece(NoteInfo, U, 8), ';', 1);
387 CurrentNoteMemo.Lines.Add(s);
388 s := 'Location: ' + Piece(NoteInfo, U, 6) + ' -- ';
389 s := s + 'Note Author: ' + Piece(Piece(NoteInfo, U, 5), ';', 2);
390 CurrentNoteMemo.Lines.Add(s);
391 end;
392end;
393
394procedure TfrmImages.SetupTab(i : integer);
395//i is index in ImageInfoList (array of TImageInfo's)
396var
397 Rec : TImageInfo; //this will be a copy of record, not pointer (I think)
398 Bitmap : TBitmap;
399 index : integer;
400 Ext : AnsiString;
401
402 (*Notice: A TabControl doesn't directly support specifying which
403 images in an ImageList to show for a given tab. To get
404 around this, the help documentation recommends setting up
405 a TabControlGetImageIndex event handler.
406 I am doing this. When the event is called, then RecInfo.TabImageIndex
407 is returned.
408 *)
409
410begin
411 if i < ImageInfoList.Count then begin
412 Rec := TImageInfo(ImageInfoList[i]);
413 if (Rec.TabImageIndex < 1) then begin
414 if FileExists(Rec.CacheThumbFName) then begin
415 Bitmap := TBitmap.Create;
416 Bitmap.Width := 1024; //something big enough to hold any thumbnail.
417 Bitmap.Height := 768;
418 Bitmap.LoadFromFile(Rec.CacheThumbFName);
419 Bitmap.Width := ThumbsImageList.Width; //shrinkage crops image
420 Bitmap.Height := ThumbsImageList.Height;
421 index := ThumbsImageList.Add(Bitmap,nil);
422 //TImageInfo(ImageInfoList[i]).TabImageIndex := index;
423 Rec.TabImageIndex := index;
424 Bitmap.Free;
425 end else begin
426 Rec.TabImageIndex := ThumbnailIndexForFName(Rec.CacheFName);
427 end;
428 end;
429 TabControl.Tabs.Add(' '); //add the tab. Thumbnail should exist before this
430 end;
431end;
432
433function TfrmImages.ThumbnailIndexForFName (FName : string) : integer;
434var
435 index : integer;
436 Ext : AnsiString;
437begin
438 Result := 4; //default
439 Ext := LowerCase(ExtractFileExt(FName));
440 Ext := MidStr(Ext,2,99);
441 if (Ext='jpg')
442 or (Ext='jpeg')
443 or (Ext='png')
444 or (Ext='tif')
445 or (Ext='tiff')
446 or (Ext='gif')
447 or (Ext='bmp') then begin
448 Result := IMAGE_INDEX_IMAGE; //camera image
449 end else
450 if (Ext='pdf') then begin
451 Result := IMAGE_INDEX_ADOBE; //adobe icon
452 end else
453 if (Ext='avi')
454 or (Ext='qt')
455 or (Ext='mpg')
456 or (Ext='mpeg') then begin
457 Result := IMAGE_INDEX_VIDEO; //video icon
458 end else
459 if (Ext='mp3')
460 or (Ext='wma')
461 or (Ext='au')
462 or (Ext='wav') then begin
463 Result := IMAGE_INDEX_SOUND; //sound icon
464 end else
465 begin
466 Result := IMAGE_INDEX_MISC; // misc icon
467 end;
468end;
469
470
471procedure TfrmImages.GetThumbnailBitmapForFName (FName : string; Bitmap : TBitmap);
472var index: integer;
473begin
474 index := ThumbnailIndexForFName(FName);
475 ThumbsImageList.GetBitmap(index,Bitmap);
476end;
477
478
479procedure TfrmImages.ClearTabPages();
480begin
481 TabControl.Tabs.Clear;
482 ClearImageList();
483end;
484
485
486procedure TfrmImages.ClearImageList();
487//Note: !! This should also clear any visible images/thumbnails etc.
488//Note: Need to remove thumbnail image from image list.
489var i : integer;
490begin
491 for i := ImageInfoList.Count-1 downto 0 do begin
492 if TImageInfo(ImageInfoList[i]).LongDesc <> nil then begin
493 TImageInfo(ImageInfoList[i]).LongDesc.Free;
494 end;
495 TImageInfo(ImageInfoList[i]).Free;
496 ImageInfoList.Delete(i);
497 end;
498 NumImagesAvailableOnServer := NOT_YET_CHECKED_SERVER;
499 ImageIndexLastDownloaded := -1;
500end;
501
502
503procedure TfrmImages.EnsureImageListLoaded();
504begin
505 if NumImagesAvailableOnServer = NOT_YET_CHECKED_SERVER then begin
506 GetImageList();
507 end;
508end;
509
510procedure TfrmImages.GetImageList();
511//Sets up ImageInfoList
512var
513 i,j : integer;
514 s,s2 : AnsiString;
515 Rec : TImageInfo;
516 ImageIEN : integer;
517 TIUIEN : AnsiString;
518 ServerFName : AnsiString;
519 ServerPathName : AnsiString;
520 ImageFPathName : AnsiString; //path on server of image -- original data provided by server
521 ThumbnailFPathName : AnsiString; //path on server of thumbnail -- original data provided by server
522
523begin
524 inherited;
525 ClearImageList;
526 try
527 TIUIEN := IntToStr(frmNotes.lstNotes.ItemID);
528
529 except
530 //Error occurs after note is signed, and frmNotes.lstNotes.ItemID is "inaccessible"
531 on E: Exception do exit;
532 end;
533 StatusText('Retrieving images information...');
534 CallV('MAG3 CPRS TIU NOTE', [TIUIEN]);
535 for i:=0 to (RPCBrokerV.Results.Count-1) do begin
536 s :=RPCBrokerV.Results[i];
537 if i=0 then begin
538 if piece(s,'^',1)='0' then break //i.e. abort due to error signal
539 else continue; //ignore rest of header (record #0)
540 end;
541 if Pos('-1~',s)>0 then continue; //abort if error signal.
542 Rec := TImageInfo.Create; // ImageInfoList will own this.
543 Rec.LongDesc := nil;
544 Rec.TabIndex := -1;
545 Rec.TabImageIndex := 0;
546 s2 := piece(s,'^',2); if s2='' then s2 := '0'; //IEN
547 Rec.IEN := StrToInt(s2);
548 ImageFPathName := piece(s,'^',3); //Image FullPath and name
549 ThumbnailFPathName := piece(s,'^',4); //Abstract FullPath and Name
550 Rec.ShortDesc := piece(s,'^',5); //SHORT DESCRIPTION field
551 s2 := piece(s,'^',6); if s2='' then s2 := '0'; //PROCEDURE/ EXAM DATE/TIME field
552 Rec.DateTime := s2;
553 s2 := piece(s,'^',7); if s2='' then s2 := '0'; //OBJECT TYPE
554 Rec.ImageType := StrToInt(s2);
555 Rec.ProcName := piece(s,'^',8); //PROCEDURE field
556 Rec.DisplayDate := piece(s,'^',9); //Procedure Date in Display format
557 s2 := piece(s,'^',10); if s2='' then s2 := '0'; //PARENT DATA FILE image pointer
558 Rec.ParentDataFileIEN := StrToInt(s2);
559 Rec.AbsType := piece(s,'^',11)[1]; //the ABSTYPE : 'M' magnetic 'W' worm 'O' offline
560 s2 := piece(s,'^',12); if s2='' then s2 :='O';
561 Rec.Accessibility := s2[1]; //Image accessibility 'A' accessable or 'O' offline
562 s2 := piece(s,'^',13); if s2='' then s2 := '0'; //Dicom Series number
563 Rec.DicomSeriesNum := StrToInt(s2);
564 s2 := piece(s,'^',14); if s2='' then s2 := '0'; //Dicom Image Number
565 Rec.DicomImageNum := StrToInt(s2);
566 s2 := piece(s,'^',15); if s2='' then s2 := '0'; //Count of images in the group, or 1 if a single image
567 Rec.GroupCount := StrToInt(s2);
568
569 SplitLinuxFilePath(ImageFPathName,ServerPathName,ServerFName);
570 Rec.ServerPathName := ServerPathName;
571 Rec.ServerFName := ServerFName;
572 Rec.CacheFName := CacheDir + '\' + ServerFName;
573 SplitLinuxFilePath(ThumbnailFPathName,ServerPathName,ServerFName);
574 Rec.ServerThumbPathName := ServerPathName;
575 Rec.ServerThumbFName := ServerFName;
576 Rec.CacheThumbFName := CacheDir + '\' + ServerFName;
577 ImageInfoList.Add(Rec); // ImageInfoList will own Rec.
578 end;
579 for i:= 0 to ImageInfoList.Count-1 do begin
580 Rec := TImageInfo(ImageInfoList.Items[i]);
581 ImageIEN := Rec.IEN;
582 CallV('TMG GET IMAGE LONG DESCRIPTION', [ImageIEN]);
583 for j:=0 to (RPCBrokerV.Results.Count-1) do begin
584 if (j>0) then begin
585 if Rec.LongDesc = nil then Rec.LongDesc := TStringList.Create;
586 Rec.LongDesc.Add(RPCBrokerV.Results.Strings[j]);
587 end else begin
588 if RPCBrokerV.Results[j]='' then break;
589 end;
590 end;
591 end;
592 StatusText('');
593 NumImagesAvailableOnServer := ImageInfoList.Count;
594end;
595
596
597procedure TfrmImages.DownloadToCache(ImageIndex : integer);
598//Loads image specified in ImageInfoList to Cache (unless already present)
599var
600 Rec : TImageInfo;
601 ServerFName : AnsiString;
602 ServerPathName : AnsiString;
603
604begin
605 Rec := TImageInfo(ImageInfoList[ImageIndex]);
606 ServerFName := Rec.ServerFName;
607 ServerPathName := Rec.ServerPathName;
608 if not FileExists(Rec.CacheFName) then begin
609 DownloadFile(ServerPathName,ServerFName,Rec.CacheFName,(ImageIndex*2)-1,ImageInfoList.Count*2);
610 end;
611 ServerFName := Rec.ServerThumbFName;
612 ServerPathName := Rec.ServerThumbPathName;
613 if not FileExists(Rec.CacheThumbFName) then begin
614 DownloadFile(ServerPathName,ServerFName,Rec.CacheThumbFName,ImageIndex*2,ImageInfoList.Count*2);
615 end;
616 Application.ProcessMessages;
617end;
618
619procedure TfrmImages.SplitLinuxFilePath(FullPathName : AnsiString;
620 var Path : AnsiString;
621 var FName : AnsiString);
622var p : integer;
623begin
624 Path := ''; FName := '';
625 repeat
626 p := Pos('/',FullPathName);
627 if p > 0 then begin
628 Path := Path + MidStr(FullPathName,1,p);
629 FullPathName := MidStr(FullPathName,p+1,1000);
630 end else begin
631 FName := FullPathName;
632 FullPathName := '';
633 end;
634 until (FullPathName = '');
635end;
636
637
638function TfrmImages.UploadFileViaDropBox(LocalFNamePath,FPath,FName: AnsiString;CurrentImage,TotalImages: Integer): boolean;
639var
640 DropboxFile : AnsiString;
641begin
642 //First copy LocalFileNamePath --> DropBox\FileName
643 DropboxFile := ExcludeTrailingBackslash(DropboxDir) + '\' + FName;
644 if CopyFile(pchar(LocalFNamePath),pchar(DropboxFile),false)=false then begin
645 MessageDlg('Dropbox file transfer failed. Code='+InttoStr(GetLastError),
646 mtError,[mbOK],0);
647 result := false;
648 exit;
649 end;
650
651 CallV('TMG UPLOAD FILE DROPBOX', [FPath,FName]); //Move file into dropbox.
652 {
653 RPCBrokerV.ClearParameters := true;
654 RPCBrokerV.remoteprocedure := 'TMG UPLOAD FILE DROPBOX';
655 RPCBrokerV.param[0].PType := literal;
656 RPCBrokerV.param[0].Value := FPath;
657 RPCBrokerV.Param[1].PType := literal;
658 RPCBrokerV.Param[1].Value := FName;
659 RPCBrokerV.Param[2].PType := literal;
660 RPCBrokerV.Param[2].Value := '1'; //see comments in UploadFile re '1' hardcoding
661
662 CallBroker; //Move file into dropbox.
663 }
664 if RPCBrokerV.Results.Count>0 then begin
665 Result := (Piece(RPCBrokerV.Results[0],'^',1)='1'); //1=success, 0=failure
666 end else Result := false;
667end;
668
669
670function TfrmImages.UploadFile(LocalFNamePath,FPath,FName: AnsiString;CurrentImage,TotalImages: Integer): boolean;
671const
672 RefreshInterval = 500;
673 BlockSize = 512;
674
675var
676 ReadCount : Word;
677 totalReadCount : Integer;
678 ParamIndex : LongWord;
679 j : word;
680 InFile : TFileStream;
681 LocalOutFile : TFileStream;
682 Buffer : array[0..1024] of byte;
683 RefreshCountdown : integer;
684 OneLine : AnsiString;
685 RPCResult : AnsiString;
686 SavedCursor : TCursor;
687
688begin
689 result := false; //default of failure
690 if not FileExists(LocalFNamePath) then exit;
691 //if UseDropBox then begin
692 if TransferMethod = itmDropbox then begin
693 Result := UploadFileViaDropBox(LocalFNamePath,FPath,FName,CurrentImage,TotalImages);
694 exit;
695 end;
696 //LATER add support for itmDirect mode
697 try
698 InFile := TFileStream.Create(LocalFNamePath,fmOpenRead or fmShareCompat);
699 LocalOutFile := TFileStream.Create(CacheDir+'\'+FName,fmCreate or fmOpenWrite); //for local copy
700 //Note: I may well cut this out. Most of the delay occurs during
701 // the RPC call, and I can't make a progress bar change during that...
702 // (or I could, but I'm not going to change the RPC broker...)
703 ImageTransferForm.setMax(InFile.Size);
704 ImageTransferForm.ProgressMsg.Caption := 'Preparing to upload...';
705 ImageTransferForm.Show;
706 totalReadCount := 0;
707 except
708 // catch failure here... on eError...
709 exit;
710 end;
711
712 StatusText('Uploading full image...');
713 Application.ProcessMessages;
714
715 RPCBrokerV.remoteprocedure := 'TMG UPLOAD FILE';
716 RPCBrokerV.ClearParameters := true;
717 RPCBrokerV.Param[0].PType := literal;
718 RPCBrokerV.Param[0].Value := FPath;
719 RPCBrokerV.Param[1].PType := literal;
720 RPCBrokerV.Param[1].Value := FName;
721 RPCBrokerV.Param[2].PType := literal;
722 RPCBrokerV.Param[2].Value := ''; //kt 7/11/10
723 //RPCBrokerV.Param[2].Value := '1'; //Specifying a NETWORK LOCATION is now depreciated.
724
725 RPCBrokerV.Param[3].PType := list;
726 ParamIndex := 0;
727 RefreshCountdown := RefreshInterval;
728 repeat
729 ReadCount := InFile.Read(Buffer,BlockSize);
730 LocalOutFile.Write(Buffer,ReadCount); //for local copy
731 totalReadCount := totalReadCount + ReadCount;
732 ImageTransferForm.updateProgress(totalReadCount);
733 OneLine := '';
734 if ReadCount > 0 then begin
735 SetLength(OneLine,ReadCount);
736 for j := 1 to ReadCount do OneLine[j] := char(Buffer[j-1]);
737 RPCBrokerV.Param[3].Mult[IntToStr(ParamIndex)] := Encode(OneLine);
738 Inc(ParamIndex);
739
740 Dec(RefreshCountdown);
741 if RefreshCountdown < 1 then begin
742 Application.ProcessMessages;
743 RefreshCountdown := RefreshInterval;
744 end;
745 end;
746 until (ReadCount < BlockSize);
747
748 SavedCursor := Screen.Cursor;
749 Screen.Cursor := crHourGlass;
750 ImageTransferForm.ProgressMsg.Caption := 'Uploading file to server...';
751 Application.ProcessMessages;
752
753 CallBroker;
754
755 Screen.Cursor := SavedCursor;
756 if RPCBrokerV.Results.Count > 0 then begin
757 RPCResult := RPCBrokerV.Results[0];
758 end else RPCResult := '';
759 result := (Piece(RPCResult,'^',1)='1');
760 ImageTransferForm.Hide;
761 if result=false then begin
762 Application.MessageBox('Error uploading file','Error');
763 end;
764
765 InFile.Free;
766 LocalOutFile.Free;
767 StatusText('');
768end;
769
770
771function TfrmImages.DownloadFileViaDropbox(FPath,FName,LocalSaveFNamePath: AnsiString;CurrentImage,TotalImages: Integer): boolean;
772var
773 DropboxFile : AnsiString;
774 CurrentFileSize : Integer;
775 ErrMsg : string;
776begin
777 CallV('TMG DOWNLOAD FILE DROPBOX', [FPath,FName]); //Move file into dropbox.
778 {RPCBrokerV.ClearParameters := true;
779 RPCBrokerV.remoteprocedure := 'TMG DOWNLOAD FILE DROPBOX';
780 RPCBrokerV.param[0].PType := literal;
781 RPCBrokerV.param[0].Value := FPath;
782 RPCBrokerV.Param[1].PType := literal;
783 RPCBrokerV.Param[1].Value := FName;
784 RPCBrokerV.Param[2].PType := literal;
785 RPCBrokerV.Param[2].Value := '1'; //see comments in UploadFile re '1' hardcoding
786 CallBroker; }
787 if RPCBrokerV.Results.Count > 0 then begin
788 Result := (Piece(RPCBrokerV.Results[0],'^',1)='1'); //1=success, 0=failure
789 if Result = false then ErrMsg := Piece(RPCBrokerV.Results[0],'^',2);
790 end else begin
791 Result := false;
792 ErrMsg := 'Error communicating with server to retrieve image.';
793 end;
794
795 if Result=true then begin
796 if DirectoryExists(DropboxDir) = False then begin //elh added to ensure a dropbox directory is valid
797 MessageDlg('Invalid Dropbox Directory. Please check your settings and try again.',mtError,[mbOK],0);
798 ImageTransferForm.hide;
799 exit;
800 end;
801 CurrentFileSize := strtoint(Piece(RPCBrokerV.Results[0],'^',3)); //Piece 3 = file size
802 DropboxFile := ExcludeTrailingBackslash(DropboxDir) + '\' + FName;
803 if ImageTransferForm.visible = False then ImageTransferForm.show;
804 while FileSize(DropboxFile) <> CurrentFileSize do sleep(1000); //elh
805 ImageTransferForm.ProgressBar.Max := TotalImages; //elh
806 ImageTransferForm.ProgressBar.Position := CurrentImage+2; //elh
807 if TotalImages = (CurrentImage+2) then begin
808 Sleep(1000);
809 ImageTransferForm.hide;
810 end;
811 //Now move DropBox\FileName --> LocalFileNamePath
812 if MoveFile(pchar(DropboxFile),pchar(LocalSaveFNamePath))=false then begin
813 MessageDlg('Dropbox file transfer failed. Code='+InttoStr(GetLastError),
814 mtError,[mbOK],0);
815 end;
816 end else begin
817 MessageDlg('ERROR: '+ErrMsg,mtError,[mbOK],0);
818 end;
819end;
820
821
822function TfrmImages.DownloadFile(FPath,FName,LocalSaveFNamePath: AnsiString;CurrentImage,TotalImages: Integer): boolean;
823var
824 i,count : integer;
825 j : word;
826 OutFile : TFileStream;
827 s : AnsiString;
828 Buffer : array[0..1024] of byte;
829 RefreshCountdown : integer;
830
831const
832 RefreshInterval = 500;
833
834begin
835 if FileExists(LocalSaveFNamePath) then begin
836 DeleteFile(LocalSaveFNamePath);
837 end;
838 if TransferMethod = itmDropbox then begin
839 Result := DownloadFileViaDropBox(FPath,FName,LocalSaveFNamePath,CurrentImage,TotalImages);
840 exit;
841 end;
842 //LATER add support for itmDirect mode
843 Result := true; //default to success;
844 StatusText('Retrieving full image...');
845 //kt CallV('TMG DOWNLOAD FILE', [FPath,FName,'1']); //kt 7/10/10 Specifying a NETWORK LOCATION is depreciated.
846 CallV('TMG DOWNLOAD FILE', [FPath,FName]);
847 Application.ProcessMessages;
848 RefreshCountdown := RefreshInterval;
849 //Note:RPCBrokerV.Results[0]=1 if successful load, =0 if failure
850 if (RPCBrokerV.Results.Count>0) and (RPCBrokerV.Results[0]='1') then begin
851 OutFile := TFileStream.Create(LocalSaveFNamePath,fmCreate);
852 for i:=1 to (RPCBrokerV.Results.Count-1) do begin
853 s :=Decode(RPCBrokerV.Results[i]);
854 count := Length(s);
855 if count>1024 then begin
856 Result := false; //failure of load.
857 break;
858 end;
859 for j := 1 to count do Buffer[j-1] := ord(s[j]);
860 OutFile.Write(Buffer,count);
861 Dec(RefreshCountdown);
862 if RefreshCountdown < 1 then begin
863 Application.ProcessMessages;
864 RefreshCountdown := RefreshInterval;
865 end;
866 end;
867 OutFile.Free;
868 end else begin
869 result := false;
870 end;
871 StatusText('');
872end;
873
874
875function TfrmImages.Encode(Input: AnsiString) : AnsiString;
876//This function is based on ENCODE^RGUTUU, which is match for
877//DECODE^RGUTUU that is used to decode (ascii armouring) on the
878//server side. This is a base64 encoder.
879const
880 //FYI character set is 64 characters (starting as 'A')
881 // (65 characters if intro '=' is counted)
882 CharSet = '=ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
883var
884 //Result : AnsiString; // RGZ1 //'Result' is implicitly declared by Pascal
885
886 i : integer; //RGZ2
887 j : integer; //RGZ4
888 PlainTrio : longword; //RGZ3 //unsigned 32-bit
889 EncodedByte : Byte;
890 PlainByte : byte; //RGZ5
891 EncodedQuad : string[4];//RGZ6
892
893begin
894 //e.g. input (10 bytes):
895 // 174 231 193 16 29 251 93 138 4 57
896 // AE E7 C1 10 1D FB 5D 8A 04 39
897 Result := '';
898 i := 1;
899 while i<= Length(Input) do begin //cycle in groups of 3
900 PlainTrio := 0;
901 EncodedQuad := '';
902 //Get 3 bytes, to be converted into 4 characters eventually.
903 //Fill with 0's if needed to make an even 3-byte group.
904 For j:=0 to 2 do begin
905 //e.g. '174'->PlainByte=174
906 if (i+j) <= Length(Input) then PlainByte := ord(Input[i+j])
907 else PlainByte := 0;
908 PlainTrio := (PlainTrio shl 8) or PlainByte;
909 end;
910 //e.g. first 3 bytes--> PlainTrio= $AEE7C1 (10101110 11100111 11000001)
911 //e.g. last 3 bytes--> PlainTrio= $390000 (00111001 00000000 00000000) (note padded 0's)
912
913 //Take each 6 bits and convert into a character.
914 //e.g. first 3 bytes--> (101011 101110 011111 000001)
915 // 43 46 31 1
916
917 //e.g. last 3 bytes-->(001110 010000 000000 000000) (after redivision)
918 // 14 16 0 0 <-- last 2 bytes are padded 0
919 // ^ last 4 bits of '16' are padded 0's
920 For j := 1 to 4 do begin
921 //e.g. $AEE7C1 --> (43+2)=45 (46+2)=48 (31+2)=33 (1+2)=3
922 // r u f b
923
924 //e.g. $39AF00 --> (14+2)=16 (16+2)=18 (0+2)=2 (0+2)=2
925 // O Q A A <-- 2 padded bytes
926 EncodedByte := (PlainTrio and 63)+2; //63=$3F=b0111111; 0->A 1->B etc
927 EncodedQuad := CharSet[EncodedByte]+ EncodedQuad; //string Concat, not math add
928 PlainTrio := PlainTrio shr 6
929 end;
930
931 //Append result with latest quad
932 Result := Result + EncodedQuad;
933 Inc(i,3);
934 end;
935
936 // e.g. result: rufb .... .... OQAA <-- 2 padded bytes (and part of Q is padded also)
937 i := 3-(Length(Input) mod 3); //returns 1,2,or 3 (3 needs to be set to 0)
938 if (i=3) then i:=0; //e.g. input=10 -> i=2
939 j := Length(Result);
940 //i is the number of padded characters that need to be replaced with '='
941 if i>=1 then Result[j] := '='; //replace 1st paddeded char
942 if i>=2 then Result[Length(Result)-1] := '=';//replace 2nd paddeded char
943 // e.g. result: rufb .... .... OQ==
944
945 //results passed out in Result
946end;
947
948
949function TfrmImages.Decode(Input: AnsiString) : AnsiString;
950//This function is based on DECODE^RGUTUU, which is match for
951//ENCODE^RGUTUU that is used to encode (ascii armouring) on the
952//server side. This is a Base64 decoder
953const
954 //FYI character set is 64 characters (starting as 'A')
955 // (65 characters if intro '=' is counted)
956 CharSet = '=ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
957
958var
959 //Result : AnsiString; //RGZ1 //'Result' is implicitly declared by Pascal
960 i : integer; //RGZ2
961 PlainTrio : longword; //RGZ3 //unsigned 32-bit
962 j : integer; //RGZ4
963 EncodedChar : char;
964 PlainInt : integer;
965 PlainByte : byte; //RGZ5
966 DecodedTrio : string[3];//RGZ6
967
968begin
969 Result:='';
970 i := 1;
971 //e.g. input: rufb .... .... OQ==
972
973 while i <= Length(Input) Do begin //cycle in groups of 4
974 PlainTrio :=0;
975 DecodedTrio :='';
976 //Get 4 characters, to be converted into 3 bytes.
977 For j :=0 to 3 do begin
978 //e.g. last 4 chars --> 0A==
979 if (i+j) <= Length(Input) then begin
980 EncodedChar := Input[i+j];
981 PlainInt := Pos(EncodedChar,CharSet)-2; //A=0, B=1 etc.
982 if (PlainInt>=0) then PlainByte := (PlainInt and $FF) else PlainByte := 0;
983 end else PlainByte := 0;
984 //e.g. with last 4 characters:
985 //e.g. '0'->14=(b001110) 'Q'->16=(b010000) '='-> -1 -> 0=(b000000) '=' -> 0=(b000000)
986 //e.g.-- So last PlainTrio = 001110 010000 000000 000000 = 00111001 00000000 00000000
987 //Each encoded character contributes 6 bytes to final 3 bytes.
988 //4 chars * 6 bits/char=24 bits --> 24 bits / 8 bits/byte = 3 bytes
989 PlainTrio := (PlainTrio shl 6) or PlainByte; //PlainTrio := PlainTrio*64 + PlainByte;
990 end;
991 //Now take 3 bytes, and add to cumulative output (in same order)
992 For j :=0 to 2 do begin
993 DecodedTrio := Chr(PlainTrio and $FF) + DecodedTrio; //string concat (not math addition)
994 PlainTrio := PlainTrio shr 8; // PlainTrio := PlainTrio div 256
995 end;
996 //e.g. final DecodedTrio = 'chr($39) + chr(0) + chr(0)'
997 Result := Result + DecodedTrio;
998 Inc(i,4);
999 end;
1000
1001 //Now remove 1 byte from the output for each '=' in input string
1002 //(each '=' represents 1 padded 0 added to allow for even groups of 3)
1003 for j :=0 to 1 do begin
1004 if (Input[Length(Input)-j] = '=') then begin
1005 Result := MidStr(Result,1,Length(Result)-1);
1006 end;
1007 end;
1008end;
1009
1010procedure TfrmImages.NewNoteSelected(EditIsActive : boolean);
1011//Will be called by fNotes when a new note has been selected.
1012//var
1013begin
1014 ClearTabPages();
1015 DownloadImagesInBackground := true;
1016 SetupTimer;
1017 //This will start downloading images after few second delay (so that if
1018 //user is just browsing past note, this won't waste effort.
1019 //If user selects images tab, then load will occur without delay.
1020 //Note: OnTimer calls timLoadImagesTimer()
1021 FEditIsActive := EditIsActive;
1022 UploadImagesButton.Enabled := EditIsActive;
1023 UploadImagesMnuAction.Enabled := EditIsActive;
1024 WebBrowser.Navigate(NullImageName);
1025end;
1026
1027
1028procedure TfrmImages.EmptyCache();
1029//This will delete ALL files in the Cache directory
1030//Note: This will include the html_note file created by
1031// the notes tab.
1032var
1033 //CacheDir : AnsiString;
1034 FoundFile : boolean;
1035 FSearch : TSearchRec;
1036 Files : TStringList;
1037 i : integer;
1038 FName : AnsiString;
1039
1040begin
1041 Files := TStringList.Create;
1042// CacheDir := ExtractFilePath(ParamStr(0))+ 'Cache';
1043 FoundFile := (FindFirst(CacheDir+'\*.*',faAnyFile,FSearch)=0);
1044 while FoundFile do Begin
1045 FName := FSearch.Name;
1046 if (FName <> '.') and (FName <> '..') then begin
1047 FName := CacheDir + '\' + FName;
1048 Files.Add(FName);
1049 end;
1050 FoundFile := (FindNext(FSearch)=0);
1051 end;
1052
1053 for i := 0 to Files.Count-1 do begin
1054 FName := Files.Strings[i];
1055 if DeleteFile(FName) = false then begin
1056 //kt raise Exception.Create('Unable to delete file: '+FSearch.Name+#13+'Will try again later...');
1057 end;
1058 end;
1059 Files.Free;
1060end;
1061
1062
1063
1064procedure TfrmImages.UploadImagesButtonClick(Sender: TObject);
1065var
1066 Node: TORTreeNode;
1067 AddResult : TModalResult;
1068begin
1069 inherited;
1070 AddResult := UploadForm.ShowModal;
1071 if not IsAbortResult(AddResult) then begin
1072 NewNoteSelected(true); //force a reload to show recently added image.
1073 timLoadImages.Interval := IMAGE_DOWNLOAD_DELAY_FOREGROUND;
1074 Node := TORTreeNode(frmNotes.tvNotes.Selected);
1075 case Node.StateIndex of
1076 IMG_NO_IMAGES : Node.StateIndex := IMG_1_IMAGE;
1077 IMG_1_IMAGE : Node.StateIndex := IMG_2_IMAGES;
1078 IMG_2_IMAGES : Node.StateIndex := IMG_MANY_IMAGES;
1079 IMG_MANY_IMAGES : Node.StateIndex := IMG_MANY_IMAGES;
1080 end;
1081 end;
1082end;
1083
1084procedure TfrmImages.FormHide(Sender: TObject);
1085begin
1086 inherited;
1087 DownloadImagesInBackground := true;
1088
1089// Application.MessageBox('Here I can hide images.','title');
1090end;
1091
1092procedure TfrmImages.TabControlChange(Sender: TObject);
1093var
1094 FileName : AnsiString;
1095 Rec : TImageInfo;
1096 Selected : integer;
1097begin
1098 inherited;
1099 //here tab has been changed.
1100 Selected := TabControl.TabIndex;
1101 if Selected > -1 then begin
1102 Rec := TImageInfo(ImageInfoList[Selected]);
1103 FileName := Rec.CacheFName;
1104 UpdateImageInfoMemo(Rec);
1105 end else begin
1106 FileName := NullImageName;
1107 UpdateImageInfoMemo(nil);
1108 end;
1109 WebBrowser.Navigate(FileName);
1110end;
1111
1112procedure TfrmImages.TabControlGetImageIndex(Sender: TObject;
1113 TabIndex: Integer;
1114 var ImageIndex: Integer);
1115//specify which image to display, from ThumbsImageList
1116begin
1117 inherited;
1118 if (ImageInfoList <> nil) and (TabIndex < ImageInfoList.Count) then begin
1119 ImageIndex := TImageInfo(ImageInfoList[TabIndex]).TabImageIndex;
1120 end else ImageIndex := 0;
1121end;
1122
1123procedure TfrmImages.TabControlResize(Sender: TObject);
1124begin
1125 inherited;
1126 if TabControl.Width < 80 then begin
1127 TabControl.Width := 80;
1128 end;
1129end;
1130
1131function TfrmImages.CreateBarcode(MsgStr: AnsiString; ImageType: AnsiString): AnsiString;
1132//Create a local barcode file, in .png format, from MsgStr
1133//ImageType is optional, default ='png'. It should NOT contain '.'
1134//Returns file path on local client of new barcode image.
1135//Note: this function is not related to uploading or downloading images
1136// to the server for attaching to progress notes. It is included
1137// in this unit because the functionality used is nearly identical to
1138// the other code.
1139 function UniqueFName : AnsiString;
1140 var FName,tempFName : AnsiString;
1141 count : integer;
1142 begin
1143 FName := 'Barcode-Image';
1144 count := 0;
1145 repeat
1146 tempFName := CacheDir + '\' + FName + '.' + ImageType;
1147 FName := FName + '1';
1148 count := count+1;
1149 until (fileExists(tempFName)=false) or (count> 32);
1150 result := tempFName;
1151 end;
1152
1153var
1154 i,count : integer;
1155 j : word;
1156 OutFile : TFileStream;
1157 s : AnsiString;
1158 Buffer : array[0..1024] of byte;
1159 LocalSaveFNamePath : AnsiString;
1160
1161begin
1162 StatusText('Getting Barcode...');
1163 LocalSaveFNamePath := UniqueFName;
1164 Result := LocalSaveFNamePath; //default to success;
1165
1166 // CallV('TMG BARCODE ENCODE', [MsgStr]);
1167 RPCBrokerV.ClearParameters := true;
1168 RPCBrokerV.remoteprocedure := 'TMG BARCODE ENCODE';
1169 RPCBrokerV.param[0].Value := MsgStr;
1170 RPCBrokerV.param[0].PType := literal;
1171 RPCBrokerV.Param[1].Value := '.X'; //<-- is this needed or used?
1172 RPCBrokerV.Param[1].PType := list;
1173 RPCBrokerV.Param[1].Mult['"IMAGE TYPE"'] := ImageType;
1174 //RPCBrokerV.Call;
1175 CallBroker;
1176
1177 Application.ProcessMessages;
1178 //Note:RPCBrokerV.Results[0]=1 if successful load, =0 if failure
1179 if (RPCBrokerV.Results.Count>0) and (RPCBrokerV.Results[0]='1') then begin
1180 OutFile := TFileStream.Create(LocalSaveFNamePath,fmCreate);
1181 for i:=1 to (RPCBrokerV.Results.Count-1) do begin
1182 s :=Decode(RPCBrokerV.Results[i]);
1183 count := Length(s);
1184 if count>1024 then begin
1185 Result := ''; //failure of load.
1186 break;
1187 end;
1188 for j := 1 to count do Buffer[j-1] := ord(s[j]);
1189 OutFile.Write(Buffer,count);
1190 end;
1191 OutFile.Free;
1192 end else begin
1193 result := '';
1194 end;
1195 StatusText('');
1196end;
1197
1198
1199function TfrmImages.DecodeBarcode(LocalFNamePath,ImageType: AnsiString): AnsiString;
1200//Decode data from barcode on image, or return '' if none
1201//Note: if I could find a cost-effective way of decoding this on client side,
1202// then that code be done here in the function, instead of uploading image
1203// to the server for decoding.
1204const
1205 RefreshInterval = 500;
1206 BlockSize = 512;
1207
1208var
1209 ReadCount : Word;
1210 ParamIndex : LongWord;
1211 j : word;
1212 InFile : TFileStream;
1213 Buffer : array[0..1024] of byte;
1214 RefreshCountdown : integer;
1215 OneLine : AnsiString;
1216 RPCResult : AnsiString;
1217 SavedCursor : TCursor;
1218 totalReadCount : integer;
1219begin
1220 result := ''; //default of failure
1221 if not FileExists(LocalFNamePath) then exit;
1222 try
1223 InFile := TFileStream.Create(LocalFNamePath,fmOpenRead or fmShareCompat);
1224 //Note: I may well cut this out. Most of the delay occurs during
1225 // the RPC call, and I can't make a progress bar change during that...
1226 // (or I could, but I'm not going to change the RPC broker...)
1227 ImageTransferForm.setMax(InFile.Size);
1228 //ImageTransferForm.ResetStartTime;
1229 ImageTransferForm.ProgressMsg.Caption := 'Preparing to upload...';
1230 ImageTransferForm.Show;
1231 totalReadCount := 0;
1232 except
1233 // catch failure here... on eError...
1234 exit;
1235 end;
1236
1237 StatusText('Checking image for barcodes...');
1238 Application.ProcessMessages;
1239
1240 RPCBrokerV.ClearParameters := true;
1241 RPCBrokerV.Param.Clear;
1242 RPCBrokerV.Param[0].PType := list;
1243 ParamIndex := 0;
1244 RefreshCountdown := RefreshInterval;
1245 //Put image data into parameter 0 (ARRAY parameter of RPC on server side)
1246 repeat
1247 ReadCount := InFile.Read(Buffer,BlockSize);
1248 OneLine := '';
1249 totalReadCount := totalReadCount + ReadCount;
1250 ImageTransferForm.updateProgress(totalReadCount);
1251 if ReadCount > 0 then begin
1252 SetLength(OneLine,ReadCount);
1253 for j := 1 to ReadCount do OneLine[j] := char(Buffer[j-1]);
1254 RPCBrokerV.Param[0].Mult[IntToStr(ParamIndex)] := Encode(OneLine);
1255 Inc(ParamIndex);
1256 Dec(RefreshCountdown);
1257 if RefreshCountdown < 1 then begin
1258 Application.ProcessMessages;
1259 RefreshCountdown := RefreshInterval;
1260 end;
1261 end;
1262 until (ReadCount < BlockSize);
1263 RPCBrokerV.Param[1].PType := literal;
1264 RPCBrokerV.Param[1].Value := ImageType;
1265
1266 RPCBrokerV.remoteprocedure := 'TMG BARCODE DECODE';
1267
1268 SavedCursor := Screen.Cursor;
1269 Screen.Cursor := crHourGlass;
1270 ImageTransferForm.ProgressMsg.Caption := 'Uploading file to server...';
1271 Application.ProcessMessages;
1272
1273 CallBroker; //this is the slow step, pass to server and get response.
1274
1275 Screen.Cursor := SavedCursor;
1276 ImageTransferForm.Hide;
1277 //Get result: 1^DecodedMessage, or 0^Error Message
1278 RPCResult := RPCBrokerV.Results[0];
1279 if Piece(RPCResult,'^',1)='0' then begin
1280 MessageDlg(Piece(RPCResult,'^',2),mtError,[mbOK],0);
1281 end else begin
1282 result := Piece(RPCResult,'^',2);
1283 end;
1284
1285 InFile.Free;
1286 StatusText('');
1287end;
1288
1289
1290procedure TfrmImages.EnableAutoScanUploadClick(Sender: TObject);
1291begin
1292 inherited;
1293 AutoScanUpload.Checked := not AutoScanUpload.Checked;
1294 uTMGOptions.WriteBool('Scan Enabled',AutoScanUpload.Checked);
1295end;
1296
1297
1298procedure TfrmImages.PickScanFolderClick(Sender: TObject);
1299var
1300 CurScanDir : string;
1301begin
1302 inherited;
1303 CurScanDir := UploadForm.ScanDir;
1304 OpenDialog.InitialDir := CurScanDir;
1305 MessageDlg('Please pick ANY file in the desired directory.',mtInformation,[mbOK],0);
1306 if OpenDialog.Execute then begin
1307 UploadForm.SetScanDir(ExtractFilePath(OpenDialog.FileName));
1308 end;
1309 AutoScanUpload.Checked := true;
1310end;
1311
1312function TfrmImages.FileSize(fileName : wideString) : Int64;
1313var
1314 sr : TSearchRec;
1315begin
1316 if FindFirst(fileName, faAnyFile, sr ) = 0 then
1317 result := Int64(sr.FindData.nFileSizeHigh) shl Int64(32) + Int64(sr.FindData.nFileSizeLow)
1318 else
1319 result := -1;
1320
1321 FindClose(sr) ;
1322end;
1323
1324function TfrmImages.GetImagesCount : integer;
1325//Returns number of images possible, not just those already downloaded.
1326begin
1327 EnsureImageListLoaded();
1328 Result := NumImagesAvailableOnServer;
1329end;
1330
1331function TfrmImages.GetImageInfo(Index : integer) : TImageInfo;
1332begin
1333 if (Index > -1) and (Index < ImageInfoList.Count) then begin
1334 Result := TImageInfo(ImageInfoList[Index]);
1335 end else begin
1336 Result := nil;
1337 end;
1338end;
1339
1340
1341
1342procedure TfrmImages.TabControlMouseUp(Sender: TObject; Button: TMouseButton;
1343 Shift: TShiftState; X, Y: Integer);
1344//kt add 7/6/10
1345var TabIndex : integer;
1346 P : TPoint;
1347begin
1348 inherited;
1349 if Button <> mbRight then exit;
1350 TabIndex := TabControl.IndexOfTabAt(X,Y);
1351 if TabIndex < 0 then exit;
1352 FDeleteImageIndex := TabIndex;
1353 P.X := X; P.Y := Y;
1354 P := TabControl.ClientToScreen(P);
1355 TabControl.PopupMenu := mnuPopup;
1356 mnuPopup.Popup(P.X, P.Y);
1357 TabControl.PopupMenu := nil;
1358end;
1359
1360procedure TfrmImages.mnuPopupPopup(Sender: TObject);
1361//Determine here if delete option should be enabled.
1362begin
1363 inherited;
1364 mnuPopDeleteImage.Enabled := CanDeleteImages;
1365end;
1366
1367function TfrmImages.CanDeleteImages : boolean;
1368//Determine here if image can be deleted.
1369var
1370 ActionSts: TActionRec;
1371const
1372 ATTACHED_IMAGES_SERVER_REPLY = 'You must "delete" the Images using the Imaging package before proceeding.';
1373begin
1374 FImageDeleteMode := idmNone;
1375 Result := false; //default action
1376 if FEditIsActive then begin
1377 Result := true;
1378 FImageDeleteMode := idmDelete;
1379 exit;
1380 end;
1381 //Will use same user class managment rules for images as for notes.
1382 //So if user can delete a note, then they can also delete images.
1383 ActOnDocument(ActionSts, frmNotes.lstNotes.ItemIEN, 'DELETE RECORD');
1384 if (ActionSts.Success = false) then begin
1385 if Pos(ATTACHED_IMAGES_SERVER_REPLY, ActionSts.Reason) > 0 then ActionSts.Success := true;
1386 end;
1387 Result := ActionSts.Success;
1388 if Result then begin
1389 if AuthorSignedDocument(frmNotes.lstNotes.ItemIEN) then FImageDeleteMode := idmRetract
1390 else FImageDeleteMode := idmDelete;
1391 end;
1392end;
1393
1394procedure TfrmImages.mnuPopDeleteImageClick(Sender: TObject);
1395begin
1396 inherited;
1397 DeleteImageIndex(FDeleteImageIndex, FImageDeleteMode, True);
1398end;
1399
1400procedure TfrmImages.DeleteAll(DeleteMode: TImgDelMode);
1401begin
1402 EnsureALLImagesDownloaded;
1403 while TabControl.Tabs.Count > 0 do begin
1404 DeleteImageIndex(0,DeleteMode,False);
1405 NewNoteSelected(False);
1406 EnsureALLImagesDownloaded;
1407 frmImages.Formshow(self);
1408 end;
1409end;
1410
1411
1412procedure TfrmImages.DeleteImageIndex(ImageIndex : integer; DeleteMode : TImgDelMode; boolPromptUser: boolean);
1413//Note: permissions must be checked before running this function
1414var
1415 ImageInfo : TImageInfo;
1416 ReasonForDelete : string;
1417 DeleteSts : TActionRec;
1418
1419CONST
1420 TMG_PRIVACY = 'FOR PRIVACY'; //Server message (don't translate)
1421 TMG_ADMIN = 'ADMINISTRATIVE'; //Server message (don't translate)
1422
1423begin
1424 if (ImageIndex<0) or (ImageIndex>=ImagesCount) then begin
1425 MessageDlg('Invalid image index to delete: '+IntToStr(ImageIndex), mtError,[mbOK],0);
1426 exit;
1427 end;
1428 ImageInfo := Self.ImageInfo[ImageIndex];
1429 if boolPromptUser then begin
1430 ReasonForDelete := SelectDeleteReason(frmNotes.lstNotes.ItemIEN);
1431 if ReasonForDelete = DR_CANCEL then Exit;
1432 if ReasonForDelete = DR_PRIVACY then begin
1433 ReasonForDelete := TMG_PRIVACY;
1434 end else if ReasonForDelete = DR_ADMIN then begin
1435 ReasonForDelete := TMG_ADMIN;
1436 end;
1437 end else begin
1438 ReasonForDelete := 'DeleteAll';
1439 end;
1440
1441 DeleteImage(DeleteSts, ImageInfo.ServerFName, ImageInfo.IEN, frmNotes.lstNotes.ItemIEN, DeleteMode, ReasonForDelete);
1442end;
1443
1444procedure TfrmImages.DeleteImage(var DeleteSts: TActionRec;
1445 ImageFileName: String;
1446 ImageIEN, DocIEN: Integer;
1447 DeleteMode : TImgDelMode;
1448 const Reason: string); //Reason should be 10-60 chars;
1449
1450 function ServerImageDelete(ImageIEN:integer; DeleteMode:tImgDelMode; Reason:String) : boolean;
1451 //Returns success
1452 var RPCResult,IEN,Mode : string;
1453 begin
1454 IEN := IntToStr(ImageIEN);
1455 Mode := IntToStr(Ord(DeleteMode));
1456 RPCResult := sCallV('TMG IMAGE DELETE', [IEN,Mode,Reason]);
1457 Result := Piece(RPCResult,'^',1)= '1';
1458 if Result = false then begin
1459 MessageDlg(Piece(RPCResult,'^',2),mtError,[mbOK],0);
1460 end;
1461 end;
1462
1463 procedure NoteImageDelete(DocIEN:integer; FileName: string; DeleteMode:tImgDelMode; Reason:String);
1464 var
1465 NoteText, tempString: string;
1466 Beginning, Ending: integer;
1467 boolFound: boolean;
1468 // <!-- Retracted By: UserName on Date ...;.. -->
1469 // FEditIsActive
1470 begin
1471 if FEditIsActive then begin
1472 Ending := 1;
1473 Beginning := 1;
1474 boolFound := False;
1475 While (boolFound = False) AND (Beginning > 0) Do Begin
1476 NoteText := frmNotes.HtmlEditor.HTMLText;
1477 Beginning := PosEx('<IMG',NoteText, Ending);
1478 Ending := PosEx('>', NoteText, Beginning) + 1;
1479 tempString := MidStr(NoteText, Beginning, Ending-Beginning);
1480 if pos(FileName,tempString) > 0 then boolFound := True;
1481 end;
1482 if boolFound = false then begin
1483 Ending := 1;
1484 Beginning := 1;
1485 boolFound := False;
1486 While (boolFound = False) AND (Beginning > 0) Do Begin
1487 NoteText := frmNotes.HtmlEditor.HTMLText;
1488 Beginning := PosEx('<embed',NoteText, Ending);
1489 Ending := PosEx('>', NoteText, Beginning) + 1;
1490 tempString := MidStr(NoteText, Beginning, Ending-Beginning);
1491 if pos(FileName,tempString) > 0 then boolFound := True;
1492 end;
1493 end;
1494 if boolFound = False then exit;
1495 if DeleteMode = idmDelete then begin
1496 frmnotes.HtmlEditor.HTMLText := AnsiReplaceStr(frmNotes.HtmlEditor.HTMLText, tempString, '');
1497 end else if DeleteMode = idmRetract then begin
1498 frmnotes.HtmlEditor.HTMLText := AnsiReplaceStr(frmNotes.HtmlEditor.HTMLText, tempString, ' <!-- ' + tempString + ' Retracted By: ' + User.Name + ' on ' + DateToStr(Now));
1499 end;
1500 //ClearImageList;
1501 //EmptyCache;
1502 //frmImages.FormHide(self);
1503 //LastDisplayedTIUIEN := '0';
1504 //frmImages.Formshow(self);
1505 NewNoteSelected(True);
1506 frmImages.Formshow(self);
1507 end else begin
1508 //NewNoteSelected(True);
1509 //frmImages.Formshow(self);
1510 end;
1511 end;
1512
1513begin
1514 //'Permanently delete attached image or file?'
1515 //Create dialog that gives option to export before deleting?
1516 //"You are about to permanently delete this image. Would you like to export before deletion? Yes/No/Cancel
1517 //Yes = export dialog then delete (if export is later cancelled assume cancel was pressed here), No=Only Delete, Cancel = No deletion
1518 if Reason <> 'DeleteAll' then begin
1519 if MessageDlg(DKLangConstW('fImages_ConfirmDelete'),mtConfirmation,mbOKCancel,0) <> mrOK then exit;
1520 end;
1521 if ServerImageDelete(ImageIEN,DeleteMode,Reason) = false then exit;
1522 NoteImageDelete(DocIEN,ImageFileName,DeleteMode,Reason);
1523 if DeleteMode = idmRetract then begin
1524 InfoBox(DKLangConstW('fImages_Retract_1')+CRLF + // 'This image or file will now be RETRACTED. As such, it has been'
1525 DKLangConstW('fImages_Retract_2')+CRLF + // 'removed from public view, and from typical Releases of Information,'
1526 DKLangConstW('fImages_Retract_2'), // ' but will remain indefinitely discoverable to HIMS.' +CRLF +CRLF;
1527 DKLangConstW('fImages_Retraction_Notice'),MB_OK);
1528 end;
1529end;
1530
1531
1532procedure TfrmImages.mnuDeleteImageClick(Sender: TObject);
1533var
1534 SelectedImageTab,i : integer;
1535 ImageInfo : TImageInfo;
1536begin
1537 inherited;
1538 If TabControl.Tabs.Count < 1 then exit;
1539 frmImagePickExisting := TfrmImagePickExisting.Create(Self);
1540 if frmImagePickExisting.ShowModal = mrOK then begin
1541 //ImageFName := frmImagePickExisting.SelectedImageFName;
1542 if not assigned(frmImagePickExisting.SelectedImageInfo) then exit;
1543 for i := 0 to TabControl.Tabs.Count - 1 do begin
1544 ImageInfo := Self.ImageInfo[i];
1545 if frmImagePickExisting.SelectedImageInfo.ServerFName = ImageInfo.ServerFName then begin
1546 SelectedImageTab := i;
1547 end;
1548 end;
1549 if frmNotes.HTMLEditor.Active then begin
1550 FEditIsActive := true;
1551 DeleteImageIndex(SelectedImageTab,idmDelete,True);
1552 end else begin
1553 FEditIsActive := false;
1554 DeleteImageIndex(SelectedImageTab,idmRetract,True);
1555 end;
1556 NewNoteSelected(False);
1557 EnsureALLImagesDownloaded;
1558 frmImages.Formshow(self);
1559 end;
1560 FreeAndNil(frmImagePickExisting);
1561end;
1562
1563initialization
1564 //put init code here
1565
1566finalization
1567 //put finalization code here
1568
1569end.
1570
Note: See TracBrowser for help on using the repository browser.