source: cprs/trunk/CPRS-Chart/fARTAllgy.pas@ 1406

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

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