source: cprs/branches/tmg-cprs/CPRS-Chart/Orders/fOMHTML.pas@ 1117

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

Initial upload of TMG-CPRS 1.0.26.69

File size: 14.5 KB
Line 
1//kt -- Modified with SourceScanner on 8/8/2007
2unit fOMHTML;
3
4{$OPTIMIZATION OFF} // REMOVE AFTER UNIT IS DEBUGGED
5
6interface
7
8uses
9 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
10 fOMAction, StdCtrls, OleCtrls, SHDocVw, MSHTML, activex, rOrders, uConst,
11 ExtCtrls, DKLang;
12
13type
14 TfrmOMHTML = class(TfrmOMAction)
15 btnOK: TButton;
16 btnCancel: TButton;
17 btnBack: TButton;
18 pnlWeb: TPanel;
19 webView: TWebBrowser;
20 btnShow: TButton;
21 procedure btnOKClick(Sender: TObject);
22 procedure btnCancelClick(Sender: TObject);
23 procedure FormCreate(Sender: TObject);
24 procedure webViewDocumentComplete(Sender: TObject;
25 const pDisp: IDispatch; var URL: OleVariant);
26 procedure webViewBeforeNavigate2(Sender: TObject;
27 const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
28 Headers: OleVariant; var Cancel: WordBool);
29 procedure FormDestroy(Sender: TObject);
30 procedure FormClose(Sender: TObject; var Action: TCloseAction);
31 procedure btnBackClick(Sender: TObject);
32 procedure btnShowClick(Sender: TObject);
33 private
34 FOwnedBy: TComponent;
35 FRefNum: Integer;
36 FDialog: Integer;
37 FSetList: TStringList;
38 FPageCache: TList;
39 FCurrentIndex: Integer;
40 FCurrentURL: string;
41 FCurrentDoc: IHtmlDocument2;
42 FDelayEvent: TOrderDelayEvent;
43 FHistoryStack: TStringList;
44 FHistoryIndex: Integer;
45 function GetPageIndex(const URL: string): Integer;
46 function MetaElementExists(const AName, AContent: string): Boolean;
47 procedure AddPageToCache;
48 procedure SaveState;
49 procedure RestoreState;
50 procedure SetDialog(Value: Integer);
51 public
52 procedure SetEventDelay(AnEvent: TOrderDelayEvent);
53 property Dialog: Integer read FDialog write SetDialog;
54 property OwnedBy: TComponent read FOwnedBy write FOwnedBy;
55 property RefNum: Integer read FRefNum write FRefNum;
56 property SetList: TStringList read FSetList write FSetList;
57 end;
58
59var
60 frmOMHTML: TfrmOMHTML;
61
62implementation
63
64{$R *.DFM}
65
66uses ORFn, rCore, uCore, uOrders, ORNet, TRPCB, rMisc;
67
68const
69 TAB = #9;
70
71type
72 TPageState = class
73 private
74 FURL: string;
75 FTagStates: TStringList;
76 FSubmitData: TStringList;
77 public
78 constructor Create;
79 destructor Destroy; override;
80 end;
81
82{ TPageState }
83
84constructor TPageState.Create;
85begin
86 FTagStates := TStringList.Create;
87 FSubmitData := TStringList.Create;
88end;
89
90destructor TPageState.Destroy;
91begin
92 FTagStates.Free;
93 FSubmitData.Free;
94 inherited;
95end;
96
97{ temporary RPC's }
98
99
100function GetIENforHtml(const AnID: string): Integer;
101{AnID, O.name or O.ien for 101.41, H.name or H.ien for 101.14}
102begin
103 Result := StrToIntDef(sCallV('ORWDHTM GETIEN', [AnID]), 0);
104end;
105
106function GetHTMLText(AnIEN: Integer): string;
107{return HTML text from 101.14 given IEN}
108begin
109 CallV('ORWDHTM HTML', [AnIEN, Patient.DFN]);
110 Result := RPCBrokerV.Results.Text;
111end;
112
113function GetURLforDialog(AnIEN: Integer): string;
114begin
115 Result := sCallV('ORWDHTM URL', [AnIEN]);
116//if Result = '' then Result := 'about:URL not found'; <-- original line. //kt 8/8/2007
117 if Result = '' then Result := DKLangConstW('fOMHTML_aboutxURL_not_found'); //kt added 8/8/2007
118end;
119
120procedure NameValueToViewList(Src, Dest: TStringList);
121{ xform name<TAB>value into DlgIEN^DlgType^DisplayName list }
122var
123 i: Integer;
124 Subs: string;
125begin
126 RPCBrokerV.ClearParameters := True;
127 RPCBrokerV.RemoteProcedure := 'ORWDHTM NV2DNM';
128 RPCBrokerV.Param[0].PType := list;
129 for i := 0 to Pred(Src.Count) do
130 begin
131 Subs := IntToStr(Succ(i));
132 RPCBrokerV.Param[0].Mult[Subs] := Copy(Src[i], 1, 245);
133 end; {for i}
134 CallBroker;
135 Dest.Assign(RPCBrokerV.Results);
136end;
137
138procedure NameValueToOrderSet(Src, Dest: TStringList);
139{ xform name<TAB>value into DlgIEN^DlgType^DisplayName list }
140var
141 i, j: Integer;
142 Subs: string;
143 WPText: TStringList;
144begin
145 RPCBrokerV.ClearParameters := True;
146 RPCBrokerV.RemoteProcedure := 'ORWDHTM NV2SET';
147 RPCBrokerV.Param[0].PType := list;
148 WPText := TStringList.Create;
149 for i := 0 to Pred(Src.Count) do
150 begin
151 WPText.Clear;
152 WPText.Text := Copy(Src[i], Pos(TAB, Src[i]) + 1, Length(Src[i]));
153 Subs := IntToStr(Succ(i));
154 if WPText.Count = 1 then RPCBrokerV.Param[0].Mult[Subs] := Src[i] else
155 begin
156 RPCBrokerV.Param[0].Mult['"WP",' + Subs] :=
157 Piece(Src[i], TAB, 1) + TAB + 'NMVAL("WP",' + Subs + ')';
158 for j := 0 to Pred(WPText.Count) do
159 RPCBrokerV.Param[0].Mult['"WP",' + Subs + ',' + IntToStr(Succ(j)) + ',0'] := WPText[j];
160 end; {if WPText}
161 end; {for i}
162 CallBroker;
163 WPText.Free;
164 Dest.Assign(RPCBrokerV.Results);
165end;
166
167{ general procedures }
168
169procedure TfrmOMHTML.SetEventDelay(AnEvent: TOrderDelayEvent);
170begin
171 FDelayEvent := AnEvent;
172end;
173
174function TfrmOMHTML.GetPageIndex(const URL: string): Integer;
175var
176 i: Integer;
177begin
178 Result := -1;
179 for i := 0 to Pred(FPageCache.Count) do
180 if TPageState(FPageCache[i]).FURL = URL then
181 begin
182 Result := i;
183 break;
184 end;
185end;
186
187function TfrmOMHTML.MetaElementExists(const AName, AContent: string): Boolean;
188var
189 i: Integer;
190 AnElement: IHtmlElement;
191 AllElements: IHtmlElementCollection;
192begin
193 Result := False;
194 AllElements := FCurrentDoc.All;
195 for i := 0 to Pred(AllElements.Length) do
196 begin
197 AnElement := AllElements.Item(i, 0) as IHtmlElement;
198 if AnElement.tagName = 'META' then
199 with AnElement as IHtmlMetaElement do
200 if (CompareText(name, AName) = 0) and (CompareText(content, AContent) = 0)
201 then Result := True;
202 if Result then Break;
203 end;
204end;
205
206procedure TfrmOMHTML.AddPageToCache;
207var
208 APageState: TPageState;
209begin
210 APageState := TPageState.Create;
211 APageState.FURL := FCurrentURL;
212 FCurrentIndex := FPageCache.Add(APageState);
213end;
214
215procedure TfrmOMHTML.SaveState;
216var
217 i: Integer;
218 SelectName, State, NmVal, x: string;
219 APageState: TPageState;
220 AnElement: IHtmlElement;
221 AnInput: IHtmlInputElement;
222 ASelect: IHtmlSelectElement;
223 AnOption: IHtmlOptionElement;
224 ATextArea: IHtmlTextAreaElement;
225 AllElements: IHtmlElementCollection;
226begin
227 if FCurrentIndex < 0 then Exit;
228 Assert(Assigned(FCurrentDoc));
229 APageState := FPageCache[FCurrentIndex];
230 APageState.FTagStates.Clear;
231 APageState.FSubmitData.Clear;
232 if not MetaElementExists('VistAuse', 'ORWDSET') then Exit;
233
234 AllElements := FCurrentDoc.All;
235 for i := 0 to Pred(AllElements.Length) do
236 begin
237 AnElement := AllElements.Item(i, 0) as IHtmlElement;
238 NmVal := '';
239 State := '';
240 if AnElement.tagName = 'INPUT' then
241 begin
242 AnInput := AnElement as IHtmlInputElement;
243 if AnInput.type_ = 'checkbox' then
244 begin
245 if AnInput.checked then
246 begin
247 State := AnInput.name + TAB + '1';
248 NmVal := AnInput.name + TAB + '1';
249 end
250 else State := AnInput.name + TAB + '0';
251 end; {checkbox}
252 if AnInput.type_ = 'radio' then
253 begin
254 if AnInput.checked then
255 begin
256 State := AnInput.name + AnInput.Value + TAB + '1';
257 NmVal := AnInput.value + TAB + '1';
258 end
259 else State := AnInput.name + AnInput.Value + TAB + '0';
260 end; {radio}
261 if (AnInput.type_ = 'hidden') or (AnInput.type_ = 'password') or (AnInput.type_ = 'text') then
262 begin
263 State := AnInput.name + TAB + AnInput.value;
264 NmVal := State;
265 end; {hidden, password, text}
266 end; {INPUT}
267 if AnElement.tagname = 'SELECT' then
268 begin
269 ASelect := AnElement as IHtmlSelectElement;
270 SelectName := ASelect.name;
271 end; {SELECT}
272 if AnElement.tagName = 'OPTION' then
273 begin
274 AnOption := AnElement as IHtmlOptionElement;
275 x := AnOption.value;
276 if x = '' then x := AnOption.text;
277 if AnOption.Selected then
278 begin
279 State := SelectName + x + TAB + '1';
280 NmVal := SelectName + TAB + x;
281 end
282 else State := SelectName + x + TAB + '0';
283 end; {OPTION}
284 if AnElement.tagName = 'TEXTAREA' then
285 begin
286 ATextArea := AnElement as IHtmlTextAreaElement;
287 State := ATextArea.name + TAB + ATextArea.value;
288 NmVal := State;
289 end; {TEXTAREA}
290 if Length(State) > 0 then APageState.FTagStates.Add(State);
291 if Length(NmVal) > 0 then APageState.FSubmitData.Add(NmVal);
292 end; {for i}
293end;
294
295procedure TfrmOMHTML.RestoreState;
296var
297 i: Integer;
298 SelectName, x: string;
299 APageState: TPageState;
300 AnElement: IHtmlElement;
301 AnInput: IHtmlInputElement;
302 ASelect: IHtmlSelectElement;
303 AnOption: IHtmlOptionElement;
304 ATextArea: IHtmlTextAreaElement;
305 AllElements: IHtmlElementCollection;
306
307 function GetStateFromName(const AName: string): string;
308 var
309 i: Integer;
310 begin
311 Result := '';
312 for i := 0 to Pred(APageState.FTagStates.Count) do
313 begin
314 if Piece(APageState.FTagStates[i], TAB, 1) = AName then
315 begin
316 Result := Piece(APageState.FTagStates[i], TAB, 2);
317 Break;
318 end; {if Piece}
319 end; {for i}
320 end; {GetStateFromName}
321
322begin
323 APageState := TPageState(FPageCache.Items[FCurrentIndex]);
324 if APageState.FTagStates.Count = 0 then Exit;
325 AllElements := FCurrentDoc.All;
326 for i := 0 to Pred(AllElements.Length) do
327 begin
328 AnElement := AllElements.Item(i, 0) as IHtmlElement;
329 if AnElement.tagName = 'INPUT' then
330 begin
331 AnInput := AnElement as IHtmlInputElement;
332 if AnInput.type_ = 'checkbox'
333 then AnInput.Set_checked(GetStateFromName(AnInput.name) = '1');
334 if AnInput.Type_ = 'radio'
335 then AnInput.Set_checked(GetStateFromName(AnInput.name + AnInput.Value) = '1');
336 if (AnInput.type_ = 'hidden') or (AnInput.type_ = 'password') or (AnInput.type_ = 'text')
337 then AnInput.Set_value(GetStateFromName(AnInput.name));
338 end; {INPUT}
339 if AnElement.tagname = 'SELECT' then
340 begin
341 ASelect := AnElement as IHtmlSelectElement;
342 SelectName := ASelect.name;
343 end; {SELECT}
344 if AnElement.tagName = 'OPTION' then
345 begin
346 AnOption := AnElement as IHtmlOptionElement;
347 x := AnOption.value;
348 if x = '' then x := AnOption.text;
349 AnOption.Set_selected(GetStateFromName(SelectName + x) = '1');
350 end; {OPTION}
351 if AnElement.tagName = 'TEXTAREA' then
352 begin
353 ATextArea := AnElement as IHtmlTextAreaElement;
354 ATextArea.Set_value(GetStateFromName(ATextArea.name));
355 end; {TEXTAREA}
356 end; {for i}
357end;
358
359procedure TfrmOMHTML.SetDialog(Value: Integer);
360begin
361 FDialog := Value;
362 webView.Navigate(GetURLForDialog(FDialog));
363end;
364
365{ Form events (get the initial page loaded) }
366
367procedure TfrmOMHTML.FormCreate(Sender: TObject);
368begin
369 AutoSizeDisabled := True;
370 inherited;
371 FPageCache := TList.Create;
372 FSetList := TStringList.Create;
373 FHistoryStack := TStringList.Create;
374 FHistoryIndex := -1;
375 FCurrentIndex := -1;
376end;
377
378procedure TfrmOMHTML.FormClose(Sender: TObject; var Action: TCloseAction);
379begin
380 inherited;
381 SaveUserBounds(Self);
382 if (FOwnedBy <> nil) and (FOwnedBy is TWinControl)
383 then SendMessage(TWinControl(FOwnedBy).Handle, UM_DESTROY, FRefNum, 0);
384end;
385
386procedure TfrmOMHTML.FormDestroy(Sender: TObject);
387var
388 i: Integer;
389begin
390 for i := Pred(FPageCache.Count) downto 0 do TPageState(FPageCache[i]).Free;
391 DestroyingOrderHTML;
392 FSetList.Free;
393 FHistoryStack.Free;
394 inherited;
395end;
396
397{ webBrowser events }
398
399procedure TfrmOMHTML.webViewDocumentComplete(Sender: TObject; const pDisp: IDispatch;
400 var URL: OleVariant);
401{ This event happens after a navigation. It is at this point that there is an instantiated
402 instance of IHtmlDocument available. }
403begin
404 inherited;
405 if not Assigned(webView.Document) then Exit;
406 FCurrentDoc := webView.Document as IHtmlDocument2;
407 FCurrentURL := URL;
408 FHistoryStack.Add(FCurrentURL);
409 btnBack.Enabled := FHistoryStack.Count > 1;
410 FCurrentIndex := GetPageIndex(FCurrentURL);
411 if FCurrentIndex >= 0 then RestoreState else AddPageToCache;
412end;
413
414function CopyToCtrlChar(const Src: string; StartAt: Integer): string;
415var
416 i: Integer;
417begin
418 Result := '';
419 if StartAt < 1 then StartAt := 1;
420 for i := StartAt to Length(Src) do
421 if Ord(Src[i]) > 31 then Result := Result + Src[i] else break;
422end;
423
424procedure TfrmOMHTML.webViewBeforeNavigate2(Sender: TObject; const pDisp: IDispatch;
425 var URL, Flags, TargetFrameName, PostData, Headers: OleVariant; var Cancel: WordBool);
426begin
427 inherited;
428 SaveState;
429 // activate order dialog here, i.e., 'about:CPRSOrder=FHW1'
430end;
431
432{ button events }
433
434procedure TfrmOMHTML.btnOKClick(Sender: TObject);
435var
436 i, j: Integer;
437 APageState: TPageState;
438begin
439 inherited;
440 SaveState;
441 // create an order set based on all the saved states of pages navigated to
442 for i := 0 to Pred(FPageCache.Count) do
443 begin
444 APageState := FPageCache[i];
445 for j := 0 to Pred(APageState.FSubmitData.Count) do
446 begin
447 FSetList.Add(APageState.FSubmitData[j]);
448 end;
449 end;
450 NameValueToOrderSet(FSetList, FSetList);
451 // put in reference number, key variables, & caption later as necessary
452 //ActivateOrderList(NameValuePairs, FDelayEvent, Self, 0, '', '');
453 Close;
454end;
455
456procedure TfrmOMHTML.btnCancelClick(Sender: TObject);
457begin
458 inherited;
459 Close;
460end;
461
462procedure TfrmOMHTML.btnBackClick(Sender: TObject);
463var
464 BackURL: string;
465begin
466 inherited;
467 if FHistoryStack.Count > 1 then
468 begin
469 FHistoryStack.Delete(Pred(FHistoryStack.Count));
470 BackURL := FHistoryStack[Pred(FHistoryStack.Count)];
471 FHistoryStack.Delete(Pred(FHistoryStack.Count));
472 if FHistoryStack.Count < 2 then btnBack.Enabled := False;
473 webView.Navigate(BackURL);
474 end;
475end;
476
477procedure TfrmOMHTML.btnShowClick(Sender: TObject);
478var
479 i, j: Integer;
480 APageState: TPageState;
481 tmpList: TStringList;
482begin
483 inherited;
484 SaveState;
485 tmpList := TStringList.Create;
486 // create an order set based on all the saved states of pages navigated to
487 for i := 0 to Pred(FPageCache.Count) do
488 begin
489 APageState := FPageCache[i];
490 for j := 0 to Pred(APageState.FSubmitData.Count) do
491 begin
492 tmpList.Add(APageState.FSubmitData[j]);
493 end;
494 end;
495 NameValueToViewList(tmpList, tmpList);
496//InfoBox(tmpList.Text, 'Current Selections', MB_OK); <-- original line. //kt 8/8/2007
497 InfoBox(tmpList.Text, DKLangConstW('fOMHTML_Current_Selections'), MB_OK); //kt added 8/8/2007
498 tmpList.Free;
499end;
500
501end.
Note: See TracBrowser for help on using the repository browser.