source: cprs/trunk/CPRS-Chart/Orders/fOCSession.pas@ 1797

Last change on this file since 1797 was 1679, checked in by healthsevak, 10 years ago

Updating the working copy to CPRS version 28
File size: 34.1 KB
RevLine 
[456]1unit fOCSession;
2
3interface
4
5uses
[1679]6 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, fOCMonograph,
7 fAutoSz, StdCtrls, ORFn, uConst, ORCtrls, ExtCtrls, VA508AccessibilityManager,
8 Grids, strUtils, uDlgComponents, VAUtils, VA508AccessibilityRouter;
[456]9
10type
11 TfrmOCSession = class(TfrmAutoSz)
12 pnlBottom: TPanel;
13 lblJustify: TLabel;
14 txtJustify: TCaptionEdit;
15 cmdCancelOrder: TButton;
16 cmdContinue: TButton;
[829]17 btnReturn: TButton;
18 memNote: TMemo;
[1679]19 cmdMonograph: TButton;
20 grdchecks: TCaptionStringGrid;
21 lblInstr: TVA508StaticText;
22 pnlTop: TORAutoPanel;
23 lblHover: TLabel;
[456]24 procedure cmdCancelOrderClick(Sender: TObject);
25 procedure cmdContinueClick(Sender: TObject);
26 procedure FormClose(Sender: TObject; var Action: TCloseAction);
27 procedure FormShow(Sender: TObject);
28 procedure FormResize(Sender: TObject);
29 procedure txtJustifyKeyDown(Sender: TObject; var Key: Word;
30 Shift: TShiftState);
[829]31 procedure btnReturnClick(Sender: TObject);
32 procedure memNoteEnter(Sender: TObject);
[1679]33 procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
34 procedure cmdMonographClick(Sender: TObject);
35 procedure grdchecksDrawCell(Sender: TObject; ACol, ARow: Integer;
36 Rect: TRect; State: TGridDrawState);
37 function CheckBoxRect(poRect: TRect): TRect;
38 function GetCheckState(grid: TStringGrid; ACol, ARow: integer): boolean;
39 function InCheckBox(Grid: TStringGrid; X, Y, ACol, ARow: integer): boolean;
40 procedure SetCheckState(grid: TStringGrid; ACol, ARow: integer; State: boolean);
41 procedure grdchecksMouseDown(Sender: TObject; Button: TMouseButton;
42 Shift: TShiftState; X, Y: Integer);
43 procedure grdchecksSelectCell(Sender: TObject; ACol, ARow: Integer;
44 var CanSelect: Boolean);
45 procedure GridDeleteRow(RowNumber: Integer; Grid: TstringGrid);
46 procedure grdchecksEnter(Sender: TObject);
47 procedure FormCreate(Sender: TObject);
48 procedure grdchecksKeyDown(Sender: TObject; var Key: Word;
49 Shift: TShiftState);
50 procedure grdchecksMouseWheelDown(Sender: TObject; Shift: TShiftState;
51 MousePos: TPoint; var Handled: Boolean);
52 procedure grdchecksMouseWheelUp(Sender: TObject; Shift: TShiftState;
53 MousePos: TPoint; var Handled: Boolean);
54 procedure FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
55 MousePos: TPoint; var Handled: Boolean);
56 procedure grdchecksMouseMove(Sender: TObject; Shift: TShiftState; X,
57 Y: Integer);
58 // procedure memNoteSetText(str: string);
[456]59 private
60 FCritical: Boolean;
[829]61 FCancelSignProcess : Boolean;
[456]62 FCheckList: TStringList;
63 FOrderList: TStringList;
64 procedure SetReqJustify;
[829]65 procedure SetReturn(const Value: Boolean);
[456]66 public
67 { Public declarations }
[829]68 property CancelSignProcess : Boolean read FCancelSignProcess write SetReturn default false;
[456]69 end;
70
71procedure ExecuteReleaseOrderChecks(SelectList: TList);
[829]72function ExecuteSessionOrderChecks(OrderList: TStringList) : Boolean;
[456]73
74implementation
75
76{$R *.DFM}
77
[829]78uses rOrders, uCore, rMisc, fFrame;
[456]79
80type
81 TOCRec = class
82 OrderID: string;
83 OrderText: string;
84 Checks: TStringList;
85 constructor Create(const AnID: string);
86 destructor Destroy; override;
87 end;
88
89var
90 uCheckedOrders: TList;
91 FOldHintHidePause: integer;
92
93constructor TOCRec.Create(const AnID: string);
94begin
95 OrderID := AnID;
96 Checks := TStringList.Create;
97 FOldHintHidePause := Application.HintHidePause;
98end;
99
100destructor TOCRec.Destroy;
101begin
102 Application.HintHidePause := FOldHintHidePause;
103 Checks.Free;
104 inherited Destroy;
105end;
106
107procedure ExecuteReleaseOrderChecks(SelectList: TList);
108var
109 i: Integer;
110 AnOrder: TOrder;
111 OrderIDList: TStringList;
112begin
113 OrderIDList := TStringList.Create;
114 try
115 for i := 0 to SelectList.Count - 1 do
116 begin
117 AnOrder := TOrder(SelectList.Items[i]);
118 OrderIDList.Add(AnOrder.ID + '^^1'); // 3rd pce = 1 means releasing order
119 end;
[829]120 if ExecuteSessionOrderChecks(OrderIDList) then
121 for i := SelectList.Count - 1 downto 0 do
[456]122 begin
[829]123 AnOrder := TOrder(SelectList.Items[i]);
124 if OrderIDList.IndexOf(AnOrder.ID + '^^1') < 0 then
125 begin
126 Changes.Remove(CH_ORD, AnOrder.ID);
127 SelectList.Delete(i);
128 end;
129 end
130 else
131 SelectList.Clear;
[456]132 finally
133 OrderIDList.Free;
134 end;
135end;
136
[829]137{Returns True if the Signature process should proceed.
138 Clears OrderList If False. }
139function ExecuteSessionOrderChecks(OrderList: TStringList) : Boolean;
[456]140var
[1679]141 i, j, k, l, m, rowcnt: Integer;
142 LastID, NewID, gridtext: string;
143 CheckList,remOC: TStringList;
[456]144 OCRec: TOCRec;
145 frmOCSession: TfrmOCSession;
[1679]146 x,substring: string;
[456]147begin
[829]148 Result := True;
[456]149 CheckList := TStringList.Create;
150 try
151 StatusText('Order Checking...');
152 OrderChecksForSession(CheckList, OrderList);
153 StatusText('');
154 if CheckList.Count > 0 then
155 begin
156 frmOCSession := TfrmOCSession.Create(Application);
[1679]157 //frmOCSession.grdchecks.RowCount := frmOCSession.grdchecks.RowCount + 1; *)
158 //rowcnt := frmOCSession.grdchecks.RowCount;
159 //if RowCnt > frmOCSession.grdchecks.RowCount then frmOCSession.grdchecks.RowCount := RowCnt;
160 rowcnt := 1;
161 frmOCSession.grdchecks.canvas.Font.Name := 'Courier New';
162 frmOCSession.grdchecks.Canvas.Font.Size := MainFontSize;
163 frmOCSession.cmdMonograph.Enabled := false;
164 if IsMonograph then frmOCSession.cmdMonograph.Enabled := true;
[456]165 try
166 ResizeFormToFont(TForm(frmOCSession));
167 uCheckedOrders := TList.Create;
168 LastID := '';
169 for i := 0 to CheckList.Count - 1 do
170 begin
171 NewID := Piece(CheckList[i], U, 1);
172 if NewID <> LastID then
173 begin
174 OCRec := TOCRec.Create(NewID);
175 uCheckedOrders.Add(OCRec);
176 LastID := NewID;
177 end; {if NewID}
178 end; {for i}
179 with uCheckedOrders do for i := 0 to Count - 1 do
180 begin
181 OCRec := TOCRec(Items[i]);
182 x := TextForOrder(OCRec.OrderID);
183 OCRec.OrderText := x;
[1679]184 frmOCSession.grdchecks.Cells[2,rowcnt] := OCRec.OrderID + '^O^0^';
185 frmOCSession.grdchecks.Cells[1,rowcnt] := OCRec.OrderText;
186 RowCnt := RowCnt + 1;
187 if RowCnt > frmOCSession.grdchecks.RowCount then frmOCSession.grdchecks.RowCount := RowCnt;
188 l := 0;
189 m := 0;
[456]190 for j := 0 to CheckList.Count - 1 do
[1679]191 if Piece(CheckList[j], U, 1) = OCRec.OrderID then m := m+1;
192
193 for j := 0 to CheckList.Count - 1 do
[456]194 if Piece(CheckList[j], U, 1) = OCRec.OrderID then
195 begin
[1679]196 l := l+1;
197 gridText := '';
198 substring := Copy(Piece(CheckList[j], U, 4),0,2);
199 if substring='||' then
200 begin
201 remOC := TStringList.Create;
202 substring := Copy(Piece(CheckList[j], U, 4),3,Length(Piece(CheckList[j], U, 4)));
203 GetXtraTxt(remOC,Piece(substring,'&',1),Piece(substring,'&',2));
204 for k := 0 to remOC.Count - 1 do
205 begin
206 //add each line to x and OCRec.Checks
207 if k=remOC.Count-1 then
208 begin
209 OCRec.Checks.Add(Pieces(CheckList[j], U, 2, 3)+'^'+' '+RemOC[k]);
210 x := x + CRLF + RemOC[k];
211 if gridText = '' then gridText := RemOC[k]
212 else gridText := gridText + CRLF + ' ' +RemOC[k];
213 end
214 else if k=0 then
215 begin
216 OCRec.Checks.Add(Pieces(CheckList[j], U, 2, 3)+'^'+RemOC[k]);
217 x := x + CRLF + '('+inttostr(l)+' of '+inttostr(m)+') ' + RemOC[k];
218 if gridText = '' then gridText := '('+inttostr(l)+' of '+inttostr(m)+') ' + RemOC[k]
219 else gridText := gridText + CRLF + RemOC[k];
220 end
221 else
222 begin
223 OCRec.Checks.Add(Pieces(CheckList[j], U, 2, 3)+'^'+' '+RemOC[k]);
224 x := x + CRLF + RemOC[k];
225 if gridText = '' then gridText := RemOC[k]
226 else gridText := gridText + CRLF + ' ' + RemOC[k];
227 end;
228 end;
229 x := x + CRLF + ' ';
230 if gridText = '' then gridText := ' '
231 else gridText := gridText + CRLF + ' ';
232 remOC.free;
233 end
234 else
235 begin
236 OCRec.Checks.Add(Pieces(CheckList[j], U, 2, 4));
237 x := x + CRLF + '('+inttostr(l)+' of '+inttostr(m)+') ' + Piece(CheckList[j], U, 4);
238 gridText := '('+inttostr(l)+' of '+inttostr(m)+') ' + Piece(CheckList[j], U, 4);
239 end;
240 if (Piece(CheckList[j], U, 3) = '1') then frmOCSession.grdchecks.Cells[1,rowcnt] := '*Order Check requires Reason for Override' + CRLF + gridText
241 else frmOCSession.grdchecks.Cells[1,rowcnt] := gridText;
242 frmOCSession.grdchecks.Cells[2,rowcnt] := OCRec.OrderID + '^I^'+Piece(CheckList[j], U, 3);
243 //frmOCSession.grdchecks.Objects[2, rowcnt] := OCRec;
244 rowcnt := rowcnt +1;
245 if RowCnt > frmOCSession.grdchecks.RowCount then frmOCSession.grdchecks.RowCount := RowCnt;
[456]246 end;
247 end; {with...for i}
248 frmOCSession.FOrderList := OrderList;
249 frmOCSession.FCheckList := CheckList;
250 frmOCSession.SetReqJustify;
251 MessageBeep(MB_ICONASTERISK);
252 if frmOCSession.Visible then frmOCSession.SetFocus;
253 frmOCSession.ShowModal;
[829]254 Result := not frmOCSession.CancelSignProcess;
255 if frmOCSession.CancelSignProcess then begin
256 OrderList.Clear;
257 if Assigned(frmFrame) then
258 frmFrame.SetActiveTab(CT_ORDERS);
259 end;
[1679]260 if ScreenReaderActive = True then
261 begin
262 frmOCSession.lblInstr.TabStop := true;
263 frmOCSession.memNote.TabStop := true;
264 frmOCSession.memNote.TabOrder := 2;
265 end
266 else
267 begin
268 frmOCSession.lblInstr.TabStop := false;
269 frmOCSession.memNote.TabStop := false;
270 end;
[456]271 finally
272 with uCheckedOrders do for i := 0 to Count - 1 do TOCRec(Items[i]).Free;
273 frmOCSession.Free;
274 end; {try}
275 end; {if CheckList}
276 finally
277 CheckList.Free;
278 end;
279end;
280
[1679]281
282procedure TfrmOCSession.SetCheckState(grid: TStringGrid; ACol, ARow: integer;
283 State: boolean);
284var
285 temp: string;
286begin
287 temp := grid.Cells[2, ARow];
288 if State = True then SetPiece(temp, U, 3, '1')
289 else SetPiece(temp, U, 3, '0');
290 grid.Cells[2, ARow] := temp;
291 grid.Repaint;
292end;
293
[456]294procedure TfrmOCSession.SetReqJustify;
295var
296 i, j: Integer;
297 OCRec: TOCRec;
298begin
299 FCritical := False;
300 with uCheckedOrders do for i := 0 to Count - 1 do
301 begin
302 OCRec := TOCRec(Items[i]);
303 for j := 0 to OCRec.Checks.Count - 1 do
304 if Piece(OCRec.Checks[j], U, 2) = '1' then FCritical := True;
305 end;
306 lblJustify.Visible := FCritical;
307 txtJustify.Visible := FCritical;
[829]308 memNote.Visible := FCritical;
[456]309end;
310
[1679]311function TfrmOCSession.CheckBoxRect(poRect: TRect): TRect;
312const ciCheckBoxDim = 20;
[456]313begin
[1679]314 with poRect do begin
315 Result.Top := Top + FontHeightPixel(Font.Handle);
316 Result.Left := Left - (ciCheckBoxDim div 2) + (Right - Left) div 2;
317 Result.Right := Result.Left + ciCheckBoxDim;
318 Result.Bottom := Result.Top + ciCheckBoxDim;
319 end
[456]320end;
321
[1679]322procedure TfrmOCSession.cmdCancelOrderClick(Sender: TObject);
[456]323var
[1679]324 cnt, i, j, already: Integer;
325 AnOrderID: string;
326 DeleteOrderList, DeleteRowList: TstringList;
327 StillCritical: boolean;
[456]328begin
329 inherited;
[1679]330 DeleteOrderList := TStringList.Create;
331 DeleteRowList := TStringList.Create;
332 for I := 0 to grdChecks.RowCount do
333 if (Piece(grdChecks.Cells[2, i], U, 3) = '1') and (Piece(grdChecks.Cells[2, i], U, 2) = 'O') then
334 begin
335 AnOrderID := Piece(grdChecks.Cells[2, i], U, 1);
336 already := DeleteOrderList.IndexOf(AnOrderID);
337 if (already>=0) or (DeleteCheckedOrder(AnOrderID)) then
[456]338 begin
[1679]339 for j := FCheckList.Count - 1 downto 0 do
340 if Piece(FCheckList[j], U, 1) = AnOrderID then FCheckList.Delete(j);
341 DeleteOrderList.Add(AnOrderId);
342 for j := FOrderList.Count - 1 downto 0 do
343 if Piece(FOrderList[j], U, 1) = AnOrderID then FOrderList.Delete(j);
344 for j := uCheckedOrders.Count - 1 downto 0 do
345 if TOCRec(uCheckedOrders.Items[j]).OrderID = AnOrderId then
[456]346
[1679]347 end;
348 end;
349 if DeleteOrderList.Count = 0 then
350 begin
351 infoBox('No orders are marked to cancel. Check the Cancel box by the orders to cancel. ', 'Error', MB_OK);
352 end;
[456]353
[1679]354 for i := 0 to DeleteOrderList.Count - 1 do
355 begin
356 AnOrderId := DeleteORderList.Strings[i];
357 for j := 0 to grdChecks.RowCount do
358 if Piece(grdChecks.Cells[2, j], u, 1) = AnOrderId then
359 begin
360 //grdChecks.Rows[j].Clear;
361 DeleteRowList.Add(InttoStr(j));
362 end;
363 end;
364 if (grdChecks.RowCount - 1) = DeleteRowList.Count then Close;
365 cnt := 0;
366 for i := 0 to DeleteRowList.Count - 1 do
367 begin
368 GridDeleteRow(((StrtoInt(DeleteRowList.Strings[i])) - cnt), grdChecks);
369 cnt := cnt +1;
370 end;
371 //check if the remaining order checks are not high level and thus don't require justification
372 if FCritical then
[456]373 begin
[1679]374 StillCritical := false;
375 for I := 0 to grdChecks.RowCount do
376 begin
377 if ((Piece(grdChecks.cells[2,I],U,3) = '1') and not(Piece(grdChecks.Cells[2, i], U, 2) = 'O')) then
378 begin
379 StillCritical := true;
380 break;
381 end;
382 end;
383 if StillCritical = false then
384 begin
385 FCritical := false;
386 lblJustify.Visible := FCritical;
387 txtJustify.Visible := FCritical;
388 memNote.Visible := FCritical;
389 end;
[456]390 end;
[1679]391 grdChecks.Repaint;
[456]392end;
393
394procedure TfrmOCSession.cmdContinueClick(Sender: TObject);
[1679]395var
396i: integer;
397Cancel: boolean;
[456]398begin
399 inherited;
[1679]400 Cancel := False;
[456]401 if FCritical and ((Length(txtJustify.Text) < 2) or not ContainsVisibleChar(txtJustify.Text)) then
402 begin
403 InfoBox('A justification for overriding critical order checks is required.',
404 'Justification Required', MB_OK);
405 Exit;
406 end;
[1679]407
408 if FCritical and (ContainsUpCarretChar(txtJustify.Text)) then
409 begin
410 InfoBox('The justification may not contain the ^ character.',
411 'Justification Required', MB_OK);
412 Exit;
413 end;
414
415 for i := 0 to grdChecks.RowCount do
416 if (Piece(grdChecks.Cells[2, i], U, 3) = '1') and (Piece(grdChecks.Cells[2, i], U, 2) = 'O') then
417 begin
418 Cancel := True;
419 Break;
420 end;
421 if Cancel = True then
422 begin
423 InfoBox('One or more orders have been marked to cancel!' + CRLF + CRLF +
424 'To cancel these orders, click the "Cancel Checked Order(s)" button.' + CRLF + CRLF +
425 'To place these orders, uncheck the Cancel box beside the order you wish to keep and then click the "Accept Order(s)" button again.',
426 'Error', MB_OK);
427 Exit;
428 end;
429
[456]430 StatusText('Saving Order Checks...');
431 SaveOrderChecksForSession(txtJustify.Text, FCheckList);
432 StatusText('');
433 Close;
434end;
435
[1679]436procedure TfrmOCSession.cmdMonographClick(Sender: TObject);
437var
438 monoList: TStringList;
439begin
440 inherited;
441 monoList := TStringList.Create;
442 GetMonographList(monoList);
443 ShowMonographs(monoList);
444 monoList.Free;
445end;
446
447
[456]448procedure TfrmOCSession.FormClose(Sender: TObject;
449 var Action: TCloseAction);
450begin
451 inherited;
452 SaveUserBounds(Self); //Save Position & Size of Form
[1679]453 DeleteMonograph;
[456]454end;
455
[1679]456procedure TfrmOCSession.FormCreate(Sender: TObject);
457begin
458 inherited;
459 grdChecks.Cells[0, 0] := 'Cancel';
460 grdChecks.Cells[1, 0] := 'Order/Order Check Text';
461 //cmdMonograph.Font.Size := MainFontSize;
462 //cmdMonograph.Width := TextWidthByFont(cmdMonograph.Font.Handle, cmdMonograph.Caption);
463end;
464
[456]465procedure TfrmOCSession.FormShow(Sender: TObject);
[1679]466
[456]467begin
468 inherited;
469 SetFormPosition(Self); //Get Saved Position & Size of Form
[829]470 FCancelSignProcess := False;
[1679]471 if ScreenReaderActive = True then lblInstr.SetFocus
472 else
473 begin
474 lblInstr.TabStop := false;
475 grdChecks.SetFocus;
476 end;
477 self.lblInstr.Font.Size := mainFontSize + 1;
478 //self.lblJustify.Height := self.lblJustify.Height + 20;
479 (*if self.lblJustify.Visible = true then
480 begin
481 self.lblJustify.top := self.txtJustify.Top + self.lblJustify.Height + 50;
482 end; *)
483
484 //if mainFontSize < 12 then inc := 90
485 //else if mainFontSize < 18 then inc := 130
486 //else inc := 155;
487 //self.constraints.MinWidth := self.lblInstr.Left + TextWidthByFont(self.lblInstr.Font.Handle, self.lblInstr.Caption) + inc;
[456]488end;
489
[1679]490procedure TfrmOCSession.grdchecksDrawCell(Sender: TObject; ACol, ARow: Integer;
491 Rect: TRect; State: TGridDrawState);
492var
493 Wrap: boolean;
494 format, str, cdl, temp, colorText: string;
495 IsBelowOrder, isSelected: boolean;
496 chkRect, DrawRect, colorRect: TRect;
497 ChkState: Cardinal;
498begin
499 inherited;
500 temp := grdChecks.Cells[2, ARow];
501 format := Piece(grdChecks.Cells[2, ARow], U, 2);
502 cdl := Piece(grdChecks.Cells[2, ARow], U, 3);
503 colorText := '*Order Check requires Reason for Override';
504 grdChecks.Canvas.Brush.Color := Get508CompliantColor(clWhite);
505 grdChecks.Canvas.Font.Color := Get508CompliantColor(clBlack);
506 grdChecks.Canvas.Font.Style := [];
507 isSelected := false;
[456]508
[1679]509 if ARow = 0 then
510 begin
511 grdChecks.Canvas.Brush.Color := Get508CompliantColor(clbtnFace);
512 grdChecks.Canvas.Font.Style := [fsBold];
513 end;
514
515 //change commented out code to handle different font color this code may not be needed anymore
516 if (format = '') and (ARow > 0) then
517 grdchecks.Canvas.Font.Color := Get508CompliantColor(clBlue)
518 else
519 grdChecks.Canvas.Font.Color := Get508CompliantColor(clBlack);
520 if cdl = '1' then grdChecks.Canvas.Font.Color := Get508CompliantColor(clBlue);
521
522 //controls highlighting cell when focused in on the cell
523 if State = [gdSelected..gdFocused] then
524 begin
525 isSelected := true; //use to control colors for high order checks
526 grdChecks.Canvas.Font.Color := Get508CompliantColor(clWhite);
527 grdChecks.Canvas.Brush.Color := clHighlight;
528 grdChecks.Canvas.Font.Color := clHighlightText;
529 grdChecks.Canvas.Font.Style := [fsBold];
530 grdChecks.Canvas.MoveTo(Rect.Left,Rect.top);
531 end
532 //if not an order than blanked out lines seperating the order check
533 else if (format = 'I') then
534 begin
535 if (Arow < grdChecks.RowCount) and (Piece(grdChecks.Cells[2, Arow + 1], U, 2) = 'O') then IsBelowOrder := True
536 else IsBelowOrder := False;
537 grdChecks.Canvas.MoveTo(Rect.Left,Rect.Bottom);
538 grdChecks.Canvas.Pen.Color := Get508CompliantColor(clwhite);
539 grdChecks.Canvas.LineTo(Rect.Left, Rect.Top);
540 grdChecks.Canvas.LineTo(Rect.Right, Rect.Top);
541 grdChecks.Canvas.LineTo(Rect.Right, Rect.Bottom);
542 if (isBelowOrder = False) or (ARow = (grdChecks.RowCount -1)) then grdChecks.Canvas.LineTo(Rect.left, Rect.Bottom);
543 end;
544 Str:= grdChecks.Cells[ACol, ARow];
545 //determine if the cell needs to wrap
546 if ACol = 1 then Wrap := true
547 else wrap := false;
548 //Blank out existing Cell to prevent overlap after resize
549 grdChecks.Canvas.FillRect(Rect);
550 //get existing cell
551 DrawRect:= Rect;
552 if (ACol = 0) and (format = 'O') and (ARow > 0) then
553 begin
554 if Piece(grdChecks.Cells[2, ARow], U, 4) = '' then
555 begin
556 DrawRect.Bottom := DrawRect.Bottom + FontHeightPixel(Font.Handle) + 5;
557 setPiece(temp, U, 4, 'R');
558 grdChecks.Cells[2, ARow] := temp;
559 end;
560 if GetCheckState(grdChecks, ACol, ARow) = True then chkState := DFCS_CHECKED
561 else chkState := DFCS_BUTTONCHECK;
562 chkRect := CheckBoxRect(DrawRect);
563 DrawFrameControl(grdChecks.Canvas.Handle, chkRect, DFC_BUTTON, chkState);
564 DrawText(grdChecks.Canvas.Handle, PChar('Cancel?'), length('Cancel?'), DrawRect, DT_SINGLELINE or DT_Top or DT_Center);
565 if ((DrawRect.Bottom - DrawRect.Top) > grdChecks.RowHeights[ARow]) or
566 ((DrawRect.Bottom - DrawRect.Top) < grdChecks.RowHeights[ARow]) then
567 begin
568 grdChecks.RowHeights[ARow]:= (DrawRect.Bottom - DrawRect.Top);
569 end;
570 end;
571 //If order check than indent the order check text
572 if (ACol = 1) and (format = 'I') then DrawRect.Left := DrawRect.Left + 10;
573 //colorRect use to create Rect for Order Check Label
574 colorRect := DrawRect;
575 if Wrap then
576 begin
577 if (cdl = '1') and (format = 'I') then
578 begin
579 if isSelected = false then
580 begin
581 grdChecks.Canvas.Font.Color := Get508CompliantColor(clRed);
582 grdChecks.Canvas.Font.Style := [fsBold];
583 end;
584 //determine rect size for order check label
585 DrawText(grdChecks.Canvas.Handle, PChar(colorText), length(colorText), colorRect, dt_calcrect or dt_wordbreak);
586 DrawRect.Top := ColorRect.Bottom;
587 //determine rect size for order check text
588 DrawText(grdChecks.Canvas.Handle, PChar(str), length(str), DrawRect, dt_calcrect or dt_wordbreak);
589 str := copy(str, length(colorText + CRLF) + 1, length(str));
590 if isSelected = false then
591 begin
592 grdChecks.Canvas.Font.Color := Get508CompliantColor(clblue);
593 grdChecks.Canvas.Font.Style := [];
594 end;
595 end
596 //determine size for non-high order check text
597 else DrawText(grdChecks.Canvas.Handle, PChar(str), length(str), DrawRect, dt_calcrect or dt_wordbreak);
598 DrawRect.Bottom := DrawRect.Bottom + 2;
599 //Resize the Cell height if the height does not match the Rect Height
600 if ((DrawRect.Bottom - DrawRect.Top) > grdChecks.RowHeights[ARow]) then
601 begin
602 grdChecks.RowHeights[ARow]:= (DrawRect.Bottom - DrawRect.Top);
603 end
604 else
605 begin
606 //if cell doesn't need to grow reset the cell
607 DrawRect.Right:= Rect.Right;
608 if (cdl = '1') and (format = 'I') then
609 begin
610 //DrawRect.Top := ColorRect.Bottom;
611 if isSelected = false then
612 begin
613 grdChecks.Canvas.Font.Color := Get508CompliantColor(clRed);
614 grdChecks.Canvas.Font.Style := [fsBold];
615 end;
616 DrawText(grdChecks.Canvas.Handle, PChar(colorText), length(colorText), colorRect, dt_wordbreak);
617 if isSelected = false then
618 begin
619 grdChecks.Canvas.Font.Color := Get508CompliantColor(clBlue);
620 grdChecks.Canvas.Font.Style := [];
621 end;
622 end;
623 DrawText(grdChecks.Canvas.Handle, PChar(Str), length(Str), DrawRect, dt_wordbreak);
624 //reset height
625 if format = 'I' then grdChecks.RowHeights[ARow]:= (DrawRect.Bottom - DrawRect.Top);
626 end;
627 end
628 else
629 //if not wrap than grow just draw the cell
630 DrawText(grdChecks.Canvas.Handle, PChar(Str), length(Str), DrawRect, dt_wordbreak);
631end;
632
633procedure TfrmOCSession.grdchecksEnter(Sender: TObject);
634begin
635 inherited;
636 if ScreenReaderActive then
637 begin
638 grdChecks.Row := 1;
639 grdChecks.Col := 0;
640 GetScreenReader.Speak('Navigate through the grid to reviews the orders and the order checks');
641 if GetCheckState(grdchecks, 0, 1) = true then
642 GetScreenReader.Speak('Cancel checkbox is checked press spacebar to uncheck it')
643 else GetScreenReader.Speak('Cancel checkbox Not Checked press spacebar to check it to cancel the ' + grdChecks.Cells[1,1] + ' Order');
644 end;
645 grdChecks.Row := 1;
646 grdChecks.Col := 0;
647end;
648
649procedure TfrmOCSession.grdchecksKeyDown(Sender: TObject; var Key: Word;
650 Shift: TShiftState);
651begin
652 inherited;
653 if key = VK_TAB then
654 begin
655 if ssCtrl in Shift then
656 begin
657 if txtJustify.Visible = TRUE then ActiveControl := txtJustify
658 else ActiveControl := cmdContinue;
659 Key := 0;
660 Exit;
661 end;
662 end;
663 if grdchecks.Col = 0 then
664 begin
665 Case Key of
666 VK_Tab:
667 begin
668 if (ssShift in Shift) and (grdChecks.Row > 1) then
669 begin
670 grdChecks.Col := 1;
671 grdChecks.Row := grdChecks.Row - 1;
672 end;
673 end;
674 VK_Space:
675 begin
676 if Piece(grdChecks.Cells[2, grdChecks.Row], U, 2) = 'O' then
677 begin
678 if GetCheckState(grdChecks, 2, grdChecks.Row) = True then
679 SetCheckState(grdChecks, 2, grdChecks.Row, False)
680 else SetCheckState(grdChecks, 2, grdChecks.Row, True);
681 if ScreenReaderActive then
682 begin
683 if GetCheckState(grdchecks, 0, grdChecks.Row) = true then
684 GetScreenReader.Speak('Cancel checkbox checked')
685 else GetScreenReader.Speak('Cancel checkbox unChecked');
686 end;
687 end;
688 end;
689 (* VK_Down:
690 begin
691 if (grdChecks.Row < grdChecks.RowCount) and (Piece(grdChecks.Cells[2, grdChecks.Row + 1], U, 2) <> 'O') then
692 begin
693 for I := grdChecks.Row + 1 to grdChecks.RowCount do
694 begin
695 if (Piece(grdChecks.Cells[2, i], U, 2) <> 'O') or (grdChecks.Cells[2, i] = '') then continue
696 else
697 begin
698 grdChecks.Row := i;
699 exit;
700 end;
701
702 end;
703 end;
704 end;
705 VK_Up:
706 Begin
707 if ((grdChecks.Row - 1) > 1) and (Piece(grdChecks.Cells[2, grdChecks.Row - 1], U, 2) <> 'O') then
708 begin
709 for i := grdChecks.Row - 1 downto 0 do
710 begin
711 if (Piece(grdChecks.Cells[2, i], U, 2) <> 'O') or (grdChecks.Cells[2, i] = '') then continue
712 else
713 begin
714 grdChecks.Row := i;
715 exit;
716 end;
717 end;
718 end;
719 End; *)
720 End;
721 end;
722 if grdChecks.Col = 1 then
723 begin
724 // needed to add control for tab key to handle the blank cells that should not have focus.
725 if key = VK_Tab then
726 begin
727 if ssShift in Shift then
728 begin
729 if Piece(grdChecks.Cells[2, grdChecks.Row], U, 2) = 'O' then grdChecks.Col := 0
730 else if grdChecks.Row > 1 then
731 begin
732 grdChecks.Col := 1;
733 grdChecks.Row := grdChecks.Row - 1;
734 end;
735 end
736 else
737 begin
738 if grdChecks.Row = (grdChecks.RowCount - 1) then
739 begin
740 if ScreenReaderActive = True then ActiveControl := memNote
741 else if txtJustify.Visible = TRUE then ActiveControl := txtJustify
742 else ActiveControl := cmdContinue;
743 Key := 0;
744 end
745 else
746 begin
747 grdChecks.Row := grdChecks.Row + 1;
748 if Piece(grdChecks.Cells[2, grdChecks.Row], U, 2) = 'O' then grdChecks.Col := 0
749 else grdChecks.Col := 2;
750 end;
751 end;
752 Key := 0;
753 end;
754 end;
755end;
756
757procedure TfrmOCSession.grdchecksMouseDown(Sender: TObject;
758 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
759var
760 Row, Col: integer;
761begin
762 inherited;
763 grdChecks.MouseToCell(X, Y, Col, Row);
764 if Col <> 0 then exit;
765 if Piece(grdChecks.Cells[2,row], U, 2) <> 'O' then exit;
766 if InCheckBox(grdChecks, X, Y, Col, Row) = false then exit;
767 if GetCheckState(grdChecks, Col, Row) = True then SetCheckState(grdChecks, Col, Row, False)
768 else SetCheckState(grdChecks, Col, Row, True);
769end;
770
771
772
773procedure TfrmOCSession.grdchecksMouseMove(Sender: TObject; Shift: TShiftState;
774 X, Y: Integer);
775var
776acol , arow: integer;
777//P : Tpoint;
778//Rect: TRect;
779begin
780//Rect := grdChecks.CellRect(ACol, ARow);
781//P.X := Rect.Left;
782//P.Y := Rect.Top;
783
784grdChecks.MouseToCell(X,y,acol , arow);
785//check to see if hint should show
786if ARow > grdChecks.RowCount then Exit;
787if ACol <> 1 then exit;
788if grdChecks.RowHeights[Arow] < grdChecks.Height then Exit;
789
790
791
792grdChecks.Hint := grdChecks.Cells[ACol, ARow];
793Application.HintHidePause := 20000; //20 Sec
794if grdChecks.Hint <> '' then grdCHecks.ShowHint := true;
795
796//Application.HintColor := clYellow;
797//Application.ActivateHint(P);
798
799end;
800
801procedure TfrmOCSession.grdchecksMouseWheelDown(Sender: TObject;
802 Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
803begin
804 inherited;
805(* if grdChecks.Col = 0 then
806 begin
807 if (grdChecks.Row < grdChecks.RowCount) and (Piece(grdChecks.Cells[2, grdChecks.Row + 1], U, 2) <> 'O') then
808 begin
809 for I := grdChecks.Row + 1 to grdChecks.RowCount do
810 begin
811 if (Piece(grdChecks.Cells[2, i], U, 2) <> 'O') or (grdChecks.Cells[2, i] = '') then continue
812 else
813 begin
814 grdChecks.Row := i;
815 exit;
816 end;
817 end;
818 end;
819 end; *)
820end;
821
822procedure TfrmOCSession.grdchecksMouseWheelUp(Sender: TObject;
823 Shift: TShiftState; MousePos: TPoint; var Handled: Boolean);
824begin
825 inherited;
826 (* if grdChecks.Col = 0 then
827 begin
828 if ((grdChecks.Row - 1) > 1) and (Piece(grdChecks.Cells[2, grdChecks.Row - 1], U, 2) <> 'O') then
829 begin
830 for i := grdChecks.Row - 1 downto 0 do
831 begin
832 if (Piece(grdChecks.Cells[2, i], U, 2) <> 'O') or (grdChecks.Cells[2, i] = '') then continue
833 else
834 begin
835 grdChecks.Row := i;
836 exit;
837 end;
838 end;
839 end;
840 end; *)
841end;
842
843procedure TfrmOCSession.grdchecksSelectCell(Sender: TObject; ACol,
844 ARow: Integer; var CanSelect: Boolean);
845begin
846 inherited;
847 CanSelect := True;
848 if ARow = 0 then CanSelect := false
849 else if (ACol = 2) then CanSelect := False
850 else if (ACol = 1) and (grdChecks.Cells[Acol, Arow] = '') then CanSelect := False;
851 //else if (ACol = 0) and (Piece(grdChecks.cells[2,ARow], U, 2) <> 'O') then CanSelect := false;
852 if (CanSelect = True) and (ACol = 0) and (Piece(grdChecks.cells[2,ARow], U, 2) = 'O') and (ScreenReaderActive) then
853 begin
854 if GetCheckState(grdchecks, ACol, ARow) = true then
855 GetScreenReader.Speak('Cancel checkbox is checked press spacebar to uncheck it')
856 else GetScreenReader.Speak('Cancel checkbox Not Checked press spacebar to check it to cancel the ' + grdChecks.Cells[1,Arow] + ' Order');
857 end;
858end;
859
860procedure TfrmOCSession.GridDeleteRow(RowNumber: Integer; Grid: TstringGrid);
861var
862 i: Integer;
863begin
864 Grid.Row := RowNumber;
865 if (Grid.Row = Grid.RowCount - 1) then
866 { On the last row}
867 Grid.RowCount := Grid.RowCount - 1
868 else
869 begin
870 { Not the last row}
871 for i := RowNumber to Grid.RowCount - 1 do
872 Grid.Rows[i] := Grid.Rows[i + 1];
873 Grid.RowCount := Grid.RowCount - 1;
874 end;
875end;
876
877function TfrmOCSession.InCheckBox(Grid: TStringGrid; X, Y, ACol,
878 ARow: integer): boolean;
879var
880 Rect: TRect;
881begin
882 Result := False;
883 Rect := CheckBoxRect(grid.CellRect(ACol, ARow));
884 if Y < Rect.Top then Exit;
885 if Y > Rect.Bottom then Exit;
886 if X < Rect.Left then exit;
887 if X > Rect.Right then exit;
888 Result := True;
889end;
890
891function TfrmOCSession.GetCheckState(grid: TStringGrid; ACol, ARow: integer): boolean;
892begin
893 if Piece(grid.Cells[2, ARow], U, 3) = '1' then Result := True
894 else Result := false;
895end;
896
[456]897procedure TfrmOCSession.FormResize(Sender: TObject);
898begin
899 //TfrmAutoSz has defect must call inherited Resize for the resize to function.
900 inherited;
[1679]901 grdChecks.ColWidths[0] := round(grdChecks.Width * 0.08);
902 grdChecks.ColWidths[1] := round(grdChecks.Width * 0.88); //Order Text
903 grdChecks.ColWidths[2] := 0; //OrderID^Format^IsCheck
904 grdChecks.tabStops[2] := false;
905 if grdChecks.RowCount > 1 then grdChecks.Refresh;
906 self.pnlBottom.Top := self.pnlTop.Top + self.pnlTop.Height;
[456]907end;
908
909procedure TfrmOCSession.txtJustifyKeyDown(Sender: TObject; var Key: Word;
910 Shift: TShiftState);
911begin
912 inherited;
913 //GE CQ9540 activate Return key, behave as "Continue" buttom clicked.
914 if Key = VK_RETURN then cmdContinueClick(self);
915end;
916
[829]917procedure TfrmOCSession.btnReturnClick(Sender: TObject);
918begin
919 inherited;
920 FCancelSignProcess := True;
921 Close;
922end;
923
924procedure TfrmOCSession.SetReturn(const Value: Boolean);
925begin
926 FCancelSignProcess := Value;
927end;
928
929procedure TfrmOCSession.memNoteEnter(Sender: TObject);
930begin
931 inherited;
932 memNote.SelStart := 0;
933end;
934
[1679]935
936procedure TfrmOCSession.FormKeyDown(Sender: TObject; var Key: Word;
937 Shift: TShiftState);
938 begin
939 inherited;
940 if (Key = VK_F4) and (ssAlt in Shift) then Key := 0;
941end;
942procedure TfrmOCSession.FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
943 MousePos: TPoint; var Handled: Boolean);
944begin
945 inherited;
946 if self.grdchecks.Focused = false then
947 begin
948 end;
949end;
950
[456]951end.
Note: See TracBrowser for help on using the repository browser.