Changeset 729 for cprs/branches/tmg-cprs/CPRS-Chart/UploadImages.pas
- Timestamp:
- Mar 31, 2010, 5:06:56 PM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
cprs/branches/tmg-cprs/CPRS-Chart/UploadImages.pas
r453 r729 7 7 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 8 8 Dialogs, StdCtrls, Buttons, ExtCtrls, pngimage, ExtDlgs, OleCtrls, 9 uCore, 9 10 SHDocVw, DKLang; 10 11 11 12 type 12 TUploadImageInfo = class 13 14 TImageInfo = class 13 15 private 14 16 public 15 TIUIEN : int64; //IEN in file# 892516 DFN : AnsiString; 17 UploadDUZ : int64; 17 TIUIEN : int64; //IEN in file# 8925 18 DFN : AnsiString; //IEN in Patient File (#2) 19 UploadDUZ : int64; //IEN in NEW PERSON file 18 20 ThumbFPathName : AnsiString; // local file path name 19 ImageFPathName : AnsiString; 21 ImageFPathName : AnsiString; // local file path name 20 22 ServerPath : AnsiString; 21 23 ServerFName : AnsiString; … … 25 27 ImageDateTime : AnsiString; 26 28 UploadDateTime: AnsiString; 27 ObjectType : Integer; //pointer to file 2005.02 28 ProcName : String[10]; //server limit is 10 chars. 29 //AcquisitionSite 30 pLongDesc : TStrings; 31 published 32 end; 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 33 61 34 62 … … 54 82 NoteEdit: TEdit; 55 83 PickOtherButton: TBitBtn; 56 Panel1: TPanel;84 pnlIEHolder: TPanel; 57 85 WebBrowser: TWebBrowser; 58 86 Label6: TLabel; 59 87 MoveCheckBox: TCheckBox; 88 PolTimer: TTimer; 60 89 DKLanguageController1: TDKLanguageController; 61 90 procedure UploadButtonClick(Sender: TObject); … … 69 98 procedure PickOtherButtonClick(Sender: TObject); 70 99 procedure FormRefresh(Sender: TObject); 71 100 procedure PolTimerTimer(Sender: TObject); 72 101 private 73 102 { Private declarations } 74 103 Bitmap : TBitmap; 75 104 Picture : TPicture; 76 function MakeThumbNail(Info: TUploadImageInfo): boolean; 105 FScanDir : String; 106 function MakeThumbNail(Info: TImageInfo): boolean; 77 107 78 108 procedure LoadNotesEdit(); 79 109 //procedure LoadNotesList(); 80 function UploadFile(Info: T UploadImageInfo): boolean;110 function UploadFile(Info: TImageInfo; DelOrig : boolean): boolean; 81 111 procedure UploadChosenFiles(); 82 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); 83 122 public 84 123 { Public declarations } 124 procedure SetScanDir(NewDir : string); 125 published 126 property ScanDir : String read FScanDir write SetScanDir; 85 127 end; 86 128 … … 95 137 StrUtils, //for MidStr etc. 96 138 ORFn, //for PIECE etc. 97 uCore, // for User.DUZ etc98 139 Trpcb, //for .PType enum 99 140 fImages, //for upload/download files etc. 100 141 //Targa, //for TGA graphic save 101 ORNet //for RPCBrokerV 142 ORNet, //for RPCBrokerV 143 rTIU, 144 uTMGOptions 102 145 ; 103 146 … … 105 148 // DefShortDesc = '(Short Image Description)'; <-- original line. //kt 8/7/2007 106 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 107 165 var 108 166 DefShortDesc : string; //kt 167 PolInterval : integer; 168 AutoUploadNote : TAutoUploadNote; 169 109 170 110 171 procedure SetupVars; … … 115 176 //------------------------------------------------------------------------- 116 177 //------------------------------------------------------------------------- 117 function TUploadForm.MakeThumbNail(Info: TUploadImageInfo) : boolean; 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; 118 405 //This takes Info.ImageFPathName and creates a 64x64 .bmp file with 119 406 //this same name, and saves in cache directory. … … 141 428 142 429 143 function TUploadForm.UploadFile(Info: T UploadImageInfo): boolean;430 function TUploadForm.UploadFile(Info: TImageInfo; DelOrig : boolean): boolean; 144 431 //result: true if success, false if failure 145 432 var … … 196 483 Info.ServerPath := Piece(RPCResult,'^',2); 197 484 Info.ServerFName := Piece(RPCResult,'^',3); 198 result := frmImages.UploadFile(Info.ImageFPathName,Info.ServerPath,Info.ServerFName );485 result := frmImages.UploadFile(Info.ImageFPathName,Info.ServerPath,Info.ServerFName,1,1); 199 486 if result=false then begin 200 487 // ErrorMsg :='Error uploading image to server'; <-- original line. //kt 8/7/2007 … … 227 514 if result then begin 228 515 if MakeThumbNail(Info) then begin; 229 result := frmImages.UploadFile(Info.ThumbFPathName,Info.ServerPath,Info.ServerThumbFName );516 result := frmImages.UploadFile(Info.ThumbFPathName,Info.ServerPath,Info.ServerThumbFName,1,1); 230 517 if result=false then begin 231 518 // ErrorMsg :='Error sending thumbnail image to server.'; <-- original line. //kt 8/7/2007 … … 234 521 end; 235 522 end; 523 if DelOrig=true then begin 524 DeleteFile(Info.ImageFPathName); 525 end; 236 526 end; 237 527 end; … … 243 533 procedure TUploadForm.UploadChosenFiles(); 244 534 var i : integer; 245 Info: T UploadImageInfo;246 247 begin 248 SetupVars; 249 Info := T UploadImageInfo.Create();535 Info: TImageInfo; 536 537 begin 538 SetupVars; 539 Info := TImageInfo.Create(); 250 540 Info.pLongDesc := nil; 251 541 … … 269 559 Info.Extension := MidStr(Info.Extension,2,17); //remove '.' 270 560 271 if not UploadFile(Info ) then begin //Upload function passes back filename info in Info class561 if not UploadFile(Info,MoveCheckBox.Checked) then begin //Upload function passes back filename info in Info class 272 562 //Application.MessageBox('Error uploading image file!','Error'); 273 563 end; … … 376 666 Bitmap.Width := 64; 377 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; 378 688 end; 379 689 … … 412 722 end; 413 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; 1211 AbortPoint: 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 414 1261 end.
Note:
See TracChangeset
for help on using the changeset viewer.