source: cprs/branches/tmg-cprs/CPRS-Chart/rMisc.pas@ 893

Last change on this file since 893 was 453, checked in by Kevin Toppenberg, 16 years ago

Initial upload of TMG-CPRS 1.0.26.69

File size: 12.9 KB
Line 
1//kt -- Modified with SourceScanner on 8/7/2007
2unit rMisc;
3
4interface
5
6uses SysUtils, Windows, Classes, Forms, Controls, ComCtrls, Grids, ORFn, ORNet;
7
8const
9 MAX_TOOLITEMS = 30;
10
11type
12 TToolItem = record
13 Caption: string;
14 Action: string;
15 end;
16
17 TToolItemList = array[0..MAX_TOOLITEMS] of TToolItem;
18
19 {An Object of this Class is Created to Hold the Sizes of Controls(Forms)
20 while the app is running, thus reducing calls to RPCs SAVESIZ and LOADSIZ}
21 TSizeHolder = class(TObject)
22 private
23 FSizeList,FNameList: TStringList;
24 public
25 constructor Create;
26 destructor Destroy; override;
27 function GetSize(AName: String): String;
28 procedure SetSize(AName,ASize: String);
29 procedure AddSizesToStrList(theList: TStringList);
30 end;
31
32function DetailPrimaryCare(const DFN: string): TStrings; //*DFN*
33procedure GetToolMenu(var ToolItems: TToolItemList; var OverLimit: boolean);
34procedure ListSymbolTable(Dest: TStrings);
35function MScalar(const x: string): string;
36procedure SetShareNode(const DFN: string; AHandle: HWND); //*DFN*
37function ServerHasPatch(const x: string): Boolean;
38function ServerVersion(const Option, VerClient: string): string;
39function PackageVersion(const Namespace: string): string;
40
41procedure SaveUserBounds(AControl: TControl);
42procedure SaveUserSizes(SizingList: TStringList);
43procedure SetFormPosition(AForm: TForm);
44procedure SetUserBounds(var AControl: TControl);
45procedure SetUserBounds2(AName: string; var v1, v2, v3, v4: integer);
46procedure SetUserWidths(var AControl: TControl);
47procedure SetUserColumns(var AControl: TControl);
48function StrUserBounds(AControl: TControl): string;
49function StrUserBounds2(AName: string; v1, v2, v3, v4: integer): string;
50function StrUserWidth(AControl: TControl): string;
51function StrUserColumns(AControl: TControl): string;
52function UserFontSize: integer;
53procedure SaveUserFontSize( FontSize: integer);
54
55var
56 SizeHolder : TSizeHolder;
57
58implementation
59
60uses TRPCB, fOrders, math;
61
62var
63 uBounds, uWidths, uColumns: TStringList;
64
65function DetailPrimaryCare(const DFN: string): TStrings; //*DFN*
66begin
67 CallV('ORWPT1 PCDETAIL', [DFN]);
68 Result := RPCBrokerV.Results;
69end;
70
71procedure GetToolMenu(var ToolItems: TToolItemList; var OverLimit: boolean);
72var
73 i: Integer;
74 x: string;
75 LoopIndex: integer;
76begin
77 for i := 0 to MAX_TOOLITEMS do with ToolItems[i] do
78 begin
79 Caption := '';
80 Action := '';
81 end;
82 CallV('ORWU TOOLMENU', [nil]);
83 OverLimit := (MAX_TOOLITEMS < RPCBrokerV.Results.Count - 1);
84 LoopIndex := Min(MAX_TOOLITEMS, RPCBrokerV.Results.Count - 1);
85 with RPCBrokerV do for i := 0 to LoopIndex do with ToolItems[i] do
86 begin
87 x := Piece(Results[i], U, 1);
88 Caption := Piece(x, '=', 1);
89 Action := Copy(x, Pos('=', x) + 1, Length(x));
90 end;
91end;
92
93procedure ListSymbolTable(Dest: TStrings);
94var
95 i: Integer;
96 x: string;
97begin
98 Dest.Clear;
99 CallV('ORWUX SYMTAB', [nil]);
100 i := 0;
101 with RPCBrokerV.Results do while i < Count do
102 begin
103 x := Strings[i] + '=';
104 Inc(i);
105 if i < Count then x := x + Strings[i];
106 Dest.Add(x);
107 Inc(i);
108 end;
109end;
110
111function MScalar(const x: string): string;
112begin
113 with RPCBrokerV do
114 begin
115 ClearParameters := True;
116 RemoteProcedure := 'XWB GET VARIABLE VALUE';
117 Param[0].Value := x;
118 Param[0].PType := reference;
119 CallBroker;
120 Result := Results[0];
121 end;
122end;
123
124function ServerHasPatch(const x: string): Boolean;
125begin
126 Result := sCallV('ORWU PATCH', [x]) = '1';
127end;
128
129function ServerVersion(const Option, VerClient: string): string;
130begin
131 Result := sCallV('ORWU VERSRV', [Option, VerClient]);
132end;
133
134function PackageVersion(const Namespace: string): string;
135begin
136 Result := sCallV('ORWU VERSION', [Namespace]);
137end;
138
139function UserFontSize: integer;
140begin
141 Result := StrToIntDef(sCallV('ORWCH LDFONT', [nil]),8);
142end;
143
144procedure LoadSizes;
145var
146 i, p: Integer;
147begin
148 uBounds := TStringList.Create;
149 uWidths := TStringList.Create;
150 uColumns := TStringList.Create;
151 CallV('ORWCH LOADALL', [nil]);
152 with RPCBrokerV do
153 begin
154 for i := 0 to Results.Count - 1 do // change '^' to '='
155 begin
156 p := Pos(U, Results[i]);
157 if p > 0 then Results[i] := Copy(Results[i], 1, p - 1) + '=' +
158 Copy(Results[i], p + 1, Length(Results[i]));
159 end;
160 ExtractItems(uBounds, RPCBrokerV.Results, 'Bounds');
161 ExtractItems(uWidths, RPCBrokerV.Results, 'Widths');
162 ExtractItems(uColumns, RPCBrokerV.Results, 'Columns');
163 end;
164end;
165
166procedure SetShareNode(const DFN: string; AHandle: HWND); //*DFN*
167begin
168 // sets node that allows other apps to see which patient is currently selected
169 sCallV('ORWPT SHARE', [DottedIPStr, IntToHex(AHandle, 8), DFN]);
170end;
171
172procedure SetUserBounds(var AControl: TControl);
173var
174 x: string;
175begin
176 if uBounds = nil then LoadSizes;
177 x := AControl.Name;
178 if not (AControl is TForm) and (Assigned(AControl.Owner)) then x := AControl.Owner.Name + '.' + x;
179 x := uBounds.Values[x];
180 if (x = '0,0,0,0') and (AControl is TForm)
181 then TForm(AControl).WindowState := wsMaximized
182 else
183 begin
184 AControl.Left := HigherOf(StrToIntDef(Piece(x, ',', 1), AControl.Left), 0);
185 AControl.Top := HigherOf(StrToIntDef(Piece(x, ',', 2), AControl.Top), 0);
186 if Assigned( AControl.Parent ) then
187 begin
188 AControl.Width := LowerOf(StrToIntDef(Piece(x, ',', 3), AControl.Width), AControl.Parent.Width - AControl.Left);
189 AControl.Height := LowerOf(StrToIntDef(Piece(x, ',', 4), AControl.Height), AControl.Parent.Height - AControl.Top);
190 end
191 else
192 begin
193 AControl.Width := StrToIntDef(Piece(x, ',', 3), AControl.Width);
194 AControl.Height := StrToIntDef(Piece(x, ',', 4), AControl.Height);
195 end;
196 end;
197 //if (x = '0,0,' + IntToStr(Screen.Width) + ',' + IntToStr(Screen.Height)) and
198 // (AControl is TForm) then TForm(AControl).WindowState := wsMaximized;
199end;
200
201procedure SetUserBounds2(AName: string; var v1, v2, v3, v4: integer);
202var
203 x: string;
204begin
205 if uBounds = nil then LoadSizes;
206 x := uBounds.Values[AName];
207 v1 := StrToIntDef(Piece(x, ',', 1), 0);
208 v2 := StrToIntDef(Piece(x, ',', 2), 0);
209 v3 := StrToIntDef(Piece(x, ',', 3), 0);
210 v4 := StrToIntDef(Piece(x, ',', 4), 0);
211end;
212
213
214procedure SetUserWidths(var AControl: TControl);
215var
216 x: string;
217begin
218 if uWidths = nil then LoadSizes;
219 x := AControl.Name;
220 if not (AControl is TForm) and (Assigned(AControl.Owner)) then x := AControl.Owner.Name + '.' + x;
221 x := uWidths.Values[x];
222 if Assigned (AControl.Parent) then
223 AControl.Width := LowerOf(StrToIntDef(x, AControl.Width), AControl.Parent.Width - AControl.Left)
224 else
225 AControl.Width := StrToIntDef(x, AControl.Width);
226end;
227
228procedure SetUserColumns(var AControl: TControl);
229var
230 x: string;
231 i, AWidth: Integer;
232 couldSet: boolean;
233begin
234 couldSet := False;
235 if uColumns = nil then LoadSizes;
236 x := AControl.Name;
237 if not (AControl is TForm) and (Assigned(AControl.Owner)) then x := AControl.Owner.Name + '.' + x;
238 if AnsiCompareText(x,'frmOrders.hdrOrders')=0 then
239 couldSet := True;
240 x := uColumns.Values[x];
241 if AControl is THeaderControl then with THeaderControl(AControl) do
242 for i := 0 to Sections.Count - 1 do
243 begin
244 //Make sure all of the colmumns fit, even if it means scrunching the last ones.
245 AWidth := LowerOf(StrToIntDef(Piece(x, ',', i + 1), 0), HigherOf(ClientWidth - (Sections.Count - i)*5 - Sections.Items[i].Left, 5));
246 if AWidth > 0 then Sections.Items[i].Width := AWidth;
247 if couldSet and (i=0) and (AWidth>0) then
248 frmOrders.EvtColWidth := AWidth;
249 end;
250 if AControl is TCustomGrid then {nothing for now};
251end;
252
253procedure SaveUserBounds(AControl: TControl);
254var
255 x: string;
256begin
257 if (AControl is TForm) and (TForm(AControl).WindowState = wsMaximized) then
258 x := '0,0,0,0'
259 else
260 with AControl do
261 x := IntToStr(Left) + ',' + IntToStr(Top) + ',' +
262 IntToStr(Width) + ',' + IntToStr(Height);
263// CallV('ORWCH SAVESIZ', [AControl.Name, x]);
264 SizeHolder.SetSize(AControl.Name, x);
265end;
266
267procedure SaveUserSizes(SizingList: TStringList);
268begin
269 CallV('ORWCH SAVEALL', [SizingList]);
270end;
271
272procedure SaveUserFontSize( FontSize: integer);
273begin
274 CallV('ORWCH SAVFONT', [IntToStr(FontSize)]);
275end;
276
277procedure SetFormPosition(AForm: TForm);
278var
279 x: string;
280 Rect: TRect;
281begin
282// x := sCallV('ORWCH LOADSIZ', [AForm.Name]);
283 x := SizeHolder.GetSize(AForm.Name);
284 if x = '' then Exit; // allow default bounds to be passed in, else screen center?
285 if (x = '0,0,0,0') then
286 AForm.WindowState := wsMaximized
287 else
288 begin
289 AForm.SetBounds(StrToIntDef(Piece(x, ',', 1), AForm.Left),
290 StrToIntDef(Piece(x, ',', 2), AForm.Top),
291 StrToIntDef(Piece(x, ',', 3), AForm.Width),
292 StrToIntDef(Piece(x, ',', 4), AForm.Height));
293 Rect := AForm.BoundsRect;
294 ForceInsideWorkArea(Rect);
295 AForm.BoundsRect := Rect;
296 end;
297end;
298
299function StrUserBounds(AControl: TControl): string;
300var
301 x: string;
302begin
303 x := AControl.Name;
304 if not (AControl is TForm) and (Assigned(AControl.Owner)) then x := AControl.Owner.Name + '.' + x;
305 with AControl do Result := 'B' + U + x + U + IntToStr(Left) + ',' + IntToStr(Top) + ',' +
306 IntToStr(Width) + ',' + IntToStr(Height);
307 if (AControl is TForm) and (TForm(AControl).WindowState = wsMaximized)
308 then Result := 'B' + U + x + U + '0,0,0,0';
309end;
310
311function StrUserBounds2(AName: string; v1, v2, v3, v4: integer): string;
312begin
313 Result := 'B' + U + AName + U + IntToStr(v1) + ',' + IntToStr(v2) + ',' +
314 IntToStr(v3) + ',' + IntToStr(v4);
315end;
316
317function StrUserWidth(AControl: TControl): string;
318var
319 x: string;
320begin
321 x := AControl.Name;
322 if not (AControl is TForm) and (Assigned(AControl.Owner)) then x := AControl.Owner.Name + '.' + x;
323 with AControl do Result := 'W' + U + x + U + IntToStr(Width);
324end;
325
326function StrUserColumns(AControl: TControl): string;
327var
328 x: string;
329 i: Integer;
330 shouldSave: boolean;
331begin
332 shouldSave := False;
333 x := AControl.Name;
334 if not (AControl is TForm) and (Assigned(AControl.Owner)) then x := AControl.Owner.Name + '.' + x;
335 if AnsiCompareText(x,'frmOrders.hdrOrders') = 0 then
336 shouldSave := True;
337 Result := 'C' + U + x + U;
338 if AControl is THeaderControl then with THeaderControl(AControl) do
339 for i := 0 to Sections.Count - 1 do
340 begin
341 if shouldSave and (i = 0) then
342 Result := Result + IntToStr(frmOrders.EvtColWidth) + ','
343 else
344 Result := Result + IntToStr(Sections.Items[i].Width) + ',';
345 end;
346 if AControl is TCustomGrid then {nothing for now};
347 if CharAt(Result, Length(Result)) = ',' then Result := Copy(Result, 1, Length(Result) - 1);
348end;
349
350{ TSizeHolder }
351
352procedure TSizeHolder.AddSizesToStrList(theList: TStringList);
353{Adds all the Sizes in the TSizeHolder Object to theList String list parameter}
354var
355 i: integer;
356begin
357 for i := 0 to FNameList.Count-1 do
358 theList.Add('B' + U + FNameList[i] + U + FSizeList[i]);
359end;
360
361constructor TSizeHolder.Create;
362begin
363 inherited;
364 FNameList := TStringList.Create;
365 FSizeList := TStringList.Create;
366end;
367
368
369destructor TSizeHolder.Destroy;
370begin
371 FNameList.Free;
372 FSizeList.Free;
373 inherited;
374end;
375
376function TSizeHolder.GetSize(AName: String): String;
377{Fuctions returns a String of the Size(s) Of the Name parameter passed,
378 if the Size(s) are already loaded into the object it will return those,
379 otherwise it will make the apropriate RPC call to LOADSIZ}
380var
381 rSizeVal: String; //return Size value
382 nameIndex: integer;
383begin
384 rSizeVal := '';
385 nameIndex := FNameList.IndexOf(AName);
386 if nameIndex = -1 then //Currently Not in the NameList
387 begin
388 rSizeVal := sCallV('ORWCH LOADSIZ', [AName]);
389 if rSizeVal <> '' then
390 begin
391 FNameList.Add(AName);
392 FSizeList.Add(rSizeVal);
393 end;
394 end
395 else //Currently is in the NameList
396 rSizeVal := FSizeList[nameIndex];
397 result := rSizeVal;
398end;
399
400procedure TSizeHolder.SetSize(AName, ASize: String);
401{Store the Size(s) Of the ASize parameter passed, Associate it with the AName
402 Parameter. This only stores the sizes in the objects member variables.
403 to Store on the MUMPS Database call SendSizesToDB()}
404var
405 nameIndex: integer;
406begin
407 nameIndex := FNameList.IndexOf(AName);
408 if nameIndex = -1 then //Currently Not in the NameList
409 begin
410 FNameList.Add(AName);
411 FSizeList.Add(ASize);
412 end
413 else //Currently is in the NameList
414 FSizeList[nameIndex] := ASize;
415end;
416
417initialization
418 // nothing for now
419
420finalization
421 if uBounds <> nil then uBounds.Free;
422 if uWidths <> nil then uWidths.Free;
423 if uColumns <> nil then uColumns.Free;
424
425end.
Note: See TracBrowser for help on using the repository browser.