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

Last change on this file since 736 was 729, checked in by Kevin Toppenberg, 15 years ago

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