source: cprs/branches/foia-cprs/CPRS-Chart/fARTAllgy.pas@ 459

Last change on this file since 459 was 459, checked in by Kevin Toppenberg, 16 years ago

Adding foia-cprs branch
File size: 35.7 KB
Line 
1unit fARTAllgy;
2
3interface
4
5uses
6 SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
7 Forms, Dialogs, StdCtrls, ORCtrls, ORfn, ExtCtrls, ComCtrls, uConst,
8 Menus, ORDtTm, Buttons, fODBase, fAutoSz, fOMAction, rODAllergy;
9
10type
11 TfrmARTAllergy = class(TfrmOMAction)
12 pnlBase: TORAutoPanel;
13 cmdOK: TButton;
14 cmdCancel: TButton;
15 pgAllergy: TPageControl;
16 tabGeneral: TTabSheet;
17 tabVerify: TTabSheet;
18 ckNoKnownAllergies: TCheckBox;
19 btnCurrent: TButton;
20 lblAgent: TOROffsetLabel;
21 lstAllergy: TORListBox;
22 btnAgent: TSpeedButton;
23 lblOriginator: TOROffsetLabel;
24 cboOriginator: TORComboBox;
25 lblOriginateDate: TOROffsetLabel;
26 calOriginated: TORDateBox;
27 ckChartMarked: TCheckBox;
28 ckIDBand: TCheckBox;
29 lblVerifier: TOROffsetLabel;
30 ckVerified: TCheckBox;
31 cboVerifier: TORComboBox;
32 calVerifyDate: TORDateBox;
33 lblVerifyDate: TOROffsetLabel;
34 dlgReactionDateTime: TORDateTimeDlg;
35 Bevel1: TBevel;
36 lblSymptoms: TOROffsetLabel;
37 cboSymptoms: TORComboBox;
38 lblSelectedSymptoms: TOROffsetLabel;
39 lstSelectedSymptoms: TORListBox;
40 btnDateTime: TButton;
41 btnRemove: TButton;
42 grpObsHist: TRadioGroup;
43 lblSeverity: TOROffsetLabel;
44 cboSeverity: TORComboBox;
45 lblObservedDate: TOROffsetLabel;
46 calObservedDate: TORDateBox;
47 cmdPrevObs: TButton;
48 lblComments: TOROffsetLabel;
49 memComments: TRichEdit;
50 cmdPrevCmts: TButton;
51 tabEnteredInError: TTabSheet;
52 ckEnteredInError: TCheckBox;
53 memErrCmts: TRichEdit;
54 lblErrCmts: TLabel;
55 lblEnteredInError: TLabel;
56 lblAllergyType: TOROffsetLabel;
57 cboAllergyType: TORComboBox;
58 cboNatureOfReaction: TORComboBox;
59 lblNatureOfReaction: TOROffsetLabel;
60 btnSevHelp: TORAlignButton;
61 procedure btnAgentClick(Sender: TObject);
62 procedure FormCreate(Sender: TObject);
63 procedure cboOriginatorNeedData(Sender: TObject; const StartFrom: String;
64 Direction, InsertAt: Integer);
65 procedure cboSymptomsNeedData(Sender: TObject; const StartFrom: String;
66 Direction, InsertAt: Integer);
67 procedure lstAllergySelect(Sender: TObject);
68 procedure grpObsHistClick(Sender: TObject);
69 procedure ControlChange(Sender: TObject);
70 procedure memCommentsExit(Sender: TObject);
71 procedure cboSymptomsClick(Sender: TObject);
72 procedure FormDestroy(Sender: TObject);
73 procedure ckNoKnownAllergiesClick(Sender: TObject);
74 procedure cmdOKClick(Sender: TObject);
75 procedure btnCurrentClick(Sender: TObject);
76 procedure btnRemoveClick(Sender: TObject);
77 procedure lstAllergyClick(Sender: TObject);
78 procedure btnDateTimeClick(Sender: TObject);
79 procedure cboSymptomsMouseClick(Sender: TObject);
80 procedure cboSymptomsKeyDown(Sender: TObject; var Key: Word;
81 Shift: TShiftState);
82 procedure cmdCancelClick(Sender: TObject);
83 procedure cmdPrevCmtsClick(Sender: TObject);
84 procedure cmdPrevObsClick(Sender: TObject);
85 procedure lstSelectedSymptomsChange(Sender: TObject);
86 procedure cboVerifierNeedData(Sender: TObject; const StartFrom: String;
87 Direction, InsertAt: Integer);
88 procedure FormClose(Sender: TObject; var Action: TCloseAction);
89 procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
90 procedure btnSevHelpClick(Sender: TObject);
91 private
92 FLastAllergyID: string;
93 FEditAllergyIEN: integer;
94 FNKAOrder: boolean;
95 FChanged: Boolean;
96 FOldHintPause : integer;
97 protected
98 procedure EnableDisableControls(EnabledStatus: boolean);
99 procedure InitDialog; override;
100 procedure Validate(var AnErrMsg: string);
101 function ValidSave: Boolean;
102 procedure SetupDialog;
103 procedure SetupVerifyFields(ARec: TAllergyRec);
104 procedure SetUpEnteredInErrorFields(ARec: TAllergyRec);
105 end;
106
107function EnterEditAllergy(AllergyIEN: integer; AddNew, MarkAsEnteredInError: boolean): boolean;
108function MarkEnteredInError(AllergyIEN: integer): boolean;
109function EnterNKAForPatient: boolean;
110
111var
112 AllergyList: TStringList;
113 OldRec, NewRec: TAllergyRec;
114 Defaults: TStringList;
115 Changing: Boolean;
116 uAddingNew: boolean = FALSE;
117 uEditing: Boolean = FALSE;
118 uEnteredInError: Boolean = FALSE;
119 uUserCanVerify: boolean = FALSE;
120 uDeletedSymptoms: TStringList;
121
122implementation
123
124{$R *.DFM}
125
126uses
127 rODBase, uCore, rCore, rCover, fAllgyFind, fPtCWAD, fRptBox;
128
129const
130 TX_NO_ALLERGY = 'A causative agent must be specified.' ;
131 TX_NO_ALLGYTYPE = 'An allergy type must be entered for this causative agent.' ;
132 TX_NO_NATURE_OF_REACTION = 'A Nature of Reaction must be entered for this causative agent.' ;
133 TX_NO_SYMPTOMS = 'Symptoms must be selected for this observed allergy and reaction.';
134 TX_NO_OBSERVER = 'An observer must be selected for this allergy and reaction .';
135 TX_NO_ORIGINATOR = 'An originator must be selected for this allergy and reaction .';
136 TX_NO_FUTURE_DATES = 'Reaction dates in the future are not allowed.';
137 TX_BAD_OBS_DATE = 'Observation date must be in the format m/d/y or m/y or y, or T-d.';
138 TX_MISSING_OBS_DATE = 'Observation date is required for observed reactions.';
139 TX_BAD_VER_DATE = 'Verify date must be in the format m/d/y or m/y or y, or T-d.';
140 TX_BAD_ORIG_DATE = 'Origination date must be in the format m/d/y or m/y or y, or T-d.';
141 TX_NO_FUTURE_ORIG_DATES = 'An origination date in the future is not allowed.';
142 TX_MISSING_ORIG_DATE = 'Origination date is required.';
143 TX_CAP_FUTURE = 'Invalid date';
144 TX_NO_SAVE = 'This item cannot be saved for the following reason(s):' + CRLF + CRLF;
145 TX_NO_SAVE_CAP = 'Unable to Save Allergy/Adverse Reaction';
146 TX_SAVE_ERR = 'Unexpected error - it was not possible to save this request.';
147 TX_CAP_EDITING = 'Edit Allergy/Adverse Reaction';
148 TX_STS_EDITING = 'Loading Allergy/Adverse Reaction for Edit';
149 TX_CAP_ERROR = 'Mark Allergy/Adverse Reaction Entered In Error';
150 TX_STS_ERROR = 'Loading Allergy/Adverse Reaction';
151 TX_ORIG_CMTS_REQD = 'Comments are required for ''Observed'' reactions.';
152 TX_EDIT_ERROR = 'Unable to load record for editing';
153 TC_EDIT_ERROR = 'Error Encountered';
154 TX_NKA_SUCCESS = 'Patient''s record has been updated.';
155 TC_NKA_SUCCESS = 'No Known Allergies';
156 TX_OBHX_HINT = 'OBSERVED: directly observed or occurring while the patient was' + CRLF +
157 'on the suspected causative agent. Use for new information about' + CRLF +
158 'an allergy/adverse reaction and for recent reactions caused by' + CRLF +
159 'VA-prescribed medications.' + CRLF + CRLF +
160 'HISTORICAL: reported by the patient as occurring in the past;' + CRLF +
161 'no longer requires intervention' ;
162 NEW_ALLERGY = True;
163 ENTERED_IN_ERROR = True;
164
165function EnterNKAForPatient: boolean;
166var
167 x: string;
168begin
169 x := RPCEnterNKAForPatient;
170 if not (Piece(x, U, 1) = '0') then
171 InfoBox(Piece(x, U, 2), TC_EDIT_ERROR, MB_ICONERROR or MB_OK)
172 else
173 InfoBox(TX_NKA_SUCCESS, TC_NKA_SUCCESS, MB_ICONINFORMATION or MB_OK);
174 Result := (Piece(x, U, 1) = '0');
175end;
176
177function MarkEnteredInError(AllergyIEN: integer): boolean;
178begin
179 Result := EnterEditAllergy(AllergyIEN, not NEW_ALLERGY, ENTERED_IN_ERROR);
180end;
181
182function EnterEditAllergy(AllergyIEN: integer; AddNew, MarkAsEnteredInError: boolean): boolean;
183var
184 frmARTAllergy: TfrmARTAllergy;
185 Allergy: string;
186begin
187 uAddingNew := AddNew;
188 uEditing := (not AddNew) and (not MarkAsEnteredInError);
189 uEnteredInError := MarkAsEnteredInError;
190 Result := False;
191 frmARTAllergy := TfrmARTAllergy.Create(Application);
192 with frmARTAllergy do
193 try
194 ResizeFormToFont(TForm(frmARTAllergy));
195 FChanged := False;
196 Changing := True;
197 if uEditing then
198 begin
199 frmARTAllergy.Caption := TX_CAP_EDITING;
200 FEditAllergyIEN := AllergyIEN;
201 if FEditAllergyIEN = 0 then exit;
202 StatusText(TX_STS_EDITING);
203 OldRec := LoadAllergyForEdit(FEditAllergyIEN);
204 NewRec.IEN := OldRec.IEN;
205 SetupDialog;
206 end
207 else if uEnteredInError then
208 begin
209 frmARTAllergy.Caption := TX_CAP_ERROR;
210 FEditAllergyIEN := AllergyIEN;
211 if FEditAllergyIEN = 0 then exit;
212 StatusText(TX_STS_ERROR);
213 OldRec := LoadAllergyForEdit(FEditAllergyIEN);
214 NewRec.IEN := OldRec.IEN;
215 SetupDialog;
216 end
217 else if uAddingNew then
218 begin
219 SetupVerifyFields(NewRec);
220 SetupEnteredInErrorFields(NewRec);
221 AllergyLookup(Allergy, ckNoKnownAllergies.Enabled);
222 if Piece(Allergy, U, 1) = '-1' then
223 begin
224 ckNoKnownAllergies.Checked := True;
225 Result := EnterNKAForPatient;
226 Exit;
227 end
228 else if Allergy <> '' then
229 begin
230 lstAllergy.Clear;
231 lstAllergy.Items.Add(Allergy);
232 cboAllergyType.SelectByID(Piece(Allergy, U, 4));
233 end
234 else
235 begin
236 Result := False;
237 Close;
238 exit;
239 end;
240 calOriginated.FMDateTime := FMNow;
241 Changing := False;
242 ControlChange(lstAllergy);
243 end;
244 StatusText('');
245 if OldRec.IEN = -1 then
246 begin
247 Result := False;
248 Close;
249 Exit;
250 end;
251 ShowModal;
252 Result := FChanged;
253 finally
254 uAddingNew := FALSE;
255 uEditing := FALSE;
256 uEnteredInError := FALSE;
257 uUserCanVerify := FALSE;
258 frmARTAllergy.Release;
259 end;
260end;
261
262procedure TfrmARTAllergy.FormCreate(Sender: TObject);
263begin
264 inherited; // what to do here? How to set up dialog defaults without order dialog to supply prompts?
265 Changing := True;
266 AbortAction := False;
267 AllergyList := TStringList.Create;
268 uDeletedSymptoms := TStringList.Create;
269 FillChar(OldRec, SizeOf(OldRec), 0);
270 FillChar(NewRec, SizeOf(NewRec), 0);
271 with NewRec do
272 begin
273 SignsSymptoms := TStringList.Create ;
274 IDBandMarked := TStringList.Create;
275 ChartMarked := TStringList.Create;
276 Observations := TStringList.Create;
277 Comments := TStringList.Create ;
278 NewComments := TStringList.Create ;
279 ErrorComments := TStringList.Create ;
280 end;
281 Defaults := TStringList.Create;
282 StatusText('Loading Default Values');
283 uUserCanVerify := FALSE; //HasSecurityKey('GMRA-ALLERGY VERIFY');
284 Defaults.Assign(ODForAllergies);
285 StatusText('Initializing Long List');
286 ExtractItems(cboSymptoms.Items, Defaults, 'Top Ten');
287 cboSymptoms.InsertSeparator;
288 cboOriginator.InitLongList(User.Name) ;
289 cboOriginator.SelectByIEN(User.DUZ);
290 pgAllergy.ActivePage := tabGeneral;
291 InitDialog;
292 Changing := False;
293 if AbortAction then
294 begin
295 Close;
296 Exit;
297 end;
298end;
299
300procedure TfrmARTAllergy.InitDialog;
301var
302 Allergy: string;
303begin
304 inherited;
305 Changing := True;
306 FOldHintPause := Application.HintHidePause;
307 Application.HintHidePause := 15000;
308 ExtractItems(cboAllergyType.Items, Defaults, 'Allergy Types');
309 ExtractItems(cboSeverity.Items, Defaults, 'Severity');
310 ExtractItems(cboNatureOfReaction.Items, Defaults, 'Nature of Reaction');
311 lstAllergy.Items.Add('-1^Click button to search ---->');
312 grpObsHist.ItemIndex := 1;
313 calObservedDate.Text := '';
314 cboSeverity.ItemIndex := -1;
315 cboSymptoms.ItemIndex := -1;
316 memComments.Clear;
317 cmdPrevCmts.Visible := (uEditing and (OldRec.Comments <> nil) and (OldRec.Comments.Text <> ''));
318 cmdPrevObs.Visible := (uEditing and (OldRec.Observations <> nil) and (OldRec.Observations.Text <> ''));
319 btnAgent.Enabled := (not uEditing) and (not uEnteredInError);
320 ckEnteredInError.Enabled := uEditing or uEnteredInError;
321 grpObsHist.Enabled := (not uEditing) and (not uEnteredInError);
322 grpObsHist.Hint := TX_OBHX_HINT;
323 grpObsHist.ShowHint := grpObsHist.Enabled;
324 ckIDBand.Enabled := Patient.Inpatient and MarkIDBand;
325 ckChartMarked.Checked := ckChartMarked.Checked or uAddingNew;
326 ListAllergies(AllergyList);
327 with AllergyList do
328 if Count > 0 then
329 begin
330 if (Piece(Strings[0], U, 1) = '') and (Piece(Strings[0], U, 2) <> 'No Known Allergies') then
331 ckNoKnownAllergies.Enabled := True
332 else
333 begin
334 ckNoKnownAllergies.Enabled := False;
335 btnCurrent.Enabled := True;
336 end;
337 end
338 else
339 begin
340 btnCurrent.Enabled := False;
341 ckNoKnownAllergies.Enabled := True;
342 end;
343 if (not uEditing) and (not uEnteredInError) and (not uAddingNew) then
344 begin
345 SetupVerifyFields(NewRec);
346 SetupEnteredInErrorFields(NewRec);
347 AllergyLookup(Allergy, ckNoKnownAllergies.Enabled);
348 if Piece(Allergy, U, 1) = '-1' then
349 begin
350 ckNoKnownAllergies.Checked := True;
351 //Exit;
352 end
353 else if Allergy <> '' then
354 begin
355 lstAllergy.Clear;
356 lstAllergy.Items.Add(Allergy);
357 cboAllergyType.SelectByID(Piece(Allergy, U, 4));
358 end
359 else
360 begin
361 AbortAction := True;
362 Close;
363 exit;
364 end;
365 calOriginated.FMDateTime := FMNow;
366 end;
367 StatusText('');
368 Changing := False;
369 ControlChange(lstAllergy);
370end;
371
372procedure TfrmARTAllergy.SetupDialog;
373begin
374 if AbortAction then exit;
375 if OldRec.IEN = -1 then
376 begin
377 InfoBox(TX_EDIT_ERROR, TC_EDIT_ERROR, MB_ICONERROR or MB_OK);
378 Exit;
379 end;
380 if uEditing then with OldRec do
381 begin
382 Changing := True;
383 ckNoKnownAllergies.Checked := NoKnownAllergies;
384 btnAgent.Enabled := FALSE; //not Verified;
385 lstAllergy.Items.Clear;
386 lstAllergy.Items.Insert(0, U + CausativeAgent);
387 lstAllergy.ItemIndex := 0;
388 lstAllergySelect(Self);
389 cboAllergyType.SelectByID(Piece(AllergyType, U, 1));
390 cboNatureOfReaction.SelectByID(Piece(NatureOfReaction, U, 1));
391 lstSelectedSymptoms.Items.Assign(SignsSymptoms);
392 calOriginated.FMDateTime := Originated;
393 cboOriginator.InitLongList(OriginatorName);
394 cboOriginator.SelectByIEN(Originator);
395 { TODO -oRich V. -cART/Allergy : Change to calendar entry fields and prior entries button? }
396 ckIDBand.Checked := IDBandMarked.Count > 0;
397 ckChartMarked.Checked := ChartMarked.Count > 0;
398 if Piece(Observed_Historical, U, 1) <> '' then
399 case UpperCase(Piece(Observed_Historical, U, 1))[1] of
400 'O': grpObsHist.ItemIndex := 0;
401 'H': grpObsHist.ItemIndex := 1;
402 end
403 else grpObsHist.ItemIndex := -1;
404 calObservedDate.FMDateTime := ReactionDate;
405 cmdPrevObs.Enabled := (OldRec.Observations.Text <> '');
406 cboSeverity.SelectByID(Piece(Severity, U, 1));
407 cmdPrevCmts.Enabled := Comments.Text <> '';
408 SetupVerifyFields(OldRec);
409 SetUpEnteredInErrorFields(OldRec);
410 Changing := False;
411 ControlChange(Self);
412 end
413 else if uEnteredInError then with OldRec do
414 begin
415 Changing := True;
416 SetupVerifyFields(OldRec);
417 SetUpEnteredInErrorFields(OldRec);
418 Changing := False;
419 end;
420end;
421
422procedure TfrmARTAllergy.Validate(var AnErrMsg: string);
423var
424 tmpDate: TFMDateTime;
425
426 procedure SetError(const x: string);
427 begin
428 if Length(AnErrMsg) > 0 then AnErrMsg := AnErrMsg + CRLF;
429 AnErrMsg := AnErrMsg + x;
430 end;
431
432begin
433 AnErrMsg := '';
434 if tabEnteredInError.TabVisible then exit;
435 if not ckNoKnownAllergies.Checked then
436 begin
437 if lstAllergy.Items.Count = 0 then SetError(TX_NO_ALLERGY)
438 else if (Length(lstAllergy.DisplayText[0]) = 0) or
439 (Piece(lstAllergy.Items[0], U, 1) = '-1') then SetError(TX_NO_ALLERGY);
440 if (grpObsHist.ItemIndex = 0) then
441 begin
442 if (lstSelectedSymptoms.Items.Count = 0) then SetError(TX_NO_SYMPTOMS);
443 if (grpObsHist.Enabled) and RequireOriginatorComments and (memComments.Text = '') then
444 SetError(TX_ORIG_CMTS_REQD);
445 if (grpObsHist.Enabled) and (calObservedDate.Text = '') then
446 SetError(TX_MISSING_OBS_DATE);
447 end;
448 if cboAllergyType.ItemID = '' then SetError(TX_NO_ALLGYTYPE);
449 with cboNatureOfReaction do
450 if (ItemID = '') or (ItemIndex < 0) or (Text = '') then
451 SetError(TX_NO_NATURE_OF_REACTION)
452 else
453 NewRec.NatureOfReaction := ItemID + U + Text;
454 end;
455 if (cboOriginator.ItemIEN = 0) or (cboOriginator.Text = '') then SetError(TX_NO_ORIGINATOR);
456 with NewRec do
457 begin
458 if calObservedDate.Text <> '' then
459 begin
460 tmpDate := ValidDateTimeStr(calObservedDate.Text, 'TS');
461 if tmpDate > 0 then
462 begin
463 if tmpDate > FMNow then SetError(TX_NO_FUTURE_DATES)
464 else ReactionDate := tmpDate;
465 end
466 else
467 begin
468 SetError(TX_BAD_OBS_DATE);
469 pgAllergy.ActivePage := tabGeneral;
470 end;
471 end;
472 if tabVerify.TabVisible then
473 if calVerifyDate.Text <> '' then
474 begin
475 tmpDate := ValidDateTimeStr(calVerifyDate.Text, 'TS');
476 if tmpDate > 0 then VerifiedDateTime := tmpDate
477 else
478 begin
479 SetError(TX_BAD_VER_DATE);
480 pgAllergy.ActivePage := tabVerify;
481 end;
482 end;
483 if calOriginated.Text <> '' then
484 begin
485 tmpDate := ValidDateTimeStr(calOriginated.Text, 'TS');
486 if tmpDate > 0 then
487 begin
488 if tmpDate > FMNow then SetError(TX_NO_FUTURE_ORIG_DATES)
489 else Originated := tmpDate;
490 end
491 else
492 begin
493 SetError(TX_BAD_ORIG_DATE);
494 pgAllergy.ActivePage := tabGeneral;
495 end;
496 end
497 else
498 begin
499 SetError(TX_MISSING_ORIG_DATE);
500 pgAllergy.ActivePage := tabGeneral;
501 end;
502 end;
503end;
504
505procedure TfrmARTAllergy.cboOriginatorNeedData(Sender: TObject;
506 const StartFrom: string; Direction, InsertAt: Integer);
507begin
508 inherited;
509 cboOriginator.ForDataUse(SubSetOfPersons(StartFrom, Direction));
510end;
511
512procedure TfrmARTAllergy.cboSymptomsNeedData(Sender: TObject;
513 const StartFrom: string; Direction, InsertAt: Integer);
514begin
515 inherited;
516 cboSymptoms.ForDataUse(SubSetOfSymptoms(StartFrom, Direction));
517end;
518
519procedure TfrmARTAllergy.grpObsHistClick(Sender: TObject);
520begin
521 inherited;
522 Changing := True;
523 cboSeverity.ItemIndex := -1;
524 case grpObsHist.ItemIndex of
525 0: begin
526 cboSeverity.Visible := True;
527 lblSeverity.Visible := True;
528 btnSevHelp.Visible := True;
529 calObservedDate.Visible := True;
530 lblObservedDate.Visible := True;
531 calObservedDate.FMDateTime := FMToday;
532 end;
533 1: begin
534 cboSeverity.Visible := False;
535 lblSeverity.Visible := False;
536 btnSevHelp.Visible := False;
537 calObservedDate.Visible := False;
538 lblObservedDate.Visible := False;
539 end;
540 end;
541 Changing := False;
542 ControlChange(Self);
543end;
544
545procedure TfrmARTAllergy.ControlChange(Sender: TObject);
546var
547 MyFMNow: TFMDateTime;
548 i: integer;
549 SourceGlobalRoot: string;
550begin
551 inherited;
552 if Changing then Exit;
553 MyFMNow := FMNow;
554 with NewRec do
555 begin
556 if (not uEditing) and (not uEnteredInError) then IEN := 0;
557 if ckNoKnownAllergies.Checked then
558 begin
559 with cboOriginator do if ItemIEN > 0 then
560 begin
561 Originator := ItemIEN;
562 OriginatorName := Text;
563 end;
564 NoKnownAllergies := True;
565 end
566 else if tabEnteredInError.TabVisible then
567 begin
568 EnteredInError := ckEnteredInError.Checked;
569 if EnteredInError then
570 begin
571 DateEnteredInError := MyFMNow; {***}
572 UserEnteringInError := User.DUZ;
573 with memErrCmts do if GetTextLen > 0 then ErrorComments.Assign(Lines);
574 end;
575 end
576 else
577 with lstAllergy do if (Items.Count > 0) then
578 if (Piece(Items[0], U, 1) <> '-1') and (Length(DisplayText[0]) > 0) then
579 begin
580 SourceGlobalRoot := Piece(Piece(Items[0], U, 3), ',', 1) + ',';
581 if Pos('PSDRUG', SourceGlobalRoot) > 0 then
582 SourceGlobalRoot := Piece(SourceGlobalRoot, '"', 1);
583 CausativeAgent := Trim(Piece(DisplayText[0], '<', 1)) + U + Piece(Items[0], U, 1) + ';' + SourceGlobalRoot;
584 with cboAllergyType do
585 if ItemID <> '' then
586 AllergyType := ItemID + U + Text;
587 with cboNatureOfReaction do
588 if ItemID <> '' then
589 NatureOfReaction := ItemID + U + Text;
590 with cboOriginator do
591 if ItemIEN > 0 then
592 begin
593 Originator := ItemIEN;
594 OriginatorName := Text;
595 end;
596 SignsSymptoms.Clear;
597 for i := 0 to uDeletedSymptoms.Count - 1 do
598 SignsSymptoms.Add(uDeletedSymptoms[i]);
599 with lstSelectedSymptoms do
600 for i := 0 to Items.Count - 1 do
601 SignsSymptoms.Add(Items[i]);
602 if tabVerify.TabVisible then
603 begin
604 Verified := ckVerified.Checked;
605 with cboVerifier do
606 if ItemIEN > 0 then
607 begin
608 Verifier := ItemIEN;
609 VerifierName := Text;
610 end;
611 end;
612 NewRec.ChartMarked.Clear;
613 if ckChartMarked.Checked then
614 ChartMarked.Add(FloatToStr(MyFMNow));
615 NewRec.IDBandMarked.Clear;
616 if ckIDBand.Checked then
617 IDBandMarked.Add(FloatToStr(MyFMNow));
618 with grpObsHist do
619 if ItemIndex > -1 then
620 begin
621 if ItemIndex = 0 then
622 Observed_Historical := 'o^OBSERVED'
623 else
624 Observed_Historical := 'h^HISTORICAL';
625 end;
626(* tmpDate := ValidDateTimeStr(calObservedDate.Text, 'TS'); {***}
627 if tmpDate > 0 then ReactionDate := tmpDate;*)
628 with cboSeverity do
629 if ItemID <> '' then
630 Severity := ItemID;
631 with memComments do
632 if GetTextLen > 0 then
633 NewComments.Assign(Lines);
634 end;
635 end;
636end;
637
638procedure TfrmARTAllergy.lstAllergySelect(Sender: TObject);
639begin
640 inherited;
641 with lstAllergy do
642 begin
643 if Items.Count = 0 then
644 Exit
645 else if Piece(Items[0], U, 1) = '-1' then
646 Exit;
647 if Piece(Items[0], U, 1) <> FLastAllergyID then
648 FLastAllergyID := Piece(Items[0], U, 1)
649 else
650 Exit;
651 Changing := True;
652 //if Sender <> Self then FillChar(NewRec, SizeOf(NewRec), 0); // Sender=Self when called from SetupDialog
653 Changing := False;
654 end;
655 ControlChange(Self) ;
656end;
657
658procedure TfrmARTAllergy.memCommentsExit(Sender: TObject);
659var
660 AStringList: TStringList;
661begin
662 inherited;
663 AStringList := TStringList.Create;
664 try
665 AStringList.Assign(memComments.Lines);
666 LimitStringLength(AStringList, 74);
667 memComments.Lines.Assign(AstringList);
668 ControlChange(Self);
669 finally
670 AStringList.Free;
671 end;
672end;
673
674procedure TfrmARTAllergy.btnAgentClick(Sender: TObject);
675var
676 Allergy: string;
677begin
678 inherited;
679 AllergyLookup(Allergy, ckNoKnownAllergies.Enabled);
680 if Piece(Allergy, U, 1) = '-1' then
681 ckNoKnownAllergies.Checked := True
682 else if Allergy <> '' then
683 begin
684 lstAllergy.Clear;
685 lstAllergy.Items.Add(Allergy);
686 cboAllergyType.SelectByID(Piece(Allergy, U, 4));
687 end
688 else
689 begin
690 Close;
691 exit;
692 end;
693 ControlChange(lstAllergy);
694end;
695
696procedure TfrmARTAllergy.cboSymptomsClick(Sender: TObject);
697begin
698 inherited;
699 if cboSymptoms.ItemIndex < 0 then exit;
700 Changing := True;
701 if lstSelectedSymptoms.SelectByID(cboSymptoms.ItemID) > -1 then exit;
702 with lstSelectedSymptoms do
703 begin
704 Items.Add(cboSymptoms.Items[cboSymptoms.ItemIndex]);
705 SelectByID(cboSymptoms.ItemID);
706 end;
707 Changing := False;
708 ControlChange(Self)
709end;
710
711procedure TfrmARTAllergy.FormDestroy(Sender: TObject);
712begin
713 OldRec.SignsSymptoms.Free;
714 OldRec.IDBandMarked.Free;
715 OldRec.ChartMarked.Free;
716 OldRec.Observations.Free;
717 OldRec.Comments.Free;
718 OldRec.NewComments.Free;
719 OldRec.ErrorComments.Free;
720 NewRec.SignsSymptoms.Free;
721 NewRec.IDBandMarked.Free;
722 NewRec.ChartMarked.Free;
723 NewRec.Observations.Free;
724 NewRec.Comments.Free;
725 NewRec.NewComments.Free;
726 NewRec.ErrorComments.Free;
727 Defaults.Free;
728 uDeletedSymptoms.Free;
729 AllergyList.Free;
730 inherited;
731end;
732
733procedure TfrmARTAllergy.ckNoKnownAllergiesClick(Sender: TObject);
734begin
735 inherited;
736 Changing := True;
737 FNKAOrder := ckNoKnownAllergies.Checked;
738 EnableDisableControls(not FNKAOrder);
739 Changing := False;
740 ControlChange(Self);
741end;
742
743procedure TfrmARTAllergy.EnableDisableControls(EnabledStatus: boolean);
744begin
745 //InitDialog;
746 with pgAllergy do
747 begin
748 tabVerify.TabVisible := FALSE; //EnabledStatus; per Dave, leave out for now.
749 tabEnteredInError.TabVisible := uEnteredInError;
750 tabGeneral.TabVisible := not uEnteredInError;
751 end;
752 btnAgent.Enabled := EnabledStatus;
753 cboAllergyType.Enabled := EnabledStatus;
754 cboNatureOfReaction.Enabled := EnabledStatus;
755 lblAllergyType.Enabled := EnabledStatus;
756 lblAgent.Enabled := EnabledStatus;
757 lblSymptoms.Enabled := EnabledStatus;
758 lblSelectedSymptoms.Enabled := EnabledStatus;
759 grpObsHist.Enabled := EnabledStatus;
760 memComments.Enabled := EnabledStatus;
761 lblComments.Enabled := EnabledStatus;
762 lstSelectedSymptoms.Enabled := EnabledStatus;
763 lblObservedDate.Enabled := EnabledStatus;
764 calObservedDate.Enabled := EnabledStatus;
765 lblSeverity.Enabled := EnabledStatus;
766 cboSeverity.Enabled := EnabledStatus;
767 btnSevHelp.Enabled := EnabledStatus;
768 lstAllergy.Enabled := EnabledStatus;
769 cboSymptoms.Enabled := EnabledStatus;
770 btnDateTime.Enabled := EnabledStatus;
771end;
772
773procedure TfrmARTAllergy.cmdOKClick(Sender: TObject);
774const
775 TX_ENTERED_IN_ERROR = 'Mark this entry as ''Entered in Error''?';
776 TC_ENTERED_IN_ERROR = 'Are you sure?';
777var
778 Saved: string;
779begin
780 if ValidSave then
781 begin
782 if uEnteredInError then
783 if not (InfoBox(TX_ENTERED_IN_ERROR, TC_ENTERED_IN_ERROR, MB_YESNO or MB_ICONQUESTION) = ID_YES) then
784 begin
785 FChanged := False;
786 Close;
787 Exit;
788 end;
789 Saved := SaveAllergy(NewRec);
790 FChanged := (Piece(Saved, U, 1) = '0');
791 if not FChanged then
792 InfoBox(TX_NO_SAVE + Piece(Saved, U, 2), TX_NO_SAVE_CAP, MB_OK)
793 else
794 begin
795 SendMessage(Application.MainForm.Handle, UM_NEWORDER, ORDER_SIGN, 0);
796 Application.ProcessMessages;
797 end;
798 Close;
799 end;
800end;
801
802function TfrmARTAllergy.ValidSave: Boolean;
803var
804 ErrMsg: string;
805begin
806 Result := True;
807 Validate(ErrMsg);
808 if Length(ErrMsg) > 0 then
809 begin
810 InfoBox(TX_NO_SAVE + ErrMsg, TX_NO_SAVE_CAP, MB_OK);
811 Result := False;
812 end;
813end;
814
815procedure TfrmARTAllergy.btnCurrentClick(Sender: TObject);
816const
817 VIEW_CURRENT = 'Current Allergies/Adverse Reactions for ';
818begin
819 inherited;
820 ReportBox(DetailPosting('A'), VIEW_CURRENT + Patient.Name, True)
821end;
822
823procedure TfrmARTAllergy.btnRemoveClick(Sender: TObject);
824var
825 i: integer;
826 x: string;
827begin
828 inherited;
829 Changing := True;
830 with lstSelectedSymptoms do
831 begin
832 if (Items.Count = 0) or (ItemIndex = -1) then exit;
833 i := ItemIndex;
834 if uEditing then
835 begin
836 if OldRec.SignsSymptoms.IndexOf(Items[ItemIndex]) > -1 then
837 begin
838 x := Items[i];
839 SetPiece(x, U, 5, '@');
840 uDeletedSymptoms.Add(x);
841 end;
842 end;
843 Items.Delete(ItemIndex);
844 ItemIndex := i - 1;
845 if (Items.Count > 0) and (ItemIndex = -1) then ItemIndex := 0;
846 end;
847 Changing := False;
848 ControlChange(btnRemove);
849end;
850
851procedure TfrmARTAllergy.lstAllergyClick(Sender: TObject);
852begin
853 inherited;
854 lstAllergy.ItemIndex := -1;
855end;
856
857procedure TfrmARTAllergy.btnDateTimeClick(Sender: TObject);
858var
859 AFMDateTime: TFMDateTime;
860 x: string;
861begin
862 inherited;
863 Changing := True;
864 with lstSelectedSymptoms do
865 begin
866 if (Items.Count = 0) or (ItemIndex = -1) then exit;
867 AFMDateTime := MakeFMDateTime(Piece(Items[ItemIndex], U, 3));
868 if AFMDateTime > 0 then
869 dlgReactionDateTime.FMDateTime := AFMDateTime
870 else
871 dlgReactionDateTime.FMDateTime := FMNow;
872 if not dlgReactionDateTime.Execute then exit;
873 if dlgReactionDateTime.FMDateTime > FMNow then
874 InfoBox(TX_NO_FUTURE_DATES, TX_CAP_FUTURE, MB_OK)
875 else
876 begin
877 x := Items[ItemIndex];
878 x := ORFn.Pieces(x, U, 1, 2) + U + FloatToStr(dlgReactionDateTime.FMDateTime) + U +
879 FormatFMDateTime('mmm dd,yyyy@hh:nn', dlgReactionDateTime.FMDateTime);
880 Items[ItemIndex] := x;
881 end;
882 end;
883 Changing := False;
884 ControlChange(btnDateTime);
885end;
886
887procedure TfrmARTAllergy.cboSymptomsMouseClick(Sender: TObject);
888var
889 x: string;
890begin
891 inherited;
892 if (cboSymptoms.ItemIndex < 0) and (cboSymptoms.Text = '') then exit;
893 Changing := True;
894 if (lstSelectedSymptoms.SelectByID(cboSymptoms.ItemID) > -1) or
895 (lstSelectedSymptoms.Items.IndexOf(cboSymptoms.Text) > -1) then exit;
896 if cboSymptoms.ItemIndex > -1 then
897 begin
898 with cboSymptoms do
899 if Piece(Items[ItemIndex], U, 3) <> '' then
900 x := ItemID + U + Piece(Items[ItemIndex], U, 3)
901 else
902 x := ItemID + U + Piece(Items[ItemIndex], U, 2);
903 with lstSelectedSymptoms do
904 begin
905 Items.Add(x);
906 SelectByID(cboSymptoms.ItemID);
907 end;
908 end
909 else
910 with lstSelectedSymptoms do
911 begin
912 Items.Add('FT' + U + cboSymptoms.Text);
913 ItemIndex := Items.Count - 1;
914 end;
915 Changing := False;
916 ControlChange(Self)
917end;
918
919procedure TfrmARTAllergy.cboSymptomsKeyDown(Sender: TObject; var Key: Word;
920 Shift: TShiftState);
921begin
922 inherited;
923 if Key = VK_RETURN then cboSymptomsMouseClick(Self);
924end;
925
926procedure TfrmARTAllergy.cmdCancelClick(Sender: TObject);
927begin
928 inherited;
929 FChanged := False;
930 Close;
931end;
932
933procedure TfrmARTAllergy.cmdPrevCmtsClick(Sender: TObject);
934const
935 CMT_CAPTION = 'View previous comments';
936begin
937 inherited;
938 ReportBox(OldRec.Comments, CMT_CAPTION, False);
939end;
940
941procedure TfrmARTAllergy.cmdPrevObsClick(Sender: TObject);
942const
943 OBS_CAPTION = 'View previous observations';
944begin
945 inherited;
946 ReportBox(OldRec.Observations, OBS_CAPTION, False);
947end;
948
949procedure TfrmARTAllergy.lstSelectedSymptomsChange(Sender: TObject);
950begin
951 inherited;
952 with lstSelectedSymptoms do
953 begin
954 btnDateTime.Enabled := (ItemIndex <> -1);
955 btnRemove.Enabled := btnDateTime.Enabled;
956 end;
957 //ControlChange(Self);
958end;
959
960procedure TfrmARTAllergy.cboVerifierNeedData(Sender: TObject;
961 const StartFrom: String; Direction, InsertAt: Integer);
962begin
963 inherited;
964 cboVerifier.ForDataUse(SubSetOfPersons(StartFrom, Direction));
965end;
966
967procedure TfrmARTAllergy.SetupVerifyFields(ARec: TAllergyRec);
968var
969 CanBeVerified: boolean;
970begin
971 tabVerify.TabVisible := False; // FOR NOW
972 if not tabVerify.TabVisible then exit;
973 if not uUserCanVerify then
974 begin
975 tabVerify.TabVisible := False;
976 exit;
977 end;
978 Changing := True;
979 with ARec do
980 begin
981 ckVerified.Checked := Verified;
982 CanBeVerified := (not Verified) and uUserCanVerify;
983 if CanBeVerified then
984 begin
985 cboVerifier.InitLongList(User.Name);
986 cboVerifier.SelectByIEN(User.DUZ);
987 cboVerifier.Font.Color := clWindowText;
988 calVerifyDate.FMDateTime := FMNow;
989 end
990 else
991 begin
992 cboVerifier.InitLongList(VerifierName);
993 cboVerifier.SelectByIEN(Verifier);
994 cboVerifier.Font.Color := clGrayText;
995 calVerifyDate.FMDateTime := VerifiedDateTime;
996 end;
997 cboVerifier.Enabled := CanBeVerified;
998 calVerifyDate.Enabled := CanBeVerified;
999 ckVerified.Enabled := CanBeVerified;
1000 lblVerifier.Enabled := CanBeVerified;
1001 lblVerifyDate.Enabled := CanBeVerified;
1002 end;
1003 Changing := False;
1004 ControlChange(ckVerified);
1005end;
1006
1007procedure TfrmARTAllergy.SetUpEnteredInErrorFields(ARec: TAllergyRec);
1008const
1009 TC_ERR_CMTS_OPTIONAL = 'Comments (optional)';
1010 TC_ERR_CMTS_DISABLED = 'Comments (disabled)';
1011 TX_ENTERED_IN_ERROR1 = 'Clicking ''OK'' will mark ';
1012 TX_ENTERED_IN_ERROR2 = ' as ''Entered in Error''.';
1013
1014begin
1015 tabEnteredInError.TabVisible := uEnteredInError;
1016 tabGeneral.TabVisible := not uEnteredInError;
1017 tabVerify.TabVisible := FALSE; // not uEnteredInError;
1018 Changing := True;
1019 ckEnteredInError.Checked := uEnteredInError;
1020 if uEnteredInError then
1021 begin
1022 lblEnteredInError.Caption := TX_ENTERED_IN_ERROR1 + UpperCase(OldRec.CausativeAgent) + TX_ENTERED_IN_ERROR2;
1023 if EnableErrorComments then
1024 begin
1025 memErrCmts.Enabled := True;
1026 memErrCmts.Color := clWindow;
1027 lblErrCmts.Enabled := True;
1028 lblErrCmts.Caption := TC_ERR_CMTS_OPTIONAL;
1029 ActiveControl := memErrCmts;
1030 end
1031 else
1032 begin
1033 memErrCmts.Enabled := False;
1034 memErrCmts.Color := clBtnFace;
1035 lblErrCmts.Enabled := False;
1036 lblErrCmts.Caption := TC_ERR_CMTS_DISABLED;
1037 ActiveControl := cmdOK;
1038 end;
1039 end;
1040 Changing := False;
1041 ControlChange(ckEnteredInError);
1042end;
1043
1044
1045procedure TfrmARTAllergy.FormClose(Sender: TObject;
1046 var Action: TCloseAction);
1047begin
1048 inherited;
1049 uEditing := False;
1050 uEnteredInError := False;
1051 uAddingNew := False;
1052 Application.HintHidePause := FOldHintPause;
1053 Action := caFree;
1054end;
1055
1056procedure TfrmARTAllergy.FormCloseQuery(Sender: TObject;
1057 var CanClose: Boolean);
1058begin
1059 inherited;
1060 if AbortAction then exit;
1061end;
1062
1063procedure TfrmARTAllergy.btnSevHelpClick(Sender: TObject);
1064const
1065 TX_SEV_DEFINITION = 'MILD - Requires minimal therapeutic intervention '+#13+#10+
1066 'such as discontinuation of drug(s)'+#13+#10+''+#13+#10+
1067 'MODERATE - Requires active treatment of adverse reaction, '+#13+#10+
1068 'or further testing or evaluation to assess extent of non-serious'+#13+#10+
1069 'outcome (see SEVERE for definition of serious).'+#13+#10+''+#13+#10+
1070 'SEVERE - Includes any serious outcome, resulting in life- or'+#13+#10+
1071 'organ-threatening situation or death, significant or permanent'+#13+#10+
1072 'disability, requiring intervention to prevent permanent impairment '+#13+#10+
1073 'or damage, or requiring/prolonging hospitalization.';
1074 TC_SEV_CAPTION = 'Severity Levels';
1075begin
1076 inherited;
1077 InfoBox(TX_SEV_DEFINITION, TC_SEV_CAPTION, MB_ICONINFORMATION or MB_OK);
1078end;
1079
1080end.
Note: See TracBrowser for help on using the repository browser.