Procedure

TfrmFrame.ToolClick

Module

fFrame

Last Modified

3/11/2015 8:41:44 AM

Comments

Executes the program associated with an item on the Tools menu, the command line is stored
  in the item's hint property

Visibility

Public/Published

Owner

TfrmFrame

Declaration

procedure ToolClick(Sender: TObject);

Calls Hierarchy


TfrmFrame.ToolClick
 ├TakeOutAmps
 ├TfrmFrame.UpdateECSParameter
 │ ├GetVisitID
 │ │ └TEncounter.GetVisitStr
 │ │   └TEncounter.GetVisitCategory
 │ └GetDivisionID
 ├TfrmFrame.ExpandCommand
 │ ├Substitute
 │ └MScalar
 ├ExcuteECS
 │ └SaveUserPath
 └ExcuteEC

Called-By Hierarchy


     TfrmFrame.ToolClick
TfrmFrame.SetUserTools┘ 
TfrmFrame.FormCreate┘   

Calls

Name Declaration Comments
ExcuteEC function ExcuteEC(AFile,APara: string): boolean; -
ExcuteECS function ExcuteECS(AFile, APara: string; var currPath: string): boolean; -
TfrmFrame.ExpandCommand function ExpandCommand(x: string): string; -
TakeOutAmps function TakeOutAmps(AString: string): string; -
TfrmFrame.UpdateECSParameter procedure UpdateECSParameter(var CmdParameter: string); -

Called-By

Name Declaration Comments
TfrmFrame.SetUserTools procedure SetUserTools; -


Source

2033  procedure TfrmFrame.ToolClick(Sender: TObject);
2034  { executes the program associated with an item on the Tools menu, the command line is stored
2035    in the item's hint property }
2036  const
2037    TXT_ECS_NOTFOUND = 'The ECS application is not found at the default directory,' + #13 + 'would you like manually search it?';
2038    TC_ECS_NOTFOUND = 'Application Not Found';
2039  var
2040    x, AFile, Param, MenuCommand, ECSAppend, CapNm, curPath : string;
2041    IsECSInterface: boolean;
2042  
2043    function TakeOutAmps(AString: string): string;
2044    var
2045      S1,S2: string;
2046    begin
2047      if Pos('&',AString)=0 then
2048      begin
2049        Result := AString;
2050        Exit;
2051      end;
2052      S1 := Piece(AString,'&',1);
2053      S2 := Piece(AString,'&',2);
2054      Result := S1 + S2;
2055    end;
2056  
2057    function ExcuteEC(AFile,APara: string): boolean;
2058    begin
2059      if (ShellExecute(Handle, 'open', PChar(AFile), PChar(Param), '', SW_NORMAL) > 32 ) then Result := True
2060      else
2061      begin
2062        if InfoBox(TXT_ECS_NOTFOUND, TC_ECS_NOTFOUND, MB_YESNO or MB_ICONERROR) = IDYES then
2063        begin
2064          if OROpenDlg.Execute then
2065          begin
2066             AFile := OROpenDlg.FileName;
2067             if Pos('ecs gui.exe',lowerCase(AFile))<1 then
2068             begin
2069               ShowMsg('This is not a valid ECS application.');
2070               Result := True;
2071             end else
2072             begin
2073               if (ShellExecute(Handle, 'open', PChar(AFile), PChar(Param), '', SW_NORMAL)<32) then Result := False
2074               else Result := True;
2075             end;
2076          end
2077          else Result := True;
2078        end else Result := True;
2079      end;
2080    end;
2081  
2082    function ExcuteECS(AFile, APara: string; var currPath: string): boolean;
2083    var
2084      commandline,RPCHandle: string;
2085      StartupInfo: TStartupInfo;
2086      ProcessInfo: TProcessInformation;
2087    begin
2088      FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
2089      with StartupInfo do
2090      begin
2091        cb := SizeOf(TStartupInfo);
2092        dwFlags := STARTF_USESHOWWINDOW;
2093        wShowWindow := SW_SHOWNORMAL;
2094      end;
2095      commandline := AFile + Param;
2096      RPCHandle := GetAppHandle(RPCBrokerV);
2097      commandline := commandline + ' H=' + RPCHandle;
2098      if CreateProcess(nil, PChar(commandline), nil, nil, False,
2099        NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo) then Result := True
2100      else
2101      begin
2102        if InfoBox(TXT_ECS_NOTFOUND, TC_ECS_NOTFOUND, MB_YESNO or MB_ICONERROR) = IDYES then
2103        begin
2104          if OROpenDlg.Execute then
2105          begin
2106             AFile := OROpenDlg.FileName;
2107             if Pos('ecs gui.exe',lowerCase(AFile))<1 then
2108             begin
2109               ShowMsg('This is not a valid ECS application.');
2110               Result := True;
2111             end else
2112             begin
2113               SaveUserPath('Event Capture Interface='+AFile, currPath);
2114               FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
2115               with StartupInfo do
2116               begin
2117                 cb := SizeOf(TStartupInfo);
2118                 dwFlags := STARTF_USESHOWWINDOW;
2119                 wShowWindow := SW_SHOWNORMAL;
2120               end;
2121               commandline := AFile + Param;
2122               RPCHandle := GetAppHandle(RPCBrokerV);
2123               commandline := commandline + ' H=' + RPCHandle;
2124               if not CreateProcess(nil, PChar(commandline), nil, nil, False,
2125                  NORMAL_PRIORITY_CLASS, nil, nil,StartupInfo,ProcessInfo) then Result := False
2126               else Result := True;
2127             end;
2128          end
2129          else Result := True;
2130        end else Result := True;
2131      end;
2132    end;
2133  
2134  begin
2135    MenuCommand := '';
2136    ECSAppend   := '';
2137    IsECSInterface := False;
2138    curPath := '';
2139    CapNm := LowerCase(TMenuItem(Sender).Caption);
2140    CapNm := TakeOutAmps(CapNm);
2141    if AnsiCompareText('event capture interface',CapNm)=0 then
2142    begin
2143      IsECSInterface := True;
2144      if FECSAuthUser then UpdateECSParameter(ECSAppend)
2145      else begin
2146        ShowMsg('You don''t have permission to use ECS.');
2147        exit;
2148      end;
2149    end;
2150    MenuCommand := TMenuItem(Sender).Hint + ECSAppend;
2151    x := ExpandCommand(MenuCommand);
2152    if CharAt(x, 1) = '"' then
2153    begin
2154      x     := Copy(x, 2, Length(x));
2155      AFile := Copy(x, 1, Pos('"',x)-1);
2156      Param := Copy(x, Pos('"',x)+1, Length(x));
2157    end else
2158    begin
2159      AFile := Piece(x, ' ', 1);
2160      Param := Copy(x, Length(AFile)+1, Length(x));
2161    end;
2162    if IsECSInterface then
2163    begin
2164      if not ExcuteECS(AFile,Param,curPath) then
2165        ExcuteECS(AFile,Param,curPath);
2166      if Length(curPath)>0 then
2167        TMenuItem(Sender).Hint := curPath;
2168    end
2169    else if (Pos('ecs',LowerCase(AFile))>0) and (not IsECSInterface) then
2170    begin
2171      if not ExcuteEC(AFile,Param) then
2172        ExcuteEC(AFile,Param);
2173    end else
2174    begin
2175      ShellExecute(Handle, 'open', PChar(AFile), PChar(Param), '', SW_NORMAL);
2176    end;
2177  end;