close Warning: Can't use blame annotator: 
svn blame failed on cprs/trunk/CPRS-Chart/Orders/fODAllgy.pas: 'GenericSWIGWrapper' object has no attribute '_wrap'

source: cprs/trunk/CPRS-Chart/Orders/fODAllgy.pas@ 1495

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

Upgrade to version 27
File size: 17.6 KB
RevLine 
1unit fODAllgy;
2{$O-}
3interface
4
5uses
6 SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
7 Forms, Dialogs, StdCtrls, ORCtrls, ORfn, fODBase, ExtCtrls, ComCtrls, uConst,
8 Menus, ORDtTm, Buttons, VA508AccessibilityManager;
9
10type
11 TfrmODAllergy = class(TfrmODBase)
12 btnAgent: TSpeedButton;
13 cboReactionType: TORComboBox;
14 lblReactionType: TOROffsetLabel;
15 lblAgent: TOROffsetLabel;
16 lblSymptoms: TOROffsetLabel;
17 lblSelectedSymptoms: TOROffsetLabel;
18 grpObsHist: TRadioGroup;
19 memComments: TRichEdit;
20 lblComments: TOROffsetLabel;
21 lstSelectedSymptoms: TORListBox;
22 ckNoKnownAllergies: TCheckBox;
23 cboOriginator: TORComboBox;
24 lblOriginator: TOROffsetLabel;
25 Bevel1: TBevel;
26 lstAllergy: TORListBox;
27 cboSymptoms: TORComboBox;
28 dlgReactionDateTime: TORDateTimeDlg;
29 btnCurrent: TButton;
30 lblObservedDate: TOROffsetLabel;
31 calObservedDate: TORDateBox;
32 lblSeverity: TOROffsetLabel;
33 cboSeverity: TORComboBox;
34 btnRemove: TButton;
35 btnDateTime: TButton;
36 procedure btnAgentClick(Sender: TObject);
37 procedure FormCreate(Sender: TObject);
38 procedure cboOriginatorNeedData(Sender: TObject; const StartFrom: String;
39 Direction, InsertAt: Integer);
40 procedure cboSymptomsNeedData(Sender: TObject; const StartFrom: String;
41 Direction, InsertAt: Integer);
42 procedure lstAllergySelect(Sender: TObject);
43 procedure grpObsHistClick(Sender: TObject);
44 procedure ControlChange(Sender: TObject);
45 procedure memCommentsExit(Sender: TObject);
46 procedure cboSymptomsClick(Sender: TObject);
47 procedure FormDestroy(Sender: TObject);
48 procedure ckNoKnownAllergiesClick(Sender: TObject);
49 procedure EnableControls;
50 procedure DisableControls;
51 procedure cmdAcceptClick(Sender: TObject);
52 procedure btnCurrentClick(Sender: TObject);
53 procedure btnRemoveClick(Sender: TObject);
54 procedure lstAllergyClick(Sender: TObject);
55 procedure btnDateTimeClick(Sender: TObject);
56 procedure cboSymptomsKeyDown(Sender: TObject; var Key: Word;
57 Shift: TShiftState);
58 procedure cboSymptomsMouseClick(Sender: TObject);
59 procedure memCommentsKeyUp(Sender: TObject; var Key: Word;
60 Shift: TShiftState);
61 private
62 FLastAllergyID: string;
63 FNKAOrder: boolean;
64 protected
65 procedure InitDialog; override;
66 procedure Validate(var AnErrMsg: string); override;
67 public
68 procedure SetupDialog(OrderAction: Integer; const ID: string); override;
69 end;
70
71var
72 frmODAllergy: TfrmODAllergy;
73 AllergyList: TStringList;
74
75implementation
76
77{$R *.DFM}
78
79uses
80 rODBase, uCore, rCore, rCover, rODAllergy, fAllgyFind, fPtCWAD;
81
82const
83 TX_NO_ALLERGY = 'An allergy must be specified.' ;
84 TX_NO_REACTION = 'A reaction type must be entered for this allergy.' ;
85 TX_NO_SYMPTOMS = 'Symptoms must be selected for this observed allergy and reaction.';
86 TX_NO_OBSERVER = 'An observer must be selected for this allergy and reaction .';
87 TX_NO_FUTURE_DATES = 'Dates in the future are not allowed.';
88 TX_BAD_DATE = 'Dates must be in the format m/d/y or m/y or y, or T-d.';
89 TX_CAP_FUTURE = 'Invalid date';
90
91procedure TfrmODAllergy.FormCreate(Sender: TObject);
92begin
93 inherited;
94 AllergyList := TStringList.Create;
95 AllowQuickOrder := False;
96 FillerID := 'GMRD'; // does 'on Display' order check **KCM**
97 StatusText('Loading Dialog Definition');
98 Responses.Dialog := 'GMRAOR ALLERGY ENTER/EDIT'; // loads formatting info
99 StatusText('Loading Default Values');
100 CtrlInits.LoadDefaults(ODForAllergies); // returns TStrings with defaults
101 StatusText('Initializing Long List');
102 CtrlInits.SetControl(cboSymptoms, 'Top Ten');
103 cboSymptoms.InsertSeparator;
104 cboOriginator.InitLongList(User.Name) ;
105 cboOriginator.SelectByIEN(User.DUZ);
106 PreserveControl(cboSymptoms);
107 PreserveControl(cboOriginator);
108 InitDialog;
109 btnAgentClick(Self);
110end;
111
112procedure TfrmODAllergy.InitDialog;
113begin
114 inherited;
115 Changing := True;
116 with CtrlInits do
117 begin
118 SetControl(cboReactionType, 'Reactions');
119 SetControl(cboSeverity, 'Severity');
120 end;
121 lstAllergy.Items.Add('-1^Click button to search ---->');
122 grpObsHist.ItemIndex := 1;
123 calObservedDate.Text := ''; //FMDateTime := FMNow;
124 cboSeverity.ItemIndex := -1;
125 cboSymptoms.ItemIndex := -1;
126 memComments.Clear;
127 ListAllergies(AllergyList);
128 with AllergyList do
129 if Count > 0 then
130 begin
131 if Piece(Strings[0], U, 1) = '' then
132 ckNoKnownAllergies.Enabled := True
133 else
134 ckNoKnownAllergies.Enabled := False;
135 end
136 else
137 ckNoKnownAllergies.Enabled := True;
138 StatusText('');
139 memOrder.Clear ;
140 Changing := False;
141end;
142
143procedure TfrmODAllergy.SetupDialog(OrderAction: Integer; const ID: string);
144begin
145 inherited;
146 if OrderAction in [ORDER_COPY, ORDER_EDIT, ORDER_QUICK] then with Responses do
147 begin
148 SetControl(lstAllergy, 'ITEM', 1);
149 lstAllergySelect(Self);
150 Changing := True;
151 SetControl(cboReactionType, 'TYPE', 1);
152 SetControl(lstSelectedSymptoms, 'REACTION', 1); // need dates concatenated - see cboSymptomsClick
153 SetControl(grpObsHist, 'OBSERVED', 1);
154 SetControl(calObservedDate, 'START', 1);
155 SetControl(cboSeverity, 'SEVERITY', 1);
156 SetControl(memComments, 'COMMENT', 1);
157 SetControl(ckNoKnownAllergies, 'NKA', 1);
158 SetControl(cboOriginator, 'PROVIDER', 1);
159 Changing := False;
160 ControlChange(Self);
161 end;
162end;
163
164procedure TfrmODAllergy.Validate(var AnErrMsg: string);
165var
166 tmpDate: TFMDateTime;
167const
168 TX_NO_LOCATION = 'A location must be identified.' + CRLF +
169 '(Select File | Update Provider/Location)';
170 TX_NO_PROVIDER = 'A provider who is authorized to write orders must be indentified.' + CRLF +
171 '(Select File | Update Provider/Location)';
172
173 procedure SetError(const x: string);
174 begin
175 if Length(AnErrMsg) > 0 then AnErrMsg := AnErrMsg + CRLF;
176 AnErrMsg := AnErrMsg + x;
177 end;
178
179begin
180// inherited; v14a - do not reject past dates - historical would not be allowed
181 AnErrMsg := '';
182 if User.NoOrdering then AnErrMsg := 'Ordering has been disabled. Press Quit.';
183 if not ckNoKnownAllergies.Checked then
184 begin
185 if lstAllergy.Items.Count = 0 then SetError(TX_NO_ALLERGY)
186 else if (Length(lstAllergy.DisplayText[0]) = 0) or
187 (Piece(lstAllergy.Items[0], U, 1) = '-1') then SetError(TX_NO_ALLERGY);
188 if (grpObsHist.ItemIndex = 0) and (lstSelectedSymptoms.Items.Count = 0) then SetError(TX_NO_SYMPTOMS);
189 if cboReactionType.ItemID = '' then
190 SetError(TX_NO_REACTION)
191 else
192 Responses.Update('TYPE', 1, cboReactionType.ItemID, cboReactionType.Text);
193 end;
194 if cboOriginator.ItemIEN = 0 then SetError(TX_NO_OBSERVER);
195 if calObservedDate.Text <> '' then
196 begin
197 tmpDate := ValidDateTimeStr(calObservedDate.Text, 'TS');
198 if tmpDate > FMNow then SetError(TX_NO_FUTURE_DATES);
199 if tmpDate < 0 then SetError(TX_BAD_DATE);
200 end;
201 if (Encounter.Location = 0) and not(Self.EvtID>0) then AnErrMsg := TX_NO_LOCATION;
202 if (Encounter.Provider = 0) or (PersonHasKey(Encounter.Provider, 'PROVIDER') = False)
203 then AnErrMsg := TX_NO_PROVIDER;
204end;
205
206procedure TfrmODAllergy.cboOriginatorNeedData(Sender: TObject;
207 const StartFrom: string; Direction, InsertAt: Integer);
208begin
209 inherited;
210 cboOriginator.ForDataUse(SubSetOfPersons(StartFrom, Direction));
211end;
212
213procedure TfrmODAllergy.cboSymptomsNeedData(Sender: TObject;
214 const StartFrom: string; Direction, InsertAt: Integer);
215begin
216 inherited;
217 cboSymptoms.ForDataUse(SubSetOfSymptoms(StartFrom, Direction));
218end;
219
220procedure TfrmODAllergy.grpObsHistClick(Sender: TObject);
221begin
222 inherited;
223 Changing := True;
224 cboSeverity.ItemIndex := -1;
225 case grpObsHist.ItemIndex of
226 0: begin
227 cboSeverity.Visible := True;
228 lblSeverity.Visible := True;
229 end;
230 1: begin
231 cboSeverity.Visible := False;
232 lblSeverity.Visible := False;
233 end;
234 end;
235 Changing := False;
236 ControlChange(Self);
237end;
238
239procedure TfrmODAllergy.ControlChange(Sender: TObject);
240var
241 i: integer;
242 tmpDate: TFMDateTime;
243begin
244 inherited;
245 if Changing then Exit;
246 Responses.Clear;
247 if ckNoKnownAllergies.Checked then
248 begin
249 Responses.Update('NKA', 1, 'NKA', 'No Known Allergies');
250 with cboOriginator do if ItemIEN > 0 then Responses.Update('PROVIDER', 1, ItemID, Text);
251 end
252 else
253 with lstAllergy do
254 if (Items.Count > 0) then
255 if (Piece(Items[0], U, 1) <> '-1') and (Length(DisplayText[0]) > 0) then
256 begin
257 Responses.Update('ITEM', 1, DisplayText[0], DisplayText[0]);
258 with cboReactionType do if ItemID <> '' then Responses.Update('TYPE', 1, ItemID, Text);
259 with lstSelectedSymptoms do for i := 0 to Items.Count - 1 do
260 begin
261 Responses.Update('REACTION', i+1, Piece(Items[i],U,1), Piece(Items[i],U,2));
262 Responses.Update('REACTDT', i+1, Piece(Items[i],U,3), Piece(Items[i],U,4));
263 end;
264 with grpObsHist do if ItemIndex > -1 then
265 if ItemIndex = 0 then Responses.Update('OBSERVED', 1, 'o', 'Observed')
266 else Responses.Update('OBSERVED', 1, 'h', 'Historical');
267 with calObservedDate do
268 begin
269 tmpDate := ValidDateTimeStr(calObservedDate.Text, 'TS');
270 if tmpDate > 0 then Responses.Update('START', 1, FloatToStr(tmpDate), Text);
271 end;
272 with cboSeverity do if ItemID <> '' then Responses.Update('SEVERITY', 1, ItemID, Text);
273 with cboOriginator do if ItemIEN > 0 then Responses.Update('PROVIDER', 1, ItemID, Text);
274 with memComments do if GetTextLen > 0 then Responses.Update('COMMENT', 1, TX_WPTYPE, Text);
275 end;
276 memOrder.Text := Responses.OrderText;
277end;
278
279procedure TfrmODAllergy.lstAllergySelect(Sender: TObject);
280begin
281 inherited;
282 with lstAllergy do
283 begin
284 if Items.Count = 0 then
285 Exit
286 else if Piece(Items[0], U, 1) = '-1' then
287 Exit;
288 if Piece(Items[0], U, 1) <> FLastAllergyID then FLastAllergyID := Piece(Items[0], U, 1) else Exit;
289 Changing := True;
290 if Sender <> Self then Responses.Clear; // Sender=Self when called from SetupDialog
291 Changing := False;
292 if CharAt(Piece(Items[0], U, 1), 1) = 'Q' then
293 begin
294 Responses.QuickOrder := ExtractInteger(Piece(Items[0], U, 1));
295 Responses.SetControl(lstAllergy, 'ITEM', 1);
296 FLastAllergyID := Piece(Items[0], U, 1);
297 end;
298 end;
299 with Responses do if QuickOrder > 0 then
300 begin
301 SetControl(lstAllergy, 'ITEM', 1);
302 lstAllergySelect(Self);
303 Changing := True;
304 SetControl(cboReactionType, 'TYPE', 1);
305 SetControl(lstSelectedSymptoms, 'REACTION', 1);
306 SetControl(grpObsHist, 'OBSERVED', 1);
307 SetControl(calObservedDate, 'START', 1);
308 SetControl(cboSeverity, 'SEVERITY', 1);
309 SetControl(memComments, 'COMMENT', 1);
310 SetControl(ckNoKnownAllergies, 'NKA', 1);
311 SetControl(cboOriginator, 'PROVIDER', 1);
312 end;
313 ControlChange(Self) ;
314end;
315
316procedure TfrmODAllergy.memCommentsExit(Sender: TObject);
317var
318 AStringList: TStringList;
319begin
320 inherited;
321 AStringList := TStringList.Create;
322 try
323 FastAssign(memComments.Lines, AStringList);
324 LimitStringLength(AStringList, 74);
325 QuickCopy(AstringList, memComments);
326 ControlChange(Self);
327 finally
328 AStringList.Free;
329 end;
330end;
331
332procedure TfrmODAllergy.btnAgentClick(Sender: TObject);
333var
334 Allergy: string;
335begin
336 inherited;
337 AllergyLookup(Allergy, ckNoKnownAllergies.Enabled);
338 if Piece(Allergy, U, 1) = '-1' then
339 ckNoKnownAllergies.Checked := True
340 else
341 if Allergy <> '' then
342 begin
343 lstAllergy.Clear;
344 lstAllergy.Items.Add(Allergy);
345 cboReactionType.SelectByID(Piece(Allergy, U, 4));
346 end
347 else
348 Close;
349 ControlChange(lstAllergy);
350end;
351
352procedure TfrmODAllergy.cboSymptomsClick(Sender: TObject);
353begin
354 inherited;
355 if cboSymptoms.ItemIndex < 0 then exit;
356 Changing := True;
357 if lstSelectedSymptoms.SelectByID(cboSymptoms.ItemID) > -1 then exit;
358 with lstSelectedSymptoms do
359 begin
360 Items.Add(cboSymptoms.Items[cboSymptoms.ItemIndex]);
361 SelectByID(cboSymptoms.ItemID);
362 end;
363 Changing := False;
364 ControlChange(Self)
365end;
366
367procedure TfrmODAllergy.FormDestroy(Sender: TObject);
368begin
369 AllergyList.Free;
370 inherited;
371end;
372
373procedure TfrmODAllergy.ckNoKnownAllergiesClick(Sender: TObject);
374begin
375 inherited;
376 if ckNoKnownAllergies.Checked then
377 begin
378 DisableControls;
379 FNKAOrder := True;
380 end
381 else
382 begin
383 EnableControls;
384 FNKAOrder := False;
385 end;
386 ControlChange(Self);
387end;
388
389procedure TfrmODAllergy.DisableControls;
390begin
391 InitDialog;
392 btnAgent.Enabled := False;
393 cboReactionType.Enabled := False;
394 lblReactionType.Enabled := False;
395 lblAgent.Enabled := False;
396 lblSymptoms.Enabled := False;
397 lblSelectedSymptoms.Enabled := False;
398 grpObsHist.Enabled := False;
399 memComments.Enabled := False;
400 lblComments.Enabled := False;
401 lstSelectedSymptoms.Enabled := False;
402 lblObservedDate.Enabled := False;
403 calObservedDate.Enabled := False;
404 lblSeverity.Enabled := False;
405 cboSeverity.Enabled := False;
406 lstAllergy.Enabled := False;
407 cboSymptoms.Enabled := False;
408 btnDateTime.Enabled := False;
409end;
410
411procedure TfrmODAllergy.EnableControls;
412begin
413 InitDialog;
414 btnAgent.Enabled := True;
415 cboReactionType.Enabled := True;
416 lblReactionType.Enabled := True;
417 lblAgent.Enabled := True;
418 lblSymptoms.Enabled := True;
419 lblSelectedSymptoms.Enabled := True;
420 grpObsHist.Enabled := True;
421 memComments.Enabled := True;
422 lblComments.Enabled := True;
423 lstSelectedSymptoms.Enabled := True;
424 lblObservedDate.Enabled := True;
425 calObservedDate.Enabled := True;
426 lblSeverity.Enabled := True;
427 cboSeverity.Enabled := True;
428 lstAllergy.Enabled := True;
429 cboSymptoms.Enabled := True;
430 btnDateTime.Enabled := True;
431end;
432
433procedure TfrmODAllergy.cmdAcceptClick(Sender: TObject);
434begin
435 if not FNKAOrder then
436 inherited
437 else
438 if ValidSave then
439 begin
440 ckNoKnownAllergies.Checked := False;
441 memOrder.Clear;
442 Responses.Clear; // to allow form to close without prompting to save order
443 Close;
444 end;
445end;
446
447procedure TfrmODAllergy.btnCurrentClick(Sender: TObject);
448begin
449 inherited;
450 ShowCWAD;
451end;
452
453
454procedure TfrmODAllergy.btnRemoveClick(Sender: TObject);
455var
456 i: integer;
457begin
458 inherited;
459 with lstSelectedSymptoms do
460 begin
461 if (Items.Count = 0) or (ItemIndex = -1) then exit;
462 i := ItemIndex;
463 Items.Delete(ItemIndex);
464 ItemIndex := i - 1;
465 if (Items.Count > 0) and (ItemIndex = -1) then ItemIndex := 0;
466 end;
467end;
468
469procedure TfrmODAllergy.lstAllergyClick(Sender: TObject);
470begin
471 inherited;
472 lstAllergy.ItemIndex := -1;
473end;
474
475procedure TfrmODAllergy.btnDateTimeClick(Sender: TObject);
476begin
477 inherited;
478 with lstSelectedSymptoms do
479 begin
480 if (Items.Count = 0) or (ItemIndex = -1) then exit;
481 dlgReactionDateTime.FMDateTime := FMNow;
482 if not dlgReactionDateTime.Execute then exit;
483 if dlgReactionDateTime.FMDateTime > FMNow then
484 InfoBox(TX_NO_FUTURE_DATES, TX_CAP_FUTURE, MB_OK)
485 else
486 Items[ItemIndex] := Items[ItemIndex] + U + FloatToStr(dlgReactionDateTime.FMDateTime) + U + FormatFMDateTime('mmm dd,yyyy@hh:nn', dlgReactionDateTime.FMDateTime);
487 end;
488end;
489
490procedure TfrmODAllergy.cboSymptomsKeyDown(Sender: TObject; var Key: Word;
491 Shift: TShiftState);
492begin
493 inherited;
494 if Key = VK_RETURN then cboSymptomsMouseClick(Self);
495end;
496
497procedure TfrmODAllergy.cboSymptomsMouseClick(Sender: TObject);
498var
499 x: string;
500begin
501 inherited;
502 if cboSymptoms.ItemIndex < 0 then exit;
503 Changing := True;
504 if lstSelectedSymptoms.SelectByID(cboSymptoms.ItemID) > -1 then exit;
505 with cboSymptoms do
506 if Piece(Items[ItemIndex], U, 3) <> '' then
507 x := ItemID + U + Piece(Items[ItemIndex], U, 3)
508 else
509 x := ItemID + U + Piece(Items[ItemIndex], U, 2);
510 with lstSelectedSymptoms do
511 begin
512 Items.Add(x);
513 SelectByID(cboSymptoms.ItemID);
514 end;
515 Changing := False;
516 ControlChange(Self)
517end;
518
519procedure TfrmODAllergy.memCommentsKeyUp(Sender: TObject; var Key: Word;
520 Shift: TShiftState);
521begin
522 inherited;
523 if (Key = VK_TAB) then
524 begin
525 if ssShift in Shift then
526 begin
527 FindNextControl(Sender as TWinControl, False, True, False).SetFocus; //previous control
528 Key := 0;
529 end
530 else if ssCtrl in Shift then
531 begin
532 FindNextControl(Sender as TWinControl, True, True, False).SetFocus; //next control
533 Key := 0;
534 end;
535 end;
536 if (key = VK_ESCAPE) then begin
537 FindNextControl(Sender as TWinControl, False, True, False).SetFocus; //previous control
538 key := 0;
539 end;
540end;
541
542end.
Note: See TracBrowser for help on using the repository browser.