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

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

Fixing uploads of PDF files
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 end;
784
785 procedure TUploadForm.DecodeImgTxt(Line : string; out ChartNum, Location,
786 FName, LName, MName, Sex, DOB, DOS, Provider,
787 Title : string; FilePaths : TStrings);
788 //format of line is as follows:
789 //ChartNum^Location^FName^LName^MName^Sex^DOB^DOS^Provider^Title^FilePath(s)
790 //NOTE: To provide patient IEN instead of FName etc, use this format:
791 // ^Location^^`1234567^^^^DOS^Provider^Title^FilePath(s)
792 // i.e. `IEN (note ` is not an appostrophy ('))
793 // `IEN in place of LName, and leave blank: ChartNum,FName,FName,Sex,DOB
794
795 var Files: String;
796 FileName : String;
797 num,i : integer;
798 begin
799 if Pos('}',Line)>0 then begin
800 Line := Piece(Line,'}',2); //If error message is present, still allow parse.
801 end;
802 ChartNum := Piece(Line,'^',1);
803 Location := Piece(Line,'^',2);
804 FName := Piece(Line,'^',3);
805 LName := Piece(Line,'^',4);
806 MName := Piece(Line,'^',5);
807 Sex := Piece(Line,'^',6);
808 DOB := Piece(Line,'^',7);
809 DOS := Piece(Line,'^',8);
810 Provider := Piece(Line,'^',9);
811 Title := Piece(Line,'^',10);
812 Files := Piece(Line,'^',11); //may be list of multiple files separated by ;
813 if Pos(';',Files)>0 then begin
814 num := NumPieces(Files,';');
815 for i := 1 to num do begin
816 FileName := piece(files,';',i);
817 if FileName <> '' then FilePaths.Add(FileName);
818 end;
819 end else begin
820 FilePaths.Add(Files);
821 end;
822
823 end;
824
825 function TUploadForm.EncodeImgTxt(ChartNum, Location, FName, LName, MName, Sex, DOB,
826 DOS, Provider, Title : string; FilePaths : TStrings) : AnsiString;
827 //format of line is as follows:
828 //ChartNum^Location^FName^LName^MName^Sex^DOB^DOS^Provider^Title^FilePath(s)
829 //NOTE: To provide patient IEN instead of FName etc, use this format:
830 // ^Location^^`1234567^^^^DOS^Provider^Title^FilePath(s)
831 // i.e. `IEN (note ` is not an appostrophy ('))
832 // `IEN in place of LName, and leave blank: ChartNum,FName,FName,Sex,DOB
833 var i : integer;
834 begin
835 Result := ChartNum + '^' + Location + '^' + FName + '^' + LName + '^' +
836 MName + '^' + Sex + '^' + DOB + '^' + DOS + '@01:00' + '^' + Provider + '^' +
837 Title + '^'; //added time of 1:00 elh 7/8/08
838 for i:= 0 to FilePaths.Count-1 do begin
839 Result := Result + FilePaths.Strings[i];
840 if i <> FilePaths.Count-1 then Result := Result + ';';
841 end;
842 end;
843
844
845 procedure TUploadForm.FinishDocument(UploadNote : TAutoUploadNote);
846 var Text : TStringList;
847 ErrMsg : String;
848 RPCResult : String;
849 i : integer;
850 oneImage: string;
851 //TIUIEN : int64;
852
853 begin
854 if (UploadNote.TIUIEN>0) and (UploadNote.CurNoteImages.Count>0)
855 and (UploadNote.UploadError = False) then begin
856 //Add text for note: "See scanned image" --
857 // or later, some HTML code to show note in CPRS directly....
858 Text := TStringList.Create;
859 Text.Add('<!DOCTYPE HTML PUBLIC>');
860 Text.Add('<html>');
861 Text.Add('<head>');
862 Text.Add('<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">');
863 Text.Add('<title>VistA HTML Note</title>');
864 Text.Add('</head>');
865 Text.Add('<body>');
866 Text.Add('<p>');
867 Text.Add('Note created automatically from imported media.');
868 Text.Add('<p>');
869 for i := 0 to UploadNote.CurNoteImages.Count-1 do begin
870 // note: $CPRSDIR$ will be replaced at runtime with directory of CPRS
871 // This will be done as page is passed to TWebBrowser (in rHTMLTools)
872 oneImage := '$CPRSDIR$\Cache\' + UploadNote.CurNoteImages.Strings[i];
873 //oneImage := CacheDir + '\' + CurNoteImages.Strings[i];
874 Text.Add('<img WIDTH=640 src="'+oneImage+'">');
875 Text.Add('<p>');
876 end;
877 //Text.Add('<small>');
878 //Text.Add('If images don''t display, first view them in IMAGES tab.<br>');
879 //Text.Add('Then return here, click on note and press [F5] key to refresh.');
880 //Text.Add('</small>');
881 //Text.Add('<p>');
882 Text.Add('</body>');
883 Text.Add('</html>');
884 Text.Add(' ');
885 rTIU.SetText(ErrMsg,Text,UploadNote.TIUIEN,0); //elh changed from 1 to 0 //1=commit data, do actual save.
886 Text.Free;
887 //Here I autosign -- later make this optional?
888 RPCBrokerV.ClearParameters := true;
889 RPCBrokerV.remoteprocedure := 'TMG AUTOSIGN TIU DOCUMENT';
890 RPCBrokerV.param[0].value := IntToStr(UploadNote.TIUIEN);
891 RPCBrokerV.param[0].ptype := literal;
892 //RPCBrokerV.Call;
893 CallBroker;
894 if RPCBrokerV.Results.Count > 0 then begin
895 RPCResult := RPCBrokerV.Results[0]; //returns: error: -1; success=1
896 end else begin
897 RPCResult := '-1';
898 end;
899 if RPCResult='-1' then begin
900 MessageDlg('Unable to set status for scanned document to SIGNED',mtError,[mbOK],0);
901 end;
902 UploadNote.TIUIEN := 0;
903 end;
904 UploadNote.Clear;
905 end;
906
907
908 function TUploadForm.ProcessOneLine(Line : string) : string;
909 //Returns: if success, ''; if failure, returns reason
910
911 //format of line is as follows:
912 //ChartNum^Location^FName^LName^MName^Sex^DOB^DOS^Provider^Title^FilePath(s)
913 //NOTE: To provide patient IEN instead of FName etc, use this format:
914 // ^Location^^`1234567^^^^DOS^Provider^Title^FilePath(s)
915 // i.e. `IEN (note ` is not an appostrophy ('))
916 // `IEN in place of LName, and leave blank: ChartNum,FName,FName,Sex,DOB
917
918 var
919 ChartNum,FName,LName,MName,Sex,DOB : String;
920 DOS,Provider,Title : String;
921 ThisNote : TAutoUploadNote;
922 FilePaths : TStringList;
923 i : integer;
924 Location : string;
925
926 begin
927 Result := ''; //default to success for function
928 ThisNote := TAutoUploadNote.Create;
929 FilePaths := TStringList.Create();
930 DecodeImgTxt(Line, ChartNum, Location, FName, LName, MName, Sex, DOB, DOS, Provider, Title, FilePaths);
931
932 ThisNote.SetDFN(ChartNum,Location,FName,LName,MName,DOB,Sex);
933 ThisNote.SetInfo(DOS,Provider,Location,Title);
934 if Pos('//Failed',Line)>0 then ThisNote.UploadError := true;
935 if ThisNote.IsValid then begin //A note can be 'Valid' and still have an 'UploadError'
936 if ThisNote.SameAs(AutoUploadNote)= false then begin
937 ThisNote.TIUIEN := AutoUploadNote.TIUIEN;
938 FinishDocument(AutoUploadNote); // Close and clear any existing note
939 AutoUploadNote.InitFrom(ThisNote);
940 Result := AutoUploadNote.ErrMsg; //'' if no error
941 end;
942 if ThisNote.UploadError then AutoUploadNote.UploadError := true;
943 if (AutoUploadNote.UploadError=false) then for i := 0 to FilePaths.Count-1 do begin
944 AutoUploadNote.ImageInfo.pLongDesc := nil;
945 //Load up info record with data for upload
946 AutoUploadNote.ImageInfo.ShortDesc := 'Scanned document';
947 AutoUploadNote.ImageInfo.UploadDUZ := User.DUZ;
948 AutoUploadNote.ImageInfo.ObjectType := 1; //type 1 is Still Image (jpg). OK to use with .bmp??
949 AutoUploadNote.ImageInfo.ProcName := 'Scanned'; //max length is 10 characters
950 AutoUploadNote.ImageInfo.ImageDateTime := DOS;
951 AutoUploadNote.ImageInfo.TIUIEN := AutoUploadNote.TIUIEN;
952 AutoUploadNote.ImageInfo.UploadDateTime := 'NOW';
953 AutoUploadNote.ImageInfo.DFN := AutoUploadNote.Patient.DFN;
954 AutoUploadNote.ImageInfo.ImageFPathName := FilePaths.Strings[i];
955 AutoUploadNote.ImageInfo.Extension := ExtractFileExt(AutoUploadNote.ImageInfo.ImageFPathName); //includes '.'
956 AutoUploadNote.ImageInfo.Extension := MidStr(AutoUploadNote.ImageInfo.Extension,2,17); //remove '.'
957 if not UploadFile(AutoUploadNote.ImageInfo,true) then begin //Upload function passes back filename info in Info class
958 Result := 'ERROR UPLOADING IMAGE FILE';
959 end;
960 AutoUploadNote.CurNoteImages.Add(AutoUploadNote.ImageInfo.ServerFName);
961 end else begin
962 If Result='' then Result := '(Error found in earlier file entry in batch)';
963 end;
964 end else begin
965 Result := 'NOTE INFO INVALID (Probably: PATIENT NOT FOUND)';
966 end;
967 FilePaths.Free;
968 ThisNote.Free;
969 end;
970
971
972 function TUploadForm.ProcessOneFile(FileName : string) : boolean;
973 //This will process image(s) indicated in textfile FileName
974 //After uploading image to server, textfile and specified images are deleted
975 //Returns Success
976 //Note: To upload multiple images into one document, one may add multiple
977 // lines to the ImgTxt text file. As long as the info is the same
978 // (i.e. same provider, patient, note type, DOS etc) then they
979 // will be appended to current note.
980 // OR, add multiple image file names to one line.
981 // -- the problem with multiple images on one line is that errors
982 // can not be reported for just one image. It will be ONE for any/all
983 // OR, if the next file in process-order is still has the same info as
984 // the prior file, then it will be appended.
985 var
986 Lines : TStringList;
987 i : integer;
988 ResultStr : string;
989 OneLine : string;
990 begin
991 Result := true; //default is Success=true
992 Lines := TStringList.Create;
993 Lines.LoadFromFile(FileName);
994 //FinishDocument(AutoUploadNote); //will save and clear any old data.
995 for i := 0 to Lines.Count-1 do begin
996 OneLine := Lines.Strings[i];
997 ResultStr := ProcessOneLine(OneLine); //Even process with //failed markeers (to preserve batches)
998 if Pos('//Failed',OneLine)> 0 then begin //If we already have //Failed, don't duplicate another Error Msg
999 Result := false; //prevent deletion of file containing //Failed//
1000 end else begin
1001 if ResultStr <> '' then begin
1002 Lines.Strings[i] := '//Failed: '+ResultStr+'}'+Lines.Strings[i];
1003 Lines.SaveToFile(FileName);
1004 Result := false;
1005 end;
1006 end;
1007 end;
1008 //Temp, for debugging
1009 //Lines.SaveToFile(ChangeFileExt(FileName,'.imgtxt-bak'));
1010 //end temp
1011 Lines.free;
1012 end;
1013
1014
1015 procedure TUploadForm.ScanAndHandleImgTxt;
1016 var
1017 FoundFile : string;
1018 Found : TSearchRec;
1019 FilesList : TStringList;
1020 i : integer;
1021 result : boolean;
1022 begin
1023 //NOTE: Later I may make this spawn a separate thread, so that
1024 // user doesn't encounter sudden unresponsiveness of CPRS
1025 //I can use BeginThread, then EndTread
1026 //Issues: ProcessOneFile would probably have to be a function
1027 // not in a class/object...
1028
1029 FilesList := TStringList.Create;
1030
1031 //scan for new *.ImgTxt file
1032 //FindFirst may not have correct order, so collect all names and then sort.
1033 if FindFirst(FScanDir+'*.imgtxt',faAnyFile,Found)=0 then repeat
1034 FilesList.Add(FScanDir+Found.Name);
1035 until FindNext(Found) <> 0;
1036 FindClose(Found);
1037 FilesList.Sort; //puts filenames in alphanumeric order
1038
1039 //Now process images in correct order.
1040 for i := 0 to FilesList.Count-1 do begin
1041 FoundFile := FilesList.Strings[i];
1042 if ProcessOneFile(FoundFile) = true then begin {process *.imgtxt file}
1043 DeleteFile(FoundFile);
1044 FoundFile := ChangeFileExt(FoundFile,'.barcode.txt');
1045 DeleteFile(FoundFile);
1046 end; //Note: it is OK to continue, to get other non-error notes afterwards.
1047 end;
1048 FinishDocument(AutoUploadNote); // Close and clear any existing note
1049 FilesList.Free
1050 end;
1051
1052
1053 procedure TUploadForm.ScanAndHandleImages;
1054 (* Overview of mechanism of action of automatically uploading images.
1055 =================================================================
1056 -- For an image to be uploaded, it must first be positively identified.
1057 This can occur 1 of two ways:
1058 -- the image contains a datamatrix barcode.
1059 -- the image is part of a batch, and the first image of the batch
1060 contains a barcode for the entire batch.
1061 -- At our site, the scanner program automatically names the files numerically
1062 so that sorting on the name will put them in proper order when working
1063 with batches.
1064 -- The decoding of the barcode requires a special program. I was not
1065 able to find a way to run this on the Windows client. I found the
1066 libdmtx that does this automatically. It currently is on unix only.
1067 It was too complicated for me to compile it for windows. I initially
1068 wanted everything to run through the RPC broker. This involved
1069 uploading the image to the linux server, running the decoder on the
1070 server, then passing the result back. The code for this is still avail
1071 in this CPRS code. However, the process was too slow and I had to
1072 come up with something faster. So the following arrangement was setup
1073 -- scanned images are stored in a folder that was shared by both the
1074 windows network (and thus is available to CPRS), and the linux server.
1075 -- At our site, we used a copier/scanner unit that created only TIFF
1076 files. These are not the needed format for the barcode decoder, so...
1077 -- a cron job runs on the linux server that converts the .tif files
1078 to .png. Here is that script:
1079 <removed due to frequent changes...>
1080 ---------------------------------
1081 -- Next the .png files must be checked for a barcode. Another cron
1082 task scans a directory for .png files and creates a metafile for
1083 the file giving its barcode reading, or a marker that there is
1084 no barcode available for that image. The file name format is:
1085 *.barcode.txt, with the * coorelating to filename of the image.
1086 -- The decoding process can take some time (up to several minutes
1087 per image.
1088 -- A flag file named barcodeRead.working.txt is created when the
1089 script is run, and deleted when done. So if this file is present
1090 then the decoding process is not complete.
1091 -- if a *.barcode.txt file is present, then no attempts will be made
1092 to decode the image a second time.
1093 -- CPRS still contains code to upload an image to look for a barcode.
1094 At this site, only png's will contain barcodes, so I have commented
1095 out support for automatically uploading other file formats.
1096 -- Here is the unix bash script that decodes the barcodes. It is
1097 launched by cron:
1098 ---------------------------------
1099 <removed due to frequent changes...>
1100 ---------------------------------
1101 -- After the *.png images are available, and no flag files are present
1102 to indicate that the server is working with the files, then the images
1103 are processed, using the barcode metafiles. This is triggered by a
1104 timer in CPRS. It essentially converts imagename + barcode data -->
1105 --> *.imgtxt.
1106 -- For each *.png image, there will be a *.imgtxt metafile created. This
1107 will contain information needed by the server, in a special format for
1108 the RPC calls. When an *.imgtxt file is present, this is a flag that
1109 the image is ready to be uploaded.
1110 -- A timer in CPRS scans for *.imgtxt files. When found, it uploads the
1111 image to the server and creates a container progress note for displaying
1112 it in CPRS.
1113 *)
1114
1115 procedure ScanOneImageType(ImageType : string);
1116 //Scan directory for all instances of images of type ImageType
1117 //For each one, create a metadata file (if not already present)
1118
1119 //Note: Batch mode only works for a batch of file ALL OF THE SAME TYPE.
1120 //I.e. There can't be a batch of .jpg, then .gif, then .bmp. This is
1121 //because a scanner, if it is scanning a stack of documents for a given
1122 //patient will produce all files in the same ImageType
1123
1124 function DeltaMins(CurrentTime,PriorTime : TDateTime) : integer;
1125 //Return ABSOLUTE difference in minutes between Current <--> Prior.
1126 //NOTE: if value is > 1440, then 1440 is returned
1127 var DeltaDays,FracDays : double;
1128 begin
1129 DeltaDays := abs(CurrentTime-PriorTime);
1130 FracDays := DeltaDays - Round(DeltaDays);
1131 if DeltaDays>1 then FracDays := 1;
1132 Result := Round((60*24)*FracDays);
1133 end;
1134
1135 var
1136 FoundFile : string;
1137 MetaFilename : string;
1138 Found : TSearchRec;
1139 BarCodeData : AnsiString;
1140 DFN,DOS,AuthIEN,LocIEN,NoteTypeIEN : string;
1141 OneLine : string;
1142 FilePaths : TStringList;
1143 AllFiles : TStringList;
1144 OutFileLines : TStringList;
1145 BatchS : string;
1146 tempCount : integer;
1147 BatchFInfo : TFileInfo;
1148 LastFileTimeStamp,CurFileTimeStamp : TDateTime;
1149 DeltaMinutes : integer;
1150 pFInfo : TFileInfo;
1151 i : integer;
1152 Label AbortPoint;
1153
1154 const
1155 ALLOWED_TIME_GAP = 2; //time in minutes
1156
1157 begin
1158 FilePaths := TStringList.Create;
1159 OutFileLines := TStringList.Create;
1160 AllFiles := TStringList.Create;
1161 BatchFInfo := TFileInfo.Create;
1162
1163 //NOTE: Later I may make this spawn a separate thread, so that
1164 // user doesn't encounter sudden unresponsiveness of CPRS
1165 //I can use BeginThread, then EndTread
1166 //Issues: ProcessOneFile would probably have to be a function
1167 // not in a class/object...
1168
1169 //scan for all instances *.ImageType Image file
1170 //Store info for processesing after loop
1171 //Do this as a separate step, so files can be processed in proper order
1172 if FindFirst(FScanDir+'*.'+ImageType,faAnyFile,Found)=0 then repeat
1173 FoundFile := FScanDir+Found.Name;
1174 if FileExists(ChangeFileExt(FoundFile,'.imgtxt')) then continue;
1175 MetaFilename := ChangeFileExt(FoundFile,'.barcode.txt');
1176 pFInfo := TFileInfo.Create; //will be owned by AllFiles
1177 pFInfo.MetaFileName := MetaFilename;
1178 pFInfo.FPath := FoundFile;
1179 pFInfo.SrcRec := Found;
1180 pFInfo.STimeStamp := FloatToStr(FileDateToDateTime(Found.Time));
1181 pFInfo.MetaFileExists := FileExists(MetaFilename);
1182 pFInfo.SBarCode := ''; //default to empty.
1183 pFInfo.BatchCount := 0;
1184 if pFInfo.MetaFileExists = false then begin
1185 //Call server via RPC to decode Barcode
1186 //This is too slow and buggy. Will remove for now...
1187 //BarCodeData := frmImages.DecodeBarcode(FoundFile,ImageType);
1188 //pFInfo.SBarCode := BarCodeData;
1189 pFInfo.SBarCode := '';
1190 //Here I could optionally create a Metafile for processing below.
1191 end;
1192 if pFInfo.MetaFileExists then begin //Retest in case RPC changed status.
1193 if FileExists(FScanDir+'barcodeRead.working.txt') then goto AbortPoint;
1194 OutFileLines.LoadFromFile(pFInfo.MetaFileName);
1195 if OutFileLines.Count>0 then begin
1196 pFInfo.SBarCode := OutFileLines.Strings[0];
1197 //convert 'No Barcode message into an empty string, to match existing code.
1198 if Pos('//',pFInfo.SBarCode)=1 then pFInfo.SBarCode := '';
1199 if NumPieces(pFInfo.SBarCode,'-') <> 8 then pFInfo.SBarCode := '';
1200 end else begin
1201 pFInfo.MetaFileExists := false; //set empty file to Non-existence status
1202 end;
1203 end;
1204 AllFiles.AddObject(pFInfo.FPath,pFInfo); //Store filename, to allow sorting on this.
1205 until FindNext(Found) <> 0;
1206 AllFiles.Sort; // Sort on timestamp --> put in ascending alpha filename order
1207
1208 //-------- Now, process files in name order ------------
1209 LastFileTimeStamp := 0;
1210 BatchFInfo.BatchCount := 0;
1211 for i := 0 to AllFiles.Count-1 do begin
1212 pFInfo := TFileInfo(AllFiles.Objects[i]);
1213 if pFInfo.MetaFileExists = false then continue;
1214 CurFileTimeStamp := FileDateToDateTime(pFInfo.SrcRec.Time);
1215 DeltaMinutes := DeltaMins(CurFileTimeStamp,LastFileTimeStamp);
1216 // *.barcode.txt file exists at this point
1217 if pFInfo.SBarCode <> '' then begin //Found a new barcode
1218 LastFileTimeStamp := CurFileTimeStamp;
1219 //Note: The expected format of barcode must be same as that
1220 // created by TfrmPtLabelPrint.PrintButtonClick:
1221 // 70685-12-31-2008-73-6-1302-0
1222 // PtIEN-DateOfService-AuthorIEN-LocIEN-NoteTypeIEN-BatchFlag
1223 // THUS there should be 8 pieces in the string.
1224 DFN := piece(pFInfo.SBarCode,'-',1);
1225 DOS := pieces(pFInfo.SBarCode,'-',2,4);
1226 AuthIEN := piece(pFInfo.SBarCode,'-',5);
1227 LocIEN := piece(pFInfo.SBarCode,'-',6);
1228 NoteTypeIEN := piece(pFInfo.SBarCode,'-',7);
1229 BatchS := piece(pFInfo.SBarCode,'-',8);
1230 if BatchS = '*' then begin
1231 pFInfo.BatchCount := 9999
1232 end else begin
1233 try
1234 pFInfo.BatchCount := StrToInt(BatchS);
1235 except
1236 on E:EConvertError do begin
1237 pFInfo.BatchCount := 1;
1238 end;
1239 end;
1240 end;
1241 //BatchFInfo.SBarCode := pFInfo.SBarCode;
1242 end else if (BatchFInfo.BatchCount > 0) then begin
1243 if (DeltaMinutes > ALLOWED_TIME_GAP) then begin
1244 pFInfo.Clear;
1245 BatchFInfo.Clear;
1246 end else begin
1247 //Apply barcode from last image onto this one (from same batch)
1248 pFInfo.SBarCode := BatchFInfo.SBarCode;
1249 end;
1250 end;
1251 if pFInfo.SBarCode <> '' then begin
1252 //Success --> write out ImgTxt file...
1253 FilePaths.Add(pFInfo.FPath);
1254 OneLine := EncodeImgTxt('', '`'+LocIEN,'', '`'+DFN, '', '', '',
1255 DOS,'`'+AuthIEN, '`'+NoteTypeIEN, FilePaths);
1256 if pFInfo.BatchCount>0 then begin
1257 //A BATCH marker has been found on current barcode. This means that
1258 //Batchmode should be turned on. This will apply current barcode
1259 //data to any subsequent images, providing there is not a gap in
1260 //time > ALLOWED_TIME_GAP
1261 BatchFInfo.Assign(pFInfo); //reset Batch info to current
1262 end;
1263 //Decrease use count of Batch Info
1264 Dec(BatchFInfo.BatchCount);
1265 end else begin
1266 OneLine := '';
1267 end;
1268 OutFileLines.Clear;
1269 if OneLine <> '' then begin
1270 OutFileLines.Add(OneLine);
1271 OutFileLines.SaveToFile(ChangeFileExt(pFInfo.FPath,'.imgtxt'));
1272 end;
1273 FilePaths.Clear;
1274 OutFileLines.Clear;
1275 LastFileTimeStamp := CurFileTimeStamp;
1276 end;
1277AbortPoint:
1278 FindClose(Found);
1279 BatchFInfo.Free;
1280 FilePaths.Free;
1281 for i := 0 to AllFiles.Count-1 do begin //free owned objects
1282 pFInfo := TFileInfo(AllFiles.Objects[i]);
1283 pFInfo.Free;
1284 end;
1285 AllFiles.Free;
1286 OutFileLines.Free;
1287 end;
1288
1289 var flag1Filename,flag2Filename : string;
1290 begin
1291 flag1Filename := FScanDir+'barcodeRead.working.txt';
1292 flag2Filename := FScanDir+'convertTif2Png.working.txt';
1293 //if linux server is in middle of a conversion or barcode decode, then skip.
1294 if (FileExists(flag1Filename)=false) and (FileExists(flag2Filename)=false) then begin
1295 (* Remove {}'s to be able to have jpg's etc that contain barcodes
1296 In our site, only png's will have barcodes, and thus these are the
1297 only images that can be uploaded automatically. Uploading jpg's, bmp's
1298 etc to look for (nonexistent) barcodes will just waste time and bandwidth. *)
1299 {
1300 ScanOneImageType('jpg');
1301 ScanOneImageType('jpeg');
1302 ScanOneImageType('gif');
1303 ScanOneImageType('bmp');
1304 }
1305 //ScanOneImageType('tif'); {Tiff was not showing up in IE for some reason}
1306 //ScanOneImageType('tiff'); {Tiff was not showing up in IE for some reason}
1307 ScanOneImageType('png');
1308 end;
1309 end;
1310
1311 procedure TUploadForm.PolTimerTimer(Sender: TObject);
1312 begin
1313 PolTimer.Enabled := false;
1314 try
1315 if Assigned(frmImages) and frmImages.AutoScanUpload.Checked then begin
1316 ScanAndHandleImages; //create metadata for images (if not done already)
1317 ScanAndHandleImgTxt; //process upload file, based on metadata
1318 end;
1319 finally
1320 PolTimer.Enabled := true;
1321 PolTimer.Interval := PolInterval;
1322 end;
1323 end;
1324
1325 procedure TUploadForm.SetAllowNonImages(Value : boolean);
1326 begin
1327 FAllowNonImages := Value;
1328 btnPickPDF.Enabled := Value;
1329 PickOtherButton.Enabled := Value;
1330 end;
1331
1332
1333
1334end.
Note: See TracBrowser for help on using the repository browser.