Skip to content

Commit

Permalink
Merge branch 'HealthIntersections:master' into master
Browse files Browse the repository at this point in the history
  • Loading branch information
@costateixeira
costateixeira authored Oct 18, 2024
2 parents 46df00a + e76a81c commit fca10db
Show file tree
Hide file tree
Showing 60 changed files with 1,931 additions and 1,847 deletions.
4 changes: 4 additions & 0 deletions library/fhir/fhir_client_http.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -61,6 +61,7 @@ TFHIRHTTPCommunicator = class (TFHIRClientCommunicator)
FTerminated : boolean;
FTimeout: cardinal;
FBytesToTransfer: Int64;
FApiKey : String;

indy : TIdHTTP;
ssl : TIdOpenSSLIOHandlerClient;
Expand Down Expand Up @@ -110,6 +111,7 @@ TFHIRHTTPCommunicator = class (TFHIRClientCommunicator)
property username : String read FUsername write FUsername;
property password : String read FPassword write FPassword;
property timeout : cardinal read FTimeout write SetTimeout;
property ApiKey : String read FApiKey write FApiKey;

function address : String; override;

Expand Down Expand Up @@ -350,6 +352,8 @@ procedure TFHIRHTTPCommunicator.createClient;
raise EFHIRException.Create('Unable to process proxy "'+proxy+'" - use address:port');
end;
end;
if FApiKey <> '' then
indy.Request.CustomHeaders.add('Api-Key: '+FApiKey);
ssl := TIdOpenSSLIOHandlerClient.Create(nil);
indy.IOHandler := ssl;
ssl.Options.TLSVersionMinimum := TIdOpenSSLVersion.TLSv1_2;
Expand Down
8 changes: 8 additions & 0 deletions library/fhir/fhir_common.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1003,9 +1003,12 @@ TFHIRValueSetCodeSystemW = class (TFHIRXVersionElementWrapper)
function concepts : TFhirCodeSystemConceptListW; virtual; abstract;
end;

{ TFhirValueSetW }

TFhirValueSetW = class (TFHIRMetadataResourceW)
public
function link : TFhirValueSetW; overload;
function clone : TFhirValueSetW; overload;
function source : String; virtual; abstract;

function checkCompose(place, role : String) : boolean; virtual; abstract;
Expand Down Expand Up @@ -2266,6 +2269,11 @@ function TFhirValueSetW.link: TFhirValueSetW;
result := TFhirValueSetW(inherited link);
end;

function TFhirValueSetW.clone: TFhirValueSetW;
begin
result := TFhirValueSetW(inherited clone);
end;

{ TFhirValueSetComposeIncludeFilterW }

function TFhirValueSetComposeIncludeFilterW.link: TFhirValueSetComposeIncludeFilterW;
Expand Down
85 changes: 48 additions & 37 deletions library/fhir/fhir_tx.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -20,30 +20,31 @@ interface

{ TTerminologyOperationContext }

TTerminologyOperationContext = class (TFslObject)
TTerminologyOperationContext = class (TTxOperationContext)
private
FId : String;
FStartTime : UInt64;
FContexts : TStringList;
FLangList : THTTPLanguageList;
FI18n : TI18nSupport;
FTimeLimit : Cardinal;
FNotes : TStringList;
FOwnsNotes : boolean;
FOnGetCurrentRequestCount: TGetCurrentRequestCountEvent;
FTimeTracker: TFslTimeTracker;
procedure SetTimeTracker(AValue: TFslTimeTracker);
public
constructor Create(i18n : TI18nSupport; id : String; langList : THTTPLanguageList; timeLimit : cardinal; getRequestCount : TGetCurrentRequestCountEvent);
constructor Create(i18n : TI18nSupport; id : String; langList : THTTPLanguageList; timeLimit : cardinal; getRequestCount : TGetCurrentRequestCountEvent; tt : TFslTimeTracker);
destructor Destroy; override;

property reqId : String read FId;
property TimeTracker : TFslTimeTracker read FTimeTracker write SetTimeTracker;
function copy : TTerminologyOperationContext;
function deadCheck(var time : integer) : boolean;
procedure seeContext(vurl : String);
procedure clearContexts;

procedure log(note : String); override;
procedure addNote(vs : TFHIRValueSetW; note : String);
function notes : String;
function hasNotes : boolean;
function diagnostics : String;
property OnGetCurrentRequestCount : TGetCurrentRequestCountEvent read FOnGetCurrentRequestCount write FOnGetCurrentRequestCount;

class function renderCoded(system : TCodeSystemProvider) : String; overload;
Expand Down Expand Up @@ -223,7 +224,7 @@ TTerminologyWorker = class (TFslObject)
function findCodeSystem(url, version : String; params : TFHIRTxOperationParams; kinds : TFhirCodeSystemContentModeSet; nullOk : boolean) : TCodeSystemProvider;
function listVersions(url : String) : String;
procedure loadSupplements(cse: TFHIRCodeSystemEntry; url: String);
procedure checkSupplements(cs: TCodeSystemProvider; src: TFHIRXVersionElementWrapper);
procedure checkSupplements(opContext : TTxOperationContext; cs: TCodeSystemProvider; src: TFHIRXVersionElementWrapper);
public
constructor Create(factory : TFHIRFactory; opContext : TTerminologyOperationContext; getCS : TGetProviderEvent; getVersions : TGetSystemVersionsEvent; txResources : TFslMetadataResourceList; languages : TIETFLanguageDefinitions; i18n : TI18nSupport); overload;
destructor Destroy; override;
Expand All @@ -234,7 +235,7 @@ TTerminologyWorker = class (TFslObject)

TFHIRCodeSystemInformationProvider = class (TTerminologyWorker)
public
procedure lookupCode(coding : TFHIRCodingW; profile : TFHIRTxOperationParams; props : TArray<String>; resp : TFHIRLookupOpResponseW);
procedure lookupCode(opContext : TTxOperationContext; coding : TFHIRCodingW; profile : TFHIRTxOperationParams; props : TArray<String>; resp : TFHIRLookupOpResponseW);
end;

const
Expand All @@ -246,7 +247,13 @@ implementation

{ TTerminologyOperationContext }

constructor TTerminologyOperationContext.Create(i18n: TI18nSupport; id : String; langList : THTTPLanguageList; timeLimit : cardinal; getRequestCount : TGetCurrentRequestCountEvent);
procedure TTerminologyOperationContext.SetTimeTracker(AValue: TFslTimeTracker);
begin
FTimeTracker.free;
FTimeTracker:=AValue;
end;

constructor TTerminologyOperationContext.Create(i18n: TI18nSupport; id : String; langList : THTTPLanguageList; timeLimit : cardinal; getRequestCount : TGetCurrentRequestCountEvent; tt : TFslTimeTracker);
begin
inherited create;
FI18n := i18n;
Expand All @@ -256,28 +263,27 @@ constructor TTerminologyOperationContext.Create(i18n: TI18nSupport; id : String;
FStartTime := GetTickCount64;
FOnGetCurrentRequestCount := getRequestCount;
FTimeLimit := timeLimit;
FNotes := TStringList.create;
FOwnsNotes := true;
if (tt = nil) then
FTimeTracker := TFslTimeTracker.create
else
FTimeTracker := tt;
FTimeTracker.step('tx-op');
end;

destructor TTerminologyOperationContext.Destroy;
begin
if FOwnsNotes then
FNotes.free;
FLangList.free;
FI18n.free;
FContexts.free;
FTimeTracker.free;
inherited Destroy;
end;

function TTerminologyOperationContext.copy: TTerminologyOperationContext;
begin
result := TTerminologyOperationContext.create(FI18n.link, FId, FLangList.link, FTimeLimit, OnGetCurrentRequestCount);
result := TTerminologyOperationContext.create(FI18n.link, FId, FLangList.link, FTimeLimit, OnGetCurrentRequestCount, FTimeTracker.link);
result.FContexts.assign(FContexts);
result.FStartTime := FStartTime;
result.FNotes.free;
result.FOwnsNotes := false;
result.FNotes := FNotes;
end;

function TTerminologyOperationContext.deadCheck(var time : integer): boolean;
Expand Down Expand Up @@ -325,24 +331,29 @@ procedure TTerminologyOperationContext.clearContexts;
FContexts.clear;
end;

procedure TTerminologyOperationContext.addNote(vs : TFHIRValueSetW; note: String);
procedure TTerminologyOperationContext.log(note: String);
var
s : string;
begin
s := DescribePeriodMS(GetTickCount64 - FStartTime)+' '+vs.vurl+': '+note;
if false and UnderDebugger then
s := DescribePeriodMS(GetTickCount64 - FStartTime)+' '+note;
if UnderDebugger then
Logging.log(s);
FNotes.add(s);
FTimeTracker.step(s);
end;

function TTerminologyOperationContext.notes: String;
procedure TTerminologyOperationContext.addNote(vs : TFHIRValueSetW; note : String);
var
s : string;
begin
result := FNotes.Text;
s := DescribePeriodMS(GetTickCount64 - FStartTime)+' '+vs.vurl+': '+note;
if UnderDebugger then
Logging.log(s);
FTimeTracker.step(s);
end;

function TTerminologyOperationContext.hasNotes: boolean;
function TTerminologyOperationContext.diagnostics: String;
begin
result := FNotes.Count > 0;
result := FTimeTracker.log;
end;

class function TTerminologyOperationContext.renderCoded(system: TCodeSystemProvider): String;
Expand Down Expand Up @@ -525,7 +536,7 @@ function TTerminologyWorker.findCodeSystem(url, version: String; params: TFHIRTx

function TTerminologyWorker.costDiags(e: ETooCostly): ETooCostly;
begin
e.diagnostics := FOpContext.notes;
e.diagnostics := FOpContext.diagnostics;
result := e;
end;

Expand Down Expand Up @@ -596,22 +607,22 @@ procedure TTerminologyWorker.loadSupplements(cse : TFHIRCodeSystemEntry; url : S
end;
end;

procedure TTerminologyWorker.checkSupplements(cs : TCodeSystemProvider; src : TFHIRXVersionElementWrapper);
procedure TTerminologyWorker.checkSupplements(opContext : TTxOperationContext; cs : TCodeSystemProvider; src : TFHIRXVersionElementWrapper);
var
ext : TFHIRExtensionW;
i : integer;
begin
for ext in src.getExtensionsW(EXT_VSSUPPLEMENT).forEnum do
if not cs.hasSupplement(ext.valueAsString) then
if not cs.hasSupplement(opContext, ext.valueAsString) then
raise ETerminologyError.create('ValueSet depends on supplement '''+ext.valueAsString+''' on '+cs.systemUri+' that is not known', itBusinessRule);
for i := FRequiredSupplements.count - 1 downto 0 do
if cs.hasSupplement(FRequiredSupplements[i]) then
if cs.hasSupplement(opContext, FRequiredSupplements[i]) then
FRequiredSupplements.delete(i);
end;

{ TFHIRCodeSystemInformationProvider }

procedure TFHIRCodeSystemInformationProvider.lookupCode(coding: TFHIRCodingW; profile: TFHIRTxOperationParams; props: TArray<String>; resp: TFHIRLookupOpResponseW);
procedure TFHIRCodeSystemInformationProvider.lookupCode(opContext : TTxOperationContext; coding: TFHIRCodingW; profile: TFHIRTxOperationParams; props: TArray<String>; resp: TFHIRLookupOpResponseW);
var
provider : TCodeSystemProvider;
ctxt : TCodeSystemProviderContext;
Expand All @@ -637,29 +648,29 @@ procedure TFHIRCodeSystemInformationProvider.lookupCode(coding: TFHIRCodingW; pr
s := provider.version;
if (s <> '') then
resp.version := s;
ctxt := provider.locate(coding.code);
ctxt := provider.locate(opContext, coding.code);
try
if ctxt = nil then
raise ETerminologyError.Create('Unable to find code '+coding.code+' in '+coding.systemUri+' version '+s, itInvalid);

if (hasProp('abstract', true) and provider.IsAbstract(ctxt)) then
if (hasProp('abstract', true) and provider.IsAbstract(opContext, ctxt)) then
begin
p := resp.addProp('abstract');
p.value := FFactory.makeBoolean(true);
end;
if (hasProp('inactive', true)) then
begin
p := resp.addProp('inactive');
p.value := FFactory.makeBoolean(provider.IsInactive(ctxt));
p.value := FFactory.makeBoolean(provider.IsInactive(opContext, ctxt));
end;
if hasProp('definition', true) and (provider.Definition(ctxt) <> '') then
if hasProp('definition', true) and (provider.Definition(opContext, ctxt) <> '') then
begin
p := resp.addProp('definition');
p.value := FFactory.makeString(provider.Definition(ctxt));
p.value := FFactory.makeString(provider.Definition(opContext, ctxt));
end;
resp.code := coding.code;
resp.display := provider.Display(ctxt, FlangList);
provider.extendLookup(FFactory, ctxt, FlangList, props, resp);
resp.display := provider.Display(opContext, ctxt, FlangList);
provider.extendLookup(opContext, FFactory, ctxt, FlangList, props, resp);
finally
ctxt.free;
end;
Expand Down
61 changes: 61 additions & 0 deletions library/fsl/fsl_logging.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -190,6 +190,24 @@ TLogging = class (TFslObject)
var
Logging : TLogging;

type

{ TFslTimeTracker }

TFslTimeTracker = class (TFslObject)
private
FStart : int64;
FLast : Int64;
FLog : TFslStringBuilder;
public
constructor Create; override;
destructor Destroy; override;
function link : TFslTimeTracker; overload;

procedure step(name : String);
function total : integer;
function log : String;
end;

implementation

Expand Down Expand Up @@ -827,6 +845,49 @@ function TLogging.sizeInBytesV(magic : integer) : cardinal;
inc(result, (FWorkingLine.length * sizeof(char)) + 12);
end;


{ TFslTimeTracker }

constructor TFslTimeTracker.Create;
begin
inherited;
FStart := GetTickCount64;
FLast := FStart;
FLog := TFslStringBuilder.create;
Flog.append('0 0 : start'#13#10);
end;

destructor TFslTimeTracker.Destroy;
begin
FLog.free;
inherited;
end;

function TFslTimeTracker.link: TFslTimeTracker;
begin
result := TFslTimeTracker(inherited Link);
end;

function TFslTimeTracker.log : String;
begin
result := Flog.AsString;
end;

procedure TFslTimeTracker.step(name: String);
var
t : int64;
begin
t := GetTickCount64;
Flog.append(inttostr(t-FStart)+' '+inttostr(t - FLast)+': '+name+#13#10);
FLast := t;
end;

function TFslTimeTracker.total: integer;
begin
result := GetTickCount64 - FStart;
end;


Initialization
Logging := TLogging.Create;
Finalization
Expand Down
Loading

0 comments on commit fca10db

Please sign in to comment.