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

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

Corrected HTML line feed
File size: 52.4 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 frmImages.NumImagesAvailableOnServer := NOT_YET_CHECKED_SERVER; //Forces re-query of server
586 end;
587
588 procedure TUploadForm.LoadNotesEdit();
589 begin
590 NoteEdit.Text := frmNotes.tvNotes.Selected.Text;
591 end;
592
593 {
594 procedure TUploadForm.LoadNotesList();
595 var
596 NoteInfo,s,dateS : AnsiString;
597 i : integer;
598 const
599 U='^';
600 begin
601 NoteComboBox.Items.Clear;
602
603 for i := 0 to frmNotes.lstNotes.Count-1 do with frmNotes.lstNotes do begin
604 NoteInfo := Items[i];
605 (* example NoteInfo:
606 piece# 1: 14321^ //TIU IEN
607 piece# 2: PRESCRIPTION CALL IN^ //Document Title
608 piece# 3: 3050713.0947^ //Date/Time
609 piece# 4: TEST, KILLME D (T0101)^ //Patient
610 piece# 5: 133;JANE A DOE;DOE,JANE A^ //Author
611 piece# 6: Main_Office^ //Location of Visit
612 piece# 7: completed^ //Status of Document
613 piece# 8: Visit: 07/13/05;3050713.094721^ //Date/Time
614 piece# 9...: ;^^1^^^1^' //?
615 *)
616 dateS := Piece(Piece(NoteInfo, U, 8), ';', 2);
617 s := FormatFMDateTime('mmm dd,yy@hh:nn', MakeFMDateTime(dateS)) + ' -- ';
618 // s := Piece(Piece(NoteInfo, U, 8), ';', 1) + ' -- ';
619 s := s + Piece(NoteInfo, U, 2) + '; ';
620 s := s + 'Author: ' + Piece(Piece(NoteInfo, U, 5), ';', 2) + ', ';
621 s := s + Piece(NoteInfo, U, 6);
622 NoteComboBox.Items.Add(s);
623 end;
624 NoteComboBox.ItemIndex := frmNotes.lstNotes.ItemIndex;
625 end;
626 }
627 //Delphi events etc.------------------------------------------------
628
629 procedure TUploadForm.UploadButtonClick(Sender: TObject);
630 begin
631 try
632 WebBrowser.Navigate(frmImages.NullImageName);
633 sleep(500); //Give Webbrowser time to release any browsed document.
634 except
635 on E: Exception do exit;
636 end;
637 UploadChosenFiles();
638 //note This UploadButton has .ModalResult = mrOK, so form is closed after this.
639 end;
640
641 procedure TUploadForm.PickImagesButtonClick(Sender: TObject);
642 var i : integer;
643 begin
644 If OpenDialog.Execute then begin
645 for i := 0 to OpenDialog.Files.Count-1 do begin
646 FilesToUploadList.Items.Add(OpenDialog.Files.Strings[i]);
647 end;
648 end;
649 end;
650
651 procedure TUploadForm.PickOtherButtonClick(Sender: TObject);
652 var i : integer;
653 begin
654 If OpenFileDialog.Execute then begin
655 for i := 0 to OpenFileDialog.Files.Count-1 do begin
656 FilesToUploadList.Items.Add(OpenFileDialog.Files.Strings[i]);
657 end;
658 end;
659 end;
660
661 procedure TUploadForm.btnPickPDFClick(Sender: TObject);
662 var i : integer;
663 begin
664 if not Assigned(frmImagePickPDF) then begin
665 frmImagePickPDF := TfrmImagePickPDF.Create(Self); //free'd in OnHide
666 end;
667 if frmImagePickPDF.Execute then begin
668 for i := 0 to frmImagePickPDF.Files.Count-1 do begin
669 FilesToUploadList.Items.Add(frmImagePickPDF.Files.Strings[i]);
670 end;
671 end;
672 end;
673
674 procedure TUploadForm.FormShow(Sender: TObject);
675 begin
676 FormRefresh(self);
677 FilesToUploadList.Items.Clear;
678 FUploadedImagesList.Clear;
679 LoadNotesEdit();
680 SetupVars;
681 ShortDescEdit.Text := DefShortDesc;
682 end;
683
684 procedure TUploadForm.ShortDescEditChange(Sender: TObject);
685 begin
686 if Length(ShortDescEdit.Text)> 60 then begin
687 ShortDescEdit.Text := MidStr(ShortDescEdit.Text,1,60);
688 end;
689 end;
690
691 procedure TUploadForm.ClearImagesButtonClick(Sender: TObject);
692 begin
693 FilesToUploadList.Items.Clear;
694 FilesToUploadListClick(self);
695 end;
696
697 procedure TUploadForm.FormCreate(Sender: TObject);
698 begin
699 Bitmap := TBitmap.Create;
700 Bitmap.Height := 64;
701 Bitmap.Width := 64;
702 Picture := TPicture.Create;
703 FAllowNonImages := true;
704 FUploadedImagesList := TStringList.Create;
705
706 AutoUploadNote := TAutoUploadNote.Create;
707 FScanDir := uTMGOptions.ReadString('Pol Directory','??');
708 if FScanDir='??' then begin
709 FScanDir := ExtractFileDir(Application.ExeName);
710 uTMGOptions.WriteString('Pol Directory',FScanDir);
711 end;
712 PolInterval := uTMGOptions.ReadInteger('Pol Interval (milliseconds)',0);
713 if PolInterval=0 then begin
714 PolInterval := 60000;
715 uTMGOptions.WriteInteger('Pol Interval (milliseconds)',PolInterval);
716 end;
717 end;
718
719 procedure TUploadForm.SetScanDir(NewDir : string);
720 begin
721 if DirectoryExists(NewDir) then begin
722 FScanDir := NewDir;
723 uTMGOptions.WriteString('Pol Directory',FScanDir);
724 end;
725 end;
726
727 procedure TUploadForm.FormDestroy(Sender: TObject);
728 begin
729 Bitmap.Free;
730 Picture.Free;
731 FUploadedImagesList.Free;
732 end;
733
734 procedure TUploadForm.FilesToUploadListClick(Sender: TObject);
735 var
736 FileName: AnsiString;
737 SelectedItem: integer;
738 begin
739 SelectedItem := FilesToUploadList.ItemIndex;
740 if SelectedItem > -1 then begin
741 FileName := FilesToUploadList.Items[SelectedItem];
742 if UpperCase(ExtractFileExt(FileName))='.PDF' then begin
743 FileName := CopyFileToTemp(FileName); //returns '' if copy fails
744 if FileName = '' then FileName := frmImages.NullImageName;
745 end;
746 end else begin
747 FileName := frmImages.NullImageName;
748 end;
749 try
750 WebBrowser.Navigate(FileName);
751 except
752 on E: Exception do exit;
753 end;
754 end;
755
756 function TUploadForm.CopyFileToTemp(FNamePath : string) : string;
757 var DestFile : string;
758 lpDestFile : PAnsiChar;
759 lpSourceFile : PAnsiChar;
760 begin
761 DestFile := frmImages.CacheDir + '\tempbrowseable' + ExtractFileExt(FNamePath);
762 lpDestFile := PAnsiChar(DestFile);
763 lpSourceFile := PAnsiChar(FNamePath);
764 if CopyFile(lpSourcefile,lpDestFile,LongBool(FALSE)) = TRUE then begin //0=success
765 Result := DestFile;
766 end else begin
767 Result := '';
768 end;
769 end;
770
771 procedure TUploadForm.FormRefresh(Sender: TObject);
772 begin
773 try
774 WebBrowser.Navigate(frmImages.NullImageName);
775 except
776 on E: Exception do exit;
777 end;
778 end;
779
780 procedure TUploadForm.FormHide(Sender: TObject);
781 begin
782 FormRefresh(Sender);
783 frmImagePickPDF.Free;
784 frmImagePickPDF := nil;
785 end;
786
787 procedure TUploadForm.DecodeImgTxt(Line : string; out ChartNum, Location,
788 FName, LName, MName, Sex, DOB, DOS, Provider,
789 Title : string; FilePaths : TStrings);
790 //format of line is as follows:
791 //ChartNum^Location^FName^LName^MName^Sex^DOB^DOS^Provider^Title^FilePath(s)
792 //NOTE: To provide patient IEN instead of FName etc, use this format:
793 // ^Location^^`1234567^^^^DOS^Provider^Title^FilePath(s)
794 // i.e. `IEN (note ` is not an appostrophy ('))
795 // `IEN in place of LName, and leave blank: ChartNum,FName,FName,Sex,DOB
796
797 var Files: String;
798 FileName : String;
799 num,i : integer;
800 begin
801 if Pos('}',Line)>0 then begin
802 Line := Piece(Line,'}',2); //If error message is present, still allow parse.
803 end;
804 ChartNum := Piece(Line,'^',1);
805 Location := Piece(Line,'^',2);
806 FName := Piece(Line,'^',3);
807 LName := Piece(Line,'^',4);
808 MName := Piece(Line,'^',5);
809 Sex := Piece(Line,'^',6);
810 DOB := Piece(Line,'^',7);
811 DOS := Piece(Line,'^',8);
812 Provider := Piece(Line,'^',9);
813 Title := Piece(Line,'^',10);
814 Files := Piece(Line,'^',11); //may be list of multiple files separated by ;
815 if Pos(';',Files)>0 then begin
816 num := NumPieces(Files,';');
817 for i := 1 to num do begin
818 FileName := piece(files,';',i);
819 if FileName <> '' then FilePaths.Add(FileName);
820 end;
821 end else begin
822 FilePaths.Add(Files);
823 end;
824
825 end;
826
827 function TUploadForm.EncodeImgTxt(ChartNum, Location, FName, LName, MName, Sex, DOB,
828 DOS, Provider, Title : string; FilePaths : TStrings) : AnsiString;
829 //format of line is as follows:
830 //ChartNum^Location^FName^LName^MName^Sex^DOB^DOS^Provider^Title^FilePath(s)
831 //NOTE: To provide patient IEN instead of FName etc, use this format:
832 // ^Location^^`1234567^^^^DOS^Provider^Title^FilePath(s)
833 // i.e. `IEN (note ` is not an appostrophy ('))
834 // `IEN in place of LName, and leave blank: ChartNum,FName,FName,Sex,DOB
835 var i : integer;
836 begin
837 Result := ChartNum + '^' + Location + '^' + FName + '^' + LName + '^' +
838 MName + '^' + Sex + '^' + DOB + '^' + DOS + '@01:00' + '^' + Provider + '^' +
839 Title + '^'; //added time of 1:00 elh 7/8/08
840 for i:= 0 to FilePaths.Count-1 do begin
841 Result := Result + FilePaths.Strings[i];
842 if i <> FilePaths.Count-1 then Result := Result + ';';
843 end;
844 end;
845
846
847 procedure TUploadForm.FinishDocument(UploadNote : TAutoUploadNote);
848 var Text : TStringList;
849 ErrMsg : String;
850 RPCResult : String;
851 i : integer;
852 oneImage: string;
853 //TIUIEN : int64;
854
855 begin
856 if (UploadNote.TIUIEN>0) and (UploadNote.CurNoteImages.Count>0)
857 and (UploadNote.UploadError = False) then begin
858 //Add text for note: "See scanned image" --
859 // or later, some HTML code to show note in CPRS directly....
860 Text := TStringList.Create;
861 Text.Add('<!DOCTYPE HTML PUBLIC>');
862 Text.Add('<html>');
863 Text.Add('<head>');
864 Text.Add('<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">');
865 Text.Add('<title>VistA HTML Note</title>');
866 Text.Add('</head>');
867 Text.Add('<body>');
868 Text.Add('<p>');
869 Text.Add('Note created automatically from imported media.');
870 Text.Add('<p>');
871 for i := 0 to UploadNote.CurNoteImages.Count-1 do begin
872 // note: CPRS_DIR_SIGNAL ('$CPRSDIR$') will be replaced at runtime with directory of CPRS
873 // This will be done as page is passed to TWebBrowser (in rHTMLTools)
874 oneImage := CPRS_CACHE_DIR_SIGNAL + UploadNote.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.