source: cprs/branches/GUI-config/BatchAddU.pas@ 736

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

v1.1 Fixes Access/Verify code issues
File size: 19.7 KB
Line 
1unit BatchAddU;
2 (*
3 WorldVistA Configuration Utility
4 (c) 8/2008 Kevin Toppenberg
5 Programmed by Kevin Toppenberg, Eddie Hagood
6
7 Family Physicians of Greeneville, PC
8 1410 Tusculum Blvd, Suite 2600
9 Greeneville, TN 37745
10 kdtop@yahoo.com
11
12 This library is free software; you can redistribute it and/or
13 modify it under the terms of the GNU Lesser General Public
14 License as published by the Free Software Foundation; either
15 version 2.1 of the License, or (at your option) any later version.
16
17 This library is distributed in the hope that it will be useful,
18 but WITHOUT ANY WARRANTY; without even the implied warranty of
19 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 Lesser General Public License for more details.
21
22 You should have received a copy of the GNU Lesser General Public
23 License along with this library; if not, write to the Free Software
24 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
25 *)
26
27interface
28
29uses
30 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
31 Dialogs, StdCtrls, Buttons, Grids, ExtCtrls, ComCtrls, DateUtils;
32
33type
34 TBatchAddForm = class(TForm)
35 Panel1: TPanel;
36 Panel2: TPanel;
37 BatchGrid: TStringGrid;
38 btnCreateTemplate: TBitBtn;
39 btnOpenDataFile: TBitBtn;
40 btnDoRegistration: TBitBtn;
41 btnClearGrid: TBitBtn;
42 OpenDialog: TOpenDialog;
43 btnDone: TBitBtn;
44 ProgressBar: TProgressBar;
45 btnSaveGrid: TBitBtn;
46 btnAbortRegistration: TBitBtn;
47 SaveDialog: TSaveDialog;
48 EstTimeLabel: TLabel;
49 procedure btnCreateTemplateClick(Sender: TObject);
50 procedure btnClearGridClick(Sender: TObject);
51 procedure btnOpenDataFileClick(Sender: TObject);
52 function LTrim(s,subStr : string): string;
53 function RTrim(s,subStr : string): string;
54 function Trim(s,subStr : string): string;
55 procedure FormClose(Sender: TObject; var Action: TCloseAction);
56 procedure FormCreate(Sender: TObject);
57 procedure btnDoRegistrationClick(Sender: TObject);
58 procedure FormDestroy(Sender: TObject);
59 procedure btnAbortRegistrationClick(Sender: TObject);
60 procedure btnSaveGridClick(Sender: TObject);
61 procedure BatchGridSetEditText(Sender: TObject; ACol, ARow: Integer;
62 const Value: String);
63 private
64 { Private declarations }
65 FieldNumList : TStringList;
66 FAbortRegistration : boolean;
67 procedure ClearGrid;
68 procedure LoadData(fileName : string);
69 procedure AddHeaderCol(oneEntry : string);
70 procedure GetColFieldNums(List : TStringList);
71 function GetOneRow(row : integer; ColFields : TStringList) : string;
72 function RowToStr(row : integer) : string;
73 procedure AddRowFromStr(Str : string);
74 function RegisterOne(oneRow : string; Log : TStringList) : string;
75 //procedure DelGridRow(BatchGrid : TStringGrid; row : integer);
76 public
77 { Public declarations }
78 end;
79
80var
81 BatchAddForm: TBatchAddForm;
82
83implementation
84
85uses CreateTemplateU, StrUtils, ORNet, ORFn,
86 Trpcb, //needed for .ptype types
87 FMErrorU;
88
89const NOT_ADDED='(Not Added)';
90 ADD_ROW='Add-->';
91 ALREADY_ADDED='(Already Registered)';
92{$R *.dfm}
93
94 procedure TBatchAddForm.ClearGrid;
95 begin
96 BatchGrid.ColCount := 2;
97 BatchGrid.RowCount := 3;
98 BatchGrid.Cells[0,0] := 'Field NAME';
99 BatchGrid.Cells[0,1] := 'Field NUM';
100 BatchGrid.Cells[0,2] := '';
101 BatchGrid.Cells[1,0] := '';
102 BatchGrid.Cells[1,1] := '';
103 BatchGrid.Cells[1,2] := '';
104 end;
105
106
107 procedure TBatchAddForm.btnCreateTemplateClick(Sender: TObject);
108 begin
109 CreateTemplateForm.PrepForm('2');
110 CreateTemplateForm.ShowModal;
111 end;
112
113 procedure TBatchAddForm.btnClearGridClick(Sender: TObject);
114 begin
115 if MessageDlg('Clear All Patients?',mtConfirmation,mbOKCancel,0) = mrOK then begin
116 ClearGrid;
117 btnSaveGrid.Enabled := false;
118 btnDoRegistration.Enabled := false;
119 btnClearGrid.Enabled := false;
120 btnCreateTemplate.Enabled := true;
121 btnOpenDataFile.Enabled := true;
122 end;
123 end;
124
125 procedure TBatchAddForm.btnOpenDataFileClick(Sender: TObject);
126 begin
127 if OpenDialog.Execute then begin
128 LoadData(OpenDialog.FileName);
129 btnClearGrid.Enabled := true;
130 btnDoRegistration.Enabled := true;
131 btnCreateTemplate.Enabled := false;
132 btnOpenDataFile.Enabled := false;
133 end;
134 end;
135
136 function TBatchAddForm.RTrim(s,subStr : string): string;
137 var p,subLen : integer;
138 begin
139 result := s;
140 p := Pos(subStr,s);
141 subLen := length(subStr);
142 if p <> length(s)-subLen+1 then exit;
143 result := MidStr(s,1, length(s)-subLen);
144 end;
145
146
147 function TBatchAddForm.LTrim(s,subStr : string): string;
148 var p,subLen : integer;
149 begin
150 result := s;
151 p := Pos(subStr,s);
152 subLen := length(subStr);
153 if p <> 1 then exit;
154 result := MidStr(s,subLen+1,999);
155 end;
156
157 function TBatchAddForm.Trim(s,subStr : string): string;
158 begin
159 result := LTrim(s,subStr);
160 result := RTrim(result,subStr);
161 end;
162
163
164 procedure TBatchAddForm.LoadData(fileName : string);
165 var Data: TStringList;
166 Line1List: TStringList;
167 oneLine : string;
168 value : string;
169 row,i,j : integer;
170 fldName,fldNum : string;
171 dataFound : boolean;
172 oneEntry : string;
173 begin
174 Data := TStringList.Create;
175 Line1List := TStringList.Create;
176 Data.LoadFromFile(fileName);
177 if Data.Count < 3 then begin
178 MessageDlg('Template file has less than 3 lines.'+#10+#13+
179 'Doesn''t appear to be valid template'+#10+#13+
180 'filled with patient data. Please fill '+#10+#13+
181 'with patient demographics first.', mtError,[mbOK],0);
182 exit;
183 end;
184 ClearGrid;
185 //------- set up header rows (name and number) ------------------
186 oneLine := Data.Strings[0];
187 PiecesToList(oneLine, #9, Line1List);
188 oneLine := Data.Strings[1];
189 PiecesToList(oneLine, #9, FieldNumList);
190 for i := 1 to Line1List.Count-1 do begin
191 fldName := Trim(Line1List.Strings[i],'"');
192 if i < FieldNumList.Count then begin
193 fldNum := LTrim(FieldNumList.Strings[i],'"<');
194 fldNum := RTrim(fldNum,'>"');
195 end else begin
196 fldNum := '??';
197 end;
198 oneEntry := fldNum+'^'+fldName;
199 AddHeaderCol(oneEntry);
200 end;
201 //--------- now load data ----------------------
202 dataFound := true;
203 for i := 2 to Data.Count-1 do begin
204 if dataFound then begin
205 if BatchGrid.RowCount = 3 then begin
206 if BatchGrid.Cells[0,2] <> '' then BatchGrid.RowCount := BatchGrid.RowCount + 1;
207 end else begin
208 BatchGrid.RowCount := BatchGrid.RowCount + 1;
209 end;
210 end;
211 row := BatchGrid.RowCount-1;
212 oneLine := Data.Strings[i];
213 PiecesToList(oneLine, #9, Line1List);
214 BatchGrid.Cells[0,row] := ADD_ROW;
215 dataFound := false; //don't advance line if data row is empty.
216 for j := 1 to Line1List.Count-1 do begin //don't use first column of data file
217 value := Line1List.Strings[j];
218 value := Trim(value,'"');
219 if FieldNumList.Strings[j]='"<.09>"' then begin
220 value := LTrim(value,'<');
221 value := RTrim(value,'>');
222 end;
223 if value <> '' then dataFound := true;
224 BatchGrid.Cells[j,row]:= value;
225 end;
226 if (dataFound = false) and (i = Data.Count-1) then begin
227 BatchGrid.RowCount := BatchGrid.RowCount - 1;
228 end;
229 end;
230 Data.Free;
231 Line1List.Free;
232 end;
233
234 procedure TBatchAddForm.AddHeaderCol(oneEntry : string);
235 //oneEntry format: fldNum^fldName
236 var i : integer;
237 fldName,fldNum : string;
238 begin
239 CreateTemplateForm.GetNumName(oneEntry,fldName,fldNum);
240 i := BatchGrid.ColCount-1;
241 if BatchGrid.Cells[i,0] <> '' then begin
242 BatchGrid.ColCount := BatchGrid.ColCount + 1;
243 end;
244 i := BatchGrid.ColCount-1;
245
246 BatchGrid.Cells[i,0] := fldName;
247 BatchGrid.Cells[i,1] := fldNum;
248 end;
249
250
251 procedure TBatchAddForm.FormClose(Sender: TObject; var Action: TCloseAction);
252 begin
253 {
254 if MessageDlg('Leave Batch Registration? (Later check to ensure data was saved)',mtConfirmation,mbOKCancel,0) = mrOK then begin
255 Action := caHide;
256 end else begin
257 Action := caNone;
258 end;
259 }
260 end;
261
262 procedure TBatchAddForm.FormCreate(Sender: TObject);
263 begin
264 FieldNumList := TStringList.Create;
265 end;
266
267
268 procedure TBatchAddForm.btnDoRegistrationClick(Sender: TObject);
269 var i,row : integer;
270 FailedPatients : TStringList;
271 ColFields : TStringList;
272 onePostEntry : string;
273 RPCResult : string;
274 Log : TStringList;
275 Success,Failure,PreExisting,Errors : integer;
276 StartTime : TDateTime;
277
278 procedure ShowEstTime(Pct : single);
279 var Delta : single;
280 EstTotalMin : Integer;
281 s : string;
282 begin
283 Delta := MinuteSpan(Now,StartTime);
284 if Pct=0 then begin
285 EstTimeLabel.caption := '';
286 exit;
287 end;
288 EstTotalMin := Round(Delta / Pct);
289 s := '';
290 if EstTotalMin > 1440 then begin //extract number of days
291 s := s + IntToStr(EstTotalMin div 1440) + 'd:';
292 EstTotalMIn := EstTotalMin mod 1440;
293 end;
294 if EstTotalMin > 60 then begin //extract number of hours
295 if s <> '' then s := s + IntToStr(EstTotalMin div 60) + 'h:'
296 else s := IntToStr(EstTotalMin div 60) + ':';
297 EstTotalMIn := EstTotalMin mod 60;
298 end;
299 s := s + IntToStr(EstTotalMin) + ':';
300 EstTimeLabel.Caption := s;
301 end;
302
303 begin
304 btnOpenDataFile.Enabled := false;
305 btnClearGrid.Enabled := true;
306 btnAbortRegistration.Enabled := True;
307 btnClearGrid.Enabled := False;
308 btnSaveGrid.Enabled := False;
309
310 Log := TStringList.Create;
311 Success := 0;
312 Failure := 0;
313 PreExisting := 0;
314 Errors := 0;
315 FMErrorForm.Memo.Lines.clear;
316 ColFields := TStringList.Create;
317 FailedPatients := TStringList.Create;
318 GetColFieldNums(ColFields);
319 ProgressBar.Max := BatchGrid.RowCount-1;
320 FAbortRegistration := false; //abort button can change this.
321 StartTime := Now;
322 EstTimeLabel.Caption := '';
323 for row := 2 to BatchGrid.RowCount-1 do begin
324 if FAbortRegistration = true then break;
325 ProgressBar.Position := row;
326 if (row mod 100) = 0 then ShowEstTime(row/(BatchGrid.RowCount-1));
327 onePostEntry := GetOneRow(row,ColFields);
328 RPCResult := RegisterOne(onePostEntry,Log); //Returns: NewIEN^PrevReg^Reg'dNow^ErrorOccured
329 BatchGrid.Cells[0,row] := Piece(RPCResult,'^',1);
330 if Piece(RPCResult,'^',1)=NOT_ADDED then inc(Failure);
331 if Piece(RPCResult,'^',2)='1' then inc(PreExisting);
332 if Piece(RPCResult,'^',3)='1' then inc(Success);
333 if Piece(RPCResult,'^',4)='1' then inc(Errors);
334 Application.ProcessMessages;
335 end;
336 ProgressBar.Position := 0;
337 ColFields.free;
338 MessageDlg(IntToStr(Success)+' successful registrations or data refresh, '+#10+#13+
339 IntToStr(PreExisting)+' patients were already registered,'+#10+#13+
340 IntToStr(Errors)+' filing errors encountered (including minor errors),'+#10+#13+
341 IntToStr(Failure)+' patients NOT registered.',
342 mtInformation,[mbOK],0);
343 EstTimeLabel.Caption := '';
344 StartTime := Now;
345 if BatchGrid.RowCount > 1000 then ShowMessage('Will now clear out patients that have been registered.');
346 for row := 2 to BatchGrid.RowCount-1 do begin
347 if (BatchGrid.Cells[0,row] = NOT_ADDED) or (BatchGrid.Cells[0,row] = ADD_ROW) then begin
348 FailedPatients.Add(RowToStr(row));
349 end;
350 ProgressBar.Position := row;
351 if (row mod 100) = 0 then ShowEstTime(row/(BatchGrid.RowCount-1));
352 Application.ProcessMessages;
353 end;
354 BatchGrid.RowCount := 2;
355 ProgressBar.Max := FailedPatients.Count;
356 StartTime := Now;
357 for i := 0 to FailedPatients.Count-1 do begin
358 AddRowFromStr(FailedPatients.Strings[i]);
359 ProgressBar.Position := i;
360 if (i mod 100) = 0 then ShowEstTime(i/(FailedPatients.Count-1));
361 Application.ProcessMessages;
362 end;
363 {
364 for row := BatchGrid.RowCount-1 downto 2 do begin
365 if (BatchGrid.Cells[0,row] <> NOT_ADDED)
366 and (BatchGrid.Cells[0,row] <> ADD_ROW) then begin
367 DelGridRow(BatchGrid,row); // <------- this is VERY SLOW!!@#@!
368 end;
369 ProgressBar.Position := row;
370 if (row mod 100) = 0 then ShowEstTime((BatchGrid.RowCount-1-row)/(BatchGrid.RowCount-1));
371 Application.ProcessMessages;
372 end;
373 }
374 EstTimeLabel.Caption := '';
375 if Log.Count>0 then begin
376 FMErrorForm.Memo.Lines.Assign(Log);
377 FMErrorForm.PrepMessage;
378 FMErrorForm.ShowModal;
379 end;
380 Log.Free;
381 if (BatchGrid.RowCount=3)and(BatchGrid.Cells[0,2]='') then begin
382 btnSaveGrid.Enabled := false;
383 btnDoRegistration.Enabled := false;
384 btnClearGrid.Enabled := false;
385 btnCreateTemplate.Enabled := true;
386 btnOpenDataFile.Enabled := true;
387 btnAbortRegistration.Enabled := true;
388 end else begin
389 btnClearGrid.Enabled := true;
390 btnSaveGrid.Enabled := true;
391 btnAbortRegistration.Enabled := false;
392 end;
393 FailedPatients.Free;
394
395 end;
396
397 function TBatchAddForm.RegisterOne(oneRow : string; Log : TStringList) : string;
398 //Returns: NewIEN^Bool1^Bool2^Bool3
399 // NewIEN can be a #, or NOT_ADDED
400 // For each Bool, 0=false, 1=true
401 // Bool1 : Patient previously registered
402 // Bool2 : Patient registered this time (using identifier fields)
403 // Bool3 : Some Problem occurred during filing
404 var tempResult,RPCResult : string;
405 Msg : string;
406 i : integer;
407 begin
408 RPCBrokerV.remoteprocedure := 'TMG CHANNEL';
409 RPCBrokerV.param[0].ptype := list;
410 RPCBrokerV.Param[0].Mult['"REQUEST"'] := 'REGISTER PATIENT^'+oneRow;
411 RPCBrokerV.Call;
412 RPCResult := RPCBrokerV.Results[0];
413 //returns: error: -1^Message; success=1^Success^IEN; or Equivical=0^Message^IEN
414 //If 0 then Message is in this format
415 // [Bool1;Bool2;Bool3;Bool4;Bool5*MessageText]
416 // For each Bool, 0=false, 1=true
417 // Bool1 : Patient previously registered
418 // Bool2 : Patient registered this time (using identifier fields)
419 // Bool3 : Problem filing non-identifier fields
420 // Bool4 : Problem filing data info sub-file fields
421 // Bool5 : Problem filing HRN
422 tempResult := piece(RPCResult,'^',1);
423 if tempResult='1' then begin //1=Success
424 result := piece(RPCResult,'^',3)+'^0^1^0';
425 end else if tempResult='0' then begin //0=Mixed results
426 Msg := piece(RPCResult,'^',2);
427 result := piece(RPCResult,'^',3);
428 if result = '' then result := NOT_ADDED;
429 result := result + '^' + Piece(Msg,';',1) + '^' + Piece(Msg,';',2);
430 if Pos('1',Pieces(Msg,';',3,5))>0 then begin
431 result := result + '^1';
432 if RPCBrokerV.Results.Count > 1 then begin
433 Log.Add('-----------------------------------------------');
434 Log.Add('There was a problem with registering a patient.');
435 for i := 1 to RPCBrokerV.Results.Count-1 do begin
436 Log.Add(RPCBrokerV.Results.Strings[i]);
437 end;
438 end;
439 end else begin
440 result := result + '^0';
441 end;
442 end else begin //should be tempResult='-1' //-1=Error
443 FMErrorForm.Memo.Lines.Assign(RPCBrokerV.Results);
444 FMErrorForm.PrepMessage; //Does some clean up of the message format
445 //FMErrorForm.ShowModal; //later just put these in log...
446 Log.Add('-----------------------------------------------');
447 Log.Add('There was a problem with registering a patient.');
448 for i:= 0 to FMErrorForm.Memo.Lines.Count-1 do begin
449 Log.Add(FMErrorForm.Memo.Lines.Strings[i]);
450 end;
451 Log.Add(' ');
452 FMErrorForm.Memo.Lines.Clear;
453 result := NOT_ADDED+'^0^0^1'; //Not-prev-reg^Not-reg-this-time^Problem-occured
454 end;
455 end;
456
457 {
458 procedure TBatchAddForm.DelGridRow(BatchGrid : TStringGrid; row : integer);
459 var col : integer;
460 begin
461 if row >= BatchGrid.RowCount then exit;
462 repeat
463 if row = BatchGrid.RowCount-1 then begin
464 if BatchGrid.RowCount=3 then begin
465 for col := 0 to BatchGrid.ColCount-1 do begin
466 BatchGrid.Cells[col,row] := '';
467 end;
468 end else begin
469 BatchGrid.RowCount := BatchGrid.RowCount-1;
470 end;
471 exit;
472 end;
473 for col := 0 to BatchGrid.ColCount-1 do begin
474 BatchGrid.Cells[col,row] := BatchGrid.Cells[col,row+1]
475 end;
476 inc(row);
477 until (1=0);
478 end;
479 }
480
481 procedure TBatchAddForm.FormDestroy(Sender: TObject);
482 begin
483 FieldNumList.Free;
484 end;
485
486 procedure TBatchAddForm.GetColFieldNums(List : TStringList);
487 var i : integer;
488 begin
489 List.Clear;
490 List.Add(''); //fill 0'th column will null
491 for i := 1 to BatchGrid.ColCount-1 do begin
492 List.Add(BatchGrid.Cells[i,1]);
493 end;
494 end;
495
496 function TBatchAddForm.GetOneRow(row : integer; ColFields : TStringList) : string;
497 //Output format: FldNum1^Value1^fldNum2^Value2^FldNum3^Value3...
498 var i : integer;
499 begin
500 result := '';
501 if row >= BatchGrid.RowCount then exit;
502 for i := 1 to BatchGrid.ColCount-1 do begin
503 result := result + ColFields.Strings[i]+'^'+BatchGrid.Cells[i,row]+'^';
504 end;
505 end;
506
507 function TBatchAddForm.RowToStr(row : integer) : string;
508 //Output format: Cell0^Cell1^Cell2^Cell3^Cell4....
509 var i : integer;
510 begin
511 result := '';
512 if row >= BatchGrid.RowCount then exit;
513 for i := 0 to BatchGrid.ColCount-1 do begin
514 result := result + BatchGrid.Cells[i,row]+'^';
515 end;
516 end;
517
518 procedure TBatchAddForm.AddRowFromStr(Str : string);
519 var row : integer;
520 i : integer;
521 begin
522 BatchGrid.RowCount := BatchGrid.RowCount + 1;
523 row := BatchGrid.RowCount-1;
524 for i := 0 to BatchGrid.ColCount-1 do begin
525 BatchGrid.Cells[i,row] := Piece(Str,'^',i+1);
526 end;
527 end;
528
529
530 procedure TBatchAddForm.btnAbortRegistrationClick(Sender: TObject);
531 begin
532 FAbortRegistration := true;
533 end;
534
535 procedure TBatchAddForm.btnSaveGridClick(Sender: TObject);
536 var DataLines : TStringList;
537 Value : string;
538 row,col : integer;
539 Line : string;
540 begin
541 If SaveDialog.Execute then begin
542 DataLines := TStringList.Create;
543 for row := 0 to BatchGrid.RowCount-1 do begin
544 Line := '';
545 for col := 0 to BatchGrid.ColCount-1 do begin
546 Value := BatchGrid.Cells[col,row];
547 if Value = ADD_ROW then Value := ' ';
548 if (row=1)or((BatchGrid.Cells[col,1]='.09')and(row<>0)) then begin
549 Value := '<'+Value+'>'; //protect field numbers as text
550 end;
551 Line := Line + '"'+Value+'"' + #9
552 end;
553 DataLines.Add(Line);
554 end;
555 DataLines.Add(' ');
556 DataLines.Add('Add as many rows as needed)');
557 DataLines.Add(' ');
558 DataLines.Add('When done, save file and import with');
559 DataLines.Add(' the WorldVista Config Utility.');
560 DataLines.Add('Save in CSV format, using TAB as field');
561 DataLines.Add(' delimiter, and " as text delimiter.');
562 DataLines.SaveToFile(SaveDialog.FileName);
563 DataLines.Free;
564 end;
565 end;
566
567 procedure TBatchAddForm.BatchGridSetEditText(Sender: TObject; ACol, ARow: Integer; const Value: String);
568 begin
569 btnSaveGrid.Enabled := true;
570 end;
571
572end.
573
Note: See TracBrowser for help on using the repository browser.