Module

fOCSession

Path

C:\CPRS\CPRS30\Orders\fOCSession.pas

Last Modified

7/15/2014 3:26:40 PM

Units Used in Interface

Name Comments
fAutoSz -
fOCMonograph -
uConst -
uDlgComponents -

Units Used in Implementation

Name Comments
fFrame -
rMisc -
rOrders -
uCore -

Classes

Name Comments
TfrmOCSession -
TOCRec -

Procedures

Name Owner Declaration Scope Comments
btnReturnClick TfrmOCSession procedure btnReturnClick(Sender: TObject); Public/Published -
cmdCancelOrderClick TfrmOCSession procedure cmdCancelOrderClick(Sender: TObject); Public/Published -
cmdContinueClick TfrmOCSession procedure cmdContinueClick(Sender: TObject); Public/Published -
cmdMonographClick TfrmOCSession procedure cmdMonographClick(Sender: TObject); Public/Published -
ExecuteReleaseOrderChecks - procedure ExecuteReleaseOrderChecks(SelectList: TList); Interfaced -
FormClose TfrmOCSession procedure FormClose(Sender: TObject; var Action: TCloseAction); Public/Published -
FormCreate TfrmOCSession procedure FormCreate(Sender: TObject); Public/Published -
FormKeyDown TfrmOCSession procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); Public/Published -
FormMouseWheelDown TfrmOCSession procedure FormMouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); Public/Published -
FormResize TfrmOCSession procedure FormResize(Sender: TObject); Public/Published -
FormShow TfrmOCSession procedure FormShow(Sender: TObject); Public/Published -
grdchecksDrawCell TfrmOCSession procedure grdchecksDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); Public/Published -
grdchecksEnter TfrmOCSession procedure grdchecksEnter(Sender: TObject); Public/Published -
grdchecksKeyDown TfrmOCSession procedure grdchecksKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); Public/Published -
grdchecksMouseDown TfrmOCSession procedure grdchecksMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Public/Published -
grdchecksMouseMove TfrmOCSession procedure grdchecksMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer); Public/Published
P : Tpoint;
Rect: TRect;
grdchecksMouseWheelDown TfrmOCSession procedure grdchecksMouseWheelDown(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); Public/Published -
grdchecksMouseWheelUp TfrmOCSession procedure grdchecksMouseWheelUp(Sender: TObject; Shift: TShiftState; MousePos: TPoint; var Handled: Boolean); Public/Published -
grdchecksSelectCell TfrmOCSession procedure grdchecksSelectCell(Sender: TObject; ACol, ARow: Integer; var CanSelect: Boolean); Public/Published -
GridDeleteRow TfrmOCSession procedure GridDeleteRow(RowNumber: Integer; Grid: TstringGrid); Public/Published -
memNoteEnter TfrmOCSession procedure memNoteEnter(Sender: TObject); Public/Published -
SetCheckState TfrmOCSession procedure SetCheckState(grid: TStringGrid; ACol, ARow: integer; State: boolean); Public/Published -
SetReqJustify TfrmOCSession procedure SetReqJustify; Private -
SetReturn TfrmOCSession procedure SetReturn(const Value: Boolean); Private -
txtJustifyKeyDown TfrmOCSession procedure txtJustifyKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); Public/Published -

Functions

Name Owner Declaration Scope Comments
CheckBoxRect TfrmOCSession function CheckBoxRect(poRect: TRect): TRect; Public/Published -
ExecuteSessionOrderChecks - function ExecuteSessionOrderChecks(OrderList: TStringList) : Boolean; Interfaced
Returns True if the Signature process should proceed.
 Clears OrderList If False.
GetCheckState TfrmOCSession function GetCheckState(grid: TStringGrid; ACol, ARow: integer): boolean; Public/Published -
InCheckBox TfrmOCSession function InCheckBox(Grid: TStringGrid; X, Y, ACol, ARow: integer): boolean; Public/Published -

Global Variables

Name Type Declaration Comments
FOldHintHidePause Integer FOldHintHidePause: integer; -
uCheckedOrders TList uCheckedOrders: TList; -


Module Source

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

Module Calls (2 levels)


fOCSession
 ├fOCMonograph
 │ └rOrders
 ├fAutoSz
 │ └fBase508Form
 ├uConst
 ├rOrders...
 ├uCore
 │ ├rCore
 │ ├uConst
 │ ├uCombatVet
 │ ├rTIU
 │ ├rOrders...
 │ ├rConsults
 │ └uOrders
 ├rMisc
 │ └fOrders
 └fFrame
   ├fPage
   ├uConst
   ├VERGENCECONTEXTORLib_TLB
   ├fBase508Form...
   ├XuDsigS
   ├rCore...
   ├fPtSelMsg
   ├fPtSel
   ├fCover
   ├fProbs
   ├fMeds
   ├fOrders...
   ├rOrders...
   ├fNotes
   ├fConsults
   ├fDCSumm
   ├rMisc...
   ├fLabs
   ├fReports
   ├rReports
   ├fPtDemo
   ├fEncnt
   ├fPtCWAD
   ├uCore...
   ├fAbout
   ├fReview
   ├fxBroker
   ├fxLists
   ├fxServer
   ├fRptBox
   ├rODAllergy
   ├uInit
   ├fLabInfo
   ├uReminders
   ├fReminderTree
   ├fDeviceSelect
   ├fDrawers
   ├fReminderDialog
   ├fOptions
   ├fGraphs
   ├fGraphData
   ├rTemplates
   ├fSurgery
   ├rSurgery
   ├uEventHooks
   ├uSignItems
   ├rECS
   ├fIconLegend
   ├uOrders...
   ├uSpell
   ├uOrPtf
   ├fPatientFlagMulti
   ├fAlertForward
   ├UBAGlobals
   ├UBACore
   ├fOrdersSign
   ├uVitals
   ├fMHTest
   ├uFormMonitor
   ├fOtherSchedule
   ├uVA508CPRSCompatibility
   ├fIVRoutes
   ├fPrintLocation
   ├fTemplateEditor
   └fCombatVet

Module Called-By (2 levels)


             fOCSession
              fOrders┤ 
            uOrders┤ │ 
            fODBase┤ │ 
             fFrame┤ │ 
              rMisc┤ │ 
            uODBase┤ │ 
              fMeds┤ │ 
          fOrdersDC┤ │ 
          fOrdersCV┤ │ 
            fOMNavA┤ │ 
             fOMSet┤ │ 
 fOrdersEvntRelease┤ │ 
    fODReleaseEvent┤ │ 
         mEvntDelay┤ │ 
          fODActive┤ │ 
        fOrdersCopy┤ │ 
           fMedCopy┤ │ 
fActivateDeactivate┘ │ 
              fReview┘ 
         UBAGlobals┤   
            UBACore┤   
          fFrame...┤   
  fBALocalDiagnoses┤   
             fEncnt┤   
         uSignItems┘