source: cprs/trunk/CPRS-Chart/Orders/fOMHTML.pas@ 457

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

Initial Upload of Official WV CPRS 1.0.26.76

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