source: cprs/trunk/CPRS-Chart/rMisc.pas@ 828

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

Initial Upload of Official WV CPRS 1.0.26.76

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