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

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

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