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

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

Bug fixes. Improved Adding Image
File size: 52.3 KB
Line 
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 uCore,
10 SHDocVw, DKLang;
11
12type
13
14 TImageInfo = class
15 private
16 public
17 TIUIEN : int64; //IEN in file# 8925
18 DFN : AnsiString; //IEN in Patient File (#2)
19 UploadDUZ : int64; //IEN in NEW PERSON file
20 ThumbFPathName : AnsiString; // local file path name
21 ImageFPathName : AnsiString; // local file path name
22 ServerPath : AnsiString;
23 ServerFName : AnsiString;
24 ServerThumbFName: AnsiString;
25 ShortDesc : String[60];
26 Extension : String[16];
27 ImageDateTime : AnsiString;
28 UploadDateTime: AnsiString;
29 ObjectType : int64; //pointer to file 2005.02
30 ProcName : String[10]; //server limit is 10 chars.
31 pLongDesc : TStrings; //Won't be owned by this list
32 procedure Assign(Source : TImageInfo);
33 procedure Clear;
34 end;
35
36 TAutoUploadNote = class
37 private
38 public
39 TIUIEN : int64; //IEN in file# 8925
40 ErrMsg : AnsiString;
41 NoteTitle : AnsiString; //Title of note to be associated with image
42 Patient : TPatient;
43 ImageInfo : TImageInfo;
44 Location : AnsiString; //Location that image if from
45 DOS : AnsiString; //Date of service
46 Provider : AnsiString;
47 CurNoteImages: TStringList;
48 UploadError : Boolean;
49 procedure SetDFN(var ChartNum,Location,FName,LName,MName,DOB,Sex : string);
50 Procedure SetInfo(var DOS,Provider,Location,Title : string);
51 function SameAs(OtherNote: TAutoUploadNote): boolean;
52 procedure MakeNewBlankNote(DFN,DOS,Provider,Location,Title : string);
53 procedure InitFrom(OtherNote: TAutoUploadNote);
54 function IsValid : boolean;
55 procedure Clear;
56 constructor Create();
57 destructor Destroy; override;
58 end;
59
60type
61 TUploadForm = class(TForm)
62 OpenFileDialog: TOpenDialog;
63 Image1: TImage;
64 PickImagesButton: TBitBtn;
65 Label1: TLabel;
66 CancelButton: TBitBtn;
67 UploadButton: TBitBtn;
68 Label2: TLabel;
69 Label4: TLabel;
70 ShortDescEdit: TEdit;
71 LongDescMemo: TMemo;
72 Label3: TLabel;
73 Label5: TLabel;
74 DateTimeEdit: TEdit;
75 ClearImagesButton: TBitBtn;
76 OpenDialog: TOpenPictureDialog;
77 FilesToUploadList: TListBox;
78 NoteEdit: TEdit;
79 PickOtherButton: TBitBtn;
80 pnlIEHolder: TPanel;
81 WebBrowser: TWebBrowser;
82 Label6: TLabel;
83 MoveCheckBox: TCheckBox;
84 PolTimer: TTimer;
85 DKLanguageController1: TDKLanguageController;
86 btnPickPDF: TBitBtn;
87 procedure UploadButtonClick(Sender: TObject);
88 procedure PickImagesButtonClick(Sender: TObject);
89 procedure FormShow(Sender: TObject);
90 procedure ShortDescEditChange(Sender: TObject);
91 procedure ClearImagesButtonClick(Sender: TObject);
92 procedure FormCreate(Sender: TObject);
93 procedure FormDestroy(Sender: TObject);
94 procedure FilesToUploadListClick(Sender: TObject);
95 procedure PickOtherButtonClick(Sender: TObject);
96 procedure FormRefresh(Sender: TObject);
97 procedure PolTimerTimer(Sender: TObject);
98 procedure btnPickPDFClick(Sender: TObject);
99 procedure FormHide(Sender: TObject);
100 private
101 { Private declarations }
102 Bitmap : TBitmap;
103 Picture : TPicture;
104 FAllowNonImages : boolean;
105 FUploadedImagesList : TStringList; //List of strings of images succesfully uploaded.
106 function MakeThumbNail(Info: TImageInfo): boolean;
107
108 procedure LoadNotesEdit();
109 //procedure LoadNotesList();
110 function UploadFile(Info: TImageInfo; DelOrig : boolean): boolean;
111 function CopyFileToTemp(FNamePath : string) : string;
112 procedure UploadChosenFiles();
113 function ProcessOneLine(Line : string) : string;
114 function ProcessOneFile(FileName : string) : boolean;
115 procedure ScanAndHandleImgTxt;
116 procedure ScanAndHandleImages;
117 procedure DecodeImgTxt(Line : string; out ChartNum, Location,
118 FName, LName, MName, Sex, DOB, DOS, Provider,
119 Title : string; FilePaths : TStrings);
120 function EncodeImgTxt(ChartNum, Location, FName, LName, MName, Sex, DOB,
121 DOS, Provider, Title : string; FilePaths : TStrings) : AnsiString;
122 procedure FinishDocument(UploadNote : TAutoUploadNote);
123 procedure SetAllowNonImages(Value : boolean);
124 public
125 { Public declarations }
126 FScanDir : String;
127 PolInterval : integer;
128 procedure SetScanDir(NewDir : string);
129 published
130 property ScanDir : String read FScanDir write SetScanDir;
131 property UploadedImages : TStringList read FUploadedImagesList;
132 property AllowNonImages : boolean read FAllowNonImages write SetAllowNonImages;
133 end;
134
135var
136 UploadForm: TUploadForm;
137
138implementation
139
140{$R *.dfm}
141
142 uses fNotes,
143 StrUtils, //for MidStr etc.
144 ORFn, //for PIECE etc.
145 Trpcb, //for .PType enum
146 fImages, //for upload/download files etc.
147 //Targa, //for TGA graphic save
148 ORNet, //for RPCBrokerV
149 rTIU,
150 rHTMLTools,
151 fImagePickPDF, //for PDF picker dialog
152 uTMGOptions
153 ;
154
155// const
156// DefShortDesc = '(Short Image Description)'; <-- original line. //kt 8/7/2007
157
158 type
159 TFileInfo = class
160 private
161 public
162 SrcRec : TSearchRec;
163 STimeStamp : String;
164 SBarCode : String;
165 FPath : String;
166 MetaFileName : String;
167 MetaFileExists : boolean;
168 BatchCount : integer;
169 procedure Assign(Source: TFileInfo);
170 procedure Clear;
171 end;
172
173 var
174 DefShortDesc : string; //kt
175 AutoUploadNote : TAutoUploadNote;
176
177
178 procedure SetupVars;
179 begin
180 DefShortDesc := DKLangConstW('UploadImages_xShort_Image_Descriptionx'); //kt added 8/7/2007
181 end;
182
183 //-------------------------------------------------------------------------
184 //-------------------------------------------------------------------------
185
186 function NumPieces(const s: string; ADelim : Char) : integer;
187 var List : TStringList;
188 begin
189 List := TStringList.Create;
190 PiecesToList(S, ADelim, List);
191 Result := List.Count;
192 end;
193
194 //-------------------------------------------------------------------------
195 //-------------------------------------------------------------------------
196 procedure TFileInfo.Assign(Source: TFileInfo);
197 begin
198 SrcRec := Source.SrcRec;
199 STimeStamp := Source.STimeStamp;
200 SBarCode := Source.SBarCode;
201 FPath := Source.FPath;
202 BatchCount := Source.BatchCount;
203 MetaFileName := Source.MetaFileName;
204 MetaFileExists := Source.MetaFileExists;
205 end;
206
207 procedure TFileInfo.Clear;
208 begin
209 //SrcRec := ... //Note sure how to clear this. Will leave as is...
210 STimeStamp := '';
211 SBarCode := '';
212 FPath := '';
213 BatchCount := 0;
214 MetaFileName := '';
215 MetaFileExists := false;
216 end;
217
218 //-------------------------------------------------------------------------
219 //-------------------------------------------------------------------------
220 procedure TImageInfo.Assign(Source : TImageInfo);
221 begin
222 TIUIEN := Source.TIUIEN;
223 DFN := Source.DFN;
224 UploadDUZ := Source.UploadDUZ;
225 ThumbFPathName := Source.ThumbFPathName;
226 ImageFPathName := Source.ImageFPathName;
227 ServerPath := Source.ServerPath;
228 ServerFName := Source.ServerFName;
229 ServerThumbFName := Source.ServerThumbFName;
230 ShortDesc := Source.ShortDesc;
231 Extension := Source.Extension;
232 ImageDateTime := Source.ImageDateTime;
233 UploadDateTime := Source.UploadDateTime;
234 ObjectType := Source.ObjectType;
235 ProcName := Source.ProcName;
236 pLongDesc := Source.pLongDesc; //this is only a pointer to object owned elsewhere
237 end;
238
239 procedure TImageInfo.Clear;
240 begin
241 TIUIEN := 0;
242 DFN := '';
243 UploadDUZ := 0;
244 ThumbFPathName := '';
245 ImageFPathName := '';
246 ServerPath := '';
247 ServerFName := '';
248 ServerThumbFName := '';
249 ShortDesc := '';
250 Extension := '';
251 ImageDateTime := '';
252 UploadDateTime:= '';
253 ObjectType :=0;
254 ProcName := '';
255 pLongDesc := nil
256 end;
257
258 //-------------------------------------------------------------------------
259 //-------------------------------------------------------------------------
260 procedure TAutoUploadNote.SetDFN(var ChartNum,Location,FName,LName,MName,DOB,Sex : string);
261 var RPCResult : AnsiString;
262 PMS : AnsiString;
263 begin
264 //Notice: ChartNum, and PMS are optional. If PMS is 1,2,or 3, then ChartNum
265 // is used to look up patient. Otherwise a lookup is based on just
266 // Name, DOB, Sex.
267 // To NOT use ChartNum, just set the values to ''
268 //
269 //Note: If LName is in form: `12345, then LName is used for DFN, and call
270 // to server for lookup is bypassed, and the values for FName,DOB etc
271 // are ignored
272
273 if MidStr(LName,1,1)='`' then begin
274 Self.Patient.DFN := MidStr(LName,2,999);
275 end else begin
276 //**NOTE**: site-specific code
277 if Location ='Laughlin_Office' then PMS :='2'
278 else if Location ='Peds_Office' then PMS :='3'
279 else PMS := ''; //default
280
281 RPCBrokerV.ClearParameters := true;
282 RPCBrokerV.remoteprocedure := 'TMG GET DFN';
283 RPCBrokerV.param[0].value := ChartNum; RPCBrokerV.param[0].ptype := literal;
284 RPCBrokerV.param[1].value := PMS; RPCBrokerV.Param[1].ptype := literal;
285 RPCBrokerV.param[2].value := FName; RPCBrokerV.Param[2].ptype := literal;
286 RPCBrokerV.param[3].value := LName; RPCBrokerV.Param[3].ptype := literal;
287 RPCBrokerV.param[4].value := MName; RPCBrokerV.Param[4].ptype := literal;
288 RPCBrokerV.param[5].value := DOB; RPCBrokerV.Param[5].ptype := literal;
289 RPCBrokerV.param[6].value := Sex; RPCBrokerV.Param[6].ptype := literal;
290 //RPCBrokerV.Call;
291 CallBroker;
292 RPCResult := RPCBrokerV.Results[0]; //returns: success: DFN; or error: -1^ErrMsg
293 if piece(RPCResult,'^',1) <> '-1' then begin
294 self.Patient.DFN := RPCResult;
295 end else begin
296 self.Patient.DFN := '';
297 end;
298 end;
299 end;
300
301 Procedure TAutoUploadNote.SetInfo(var DOS,Provider,Location,Title : string);
302 //Just loads values into structure. No validation done.
303 begin
304 Self.DOS := DOS;
305 Self.Provider := Provider;
306 Self.Location := Location;
307 Self.NoteTitle := Title;
308 end;
309
310 procedure TAutoUploadNote.InitFrom(OtherNote: TAutoUploadNote);
311 //Will create a blank note for itself.
312 begin
313 Patient.Assign(OtherNote.Patient);
314 ImageInfo.Assign(OtherNote.ImageInfo);
315 Location := OtherNote.Location;
316 DOS := OtherNote.DOS;
317 Provider := OtherNote.Provider;
318 NoteTitle := OtherNote.NoteTitle;
319 CurNoteImages.Assign(OtherNote.CurNoteImages);
320 MakeNewBlankNote(Patient.DFN,DOS,Provider,Location,NoteTitle);
321 end;
322
323 procedure TAutoUploadNote.MakeNewBlankNote(DFN,DOS,Provider,Location,Title : string);
324 var RPCResult : string;
325 begin
326 RPCResult := '';
327 Self.ErrMsg := ''; //default to no error messages
328
329 RPCBrokerV.ClearParameters := true;
330 RPCBrokerV.remoteprocedure := 'TMG GET BLANK TIU DOCUMENT';
331 RPCBrokerV.param[0].value := '`'+DFN; RPCBrokerV.param[0].ptype := literal;
332 RPCBrokerV.param[1].value := Provider; RPCBrokerV.Param[1].ptype := literal;
333 RPCBrokerV.param[2].value := Location; RPCBrokerV.Param[2].ptype := literal;
334 RPCBrokerV.param[3].value := DOS; RPCBrokerV.Param[3].ptype := literal;
335 RPCBrokerV.param[4].value := Title; RPCBrokerV.Param[4].ptype := literal;
336 //RPCBrokerV.Call;
337 CallBroker;
338 RPCResult := RPCBrokerV.Results[0];
339 try
340 TIUIEN := StrToInt64(Piece(RPCResult,'^',1)); //returns: success: TIU IEN; or error: -1
341 except
342 on E: EConvertError do begin
343 Self.ErrMsg := 'WHILE CREATING BLANK NOTE FOR UPLOAD, ' +
344 'ERROR CONVERTING: ' + RPCBrokerV.Results[0] + ' to document record #.';
345 TIUIEN := -1;
346 end
347 end;
348 If TIUIEN <> -1 then begin
349 Self.Patient.DFN := DFN;
350 Self.Provider := Provider;
351 Self.Location := Location;
352 Self.DOS := DOS;
353 end else begin
354 Self.ErrMsg := 'FAILED TO CREATE A BLANK NOTE FOR UPLOAD' +
355 ' ' + Piece(RPCResult,'^',2);
356 Self.UploadError := true;
357 end;
358 end;
359
360 function TAutoUploadNote.IsValid : boolean;
361 begin
362 Result := true; //default to success.
363 if (Patient.DFN='') {or (TIUIEN < 1)} or (ErrMsg <> '') or (NoteTitle = '')
364 or (Location = '') or (DOS = '') or (Provider = '') then begin
365 Result := false
366 end;
367 end;
368
369 procedure TAutoUploadNote.Clear;
370 begin
371 TIUIEN := 0;
372 if Patient <> nil then Patient.Clear;
373 if ImageInfo <> nil then ImageInfo.Clear;
374 Location := '';
375 DOS := '';
376 Provider := '';
377 NoteTitle := '';
378 UploadError := False;
379 if CurNoteImages <> nil then CurNoteImages.Clear;
380 end;
381
382 function TAutoUploadNote.SameAs(OtherNote: TAutoUploadNote): boolean;
383 begin
384 Result := true;
385 if (OtherNote = nil) or (OtherNote.Patient = nil)
386 or (Patient.DFN <> OtherNote.Patient.DFN)
387 or (DOS <> OtherNote.DOS)
388 or (Provider <> OtherNote.Provider)
389 or (Location <> OtherNote.Location)
390 or (NoteTitle <> OtherNote.NoteTitle) then begin
391 Result := false;
392 end;
393 end;
394
395 constructor TAutoUploadNote.Create;
396 begin
397 Self.TIUIEN := 0;
398 Self.Patient := TPatient.Create;
399 Self.CurNoteImages := TStringList.Create;
400 Self.ImageInfo := TImageInfo.Create;
401 Self.Clear;
402 end;
403
404 destructor TAutoUploadNote.Destroy;
405 begin
406 self.patient.free;
407 Self.CurNoteImages.Free;
408 Self.ImageInfo.Free;
409 end;
410
411 //-------------------------------------------------------------------------
412 //-------------------------------------------------------------------------
413 function TUploadForm.MakeThumbNail(Info: TImageInfo) : boolean;
414 //This takes Info.ImageFPathName and creates a 64x64 .bmp file with
415 //this same name, and saves in cache directory.
416 //saves name of this thumbnail in info.ThumbFPathName
417
418 var
419 Rect : TRect;
420 ThumbFName : AnsiString;
421 begin
422 Rect.Top := 0; Rect.Left:=0; Rect.Right:=63; Rect.Bottom:=63;
423 result := false; //default of failure
424 try
425 Picture.LoadFromFile(Info.ImageFPathName);
426 Bitmap.Canvas.StretchDraw(Rect,Picture.Graphic);
427 ThumbFName := frmImages.CacheDir + '\Thumb-' + ExtractFileName(Info.ImageFPathName);
428 ThumbFName := ChangeFileExt(ThumbFName,'.bmp');
429 Bitmap.SaveToFile(ThumbFName); //save to local cache (for upload)
430 Info.ThumbFPathName := ThumbFName; //pass info back out.
431 Info.ServerThumbFName := ChangeFileExt(Info.ServerFName,'.ABS'); //format is .bmp
432 result := true
433 except
434 on E: Exception do exit;
435 end;
436 end;
437
438
439 function TUploadForm.UploadFile(Info: TImageInfo; DelOrig : boolean): boolean;
440 //result: true if success, false if failure
441 var
442 RPCResult,index : AnsiString;
443 ImageIEN : AnsiString;
444 MsgNum : AnsiString;
445 ErrorMsg : AnsiString;
446 i : integer;
447 CacheFPathName, tempFName : string;
448
449 begin
450 RPCBrokerV.remoteprocedure := 'MAGGADDIMAGE';
451 RPCBrokerV.Param[0].Value := '.X';
452 RPCBrokerV.Param[0].PType := list;
453 RPCBrokerV.Param[0].Mult['"NETLOCABS"'] := 'ABS^STUFFONLY';
454 RPCBrokerV.Param[0].Mult['"magDFN"'] := '5^' + Info.DFN; {patient dfn}
455 RPCBrokerV.Param[0].Mult['"DATETIME"'] := '7^NOW'; {date/time image collected}
456 RPCBrokerV.Param[0].Mult['"DATETIMEPROC"'] := '15^' + Info.ImageDateTime; {Date/Time of Procedure}
457 if Info.ProcName <> '' then
458 RPCBrokerV.Param[0].Mult['"PROC"'] := '6^' + Info.ProcName; {procedure}
459 RPCBrokerV.Param[0].Mult['"DESC"'] := '10^(Hard coded Short Description)'; {image description}
460 if Info.ShortDesc <> '' then
461 RPCBrokerV.Param[0].Mult['"DESC"'] := '10^' + Info.ShortDesc; {image description}
462 RPCBrokerV.Param[0].Mult['"DUZ"'] := '8^' + IntToStr(Info.UploadDUZ); {Duz}
463
464 //The field (#14) below is used for images that are part of a group,
465 //for example a CT exam might contain 30 images. This field
466 //contains a pointer back to the Image file (2005), to the
467 //object whose type is "GROUP" that points to this object as
468 //a member of its group. A pointer to this object will be
469 //found in the Object Group multiple of the parent GROUP
470 //object.
471 //RPCBrokerV.Param[0].Mult['"GROUP"'] := '14^' + group;
472
473 RPCBrokerV.Param[0].Mult['"OBJTYPE"'] := '3^' + IntToStr(Info.ObjectType);
474 RPCBrokerV.Param[0].Mult['"FileExt"'] := 'EXT^' + Info.Extension;
475
476 if assigned(Info.pLongDesc) then begin
477 for i := 0 to Info.pLongDesc.Count - 1 do begin
478 index := IntToStr(i);
479 while length(index) < 3 do index := '0' + index;
480 index :='"LongDescr' + index + '"';
481 RPCBrokerV.Param[0].Mult[index] := '11^' + Info.pLongDesc.Strings[i];
482 end;
483 end;
484
485 //RPCResult := RPCBrokerV.STRcall; { returns ImageIEN^directory/filename }
486 CallBroker;
487 if RPCBrokerV.Results.Count>0 then RPCResult := RPCBrokerV.Results.Strings[0];
488
489 ImageIEN := Piece(RPCResult,'^',1);
490 result := ((ImageIEN <> '0') and (ImageIEN <> '')); // function result.
491 if result=false then begin
492 ErrorMsg :=DKLangConstW('UploadImages_Server_Error_xx_Couldnxxt_store_image_information'); //kt added 8/7/2007
493 MessageDlg(ErrorMsg,mtWarning,[mbOK],0);
494 end;
495 if result then begin
496 Info.ServerPath := Piece(RPCResult,'^',2);
497 Info.ServerFName := Piece(RPCResult,'^',3);
498 result := frmImages.UploadFile(Info.ImageFPathName,Info.ServerPath,Info.ServerFName,1,1);
499 if result=false then begin
500 ErrorMsg :=DKLangConstW('UploadImages_Error_uploading_image_to_server'); //kt added 8/7/2007
501 MessageDlg(ErrorMsg,mtWarning,[mbCancel],0);
502 end;
503 if result then begin
504 RPCBrokerV.remoteprocedure := 'MAG3 TIU IMAGE';
505 RPCBrokerV.param[0].ptype := literal;
506 RPCBrokerV.param[0].value := ImageIEN;
507 RPCBrokerV.Param[1].ptype := literal;
508 RPCBrokerV.param[1].value := IntToStr(Info.TIUIEN);
509 //RPCBrokerV.Call;
510 CallBroker;
511 RPCResult := RPCBrokerV.Results[0];
512 //returns: success: 1^message; or error: 0^error message
513 MsgNum := Piece(RPCResult,'^',1);
514 result := (MsgNum = '1');
515 if result=false then begin
516 ErrorMsg :=DKLangConstW('UploadImages_Error_associating_image_with_notex') + #13 + Piece(RPCResult,'^',2); //kt added 8/7/2007
517 MessageDlg(ErrorMsg,mtWarning,[mbCancel],0);
518 end;
519 end;
520 if (result=false) then exit;
521 //Copy the file into the cache directory, so that we don't have to turn around and download it again.
522 CacheFPathName := rHTMLTools.CPRSDir + '\cache\' + ExtractFileName (Info.ServerFName);
523 if not FileExists(CacheFPathName) then begin
524 tempFName := Info.ImageFPathName;
525 CopyFile(PChar(tempFName),PChar(CacheFPathName),FALSE);
526 end;
527 if (MoveCheckBox.Checked) then begin
528 DeleteFile(Info.ImageFPathName);
529 end;
530 if MakeThumbNail(Info) then begin;
531 result := frmImages.UploadFile(Info.ThumbFPathName,Info.ServerPath,Info.ServerThumbFName,1,1);
532 if result=false then begin
533 ErrorMsg :=DKLangConstW('UploadImages_Error_sending_thumbnail_image_to_serverx'); //kt added 8/7/2007
534 MessageDlg(ErrorMsg,mtWarning,[mbOK],0);
535 end;
536 CacheFPathName := rHTMLTools.CPRSDir + '\cache\' + ExtractFileName (Info.ServerFName);
537 if not FileExists(CacheFPathName) then begin
538 CopyFile(PChar(Info.ImageFPathName),PChar(CacheFPathName),FALSE);
539 end;
540 if DelOrig=true then begin
541 DeleteFile(Info.ImageFPathName);
542 end;
543 end;
544 end;
545 //returns: result
546 end;
547
548
549
550 procedure TUploadForm.UploadChosenFiles();
551 var i : integer;
552 Info: TImageInfo;
553
554 begin
555 SetupVars;
556 Info := TImageInfo.Create();
557 Info.pLongDesc := nil;
558
559 //Load up info class/record
560 Info.ShortDesc := MidStr(ShortDescEdit.Text,1,60);
561 if Info.ShortDesc = DefShortDesc then Info.ShortDesc := ' ';
562 Info.UploadDUZ := User.DUZ;
563 if LongDescMemo.Lines.Count>0 then begin
564 Info.pLongDesc := LongDescMemo.Lines;
565 end;
566 Info.ObjectType := 1; //type 1 is Still Image (jpg). OK to use with .bmp??
567 Info.ProcName := 'Picture'; //max length is 10 characters
568 Info.ImageDateTime := DateTimeEdit.Text;
569 Info.TIUIEN := frmNotes.lstNotes.ItemID;
570 Info.UploadDateTime := 'NOW';
571 Info.DFN := Patient.DFN;
572
573 for i:= 0 to FilesToUploadList.Items.Count-1 do begin
574 Info.ImageFPathName := FilesToUploadList.Items.Strings[i];
575 Info.Extension := ExtractFileExt(Info.ImageFPathName); //includes '.'
576 Info.Extension := MidStr(Info.Extension,2,17); //remove '.'
577
578 if UploadFile(Info,MoveCheckBox.Checked) then begin //Upload function passes back filename info in Info class
579 FUploadedImagesList.Add(Info.ServerFName);
580 end else begin
581 //Application.MessageBox('Error uploading image file!','Error');
582 end;
583 end;
584 Info.Free;
585 end;
586
587 procedure TUploadForm.LoadNotesEdit();
588 begin
589 NoteEdit.Text := frmNotes.tvNotes.Selected.Text;
590 end;
591
592 {
593 procedure TUploadForm.LoadNotesList();
594 var
595 NoteInfo,s,dateS : AnsiString;
596 i : integer;
597 const
598 U='^';
599 begin
600 NoteComboBox.Items.Clear;
601
602 for i := 0 to frmNotes.lstNotes.Count-1 do with frmNotes.lstNotes do begin
603 NoteInfo := Items[i];
604 (* example NoteInfo:
605 piece# 1: 14321^ //TIU IEN
606 piece# 2: PRESCRIPTION CALL IN^ //Document Title
607 piece# 3: 3050713.0947^ //Date/Time
608 piece# 4: TEST, KILLME D (T0101)^ //Patient
609 piece# 5: 133;JANE A DOE;DOE,JANE A^ //Author
610 piece# 6: Main_Office^ //Location of Visit
611 piece# 7: completed^ //Status of Document
612 piece# 8: Visit: 07/13/05;3050713.094721^ //Date/Time
613 piece# 9...: ;^^1^^^1^' //?
614 *)
615 dateS := Piece(Piece(NoteInfo, U, 8), ';', 2);
616 s := FormatFMDateTime('mmm dd,yy@hh:nn', MakeFMDateTime(dateS)) + ' -- ';
617 // s := Piece(Piece(NoteInfo, U, 8), ';', 1) + ' -- ';
618 s := s + Piece(NoteInfo, U, 2) + '; ';
619 s := s + 'Author: ' + Piece(Piece(NoteInfo, U, 5), ';', 2) + ', ';
620 s := s + Piece(NoteInfo, U, 6);
621 NoteComboBox.Items.Add(s);
622 end;
623 NoteComboBox.ItemIndex := frmNotes.lstNotes.ItemIndex;
624 end;
625 }
626 //Delphi events etc.------------------------------------------------
627
628 procedure TUploadForm.UploadButtonClick(Sender: TObject);
629 begin
630 try
631 WebBrowser.Navigate(frmImages.NullImageName);
632 sleep(500); //Give Webbrowser time to release any browsed document.
633 except
634 on E: Exception do exit;
635 end;
636 UploadChosenFiles();
637 //note This UploadButton has .ModalResult = mrOK, so form is closed after this.
638 end;
639
640 procedure TUploadForm.PickImagesButtonClick(Sender: TObject);
641 var i : integer;
642 begin
643 If OpenDialog.Execute then begin
644 for i := 0 to OpenDialog.Files.Count-1 do begin
645 FilesToUploadList.Items.Add(OpenDialog.Files.Strings[i]);
646 end;
647 end;
648 end;
649
650 procedure TUploadForm.PickOtherButtonClick(Sender: TObject);
651 var i : integer;
652 begin
653 If OpenFileDialog.Execute then begin
654 for i := 0 to OpenFileDialog.Files.Count-1 do begin
655 FilesToUploadList.Items.Add(OpenFileDialog.Files.Strings[i]);
656 end;
657 end;
658 end;
659
660 procedure TUploadForm.btnPickPDFClick(Sender: TObject);
661 var i : integer;
662 begin
663 if not Assigned(frmImagePickPDF) then begin
664 frmImagePickPDF := TfrmImagePickPDF.Create(Self); //free'd in OnHide
665 end;
666 if frmImagePickPDF.Execute then begin
667 for i := 0 to frmImagePickPDF.Files.Count-1 do begin
668 FilesToUploadList.Items.Add(frmImagePickPDF.Files.Strings[i]);
669 end;
670 end;
671 end;
672
673 procedure TUploadForm.FormShow(Sender: TObject);
674 begin
675 FormRefresh(self);
676 FilesToUploadList.Items.Clear;
677 FUploadedImagesList.Clear;
678 LoadNotesEdit();
679 SetupVars;
680 ShortDescEdit.Text := DefShortDesc;
681 end;
682
683 procedure TUploadForm.ShortDescEditChange(Sender: TObject);
684 begin
685 if Length(ShortDescEdit.Text)> 60 then begin
686 ShortDescEdit.Text := MidStr(ShortDescEdit.Text,1,60);
687 end;
688 end;
689
690 procedure TUploadForm.ClearImagesButtonClick(Sender: TObject);
691 begin
692 FilesToUploadList.Items.Clear;
693 FilesToUploadListClick(self);
694 end;
695
696 procedure TUploadForm.FormCreate(Sender: TObject);
697 begin
698 Bitmap := TBitmap.Create;
699 Bitmap.Height := 64;
700 Bitmap.Width := 64;
701 Picture := TPicture.Create;
702 FAllowNonImages := true;
703 FUploadedImagesList := TStringList.Create;
704
705 AutoUploadNote := TAutoUploadNote.Create;
706 FScanDir := uTMGOptions.ReadString('Pol Directory','??');
707 if FScanDir='??' then begin
708 FScanDir := ExtractFileDir(Application.ExeName);
709 uTMGOptions.WriteString('Pol Directory',FScanDir);
710 end;
711 PolInterval := uTMGOptions.ReadInteger('Pol Interval (milliseconds)',0);
712 if PolInterval=0 then begin
713 PolInterval := 60000;
714 uTMGOptions.WriteInteger('Pol Interval (milliseconds)',PolInterval);
715 end;
716 end;
717
718 procedure TUploadForm.SetScanDir(NewDir : string);
719 begin
720 if DirectoryExists(NewDir) then begin
721 FScanDir := NewDir;
722 uTMGOptions.WriteString('Pol Directory',FScanDir);
723 end;
724 end;
725
726 procedure TUploadForm.FormDestroy(Sender: TObject);
727 begin
728 Bitmap.Free;
729 Picture.Free;
730 FUploadedImagesList.Free;
731 end;
732
733 procedure TUploadForm.FilesToUploadListClick(Sender: TObject);
734 var
735 FileName: AnsiString;
736 SelectedItem: integer;
737 begin
738 SelectedItem := FilesToUploadList.ItemIndex;
739 if SelectedItem > -1 then begin
740 FileName := FilesToUploadList.Items[SelectedItem];
741 if UpperCase(ExtractFileExt(FileName))='.PDF' then begin
742 FileName := CopyFileToTemp(FileName); //returns '' if copy fails
743 if FileName = '' then FileName := frmImages.NullImageName;
744 end;
745 end else begin
746 FileName := frmImages.NullImageName;
747 end;
748 try
749 WebBrowser.Navigate(FileName);
750 except
751 on E: Exception do exit;
752 end;
753 end;
754
755 function TUploadForm.CopyFileToTemp(FNamePath : string) : string;
756 var DestFile : string;
757 lpDestFile : PAnsiChar;
758 lpSourceFile : PAnsiChar;
759 begin
760 DestFile := frmImages.CacheDir + '\tempbrowseable' + ExtractFileExt(FNamePath);
761 lpDestFile := PAnsiChar(DestFile);
762 lpSourceFile := PAnsiChar(FNamePath);
763 if CopyFile(lpSourcefile,lpDestFile,LongBool(FALSE)) = TRUE then begin //0=success
764 Result := DestFile;
765 end else begin
766 Result := '';
767 end;
768 end;
769
770 procedure TUploadForm.FormRefresh(Sender: TObject);
771 begin
772 try
773 WebBrowser.Navigate(frmImages.NullImageName);
774 except
775 on E: Exception do exit;
776 end;
777 end;
778
779 procedure TUploadForm.FormHide(Sender: TObject);
780 begin
781 FormRefresh(Sender);
782 frmImagePickPDF.Free;
783 frmImagePickPDF := nil;
784 end;
785
786 procedure TUploadForm.DecodeImgTxt(Line : string; out ChartNum, Location,
787 FName, LName, MName, Sex, DOB, DOS, Provider,
788 Title : string; FilePaths : TStrings);
789 //format of line is as follows:
790 //ChartNum^Location^FName^LName^MName^Sex^DOB^DOS^Provider^Title^FilePath(s)
791 //NOTE: To provide patient IEN instead of FName etc, use this format:
792 // ^Location^^`1234567^^^^DOS^Provider^Title^FilePath(s)
793 // i.e. `IEN (note ` is not an appostrophy ('))
794 // `IEN in place of LName, and leave blank: ChartNum,FName,FName,Sex,DOB
795
796 var Files: String;
797 FileName : String;
798 num,i : integer;
799 begin
800 if Pos('}',Line)>0 then begin
801 Line := Piece(Line,'}',2); //If error message is present, still allow parse.
802 end;
803 ChartNum := Piece(Line,'^',1);
804 Location := Piece(Line,'^',2);
805 FName := Piece(Line,'^',3);
806 LName := Piece(Line,'^',4);
807 MName := Piece(Line,'^',5);
808 Sex := Piece(Line,'^',6);
809 DOB := Piece(Line,'^',7);
810 DOS := Piece(Line,'^',8);
811 Provider := Piece(Line,'^',9);
812 Title := Piece(Line,'^',10);
813 Files := Piece(Line,'^',11); //may be list of multiple files separated by ;
814 if Pos(';',Files)>0 then begin
815 num := NumPieces(Files,';');
816 for i := 1 to num do begin
817 FileName := piece(files,';',i);
818 if FileName <> '' then FilePaths.Add(FileName);
819 end;
820 end else begin
821 FilePaths.Add(Files);
822 end;
823
824 end;
825
826 function TUploadForm.EncodeImgTxt(ChartNum, Location, FName, LName, MName, Sex, DOB,
827 DOS, Provider, Title : string; FilePaths : TStrings) : AnsiString;
828 //format of line is as follows:
829 //ChartNum^Location^FName^LName^MName^Sex^DOB^DOS^Provider^Title^FilePath(s)
830 //NOTE: To provide patient IEN instead of FName etc, use this format:
831 // ^Location^^`1234567^^^^DOS^Provider^Title^FilePath(s)
832 // i.e. `IEN (note ` is not an appostrophy ('))
833 // `IEN in place of LName, and leave blank: ChartNum,FName,FName,Sex,DOB
834 var i : integer;
835 begin
836 Result := ChartNum + '^' + Location + '^' + FName + '^' + LName + '^' +
837 MName + '^' + Sex + '^' + DOB + '^' + DOS + '@01:00' + '^' + Provider + '^' +
838 Title + '^'; //added time of 1:00 elh 7/8/08
839 for i:= 0 to FilePaths.Count-1 do begin
840 Result := Result + FilePaths.Strings[i];
841 if i <> FilePaths.Count-1 then Result := Result + ';';
842 end;
843 end;
844
845
846 procedure TUploadForm.FinishDocument(UploadNote : TAutoUploadNote);
847 var Text : TStringList;
848 ErrMsg : String;
849 RPCResult : String;
850 i : integer;
851 oneImage: string;
852 //TIUIEN : int64;
853
854 begin
855 if (UploadNote.TIUIEN>0) and (UploadNote.CurNoteImages.Count>0)
856 and (UploadNote.UploadError = False) then begin
857 //Add text for note: "See scanned image" --
858 // or later, some HTML code to show note in CPRS directly....
859 Text := TStringList.Create;
860 Text.Add('<!DOCTYPE HTML PUBLIC>');
861 Text.Add('<html>');
862 Text.Add('<head>');
863 Text.Add('<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">');
864 Text.Add('<title>VistA HTML Note</title>');
865 Text.Add('</head>');
866 Text.Add('<body>');
867 Text.Add('<p>');
868 Text.Add('Note created automatically from imported media.');
869 Text.Add('<p>');
870 for i := 0 to UploadNote.CurNoteImages.Count-1 do begin
871 // note: $CPRSDIR$ will be replaced at runtime with directory of CPRS
872 // This will be done as page is passed to TWebBrowser (in rHTMLTools)
873 oneImage := '$CPRSDIR$\Cache\' + UploadNote.CurNoteImages.Strings[i];
874 //oneImage := CacheDir + '\' + CurNoteImages.Strings[i];
875 Text.Add('<img WIDTH=640 src="'+oneImage+'">');
876 Text.Add('<p>');
877 end;
878 //Text.Add('<small>');
879 //Text.Add('If images don''t display, first view them in IMAGES tab.<br>');
880 //Text.Add('Then return here, click on note and press [F5] key to refresh.');
881 //Text.Add('</small>');
882 //Text.Add('<p>');
883 Text.Add('</body>');
884 Text.Add('</html>');
885 Text.Add(' ');
886 rTIU.SetText(ErrMsg,Text,UploadNote.TIUIEN,0); //elh changed from 1 to 0 //1=commit data, do actual save.
887 Text.Free;
888 //Here I autosign -- later make this optional?
889 RPCBrokerV.ClearParameters := true;
890 RPCBrokerV.remoteprocedure := 'TMG AUTOSIGN TIU DOCUMENT';
891 RPCBrokerV.param[0].value := IntToStr(UploadNote.TIUIEN);
892 RPCBrokerV.param[0].ptype := literal;
893 //RPCBrokerV.Call;
894 CallBroker;
895 if RPCBrokerV.Results.Count > 0 then begin
896 RPCResult := RPCBrokerV.Results[0]; //returns: error: -1; success=1
897 end else begin
898 RPCResult := '-1';
899 end;
900 if RPCResult='-1' then begin
901 MessageDlg('Unable to set status for scanned document to SIGNED',mtError,[mbOK],0);
902 end;
903 UploadNote.TIUIEN := 0;
904 end;
905 UploadNote.Clear;
906 end;
907
908
909 function TUploadForm.ProcessOneLine(Line : string) : string;
910 //Returns: if success, ''; if failure, returns reason
911
912 //format of line is as follows:
913 //ChartNum^Location^FName^LName^MName^Sex^DOB^DOS^Provider^Title^FilePath(s)
914 //NOTE: To provide patient IEN instead of FName etc, use this format:
915 // ^Location^^`1234567^^^^DOS^Provider^Title^FilePath(s)
916 // i.e. `IEN (note ` is not an appostrophy ('))
917 // `IEN in place of LName, and leave blank: ChartNum,FName,FName,Sex,DOB
918
919 var
920 ChartNum,FName,LName,MName,Sex,DOB : String;
921 DOS,Provider,Title : String;
922 ThisNote : TAutoUploadNote;
923 FilePaths : TStringList;
924 i : integer;
925 Location : string;
926
927 begin
928 Result := ''; //default to success for function
929 ThisNote := TAutoUploadNote.Create;
930 FilePaths := TStringList.Create();
931 DecodeImgTxt(Line, ChartNum, Location, FName, LName, MName, Sex, DOB, DOS, Provider, Title, FilePaths);
932
933 ThisNote.SetDFN(ChartNum,Location,FName,LName,MName,DOB,Sex);
934 ThisNote.SetInfo(DOS,Provider,Location,Title);
935 if Pos('//Failed',Line)>0 then ThisNote.UploadError := true;
936 if ThisNote.IsValid then begin //A note can be 'Valid' and still have an 'UploadError'
937 if ThisNote.SameAs(AutoUploadNote)= false then begin
938 ThisNote.TIUIEN := AutoUploadNote.TIUIEN;
939 FinishDocument(AutoUploadNote); // Close and clear any existing note
940 AutoUploadNote.InitFrom(ThisNote);
941 Result := AutoUploadNote.ErrMsg; //'' if no error
942 end;
943 if ThisNote.UploadError then AutoUploadNote.UploadError := true;
944 if (AutoUploadNote.UploadError=false) then for i := 0 to FilePaths.Count-1 do begin
945 AutoUploadNote.ImageInfo.pLongDesc := nil;
946 //Load up info record with data for upload
947 AutoUploadNote.ImageInfo.ShortDesc := 'Scanned document';
948 AutoUploadNote.ImageInfo.UploadDUZ := User.DUZ;
949 AutoUploadNote.ImageInfo.ObjectType := 1; //type 1 is Still Image (jpg). OK to use with .bmp??
950 AutoUploadNote.ImageInfo.ProcName := 'Scanned'; //max length is 10 characters
951 AutoUploadNote.ImageInfo.ImageDateTime := DOS;
952 AutoUploadNote.ImageInfo.TIUIEN := AutoUploadNote.TIUIEN;
953 AutoUploadNote.ImageInfo.UploadDateTime := 'NOW';
954 AutoUploadNote.ImageInfo.DFN := AutoUploadNote.Patient.DFN;
955 AutoUploadNote.ImageInfo.ImageFPathName := FilePaths.Strings[i];
956 AutoUploadNote.ImageInfo.Extension := ExtractFileExt(AutoUploadNote.ImageInfo.ImageFPathName); //includes '.'
957 AutoUploadNote.ImageInfo.Extension := MidStr(AutoUploadNote.ImageInfo.Extension,2,17); //remove '.'
958 if not UploadFile(AutoUploadNote.ImageInfo,true) then begin //Upload function passes back filename info in Info class
959 Result := 'ERROR UPLOADING IMAGE FILE';
960 end;
961 AutoUploadNote.CurNoteImages.Add(AutoUploadNote.ImageInfo.ServerFName);
962 end else begin
963 If Result='' then Result := '(Error found in earlier file entry in batch)';
964 end;
965 end else begin
966 Result := 'NOTE INFO INVALID (Probably: PATIENT NOT FOUND)';
967 end;
968 FilePaths.Free;
969 ThisNote.Free;
970 end;
971
972
973 function TUploadForm.ProcessOneFile(FileName : string) : boolean;
974 //This will process image(s) indicated in textfile FileName
975 //After uploading image to server, textfile and specified images are deleted
976 //Returns Success
977 //Note: To upload multiple images into one document, one may add multiple
978 // lines to the ImgTxt text file. As long as the info is the same
979 // (i.e. same provider, patient, note type, DOS etc) then they
980 // will be appended to current note.
981 // OR, add multiple image file names to one line.
982 // -- the problem with multiple images on one line is that errors
983 // can not be reported for just one image. It will be ONE for any/all
984 // OR, if the next file in process-order is still has the same info as
985 // the prior file, then it will be appended.
986 var
987 Lines : TStringList;
988 i : integer;
989 ResultStr : string;
990 OneLine : string;
991 begin
992 Result := true; //default is Success=true
993 Lines := TStringList.Create;
994 Lines.LoadFromFile(FileName);
995 //FinishDocument(AutoUploadNote); //will save and clear any old data.
996 for i := 0 to Lines.Count-1 do begin
997 OneLine := Lines.Strings[i];
998 ResultStr := ProcessOneLine(OneLine); //Even process with //failed markeers (to preserve batches)
999 if Pos('//Failed',OneLine)> 0 then begin //If we already have //Failed, don't duplicate another Error Msg
1000 Result := false; //prevent deletion of file containing //Failed//
1001 end else begin
1002 if ResultStr <> '' then begin
1003 Lines.Strings[i] := '//Failed: '+ResultStr+'}'+Lines.Strings[i];
1004 Lines.SaveToFile(FileName);
1005 Result := false;
1006 end;
1007 end;
1008 end;
1009 //Temp, for debugging
1010 //Lines.SaveToFile(ChangeFileExt(FileName,'.imgtxt-bak'));
1011 //end temp
1012 Lines.free;
1013 end;
1014
1015
1016 procedure TUploadForm.ScanAndHandleImgTxt;
1017 var
1018 FoundFile : string;
1019 Found : TSearchRec;
1020 FilesList : TStringList;
1021 i : integer;
1022 result : boolean;
1023 begin
1024 //NOTE: Later I may make this spawn a separate thread, so that
1025 // user doesn't encounter sudden unresponsiveness of CPRS
1026 //I can use BeginThread, then EndTread
1027 //Issues: ProcessOneFile would probably have to be a function
1028 // not in a class/object...
1029
1030 FilesList := TStringList.Create;
1031
1032 //scan for new *.ImgTxt file
1033 //FindFirst may not have correct order, so collect all names and then sort.
1034 if FindFirst(FScanDir+'*.imgtxt',faAnyFile,Found)=0 then repeat
1035 FilesList.Add(FScanDir+Found.Name);
1036 until FindNext(Found) <> 0;
1037 FindClose(Found);
1038 FilesList.Sort; //puts filenames in alphanumeric order
1039
1040 //Now process images in correct order.
1041 for i := 0 to FilesList.Count-1 do begin
1042 FoundFile := FilesList.Strings[i];
1043 if ProcessOneFile(FoundFile) = true then begin {process *.imgtxt file}
1044 DeleteFile(FoundFile);
1045 FoundFile := ChangeFileExt(FoundFile,'.barcode.txt');
1046 DeleteFile(FoundFile);
1047 end; //Note: it is OK to continue, to get other non-error notes afterwards.
1048 end;
1049 FinishDocument(AutoUploadNote); // Close and clear any existing note
1050 FilesList.Free
1051 end;
1052
1053
1054 procedure TUploadForm.ScanAndHandleImages;
1055 (* Overview of mechanism of action of automatically uploading images.
1056 =================================================================
1057 -- For an image to be uploaded, it must first be positively identified.
1058 This can occur 1 of two ways:
1059 -- the image contains a datamatrix barcode.
1060 -- the image is part of a batch, and the first image of the batch
1061 contains a barcode for the entire batch.
1062 -- At our site, the scanner program automatically names the files numerically
1063 so that sorting on the name will put them in proper order when working
1064 with batches.
1065 -- The decoding of the barcode requires a special program. I was not
1066 able to find a way to run this on the Windows client. I found the
1067 libdmtx that does this automatically. It currently is on unix only.
1068 It was too complicated for me to compile it for windows. I initially
1069 wanted everything to run through the RPC broker. This involved
1070 uploading the image to the linux server, running the decoder on the
1071 server, then passing the result back. The code for this is still avail
1072 in this CPRS code. However, the process was too slow and I had to
1073 come up with something faster. So the following arrangement was setup
1074 -- scanned images are stored in a folder that was shared by both the
1075 windows network (and thus is available to CPRS), and the linux server.
1076 -- At our site, we used a copier/scanner unit that created only TIFF
1077 files. These are not the needed format for the barcode decoder, so...
1078 -- a cron job runs on the linux server that converts the .tif files
1079 to .png. Here is that script:
1080 <removed due to frequent changes...>
1081 ---------------------------------
1082 -- Next the .png files must be checked for a barcode. Another cron
1083 task scans a directory for .png files and creates a metafile for
1084 the file giving its barcode reading, or a marker that there is
1085 no barcode available for that image. The file name format is:
1086 *.barcode.txt, with the * coorelating to filename of the image.
1087 -- The decoding process can take some time (up to several minutes
1088 per image.
1089 -- A flag file named barcodeRead.working.txt is created when the
1090 script is run, and deleted when done. So if this file is present
1091 then the decoding process is not complete.
1092 -- if a *.barcode.txt file is present, then no attempts will be made
1093 to decode the image a second time.
1094 -- CPRS still contains code to upload an image to look for a barcode.
1095 At this site, only png's will contain barcodes, so I have commented
1096 out support for automatically uploading other file formats.
1097 -- Here is the unix bash script that decodes the barcodes. It is
1098 launched by cron:
1099 ---------------------------------
1100 <removed due to frequent changes...>
1101 ---------------------------------
1102 -- After the *.png images are available, and no flag files are present
1103 to indicate that the server is working with the files, then the images
1104 are processed, using the barcode metafiles. This is triggered by a
1105 timer in CPRS. It essentially converts imagename + barcode data -->
1106 --> *.imgtxt.
1107 -- For each *.png image, there will be a *.imgtxt metafile created. This
1108 will contain information needed by the server, in a special format for
1109 the RPC calls. When an *.imgtxt file is present, this is a flag that
1110 the image is ready to be uploaded.
1111 -- A timer in CPRS scans for *.imgtxt files. When found, it uploads the
1112 image to the server and creates a container progress note for displaying
1113 it in CPRS.
1114 *)
1115
1116 procedure ScanOneImageType(ImageType : string);
1117 //Scan directory for all instances of images of type ImageType
1118 //For each one, create a metadata file (if not already present)
1119
1120 //Note: Batch mode only works for a batch of file ALL OF THE SAME TYPE.
1121 //I.e. There can't be a batch of .jpg, then .gif, then .bmp. This is
1122 //because a scanner, if it is scanning a stack of documents for a given
1123 //patient will produce all files in the same ImageType
1124
1125 function DeltaMins(CurrentTime,PriorTime : TDateTime) : integer;
1126 //Return ABSOLUTE difference in minutes between Current <--> Prior.
1127 //NOTE: if value is > 1440, then 1440 is returned
1128 var DeltaDays,FracDays : double;
1129 begin
1130 DeltaDays := abs(CurrentTime-PriorTime);
1131 FracDays := DeltaDays - Round(DeltaDays);
1132 if DeltaDays>1 then FracDays := 1;
1133 Result := Round((60*24)*FracDays);
1134 end;
1135
1136 var
1137 FoundFile : string;
1138 MetaFilename : string;
1139 Found : TSearchRec;
1140 BarCodeData : AnsiString;
1141 DFN,DOS,AuthIEN,LocIEN,NoteTypeIEN : string;
1142 OneLine : string;
1143 FilePaths : TStringList;
1144 AllFiles : TStringList;
1145 OutFileLines : TStringList;
1146 BatchS : string;
1147 tempCount : integer;
1148 BatchFInfo : TFileInfo;
1149 LastFileTimeStamp,CurFileTimeStamp : TDateTime;
1150 DeltaMinutes : integer;
1151 pFInfo : TFileInfo;
1152 i : integer;
1153 Label AbortPoint;
1154
1155 const
1156 ALLOWED_TIME_GAP = 2; //time in minutes
1157
1158 begin
1159 FilePaths := TStringList.Create;
1160 OutFileLines := TStringList.Create;
1161 AllFiles := TStringList.Create;
1162 BatchFInfo := TFileInfo.Create;
1163
1164 //NOTE: Later I may make this spawn a separate thread, so that
1165 // user doesn't encounter sudden unresponsiveness of CPRS
1166 //I can use BeginThread, then EndTread
1167 //Issues: ProcessOneFile would probably have to be a function
1168 // not in a class/object...
1169
1170 //scan for all instances *.ImageType Image file
1171 //Store info for processesing after loop
1172 //Do this as a separate step, so files can be processed in proper order
1173 if FindFirst(FScanDir+'*.'+ImageType,faAnyFile,Found)=0 then repeat
1174 FoundFile := FScanDir+Found.Name;
1175 if FileExists(ChangeFileExt(FoundFile,'.imgtxt')) then continue;
1176 MetaFilename := ChangeFileExt(FoundFile,'.barcode.txt');
1177 pFInfo := TFileInfo.Create; //will be owned by AllFiles
1178 pFInfo.MetaFileName := MetaFilename;
1179 pFInfo.FPath := FoundFile;
1180 pFInfo.SrcRec := Found;
1181 pFInfo.STimeStamp := FloatToStr(FileDateToDateTime(Found.Time));
1182 pFInfo.MetaFileExists := FileExists(MetaFilename);
1183 pFInfo.SBarCode := ''; //default to empty.
1184 pFInfo.BatchCount := 0;
1185 if pFInfo.MetaFileExists = false then begin
1186 //Call server via RPC to decode Barcode
1187 //This is too slow and buggy. Will remove for now...
1188 //BarCodeData := frmImages.DecodeBarcode(FoundFile,ImageType);
1189 //pFInfo.SBarCode := BarCodeData;
1190 pFInfo.SBarCode := '';
1191 //Here I could optionally create a Metafile for processing below.
1192 end;
1193 if pFInfo.MetaFileExists then begin //Retest in case RPC changed status.
1194 if FileExists(FScanDir+'barcodeRead.working.txt') then goto AbortPoint;
1195 OutFileLines.LoadFromFile(pFInfo.MetaFileName);
1196 if OutFileLines.Count>0 then begin
1197 pFInfo.SBarCode := OutFileLines.Strings[0];
1198 //convert 'No Barcode message into an empty string, to match existing code.
1199 if Pos('//',pFInfo.SBarCode)=1 then pFInfo.SBarCode := '';
1200 if NumPieces(pFInfo.SBarCode,'-') <> 8 then pFInfo.SBarCode := '';
1201 end else begin
1202 pFInfo.MetaFileExists := false; //set empty file to Non-existence status
1203 end;
1204 end;
1205 AllFiles.AddObject(pFInfo.FPath,pFInfo); //Store filename, to allow sorting on this.
1206 until FindNext(Found) <> 0;
1207 AllFiles.Sort; // Sort on timestamp --> put in ascending alpha filename order
1208
1209 //-------- Now, process files in name order ------------
1210 LastFileTimeStamp := 0;
1211 BatchFInfo.BatchCount := 0;
1212 for i := 0 to AllFiles.Count-1 do begin
1213 pFInfo := TFileInfo(AllFiles.Objects[i]);
1214 if pFInfo.MetaFileExists = false then continue;
1215 CurFileTimeStamp := FileDateToDateTime(pFInfo.SrcRec.Time);
1216 DeltaMinutes := DeltaMins(CurFileTimeStamp,LastFileTimeStamp);
1217 // *.barcode.txt file exists at this point
1218 if pFInfo.SBarCode <> '' then begin //Found a new barcode
1219 LastFileTimeStamp := CurFileTimeStamp;
1220 //Note: The expected format of barcode must be same as that
1221 // created by TfrmPtLabelPrint.PrintButtonClick:
1222 // 70685-12-31-2008-73-6-1302-0
1223 // PtIEN-DateOfService-AuthorIEN-LocIEN-NoteTypeIEN-BatchFlag
1224 // THUS there should be 8 pieces in the string.
1225 DFN := piece(pFInfo.SBarCode,'-',1);
1226 DOS := pieces(pFInfo.SBarCode,'-',2,4);
1227 AuthIEN := piece(pFInfo.SBarCode,'-',5);
1228 LocIEN := piece(pFInfo.SBarCode,'-',6);
1229 NoteTypeIEN := piece(pFInfo.SBarCode,'-',7);
1230 BatchS := piece(pFInfo.SBarCode,'-',8);
1231 if BatchS = '*' then begin
1232 pFInfo.BatchCount := 9999
1233 end else begin
1234 try
1235 pFInfo.BatchCount := StrToInt(BatchS);
1236 except
1237 on E:EConvertError do begin
1238 pFInfo.BatchCount := 1;
1239 end;
1240 end;
1241 end;
1242 //BatchFInfo.SBarCode := pFInfo.SBarCode;
1243 end else if (BatchFInfo.BatchCount > 0) then begin
1244 if (DeltaMinutes > ALLOWED_TIME_GAP) then begin
1245 pFInfo.Clear;
1246 BatchFInfo.Clear;
1247 end else begin
1248 //Apply barcode from last image onto this one (from same batch)
1249 pFInfo.SBarCode := BatchFInfo.SBarCode;
1250 end;
1251 end;
1252 if pFInfo.SBarCode <> '' then begin
1253 //Success --> write out ImgTxt file...
1254 FilePaths.Add(pFInfo.FPath);
1255 OneLine := EncodeImgTxt('', '`'+LocIEN,'', '`'+DFN, '', '', '',
1256 DOS,'`'+AuthIEN, '`'+NoteTypeIEN, FilePaths);
1257 if pFInfo.BatchCount>0 then begin
1258 //A BATCH marker has been found on current barcode. This means that
1259 //Batchmode should be turned on. This will apply current barcode
1260 //data to any subsequent images, providing there is not a gap in
1261 //time > ALLOWED_TIME_GAP
1262 BatchFInfo.Assign(pFInfo); //reset Batch info to current
1263 end;
1264 //Decrease use count of Batch Info
1265 Dec(BatchFInfo.BatchCount);
1266 end else begin
1267 OneLine := '';
1268 end;
1269 OutFileLines.Clear;
1270 if OneLine <> '' then begin
1271 OutFileLines.Add(OneLine);
1272 OutFileLines.SaveToFile(ChangeFileExt(pFInfo.FPath,'.imgtxt'));
1273 end;
1274 FilePaths.Clear;
1275 OutFileLines.Clear;
1276 LastFileTimeStamp := CurFileTimeStamp;
1277 end;
1278AbortPoint:
1279 FindClose(Found);
1280 BatchFInfo.Free;
1281 FilePaths.Free;
1282 for i := 0 to AllFiles.Count-1 do begin //free owned objects
1283 pFInfo := TFileInfo(AllFiles.Objects[i]);
1284 pFInfo.Free;
1285 end;
1286 AllFiles.Free;
1287 OutFileLines.Free;
1288 end;
1289
1290 var flag1Filename,flag2Filename : string;
1291 begin
1292 flag1Filename := FScanDir+'barcodeRead.working.txt';
1293 flag2Filename := FScanDir+'convertTif2Png.working.txt';
1294 //if linux server is in middle of a conversion or barcode decode, then skip.
1295 if (FileExists(flag1Filename)=false) and (FileExists(flag2Filename)=false) then begin
1296 (* Remove {}'s to be able to have jpg's etc that contain barcodes
1297 In our site, only png's will have barcodes, and thus these are the
1298 only images that can be uploaded automatically. Uploading jpg's, bmp's
1299 etc to look for (nonexistent) barcodes will just waste time and bandwidth. *)
1300 {
1301 ScanOneImageType('jpg');
1302 ScanOneImageType('jpeg');
1303 ScanOneImageType('gif');
1304 ScanOneImageType('bmp');
1305 }
1306 //ScanOneImageType('tif'); {Tiff was not showing up in IE for some reason}
1307 //ScanOneImageType('tiff'); {Tiff was not showing up in IE for some reason}
1308 ScanOneImageType('png');
1309 end;
1310 end;
1311
1312 procedure TUploadForm.PolTimerTimer(Sender: TObject);
1313 begin
1314 PolTimer.Enabled := false;
1315 try
1316 if Assigned(frmImages) and frmImages.AutoScanUpload.Checked then begin
1317 ScanAndHandleImages; //create metadata for images (if not done already)
1318 ScanAndHandleImgTxt; //process upload file, based on metadata
1319 end;
1320 finally
1321 PolTimer.Enabled := true;
1322 PolTimer.Interval := PolInterval;
1323 end;
1324 end;
1325
1326 procedure TUploadForm.SetAllowNonImages(Value : boolean);
1327 begin
1328 FAllowNonImages := Value;
1329 btnPickPDF.Enabled := Value;
1330 PickOtherButton.Enabled := Value;
1331 end;
1332
1333
1334
1335end.
Note: See TracBrowser for help on using the repository browser.