Module

fOMHTML

Path

C:\CPRS\CPRS30\Orders\fOMHTML.pas

Last Modified

7/15/2014 3:26:42 PM

Comments

REMOVE AFTER UNIT IS DEBUGGED

Units Used in Interface

Name Comments
fOMAction -
rOrders -
uConst -

Units Used in Implementation

Name Comments
rCore -
rMisc -
uCore -
uOrders -

Classes

Name Comments
TfrmOMHTML -
TPageState -

Procedures

Name Owner Declaration Scope Comments
AddPageToCache TfrmOMHTML procedure AddPageToCache; Private -
btnBackClick TfrmOMHTML procedure btnBackClick(Sender: TObject); Public/Published -
btnCancelClick TfrmOMHTML procedure btnCancelClick(Sender: TObject); Public/Published -
btnOKClick TfrmOMHTML procedure btnOKClick(Sender: TObject); Public/Published Button events
btnShowClick TfrmOMHTML procedure btnShowClick(Sender: TObject); Public/Published -
FormClose TfrmOMHTML procedure FormClose(Sender: TObject; var Action: TCloseAction); Public/Published -
FormCreate TfrmOMHTML procedure FormCreate(Sender: TObject); Public/Published Form events (get the initial page loaded)
FormDestroy TfrmOMHTML procedure FormDestroy(Sender: TObject); Public/Published -
NameValueToOrderSet - procedure NameValueToOrderSet(Src, Dest: TStringList); Global -
NameValueToViewList - procedure NameValueToViewList(Src, Dest: TStringList); Global -
RestoreState TfrmOMHTML procedure RestoreState; Private -
SaveState TfrmOMHTML procedure SaveState; Private -
SetDialog TfrmOMHTML procedure SetDialog(Value: Integer); Private -
SetEventDelay TfrmOMHTML procedure SetEventDelay(AnEvent: TOrderDelayEvent); Public General procedures
webViewBeforeNavigate2 TfrmOMHTML procedure webViewBeforeNavigate2(Sender: TObject; const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData, Headers: OleVariant; var Cancel: WordBool); Public/Published -
webViewDocumentComplete TfrmOMHTML procedure webViewDocumentComplete(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant); Public/Published
WebBrowser events 

 This event happens after a navigation.  It is at this point that there is an instantiated
  instance of IHtmlDocument available.

Functions

Name Owner Declaration Scope Comments
CopyToCtrlChar - function CopyToCtrlChar(const Src: string; StartAt: Integer): string; Global -
GetHTMLText - function GetHTMLText(AnIEN: Integer): string; Global -
GetIENforHtml - function GetIENforHtml(const AnID: string): Integer; Global Temporary RPC's
GetPageIndex TfrmOMHTML function GetPageIndex(const URL: string): Integer; Private -
GetStateFromName - function GetStateFromName(const AName: string): string; Local -
GetURLforDialog - function GetURLforDialog(AnIEN: Integer): string; Global -
MetaElementExists TfrmOMHTML function MetaElementExists(const AName, AContent: string): Boolean; Private -

Global Variables

Name Type Declaration Comments
frmOMHTML TfrmOMHTML frmOMHTML: TfrmOMHTML; -

Constants

Name Declaration Scope Comments
TAB #9 Global -


Module Source

1     unit fOMHTML;
2     
3     {$OPTIMIZATION OFF}                              // REMOVE AFTER UNIT IS DEBUGGED
4     
5     interface
6     
7     uses
8       Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
9       fOMAction, StdCtrls, OleCtrls, SHDocVw, MSHTML, activex, rOrders, uConst,
10      ExtCtrls, VA508AccessibilityManager;
11    
12    type
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    
58    var
59      frmOMHTML: TfrmOMHTML;
60    
61    implementation
62    
63    {$R *.DFM}
64    
65    uses ORFn, rCore, uCore, uOrders, ORNet, TRPCB, rMisc;
66    
67    const
68      TAB = #9;
69    
70    type
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    
83    constructor TPageState.Create;
84    begin
85      FTagStates  := TStringList.Create;
86      FSubmitData := TStringList.Create;
87    end;
88    
89    destructor TPageState.Destroy;
90    begin
91      FTagStates.Free;
92      FSubmitData.Free;
93      inherited;
94    end;
95    
96    { temporary RPC's }
97    
98    function GetIENforHtml(const AnID: string): Integer;
99    {AnID, O.name or O.ien for 101.41, H.name or H.ien for 101.14}
100   begin
101     Result := StrToIntDef(sCallV('ORWDHTM GETIEN', [AnID]), 0);
102   end;
103   
104   function GetHTMLText(AnIEN: Integer): string;
105   {return HTML text from 101.14 given IEN}
106   begin
107     CallV('ORWDHTM HTML', [AnIEN, Patient.DFN]);
108     Result := RPCBrokerV.Results.Text;
109   end;
110   
111   function GetURLforDialog(AnIEN: Integer): string;
112   begin
113     Result := sCallV('ORWDHTM URL', [AnIEN]);
114     if Result = '' then Result := 'about:URL not found';
115   end;
116   
117   procedure NameValueToViewList(Src, Dest: TStringList);
118   { xform name<TAB>value into DlgIEN^DlgType^DisplayName list }
119   var
120     i: Integer;
121     Subs: string;
122   begin
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     FastAssign(RPCBrokerV.Results, Dest);
133   end;
134   
135   procedure NameValueToOrderSet(Src, Dest: TStringList);
136   { xform name<TAB>value into DlgIEN^DlgType^DisplayName list }
137   var
138     i, j: Integer;
139     Subs: string;
140     WPText: TStringList;
141   begin
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     FastAssign(RPCBrokerV.Results, Dest);
162   end;
163   
164   { general procedures }
165   
166   procedure TfrmOMHTML.SetEventDelay(AnEvent: TOrderDelayEvent);
167   begin
168     FDelayEvent := AnEvent;
169   end;
170   
171   function TfrmOMHTML.GetPageIndex(const URL: string): Integer;
172   var
173     i: Integer;
174   begin
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;
182   end;
183   
184   function TfrmOMHTML.MetaElementExists(const AName, AContent: string): Boolean;
185   var
186     i: Integer;
187     AnElement: IHtmlElement;
188     AllElements: IHtmlElementCollection;
189   begin
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;
201   end;
202   
203   procedure TfrmOMHTML.AddPageToCache;
204   var
205     APageState: TPageState;
206   begin
207     APageState := TPageState.Create;
208     APageState.FURL := FCurrentURL;
209     FCurrentIndex := FPageCache.Add(APageState);
210   end;
211   
212   procedure TfrmOMHTML.SaveState;
213   var
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;
223   begin
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}
290   end;
291   
292   procedure TfrmOMHTML.RestoreState;
293   var
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   
319   begin
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}
354   end;
355   
356   procedure TfrmOMHTML.SetDialog(Value: Integer);
357   begin
358     FDialog := Value;
359     try
360     webView.Navigate(GetURLforDialog(FDialog));
361     except
362     end;
363   end;
364   
365   { Form events (get the initial page loaded) }
366   
367   procedure TfrmOMHTML.FormCreate(Sender: TObject);
368   begin
369     AutoSizeDisabled := True;
370     inherited;
371     FPageCache := TList.Create;
372     FSetList := TStringList.Create;
373     FHistoryStack := TStringList.Create;
374     FHistoryIndex := -1;
375     FCurrentIndex := -1;
376   end;
377   
378   procedure TfrmOMHTML.FormClose(Sender: TObject; var Action: TCloseAction);
379   begin
380     inherited;
381     SaveUserBounds(Self);
382     if (FOwnedBy <> nil) and (FOwnedBy is TWinControl)
383         then SendMessage(TWinControl(FOwnedBy).Handle, UM_DESTROY, FRefNum, 0);
384   end;
385   
386   procedure TfrmOMHTML.FormDestroy(Sender: TObject);
387   var
388     i: Integer;
389   begin
390     for i := Pred(FPageCache.Count) downto 0 do TPageState(FPageCache[i]).Free;
391     DestroyingOrderHTML;
392     FSetList.Free;
393     FHistoryStack.Free;
394     inherited;
395   end;
396   
397   { webBrowser events }
398   
399   procedure 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. }
403   begin
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;
412   end;
413   
414   function CopyToCtrlChar(const Src: string; StartAt: Integer): string;
415   var
416     i: Integer;
417   begin
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;
422   end;
423   
424   procedure TfrmOMHTML.webViewBeforeNavigate2(Sender: TObject;  const pDisp: IDispatch;
425     var URL, Flags, TargetFrameName, PostData, Headers: OleVariant; var Cancel: WordBool);
426   begin
427     inherited;
428     SaveState;
429     // activate order dialog here, i.e., 'about:CPRSOrder=FHW1'
430   end;
431   
432   { button events }
433   
434   procedure TfrmOMHTML.btnOKClick(Sender: TObject);
435   var
436     i, j: Integer;
437     APageState: TPageState;
438   begin
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;
454   end;
455   
456   procedure TfrmOMHTML.btnCancelClick(Sender: TObject);
457   begin
458     inherited;
459     Close;
460   end;
461   
462   procedure TfrmOMHTML.btnBackClick(Sender: TObject);
463   var
464     BackURL: string;
465   begin
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       try
474       webView.Navigate(BackURL);
475       except
476       end;
477     end;
478   end;
479   
480   procedure TfrmOMHTML.btnShowClick(Sender: TObject);
481   var
482     i, j: Integer;
483     APageState: TPageState;
484     tmpList: TStringList;
485   begin
486     inherited;
487     SaveState;
488     tmpList := TStringList.Create;
489     // create an order set based on all the saved states of pages navigated to
490     for i := 0 to Pred(FPageCache.Count) do
491     begin
492       APageState := FPageCache[i];
493       for j := 0 to Pred(APageState.FSubmitData.Count) do
494       begin
495         tmpList.Add(APageState.FSubmitData[j]);
496       end;
497     end;
498     NameValueToViewList(tmpList, tmpList);
499     InfoBox(tmpList.Text, 'Current Selections', MB_OK);
500     tmpList.Free;
501   end;
502   
503   end.

Module Calls (2 levels)


fOMHTML
 ├fOMAction
 │ ├fAutoSz
 │ └uConst
 ├rOrders
 │ ├uCore
 │ ├rCore
 │ ├uConst
 │ ├UBAGlobals
 │ └UBACore
 ├uConst
 ├uCore...
 ├uOrders
 │ ├uConst
 │ ├rConsults
 │ ├rOrders...
 │ ├fODBase
 │ ├XuDsigS
 │ ├fODDiet
 │ ├fODMisc
 │ ├fODGen
 │ ├fODMedIn
 │ ├fODMedOut
 │ ├fODText
 │ ├fODConsult
 │ ├fODProc
 │ ├fODRad
 │ ├fODLab
 │ ├fODBBank
 │ ├fODMeds
 │ ├fODMedIV
 │ ├fODVitals
 │ ├fODAuto
 │ ├fOMNavA
 │ ├rCore...
 │ ├uCore...
 │ ├fFrame
 │ ├fEncnt
 │ ├fOMVerify
 │ ├fOrderSaveQuick
 │ ├fOMSet
 │ ├rMisc
 │ ├uODBase
 │ ├rODMeds
 │ ├fLkUpLocation
 │ ├fOrdersPrint
 │ ├fOMAction...
 │ ├fARTAllgy
 │ ├fOMHTML...
 │ ├fOrders
 │ ├rODBase
 │ ├fODChild
 │ ├fMeds
 │ ├rMeds
 │ ├rPCE
 │ ├fRptBox
 │ ├fODMedNVA
 │ ├fODChangeUnreleasedRenew
 │ ├rODAllergy
 │ ├UBAGlobals...
 │ └uTemplateFields
 └rMisc...

Module Called-By (2 levels)


                     fOMHTML
                   uOrders┘ 
                   uCore┤   
                 fODBase┤   
                 rODBase┤   
                  fFrame┤   
                 fOrders┤   
             fOrdersSign┤   
                   fMeds┤   
               fARTAllgy┤   
                  fNotes┤   
               fConsults┤   
         fReminderDialog┤   
                 fReview┤   
            fOrdersRenew┤   
               fOrdersCV┤   
                 fODMeds┤   
                 fOMNavA┤   
         fOrderSaveQuick┤   
                  fOMSet┤   
          fOrdersRelease┤   
              fOMHTML...┤   
               fODMedNVA┤   
fODChangeUnreleasedRenew┤   
          fOrdersOnChart┤   
         fODReleaseEvent┤   
               fODActive┘