source: cprs/branches/foia-cprs/CPRS-Chart/fPtSel.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: 36.8 KB
Line 
1unit fPtSel;
2{ Allows patient selection using various pt lists. Allows display & processing of alerts. }
3
4{$OPTIMIZATION OFF} // REMOVE AFTER UNIT IS DEBUGGED
5
6interface
7
8uses
9 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
10 StdCtrls, ORCtrls, ExtCtrls, ORFn, ORNet, ORDtTmRng, Gauges, Menus, ComCtrls,
11 UBAGlobals, UBACore;
12
13type
14 TfrmPtSel = class(TForm)
15 pnlPtSel: TORAutoPanel;
16 cboPatient: TORComboBox;
17 lblPatient: TLabel;
18 cmdOK: TButton;
19 cmdCancel: TButton;
20 pnlNotifications: TORAutoPanel;
21 cmdProcessInfo: TButton;
22 cmdProcessAll: TButton;
23 cmdProcess: TButton;
24 cmdForward: TButton;
25 sptVert: TSplitter;
26 cmdSaveList: TButton;
27 pnlDivide: TORAutoPanel;
28 lblNotifications: TLabel;
29 ggeInfo: TGauge;
30 cmdRemove: TButton;
31 popNotifications: TPopupMenu;
32 mnuProcess: TMenuItem;
33 mnuRemove: TMenuItem;
34 mnuForward: TMenuItem;
35 lstvAlerts: TCaptionListView;
36 N1: TMenuItem;
37 procedure cmdOKClick(Sender: TObject);
38 procedure cmdCancelClick(Sender: TObject);
39 procedure cboPatientChange(Sender: TObject);
40 procedure cboPatientKeyPause(Sender: TObject);
41 procedure cboPatientMouseClick(Sender: TObject);
42 procedure cboPatientEnter(Sender: TObject);
43 procedure cboPatientExit(Sender: TObject);
44 procedure cboPatientNeedData(Sender: TObject; const StartFrom: string;
45 Direction, InsertAt: Integer);
46 procedure cboPatientDblClick(Sender: TObject);
47 procedure cmdProcessClick(Sender: TObject);
48 procedure cmdSaveListClick(Sender: TObject);
49 procedure cmdProcessInfoClick(Sender: TObject);
50 procedure cmdProcessAllClick(Sender: TObject);
51 procedure lstvAlertsDblClick(Sender: TObject);
52 procedure cmdForwardClick(Sender: TObject);
53 procedure cmdRemoveClick(Sender: TObject);
54 procedure FormDestroy(Sender: TObject);
55 procedure pnlPtSelResize(Sender: TObject);
56 procedure FormClose(Sender: TObject; var Action: TCloseAction);
57 procedure cboPatientKeyDown(Sender: TObject; var Key: Word;
58 Shift: TShiftState);
59 procedure lstvAlertsColumnClick(Sender: TObject; Column: TListColumn);
60 procedure lstvAlertsCompare(Sender: TObject; Item1, Item2: TListItem; Data: Integer; var Compare: Integer);
61 function DupLastSSN(const DFN: string): Boolean;
62 procedure lstFlagsClick(Sender: TObject);
63 procedure lstFlagsKeyDown(Sender: TObject; var Key: Word;
64 Shift: TShiftState);
65 procedure lstvAlertsSelectItem(Sender: TObject; Item: TListItem;
66 Selected: Boolean);
67 procedure ShowButts(ShowButts: Boolean);
68 procedure lstvAlertsInfoTip(Sender: TObject; Item: TListItem;
69 var InfoTip: String);
70 procedure FormKeyDown(Sender: TObject; var Key: Word;
71 Shift: TShiftState);
72 procedure lstvAlertsKeyDown(Sender: TObject; var Key: Word;
73 Shift: TShiftState);
74 procedure FormShow(Sender: TObject);
75 private
76 FsortCol: integer;
77 FsortAscending: boolean;
78 FLastPt: string;
79 procedure AdjustFormSize(ShowNotif: Boolean; FontSize: Integer);
80 procedure ClearIDInfo;
81 procedure ShowIDInfo;
82 procedure ShowFlagInfo;
83 procedure SetCaptionTop;
84 procedure SetPtListTop(IEN: Int64);
85 procedure RPLDisplay;
86 procedure AlertList;
87 public
88 procedure Loaded; override;
89 end;
90
91procedure SelectPatient(ShowNotif: Boolean; FontSize: Integer);
92
93var
94 frmPtSel: TfrmPtSel;
95 FDfltSrc, FDfltSrcType: string;
96 IsRPL, RPLJob, DupDFN: string; // RPLJob stores server $J job number of RPL pt. list.
97 RPLProblem: boolean; // Allows close of form if there's an RPL problem.
98 PtStrs: TStringList;
99 SortViaKeyboard: boolean;
100
101implementation
102
103{$R *.DFM}
104
105uses rCore, uCore, fDupPts, fPtSens, fPtSelDemog, fPtSelOptns, fPatientFlagMulti,
106 uOrPtf, fAlertForward, rMisc, fFrame;
107
108const
109 TX_DGSR_ERR = 'Unable to perform sensitive record checks';
110 TC_DGSR_ERR = 'Error';
111 TC_DGSR_SHOW = 'Restricted Record';
112 TC_DGSR_DENY = 'Access Denied';
113 TX_DGSR_YESNO = CRLF + 'Do you want to continue processing this patient record?';
114 AliasString = ' -- ALIAS';
115
116procedure SelectPatient(ShowNotif: Boolean; FontSize: Integer);
117{ displays patient selection dialog (with optional notifications), updates Patient object }
118var
119 frmPtSel: TfrmPtSel;
120begin
121 frmPtSel := TfrmPtSel.Create(Application);
122 RPLProblem := false;
123 try
124 with frmPtSel do
125 begin
126 AdjustFormSize(ShowNotif, FontSize); // Set initial form size
127 FDfltSrc := DfltPtList;
128 FDfltSrcType := Piece(FDfltSrc, U, 2);
129 FDfltSrc := Piece(FDfltSrc, U, 1);
130 if (IsRPL = '1') then // Deal with restricted patient list users.
131 FDfltSrc := '';
132 frmPtSelOptns.SetDefaultPtList(FDfltSrc);
133 if RPLProblem then
134 begin
135 frmPtSel.Release;
136 Exit;
137 end;
138 Notifications.Clear;
139 AlertList;
140 ClearIDInfo;
141 if (IsRPL = '1') then // Deal with restricted patient list users.
142 RPLDisplay; // Removes unnecessary components from view.
143 ShowModal;
144 end;
145 finally
146 frmPtSel.Release;
147 end;
148end;
149
150procedure TfrmPtSel.AdjustFormSize(ShowNotif: Boolean; FontSize: Integer);
151{ Adjusts the initial size of the form based on the font used & if notifications should show. }
152var
153 Rect: TRect;
154// TheFormHeight: integer;
155 SplitterTop, t1, t2, t3: integer;
156begin
157 ResizeAnchoredFormToFont(self);
158// TheFormHeight := pnlPtSel.Height;
159 // Make the form bigger (140%) to show notifications and show notification controls.
160 if ShowNotif then
161 begin
162// TheFormHeight := Round(TheFormHeight * 2.4);
163// pnlDivide.Height := lblNotifications.Height + 4;
164 pnlDivide.Visible := True;
165 lstvAlerts.Visible := True;
166 pnlNotifications.Visible := True;
167 pnlPtSel.BevelOuter := bvRaised;
168// ClientHeight := TheFormHeight;
169 end
170 else
171 begin
172 pnlDivide.Visible := False;
173 lstvAlerts.Visible := False;
174 pnlNotifications.Visible := False;
175// ClientHeight := TheFormHeight;
176// pnlPtSel.Anchors := [akLeft,akRight,akTop,akBottom];
177 end;
178// ClientHeight := TheFormHeight;
179// VertScrollBar.Range := TheFormHeight;
180
181 //After all of this calcualtion, we still use the saved preferences when possible
182 SetFormPosition(self);
183 Rect := BoundsRect;
184 ForceInsideWorkArea(Rect);
185 BoundsRect := Rect;
186
187 if frmFrame.EnduringPtSelSplitterPos <> 0 then
188 SplitterTop := frmFrame.EnduringPtSelSplitterPos
189 else
190 SetUserBounds2(Name+'.'+sptVert.Name,SplitterTop, t1, t2, t3);
191 if SplitterTop <> 0 then
192 pnlPtSel.Height := SplitterTop;
193end;
194
195procedure TfrmPtSel.SetCaptionTop;
196{ Show patient list name, set top list to 'Select ...' if appropriate. }
197var
198 x: string;
199begin
200 x := '';
201 lblPatient.Caption := 'Patients';
202 if (not User.IsReportsOnly) then
203 begin
204 case frmPtSelOptns.SrcType of
205 TAG_SRC_DFLT: lblPatient.Caption := 'Patients (' + FDfltSrc + ')';
206 TAG_SRC_PROV: x := 'Provider';
207 TAG_SRC_TEAM: x := 'Team';
208 TAG_SRC_SPEC: x := 'Specialty';
209 TAG_SRC_CLIN: x := 'Clinic';
210 TAG_SRC_WARD: x := 'Ward';
211 TAG_SRC_ALL: { Nothing };
212 end; // case stmt
213 end; // begin
214 if Length(x) > 0 then with cboPatient do
215 begin
216 RedrawSuspend(Handle);
217 ClearIDInfo;
218 ClearTop;
219 Text := '';
220 Items.Add('^Select a ' + x + '...');
221 Items.Add(LLS_LINE);
222 Items.Add(LLS_SPACE);
223 cboPatient.InitLongList('');
224 RedrawActivate(cboPatient.Handle);
225 end;
226end;
227
228{ List Source events: }
229
230procedure TfrmPtSel.SetPtListTop(IEN: Int64);
231{ Sets top items in patient list according to list source type and optional list source IEN. }
232var
233 NewTopList: string;
234 FirstDate, LastDate: string;
235begin
236 // NOTE: Some pieces in RPC returned arrays are rearranged by ListPtByDflt call in rCore!
237 IsRPL := User.IsRPL;
238 if (IsRPL = '') then // First piece in ^VA(200,.101) should always be set (to 1 or 0).
239 begin
240 InfoBox('Patient selection list flag not set.', 'Incomplete User Information', MB_OK);
241 RPLProblem := true;
242 Exit;
243 end;
244 // FirstDate := 0; LastDate := 0; // Not req'd, but eliminates hint.
245 // Assign list box TabPosition, Pieces properties according to type of list to be displayed.
246 // (Always use Piece "2" as the first in the list to assure display of patient's name.)
247 cboPatient.pieces := '2,3'; // This line and next: defaults set - exceptions modifield next.
248 cboPatient.tabPositions := '20,28';
249 if ((frmPtSelOptns.SrcType = TAG_SRC_DFLT) and (FDfltSrc = 'Combination')) then
250 begin
251 cboPatient.pieces := '2,3,4,5,9';
252 cboPatient.tabPositions := '20,28,35,45';
253 end;
254 if ((frmPtSelOptns.SrcType = TAG_SRC_DFLT) and
255 (FDfltSrcType = 'Ward')) or (frmPtSelOptns.SrcType = TAG_SRC_WARD) then
256 cboPatient.tabPositions := '35';
257 if ((frmPtSelOptns.SrcType = TAG_SRC_DFLT) and
258 (AnsiStrPos(pChar(FDfltSrcType), 'Clinic') <> nil)) or (frmPtSelOptns.SrcType = TAG_SRC_CLIN) then
259 begin
260 cboPatient.pieces := '2,3,9';
261 cboPatient.tabPositions := '24,45';
262 end;
263 NewTopList := IntToStr(frmPtSelOptns.SrcType) + U + IntToStr(IEN); // Default setting.
264 if (frmPtSelOptns.SrcType = TAG_SRC_CLIN) then with frmPtSelOptns.cboDateRange do
265 begin
266 if ItemID = '' then Exit; // Need both clinic & date range.
267 FirstDate := Piece(ItemID, ';', 1);
268 LastDate := Piece(ItemID, ';', 2);
269 NewTopList := IntToStr(frmPtSelOptns.SrcType) + U + IntToStr(IEN) + U + ItemID; // Modified for clinics.
270 end;
271 if NewTopList = frmPtSelOptns.LastTopList then Exit; // Only continue if new top list.
272 frmPtSelOptns.LastTopList := NewTopList;
273 RedrawSuspend(cboPatient.Handle);
274 ClearIDInfo;
275 cboPatient.ClearTop;
276 cboPatient.Text := '';
277 if (IsRPL = '1') then // Deal with restricted patient list users.
278 begin
279 RPLJob := MakeRPLPtList(User.RPLList); // MakeRPLPtList is in rCore, writes global "B" x-ref list.
280 if (RPLJob = '') then
281 begin
282 InfoBox('Assignment of valid OE/RR Team List Needed.', 'Unable to build Patient List', MB_OK);
283 RPLProblem := true;
284 Exit;
285 end;
286 end
287 else
288 begin
289 case frmPtSelOptns.SrcType of
290 TAG_SRC_DFLT: ListPtByDflt(cboPatient.Items);
291 TAG_SRC_PROV: ListPtByProvider(cboPatient.Items, IEN);
292 TAG_SRC_TEAM: ListPtByTeam(cboPatient.Items, IEN);
293 TAG_SRC_SPEC: ListPtBySpecialty(cboPatient.Items, IEN);
294 TAG_SRC_CLIN: ListPtByClinic(cboPatient.Items, frmPtSelOptns.cboList.ItemIEN, FirstDate, LastDate);
295 TAG_SRC_WARD: ListPtByWard(cboPatient.Items, IEN);
296 TAG_SRC_ALL: ListPtTop(cboPatient.Items);
297 end;
298 end;
299 if frmPtSelOptns.cboList.Visible then
300 lblPatient.Caption := 'Patients (' + frmPtSelOptns.cboList.Text + ')';
301 if frmPtSelOptns.SrcType = TAG_SRC_ALL then
302 lblPatient.Caption := 'Patients (All Patients)';
303 with cboPatient do if ShortCount > 0 then
304 begin
305 Items.Add(LLS_LINE);
306 Items.Add(LLS_SPACE);
307 end;
308 cboPatient.Caption := lblPatient.Caption;
309 cboPatient.InitLongList('');
310 RedrawActivate(cboPatient.Handle);
311end;
312
313{ Patient Select events: }
314
315procedure TfrmPtSel.cboPatientEnter(Sender: TObject);
316begin
317 cmdOK.Default := True;
318 if cboPatient.ItemIndex >= 0 then
319 begin
320 ShowIDInfo;
321 ShowFlagInfo;
322 end;
323end;
324
325procedure TfrmPtSel.cboPatientExit(Sender: TObject);
326begin
327 cmdOK.Default := False;
328end;
329
330procedure TfrmPtSel.cboPatientChange(Sender: TObject);
331
332 procedure ShowMatchingPatients;
333 begin
334 with cboPatient do
335 begin
336 ClearIDInfo;
337 if ShortCount > 0 then
338 begin
339 if ShortCount = 1 then
340 begin
341 ItemIndex := 0;
342 ShowIDInfo;
343 ShowFlagInfo;
344 end;
345 Items.Add(LLS_LINE);
346 Items.Add(LLS_SPACE);
347 end;
348 InitLongList('');
349 end;
350 end;
351
352begin
353 with cboPatient do
354 if frmPtSelOptns.IsLast5(Text) then
355 begin
356 if (IsRPL = '1') then
357 ListPtByRPLLast5(Items, Text)
358 else
359 ListPtByLast5(Items, Text);
360 ShowMatchingPatients;
361 end
362 else if frmPtSelOptns.IsFullSSN(Text) then
363 begin
364 if (IsRPL = '1') then
365 ListPtByRPLFullSSN(Items, Text)
366 else
367 ListPtByFullSSN(Items, Text);
368 ShowMatchingPatients;
369 end;
370end;
371
372procedure TfrmPtSel.cboPatientKeyPause(Sender: TObject);
373begin
374 if Length(cboPatient.ItemID) > 0 then //*DFN*
375 begin
376 ShowIDInfo;
377 ShowFlagInfo;
378 end else
379 begin
380 ClearIDInfo;
381 end;
382end;
383
384procedure TfrmPtSel.cboPatientMouseClick(Sender: TObject);
385begin
386 if Length(cboPatient.ItemID) > 0 then //*DFN*
387 begin
388 ShowIDInfo;
389 ShowFlagInfo;
390 end else
391 begin
392 ClearIDInfo;
393 end;
394end;
395
396procedure TfrmPtSel.cboPatientDblClick(Sender: TObject);
397begin
398 if Length(cboPatient.ItemID) > 0 then cmdOKClick(Self); //*DFN*
399end;
400
401procedure TfrmPtSel.cboPatientNeedData(Sender: TObject; const StartFrom: string;
402 Direction, InsertAt: Integer);
403var
404 i: Integer;
405 NoAlias, Patient: String;
406 PatientList: TStringList;
407begin
408
409NoAlias := StartFrom;
410with Sender as TORComboBox do
411 if Items.Count > ShortCount then
412 NoAlias := Piece(Items[Items.Count-1], U, 1) + U + NoAlias;
413if pos(AliasString, NoAlias)> 0 then
414 NoAlias := Copy(NoAlias, 1, pos(AliasString, NoAlias)-1);
415PatientList := TStringList.Create;
416try
417 begin
418 if (IsRPL = '1') then // Restricted patient lists uses different feed for long list box:
419 PatientList.Assign(ReadRPLPtList(RPLJob, NoAlias, Direction))
420 else
421 begin
422 PatientList.Assign(SubSetOfPatients(NoAlias, Direction));
423 for i := 0 to PatientList.Count-1 do // Add " - Alias" to alias names:
424 begin
425 Patient := PatientList[i];
426 // Piece 6 avoids display problems when mixed with "RPL" lists:
427 if (Uppercase(Piece(Patient, U, 2)) <> Uppercase(Piece(Patient, U, 6))) then
428 begin
429 SetPiece(Patient, U, 2, Piece(Patient, U, 2) + AliasString);
430 PatientList[i] := Patient;
431 end;
432 end;
433 end;
434 cboPatient.ForDataUse(PatientList);
435 end;
436finally
437 PatientList.Free;
438end;
439
440end;
441
442procedure TfrmPtSel.ClearIDInfo;
443begin
444 frmPtSelDemog.ClearIDInfo;
445end;
446
447procedure TfrmPtSel.ShowIDInfo;
448begin
449 frmPtSelDemog.ShowDemog(cboPatient.ItemID);
450end;
451
452{ Command Button events: }
453
454procedure TfrmPtSel.cmdOKClick(Sender: TObject);
455{ Checks for restrictions on the selected patient and sets up the Patient object. }
456const
457 DLG_CANCEL = False;
458 DGSR_FAIL = -1;
459 DGSR_NONE = 0;
460 DGSR_SHOW = 1;
461 DGSR_ASK = 2;
462 DGSR_DENY = 3;
463var
464 NewDFN, AMsg: string; //*DFN*
465 AccessStatus: Integer;
466 DateDied: TFMDateTime;
467begin
468if not (Length(cboPatient.ItemID) > 0) then //*DFN*
469 begin
470 InfoBox('A patient has not been selected.', 'No Patient Selected', MB_OK);
471 Exit;
472 end;
473 NewDFN := cboPatient.ItemID; //*DFN*
474 if FLastPt <> cboPatient.ItemID then
475 begin
476 HasActiveFlg(FlagList, HasFlag, cboPatient.ItemID);
477 flastpt := cboPatient.ItemID;
478 end;
479
480 If DupLastSSN(NewDFN) then // Check for, deal with duplicate patient data.
481 if (DupDFN = 'Cancel') then
482 Exit
483 else
484 NewDFN := DupDFN;
485 CheckSensitiveRecordAccess(NewDFN, AccessStatus, AMsg);
486 case AccessStatus of
487 DGSR_FAIL: begin
488 InfoBox(TX_DGSR_ERR, TC_DGSR_ERR, MB_OK);
489 Exit;
490 end;
491 DGSR_NONE: { Nothing - allow access to the patient. };
492 DGSR_SHOW: InfoBox(AMsg, TC_DGSR_SHOW, MB_OK);
493 DGSR_ASK: if InfoBox(AMsg + TX_DGSR_YESNO, TC_DGSR_SHOW, MB_YESNO or MB_ICONWARNING or
494 MB_DEFBUTTON2) = IDYES then LogSensitiveRecordAccess(NewDFN) else Exit;
495 else begin
496 InfoBox(AMsg, TC_DGSR_DENY, MB_OK);
497 Exit;
498 end;
499 end;
500 DateDied := DateOfDeath(NewDFN);
501 if (DateDied > 0) and (InfoBox('This patient died ' + FormatFMDateTime('mmm dd,yyyy hh:nn', DateDied) + CRLF +
502 'Do you wish to continue?', 'Deceased Patient', MB_YESNO or MB_DEFBUTTON2) = ID_NO) then
503 Exit;
504 // 9/23/2002: Code used to check for changed pt. DFN here, but since same patient could be
505 // selected twice in diff. Encounter locations, check was removed and following code runs
506 // no matter; in fFrame code then updates Encounter display if Encounter.Location has changed.
507 // NOTE: Some pieces in RPC returned arrays are modified/rearranged by ListPtByDflt call in rCore!
508 Patient.DFN := NewDFN; // The patient object in uCore must have been created already!
509 Encounter.Clear;
510 Changes.Clear; // An earlier call to ReviewChanges should have cleared this.
511 if (frmPtSelOptns.SrcType = TAG_SRC_CLIN) and (frmPtSelOptns.cboList.ItemIEN > 0) and
512 IsFMDateTime(Piece(cboPatient.Items[cboPatient.ItemIndex], U, 4)) then // Clinics, not by default.
513 begin
514 Encounter.Location := frmPtSelOptns.cboList.ItemIEN;
515 with cboPatient do Encounter.DateTime := MakeFMDateTime(Piece(Items[ItemIndex], U, 4));
516 end
517 else if (frmPtSelOptns.SrcType = TAG_SRC_DFLT) and (DfltPtListSrc = 'C') and
518 IsFMDateTime(Piece(cboPatient.Items[cboPatient.ItemIndex], U, 4))then
519 with cboPatient do // "Default" is a clinic.
520 begin
521 Encounter.Location := StrToIntDef(Piece(Items[ItemIndex], U, 10), 0); // Piece 10 is ^SC( location IEN in this case.
522 Encounter.DateTime := MakeFMDateTime(Piece(Items[ItemIndex], U, 4));
523 end
524 else if ((frmPtSelOptns.SrcType = TAG_SRC_DFLT) and (FDfltSrc = 'Combination') and
525 (copy(Piece(cboPatient.Items[cboPatient.ItemIndex], U, 3), 1, 2) = 'Cl')) and
526 (IsFMDateTime(Piece(cboPatient.Items[cboPatient.ItemIndex], U, 8))) then
527 with cboPatient do // "Default" combination, clinic pt.
528 begin
529 Encounter.Location := StrToIntDef(Piece(Items[ItemIndex], U, 7), 0); // Piece 7 is ^SC( location IEN in this case.
530 Encounter.DateTime := MakeFMDateTime(Piece(Items[ItemIndex], U, 8));
531 end
532 else if Patient.Inpatient then // Everything else:
533 begin
534 Encounter.Inpatient := True;
535 Encounter.Location := Patient.Location;
536 Encounter.DateTime := Patient.AdmitTime;
537 Encounter.VisitCategory := 'H';
538 end;
539 if User.IsProvider then Encounter.Provider := User.DUZ;
540
541 GetBAStatus(Encounter.Provider,Encounter.Location);
542 //HDS00005025
543 if BILLING_AWARE then
544 if Assigned(UBAGLOBALS.BAOrderList) then UBAGLOBALS.BAOrderList.Clear;
545 Close;
546end;
547
548procedure TfrmPtSel.cmdCancelClick(Sender: TObject);
549begin
550 // Leave Patient object unchanged
551 Close;
552end;
553
554procedure TfrmPtSel.cmdProcessClick(Sender: TObject);
555var
556 AFollowUp, i, infocount: Integer;
557 enableclose: boolean;
558 ADFN, x, RecordID, XQAID: string; //*DFN*
559begin
560 enableclose := false;
561 with lstvAlerts do
562 begin
563 if SelCount <= 0 then Exit;
564
565 // Count information-only selections for gauge
566 infocount := 0;
567 for i:= 0 to Items.Count - 1 do if Items[i].Selected then
568 if (Items[i].SubItems[0] = 'I') then Inc(infocount);
569
570 if infocount >= 1 then
571 begin
572 ggeInfo.Visible := true; (*BOB*)
573 ggeInfo.MaxValue := infocount;
574 end;
575
576 for i := 0 to Items.Count - 1 do if Items[i].Selected then
577 { Items[i].Selected = Boolean TRUE if item is selected
578 " .Caption = Info flag ('I')
579 " .SubItems[0] = Patient ('ABC,PATIE (A4321)')
580 " . " [1] = Patient location ('[2B]')
581 " . " [2] = Alert urgency level ('HIGH, Moderate, low')
582 " . " [3] = Alert date/time ('2002/12/31@12:10')
583 " . " [4] = Alert message ('New order(s) placed.')
584 " . " [5] = Forwarded by/when
585 " . " [6] = XQAID ('OR,66,50;1416;3021231.121024')
586 'TIU6028;1423;3021203.09')
587 " . " [7] = Remove without processing flag ('YES')
588 " . " [8] = Forwarding comments (if applicable) }
589 begin
590 XQAID := Items[i].SubItems[6];
591 RecordID := Items[i].SubItems[0] + ': ' + Items[i].SubItems[4] + '^' + XQAID;
592 //RecordID := patient: alert message^XQAID ('ABC,PATIE (A4321): New order(s) placed.^OR,66,50;1416;3021231.121024')
593 if Items[i].Caption = 'I' then
594 // If Caption is 'I' delete the information only alert.
595 begin
596 ggeInfo.Progress := ggeInfo.Progress + 1;
597 DeleteAlert(XQAID);
598 end
599 else if Piece(XQAID, ',', 1) = 'OR' then
600 // OR,16,50;1311;2980626.100756
601 begin
602 ADFN := Piece(XQAID, ',', 2); //*DFN*
603 AFollowUp := StrToIntDef(Piece(Piece(XQAID, ';', 1), ',', 3), 0);
604 Notifications.Add(ADFN, AFollowUp, RecordID);
605 enableclose := true;
606 end
607 else if Copy(XQAID, 1, 6) = 'TIUERR' then
608 InfoBox(Piece(RecordID, U, 1) + #13#10#13#10 +
609 'The CPRS GUI cannot yet process this type of alert. Please use List Manager.',
610 'Unable to Process Alert', MB_OK)
611 else if Copy(XQAID, 1, 3) = 'TIU' then
612 // TIU6028;1423;3021203.09
613 begin
614 x := GetTIUAlertInfo(XQAID);
615 if Piece(x, U, 2) <> '' then
616 begin
617 ADFN := Piece(x, U, 2); //*DFN*
618 AFollowUp := StrToIntDef(Piece(Piece(x, U, 3), ';', 1), 0);
619 Notifications.Add(ADFN, AFollowUp, RecordID + '^^' + Piece(x, U, 3));
620 enableclose := true;
621 end
622 else
623 DeleteAlert(XQAID);
624 end
625 else //other alerts cannot be processed
626 InfoBox('This alert cannot be processed by the CPRS GUI.', Items[i].SubItems[0] + ': ' + Items[i].SubItems[4], MB_OK); end;
627 if enableclose = true then
628 Close
629 else
630 begin
631 ggeInfo.Visible := False;
632 // Update notification list:
633 lstvAlerts.Clear;
634 AlertList;
635 end;
636 if Items.Count = 0 then ShowButts(False);
637 if SelCount <= 0 then ShowButts(False);
638 end;
639 GetBAStatus(User.DUZ,Encounter.Location);
640end;
641
642procedure TfrmPtSel.cmdSaveListClick(Sender: TObject);
643begin
644 frmPtSelOptns.cmdSaveListClick(Sender);
645end;
646
647procedure TfrmPtSel.cmdProcessInfoClick(Sender: TObject);
648 // Select and process all items that are information only in the lstvAlerts list box.
649var
650 i: integer;
651begin
652 if lstvAlerts.Items.Count = 0 then Exit;
653 if InfoBox('You are about to process all your INFORMATION alerts.' + CRLF
654 + 'These alerts will not be presented to you for individual' + CRLF
655 + 'review and they will be permanently removed from your' + CRLF
656 + 'alert list. Do you wish to continue?',
657 'Warning', MB_YESNO or MB_ICONWARNING) = IDYES then
658 begin
659 for i := 0 to lstvAlerts.Items.Count-1 do
660 lstvAlerts.Items[i].Selected := False; //clear any selected alerts so they aren't processed
661 for i := 0 to lstvAlerts.Items.Count-1 do
662 if lstvAlerts.Items[i].Caption = 'I' then
663 lstvAlerts.Items[i].Selected := True;
664 cmdProcessClick(Self);
665 ShowButts(False);
666 end;
667end;
668
669procedure TfrmPtSel.cmdProcessAllClick(Sender: TObject);
670var
671 i: integer;
672begin
673 for i := 0 to lstvAlerts.Items.Count-1 do
674 lstvAlerts.Items[i].Selected := True;
675 cmdProcessClick(Self);
676 ShowButts(False);
677end;
678
679procedure TfrmPtSel.lstvAlertsDblClick(Sender: TObject);
680begin
681 cmdProcessClick(Self);
682end;
683
684procedure TfrmPtSel.cmdForwardClick(Sender: TObject);
685var
686 i: integer;
687 Alert: String;
688begin
689 try
690 with lstvAlerts do
691 begin
692 if SelCount <= 0 then Exit;
693 for i := 0 to Items.Count - 1 do
694 if Items[i].Selected then
695 try
696 Alert := Items[i].SubItems[6] + '^' + Items[i].Subitems[0] + ': ' +
697 Items[i].Subitems[4];
698 ForwardAlertTo(Alert);
699 finally
700 Items[i].Selected := False;
701 end;
702 end;
703 finally
704 if lstvAlerts.SelCount <= 0 then ShowButts(False);
705 end;
706end;
707
708procedure TfrmPtSel.cmdRemoveClick(Sender: TObject);
709var
710 i: integer;
711begin
712 with lstvAlerts do
713 begin
714 if SelCount <= 0 then Exit;
715 for i := 0 to Items.Count - 1 do
716 if Items[i].Selected then
717 begin
718 if Items[i].SubItems[7] = '1' then //remove flag enabled
719 DeleteAlertforUser(Items[i].SubItems[6])
720 else InfoBox('This alert cannot be removed.', Items[i].SubItems[0] + ': ' + Items[i].SubItems[4], MB_OK);
721 end;
722 end;
723 lstvAlerts.Clear;
724 AlertList;
725 FsortCol := 0; //CA - display alerts in correct sort
726 FormShow(Sender); //CA - display alerts in correct sort
727 if lstvAlerts.Items.Count = 0 then ShowButts(False);
728 if lstvAlerts.SelCount <= 0 then ShowButts(False);
729end;
730
731procedure TfrmPtSel.FormDestroy(Sender: TObject);
732begin
733 SaveUserBounds(Self);
734 frmFrame.EnduringPtSelSplitterPos := pnlPtSel.Height;
735 end;
736
737procedure TfrmPtSel.pnlPtSelResize(Sender: TObject);
738begin
739 frmPtSelDemog.Left := cboPatient.Left + cboPatient.Width + 9;
740 frmPtSelDemog.Width := pnlPtSel.Width - frmPtSelDemog.Left - 2;
741 frmPtSelOptns.Width := cboPatient.Left-8;
742end;
743
744procedure TfrmPtSel.Loaded;
745begin
746 inherited;
747// This needs to be in Loaded rather than FormCreate or the TORAutoPanel resize logic breaks.
748 frmPtSelDemog := TfrmPtSelDemog.Create(Self); // Was application - kcm
749 with frmPtSelDemog do
750 begin
751 parent := pnlPtSel;
752 Top := 65;
753 Left := cboPatient.Left + cboPatient.Width + 9;
754 Width := pnlPtSel.Width - Left - 2;
755 TabOrder := cmdCancel.TabOrder + 1; //Place after cancel button
756 Show;
757 end;
758
759 frmPtSelOptns := TfrmPtSelOptns.Create(Self); // Was application - kcm
760 with frmPtSelOptns do
761 begin
762 parent := pnlPtSel;
763 Top := 4;
764 Left := 4;
765 Width := cboPatient.Left-8;
766 SetCaptionTopProc := SetCaptionTop;
767 SetPtListTopProc := SetPtListTop;
768 if RPLProblem then
769 Exit;
770 TabOrder := cmdSaveList.TabOrder; //Put just before save default list button
771 Show;
772 end;
773 FLastPt := '';
774 //Begin at alert list, or patient listbox if no alerts
775 if lstvAlerts.Items.Count = 0 then
776 ActiveControl := cboPatient;
777end;
778
779procedure TfrmPtSel.RPLDisplay;
780begin
781
782// Make unneeded components invisible:
783cmdSaveList.visible := false;
784frmPtSelOptns.visible := false;
785
786end;
787
788procedure TfrmPtSel.FormClose(Sender: TObject; var Action: TCloseAction);
789begin
790
791if (IsRPL = '1') then // Deal with restricted patient list users.
792 KillRPLPtList(RPLJob); // Kills server global data each time.
793 // (Global created by MakeRPLPtList in rCore.)
794end;
795
796procedure TfrmPtSel.cboPatientKeyDown(Sender: TObject; var Key: Word;
797 Shift: TShiftState);
798begin
799 if (Key = Ord('D')) and (ssCtrl in Shift) then begin
800 Key := 0;
801 frmPtSelDemog.ToggleMemo;
802 end;
803end;
804
805function ConvertDate(var thisList: TStringList; listIndex: integer) : string;
806{
807 CQ1075: Convert date portion from yyyy/mm/dd to mm/dd/yyyy
808}
809var
810 //thisListItem: TListItem;
811 thisDateTime: string[16];
812 tempDt: string;
813 tempYr: string;
814 tempTime: string;
815 newDtTime: string;
816 k: byte;
817 piece1: string;
818 piece2: string;
819 piece3: string;
820 piece4: string;
821 piece5: string;
822 piece6: string;
823 piece7: string;
824 piece8: string;
825 piece9: string;
826 piece10: string;
827 piece11: string;
828begin
829 piece1 := '';
830 piece2 := '';
831 piece3 := '';
832 piece4 := '';
833 piece5 := '';
834 piece6 := '';
835 piece7 := '';
836 piece8 := '';
837 piece9 := '';
838 piece10 := '';
839 piece11 := '';
840
841 piece1 := Piece(thisList[listIndex],U,1);
842 piece2 := Piece(thisList[listIndex],U,2);
843 piece3 := Piece(thisList[listIndex],U,3);
844 piece4 := Piece(thisList[listIndex],U,4);
845 //piece5 := Piece(thisList[listIndex],U,5);
846 piece6 := Piece(thisList[listIndex],U,6);
847 piece7 := Piece(thisList[listIndex],U,7);
848 piece8 := Piece(thisList[listIndex],U,8);
849 piece9 := Piece(thisList[listIndex],U,9);
850 piece10 := Piece(thisList[listIndex],U,1);
851
852 thisDateTime := Piece(thisList[listIndex],U,5);
853
854 tempYr := '';
855 for k := 1 to 4 do
856 tempYr := tempYr + thisDateTime[k];
857
858 tempDt := '';
859 for k := 6 to 10 do
860 tempDt := tempDt + thisDateTime[k];
861
862 tempTime := '';
863 //Use 'Length' to prevent stuffing the control chars into the date when a trailing zero is missing
864 for k := 11 to Length(thisDateTime) do //16 do
865 tempTime := tempTime + thisDateTime[k];
866
867 newDtTime := '';
868 newDtTime := newDtTime + tempDt + '/' + tempYr + tempTime;
869 piece5 := newDtTime;
870
871 Result := piece1 +U+ piece2 +U+ piece3 +U+ piece4 +U+ piece5 +U+ piece6 +U+ piece7 +U+ piece8 +U+ piece9 +U+ piece10 +U+ piece11;
872end;
873
874procedure TfrmPtSel.AlertList;
875var
876 List: TStringList;
877 NewItem: TListItem;
878 I,J: Integer;
879 Comment: String;
880begin
881 // Load the items
882 lstvAlerts.Items.Clear;
883 List := TStringList.Create;
884 NewItem := nil;
885 try
886 LoadNotifications(List);
887 for I := 0 to List.Count - 1 do
888 begin
889 //CQ1075: Convert date portion from yyyy/mm/dd to mm/dd/yyyy
890 List[i] := ConvertDate(List, i);
891
892 if Piece(List[I], U, 1) <> 'Forwarded by: ' then
893 begin
894 NewItem := lstvAlerts.Items.Add;
895 NewItem.Caption := Piece(List[I], U, 1);
896 for J := 2 to DelimCount(List[I], U) + 1 do
897 NewItem.SubItems.Add(Piece(List[I], U, J));
898 end
899 else //this list item is forwarding information
900 begin
901 NewItem.SubItems[5] := Piece(List[I], U, 2);
902 Comment := Piece(List[I], U, 3);
903 if Length(Comment) > 0 then NewItem.SubItems[8] := 'Fwd Comment: ' + Comment;
904 end;
905 end;
906 finally
907 List.Free;
908 end;
909 with lstvAlerts do
910 begin
911 Columns[0].Width := 30; //Info Caption
912 Columns[1].Width := 120; //Patient SubItems[0]
913 Columns[2].Width := 60; //Location SubItems[1]
914 Columns[3].Width := 60; //Urgency SubItems[2]
915 Columns[4].Width := 110; //Alert Date/Time SubItems[3]
916 Columns[5].Width := 312; //Message Text SubItems[4]
917 Columns[6].Width := 210; //Forwarded By/When SubItems[5]
918 //Items not displayed in Columns: XQAID SubItems[6]
919 // Remove w/o process SubItems[7]
920 // Forwarding comments SubItems[8]
921 end;
922 //with lstvAlerts do ca comment out 12/24/03 to prevent default selection of first alert on list
923 //if (ItemIndex = -1) and (Items.Count > 0) then
924 //ItemIndex := 0;
925end;
926
927procedure TfrmPtSel.lstvAlertsColumnClick(Sender: TObject; Column: TListColumn);
928begin
929
930 if ((FsortCol = Column.Index) and (not SortViaKeyboard)) then
931 FsortAscending := not FsortAscending
932 else
933 if Column.Index = 4 then
934 FsortAscending := false
935 else
936 FsortAscending := true;
937
938 FsortCol := Column.Index;
939 lstvAlerts.AlphaSort;
940 SortViaKeyboard := false;
941
942 //Set the Notifications sort method to last-used sort-type
943 //ie., user clicked on which column header last use of CPRS?
944 case Column.Index of
945 0: rCore.SetSortMethod('I');
946 1: rCore.SetSortMethod('P');
947 2: rCore.SetSortMethod('L');
948 3: rCore.SetSortMethod('U');
949 4: rCore.SetSortMethod('D');
950 5: rCore.SetSortMethod('M');
951 6: rCore.SetSortMethod('F');
952 end;
953end;
954
955procedure TfrmPtSel.lstvAlertsCompare(Sender: TObject; Item1, Item2: TListItem; Data: Integer; var Compare: Integer);
956begin
957 if not(Sender is TListView) then Exit;
958 if FsortAscending then
959 begin
960 if FsortCol = 0 then Compare := CompareStr(Item1.Caption, Item2.Caption)
961 else Compare := CompareStr(Item1.SubItems[FsortCol - 1], Item2.SubItems[FsortCol - 1]);
962 end
963 else
964 begin
965 if FsortCol = 0 then Compare := CompareStr(Item2.Caption, Item1.Caption)
966 else Compare := CompareStr(Item2.SubItems[FsortCol - 1], Item1.SubItems[FsortCol - 1]);
967 end;
968end;
969
970function TfrmPtSel.DupLastSSN(const DFN: string): Boolean;
971var
972 i: integer;
973 frmPtDupSel: tForm;
974begin
975 Result := False;
976
977 // Check data on server for duplicates:
978 CallV('DG CHK BS5 XREF ARRAY', [DFN]);
979 if (RPCBrokerV.Results[0] <> '1') then // No duplicates found.
980 Exit;
981 Result := True;
982 PtStrs := TStringList.Create;
983 with RPCBrokerV do if Results.Count > 0 then
984 begin
985 for i := 1 to Results.Count - 1 do
986 begin
987 if Piece(Results[i], U, 1) = '1' then
988 PtStrs.Add(Piece(Results[i], U, 2) + U + Piece(Results[i], U, 3) + U +
989 FormatFMDateTimeStr('mmm dd,yyyy', Piece(Results[i], U, 4)) + U +
990 Piece(Results[i], U, 5));
991 end;
992 end;
993
994 // Call form to get user's selection from expanded duplicate pt. list (resets DupDFN variable if applicable):
995 DupDFN := DFN;
996 frmPtDupSel:= TfrmDupPts.Create(Application);
997 with frmPtDupSel do
998 begin
999 try
1000 ShowModal;
1001 finally
1002 frmPtDupSel.Release;
1003 end;
1004 end;
1005end;
1006
1007procedure TfrmPtSel.ShowFlagInfo;
1008begin
1009 if (Pos('*SENSITIVE*',frmPtSelDemog.lblPtSSN.Caption)>0) then
1010 begin
1011// pnlPrf.Visible := False;
1012 Exit;
1013 end;
1014 if (flastpt <> cboPatient.ItemID) then
1015 begin
1016 HasActiveFlg(FlagList, HasFlag, cboPatient.ItemID);
1017 flastpt := cboPatient.ItemID;
1018 end;
1019 if HasFlag then
1020 begin
1021// lstFlags.Items.Assign(FlagList);
1022// pnlPrf.Visible := True;
1023 end
1024// else pnlPrf.Visible := False;
1025end;
1026
1027procedure TfrmPtSel.lstFlagsClick(Sender: TObject);
1028begin
1029{ if lstFlags.ItemIndex >= 0 then
1030 ShowFlags(lstFlags.ItemID); }
1031end;
1032
1033procedure TfrmPtSel.lstFlagsKeyDown(Sender: TObject; var Key: Word;
1034 Shift: TShiftState);
1035begin
1036 if Key = VK_RETURN then
1037 lstFlagsClick(Self);
1038end;
1039
1040procedure TfrmPtSel.lstvAlertsSelectItem(Sender: TObject; Item: TListItem;
1041 Selected: Boolean);
1042begin
1043 if lstvAlerts.SelCount <= 0 then ShowButts(False)
1044 else ShowButts(True);
1045 GetBAStatus(User.DUZ,Encounter.Location);
1046end;
1047
1048procedure TfrmPtSel.ShowButts(ShowButts: Boolean);
1049begin
1050 cmdProcess.Enabled := ShowButts;
1051 cmdRemove.Enabled := ShowButts;
1052 cmdForward.Enabled := ShowButts;
1053end;
1054
1055procedure TfrmPtSel.lstvAlertsInfoTip(Sender: TObject; Item: TListItem;
1056 var InfoTip: String);
1057begin
1058 InfoTip := Item.SubItems[8];
1059end;
1060
1061procedure TfrmPtSel.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
1062{
1063var
1064 keyValue: word;
1065}
1066begin{
1067 keyValue := MapVirtualKey(Key,2);
1068 if keyValue = VK_RETURN then
1069 cmdProcessClick(Sender);
1070}
1071end;
1072
1073procedure TfrmPtSel.lstvAlertsKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
1074{
1075 //KW
1076 508: Allow non-sighted users to sort Notifications using Ctrl + <key>
1077 Numbers in case stmnt are ASCII values for character keys.
1078}
1079begin
1080 if lstvAlerts.Focused then
1081 begin
1082 SortViaKeyboard := true;
1083 case Key of
1084 VK_RETURN: cmdProcessClick(Sender); //Process all selected alerts
1085 73,105: if (ssCtrl in Shift) then lstvAlertsColumnClick(Sender, lstvAlerts.Columns[0]); //I,i
1086 80,113: if (ssCtrl in Shift) then lstvAlertsColumnClick(Sender, lstvAlerts.Columns[1]); //P,p
1087 76,108: if (ssCtrl in Shift) then lstvAlertsColumnClick(Sender, lstvAlerts.Columns[2]); //L,l
1088 85,117: if (ssCtrl in Shift) then lstvAlertsColumnClick(Sender, lstvAlerts.Columns[3]); //U,u
1089 68,100: if (ssCtrl in Shift) then lstvAlertsColumnClick(Sender, lstvAlerts.Columns[4]); //D,d
1090 77,109: if (ssCtrl in Shift) then lstvAlertsColumnClick(Sender, lstvAlerts.Columns[5]); //M,m
1091 70,102: if (ssCtrl in Shift) then lstvAlertsColumnClick(Sender, lstvAlerts.Columns[6]); //F,f
1092 end;
1093 end;
1094end;
1095
1096procedure TfrmPtSel.FormShow(Sender: TObject);
1097{
1098 //KW
1099 Sort Alerts by last-used method for current user
1100}
1101var
1102 sortMethod: string;
1103begin
1104 sortMethod := rCore.GetSortMethod;
1105
1106 case sortMethod[1] of
1107 'I','i': lstvAlertsColumnClick(Sender, lstvAlerts.Columns[0]);
1108 'P','p': lstvAlertsColumnClick(Sender, lstvAlerts.Columns[1]);
1109 'L','l': lstvAlertsColumnClick(Sender, lstvAlerts.Columns[2]);
1110 'U','u': lstvAlertsColumnClick(Sender, lstvAlerts.Columns[3]);
1111 'D','d': lstvAlertsColumnClick(Sender, lstvAlerts.Columns[4]);
1112 'M','m': lstvAlertsColumnClick(Sender, lstvAlerts.Columns[5]);
1113 'F','f': lstvAlertsColumnClick(Sender, lstvAlerts.Columns[6]);
1114 end;
1115end;
1116
1117Initialization
1118 SortViaKeyboard := false;
1119
1120end.
Note: See TracBrowser for help on using the repository browser.