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

Last change on this file since 1115 was 460, checked in by Kevin Toppenberg, 17 years ago

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