source: cprs/trunk/CPRS-Chart/uReports.pas

Last change on this file was 1679, checked in by healthsevak, 9 years ago

Updating the working copy to CPRS version 28

File size: 11.2 KB
Line 
1unit uReports;
2
3interface
4
5uses sysutils, classes, ORFN, ComCtrls, Forms, Graphics;
6
7type
8
9TCellObject = class //Data Object for each Cell in ListView
10 private
11 FName : string; //Column Name
12 FSite : string; //Site (#;name)
13 FInclude : string; //Set if data is to be included in detailed report
14 FTextType : string; //Type of data (WP)
15 FVisible : string; //Set if column property is visible
16 FHandle : string; //Row:Col identifier
17 FDataType : string; //Data Type of data in column (null or 0:freetext, 1:integer, 2:datetime)
18 FData : TStringList; //Data for this field (could be WP)
19 FCount : integer;
20
21 public
22 constructor Create;
23 destructor Destroy; override;
24 procedure Add(ASite, AHandle, AColumnData: string; AData: TStringList);
25 property Name :string read FName write FName;
26 property Site :string read FSite write FSite;
27 property Include :string read FInclude write FInclude;
28 property TextType :string read FTextType write FTextType;
29 property Visible :string read FVisible write FVisible;
30 property Handle :string read FHandle write FHandle;
31 property DataType :string read FDataType write FDatatype;
32 property Data :TStringList read FData write FData;
33 property Count :integer read FCount write FCount;
34 end;
35
36TRowObject = class //List of Row objects for ReportsTab ListView
37 private
38 FCount :integer;
39 FColumnList:TList;
40 public
41 constructor Create;
42 destructor Destroy; override;
43 procedure Add(ASite, AHandle, AColumnData: string; AData: TStringList);
44 procedure Clear;
45 property Count :integer read FCount;
46 property ColumnList :TList read FColumnList;
47 end;
48
49TLabRowObject = class //List of Row objects for Labs Tab ListView
50 private
51 FCount :integer;
52 FColumnList:TList;
53 public
54 constructor Create;
55 destructor Destroy; override;
56 procedure Add(ASite, AHandle, AColumnData: string; AData: TStringList);
57 procedure Clear;
58 property Count :integer read FCount;
59 property ColumnList :TList read FColumnList;
60 end;
61
62type
63 PReportTreeObject = ^TReportTreeObject;
64 TReportTreeObject = Record
65 ID : String; //Report ID ID:Text => when passed to broker add: ;Remote~uHState
66 Heading : String; //Report Heading
67 Qualifier : String; //Report Qualifier
68 Remote : String; //Remote Data Capable
69 RptType : String; //Report Type
70 Category : String; //Report Category
71 RPCName : String; //Associated RPC
72 IFN : String; //IFN of report in file 101.24
73 HSTAG : String; //Report extract tag;routine;component #
74 SortOrder : String; //#:# of columns to use in a multi-column sort
75 MaxDaysBack: String; //Maximum number of Days allowed for report
76 Direct : String; //Direct Remote Call flag
77 HDR : String; //HDR is data source if = 1
78 FHIE : String; //FHIE is data source if = 1
79 FHIEONLY : String; //FHIEONLY if data is to only include FHIE
80end;
81
82type
83 PProcTreeObj = ^TProcedureTreeObject;
84 TProcedureTreeObject = Record
85 ParentName : String; //Parent procedure name for exam/print sets
86 ProcedureName: String; //Same as ParentName for stand-alone procedures
87 MemberOfSet : String; //1 = descendant procedures have individual reports
88 //2 = descendant procedures have one shared report
89 ExamDtTm : String; //Exam Date Time
90 Associate : Integer; //Index of the associated TListItem in the lvReports
91end;
92
93var
94 RowObjects: TRowObject;
95 LabRowObjects: TLabRowObject;
96
97//procedures & functions for Report Tree & ListView objects
98
99function MakeReportTreeObject(x: string): PReportTreeObject;
100function IsValidNumber(S: string; var V: extended): boolean;
101function StringToFMDateTime(Str: string): TFMDateTime;
102function ShortDateStrToDate(shortdate: string): string ;
103function StripSpace(str:string):string;
104function MakeProcedureTreeObject(x: string): PProcTreeObj;
105function MakePrntProcTreeObject(x: string): PProcTreeObj;
106
107//procedures & functions for Report Fonts
108
109procedure ReportTextFontChange(Self, Sender: TObject);
110function CreateReportTextComponent(ParentForm: TForm): TRichEdit;
111
112
113implementation
114
115const
116 Months: array[1..12] of string[3] = ('JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP','OCT','NOV','DEC');
117
118constructor TCellObject.Create;
119
120begin
121 FData := TStringList.Create;
122end;
123
124destructor TCellObject.Destroy;
125begin
126 FData.Free;
127end;
128
129procedure TCellObject.Add(ASite, AHandle, AColumnData: string; AData: TStringList);
130
131begin
132 FName := piece(AColumnData,'^',1);
133 FSite := ASite;
134 FInclude := piece(AColumnData,'^',5);
135 FTextType := piece(AColumnData,'^',4);
136 FVisible := piece(AColumnData,'^',2);
137 FDataType := piece(AColumnData,'^',9);
138 FHandle := AHandle;
139 FCount := AData.Count;
140 FastAssign(AData, FData);
141end;
142
143function MakeReportTreeObject(x: string): PReportTreeObject;
144var
145 AnObject: PReportTreeObject;
146begin
147 //x=id^Name^Qualifier^HSTag;Routine^Entry^Routine^Remote^Type^Category^RPC^ifn^SortOrder^MaxDaysBack^Direct^HDR^FHIE
148 New(AnObject);
149 with AnObject^ do
150 begin
151 ID := UpperCase(Piece(x, U, 1)) + ':' + UpperCase(Piece(x, U, 2));
152 Heading := Piece(x, U, 2);
153 Qualifier := Piece(x, U, 3);
154 Remote := Piece(x, U, 7);
155 RptType := Piece(x, U, 8);
156 Category := Piece(x, U, 9);
157 RPCName := UpperCase(Piece(x, U, 10));
158 IFN := Piece(x, U, 11);
159 HSTag := UpperCase(Piece(x, U, 4));
160 SortOrder := Piece(x, U, 12);
161 MaxDaysBack := Piece(x, U, 13);
162 Direct := Piece(x, U, 14);
163 HDR := Piece(x, U, 15);
164 FHIE := Piece(x, U, 16);
165 FHIEONLY := Piece(x, U, 17);
166 end;
167 Result := AnObject;
168end;
169
170constructor TRowObject.Create;
171begin
172 FColumnList := TList.Create;
173 FCount := 0;
174end;
175
176destructor TRowObject.Destroy;
177begin
178 //Clear;
179 FColumnList.Free;
180 inherited Destroy;
181end;
182
183procedure TRowObject.Add(ASite, AHandle, AColumnData: string; AData: TStringList);
184var
185 ACell: TCellObject;
186begin
187 ACell := TCellObject.Create;
188 ACell.Add(ASite,AHandle,AColumnData,AData);
189 FColumnList.Add(ACell);
190 FCount := FColumnList.Count;
191end;
192
193procedure TRowObject.Clear;
194var
195 i: Integer;
196begin
197 with FColumnList do
198 for i := 0 to Count - 1 do
199 with TCellObject(Items[i]) do Free;
200 FColumnList.Clear;
201 FCount := 0;
202end;
203
204constructor TLabRowObject.Create;
205begin
206 FColumnList := TList.Create;
207 FCount := 0;
208end;
209
210destructor TLabRowObject.Destroy;
211begin
212 //Clear;
213 FColumnList.Free;
214 inherited Destroy;
215end;
216
217procedure TLabRowObject.Add(ASite, AHandle, AColumnData: string; AData: TStringList);
218var
219 ACell: TCellObject;
220begin
221 ACell := TCellObject.Create;
222 ACell.Add(ASite,AHandle,AColumnData,AData);
223 FColumnList.Add(ACell);
224 FCount := FColumnList.Count;
225end;
226
227procedure TLabRowObject.Clear;
228var
229 i: Integer;
230begin
231 with FColumnList do
232 for i := 0 to Count - 1 do
233 with TCellObject(Items[i]) do Free;
234 FColumnList.Clear;
235 FCount := 0;
236end;
237
238function IsValidNumber(S: string; var V: extended): boolean;
239var
240 NumCode: integer;
241 FirstSpace: integer;
242begin
243 FirstSpace := Pos(' ', S);
244 if FirstSpace > 0 then
245 S := Copy(S, 1, FirstSpace - 1);
246 Val(S, V, NumCode);
247 Result := (NumCode = 0);
248 if not Result then
249 begin
250 // Remove thousands seperators
251 S := StringReplace(S, ThousandSeparator, '', [rfReplaceAll]);
252 // change DecimalSeperator to '.' because Val only recognizes that, not
253 // the locale specific decimal char... then try again. Stupid Val.
254 S := StringReplace(S, DecimalSeparator, '.', [rfReplaceAll]);
255 Val(S, V, NumCode);
256 Result := (NumCode = 0);
257 end;
258end;
259
260function StringToFMDateTime(Str: string): TFMDateTime;
261var
262 mm,dd,yy,hh: integer;
263 day,time,hr,min: string;
264begin
265 day := piece(str,' ',1);
266 time := piece(str,' ',2);
267 hh := 0;
268 if length(time) > 0 then
269 begin
270 hr := piece(time,':',1);
271 if Copy(hr,1,1) = '0' then hr := Copy(hr,2,1);
272 if Copy(hr,1,1) = '0' then hr := '';
273 min := piece(time,':',2);
274 if Copy(min,1,1) = '0' then min := Copy(min,2,1);
275 if Copy(min,1,1) = '0' then min := '';
276 hh := StrToIntDef(hr + min,0);
277 end;
278 mm := StrToIntDef(piece(day,'/',1),0);
279 dd := StrToIntDef(piece(day,'/',2),0);
280 yy := StrToIntDef(piece(day,'/',3),0) - 1700;
281 Result := (yy * 10000) + (mm * 100) + dd + (hh/10000);
282end;
283
284function ShortDateStrToDate(shortdate: string): string ;
285{Converts date in format 'mmm dd,yy' or 'mmm dd,yyyy' to standard 'mm/dd/yy'}
286var
287 month,day,year: string ;
288 i: integer ;
289begin
290 result := 'ERROR' ;
291 if (Pos(' ',shortdate) <> 4) or ((Pos(',',shortdate) <> 7) and (Pos(',',shortdate) <> 6)) then exit ; {no spaces or comma}
292 for i := 1 to 12 do
293 if Months[i] = UpperCase(Copy(shortdate,1,3)) then month := IntToStr(i);
294 if month = '' then exit ; {invalid month name}
295 if length(month) = 1 then month := '0' + month;
296 if Pos(',',shortdate) = 7 then
297 begin
298 day := IntToStr(StrToInt(Copy(shortdate,5,2))) ;
299 year := IntToStr(StrToInt(Copy(shortdate,8,99))) ;
300 end;
301 if Pos(',',shortdate) = 6 then
302 begin
303 day := '0' + IntToStr(StrToInt(Copy(shortdate,5,1))) ;
304 year := IntToStr(StrToInt(Copy(shortdate,7,99))) ;
305 end;
306 result := month+'/'+day+'/'+year ;
307end ;
308
309function StripSpace(str: string): string;
310var
311 i,j: integer;
312begin
313 i := 1;
314 j := length(str);
315 while str[i] = #32 do inc(i);
316 while str[j] = #32 do dec(j);
317 result := copy(str, i, j-i+1);
318end;
319
320function MakeProcedureTreeObject(x: string): PProcTreeObj;
321var
322 AnObject: PProcTreeObj;
323begin
324 New(AnObject);
325 with AnObject^ do
326 begin
327 ParentName := Piece(x, U, 11);
328 ProcedureName := Piece(x, U, 4);
329 MemberOfSet := Piece(x, U, 10);
330 ExamDtTm := Piece(x, U, 2);
331 Associate := -1;
332 end;
333 Result := AnObject;
334end;
335
336function MakePrntProcTreeObject(x: string): PProcTreeObj;
337var
338 AnObject: PProcTreeObj;
339begin
340 New(AnObject);
341 with AnObject^ do
342 begin
343 ParentName := Piece(x, U, 11);
344 ExamDtTm := Piece(x, U, 2);
345 Associate := -1;
346 end;
347 Result := AnObject;
348end;
349
350procedure ReportTextFontChange(Self, Sender: TObject);
351begin
352 TFont(Sender).Size := 8;
353end;
354
355// CQ#70295
356function CreateReportTextComponent(ParentForm: TForm): TRichEdit;
357var
358 m: TMethod;
359begin
360 Result := TRichEdit.Create(ParentForm);
361 with Result do
362 begin
363 Parent := ParentForm;
364 Visible := False;
365 Width := 600;
366 Font.Name := 'Courier New';
367 Font.Size := 8;
368 m.Code := @ReportTextFontChange;
369 m.Data := ParentForm;
370 Font.OnChange := TNotifyEvent(m);
371 end;
372end;
373
374end.
Note: See TracBrowser for help on using the repository browser.