Skip to content

Commit

Permalink
extend tx ecosystem to handle value sets, and fix up value set search…
Browse files Browse the repository at this point in the history 
… on tx.fhir.org
  • Loading branch information
Grahame Grieve committed Jan 12, 2024
1 parent 078e48e commit 21b1109
Show file tree
Hide file tree
Showing 5 changed files with 313 additions and 66 deletions.
85 changes: 72 additions & 13 deletions server/endpoint_txregistry.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -84,7 +84,8 @@ TFHIRTxRegistryWebServer = class (TFhirWebServerEndpoint)
function renderJson(json : TJsonObject; path, reg, srvr, ver : String) : String;
procedure sendHtml(request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; secure : boolean; json : TJsonObject; reg, srvr, ver, tx : String);
function listRows(reg, srvr, ver, tx : String) : TJsonObject;
function resolve(version, tx, usage : String; var matches : String) : TJsonObject;
function resolveCS(version, cs, usage : String; var matches : String) : TJsonObject;
function resolveVS(version, vs, usage : String; var matches : String) : TJsonObject;
function renderInfo : String;

function doRequest(AContext: TIdContext; request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; id: String; secure: boolean): String;
Expand Down Expand Up @@ -522,7 +523,7 @@ procedure TFHIRTxRegistryWebServer.populate(json : TJsonObject; srvr : TServerIn
if (ssCert in ver.Security) then json.bool[CODES_TServerSecurity[ssCert]] := true;
end;

function TFHIRTxRegistryWebServer.resolve(version, tx, usage: String; var matches : String): TJsonObject;
function TFHIRTxRegistryWebServer.resolveCS(version, cs, usage: String; var matches : String): TJsonObject;
var
reg : TServerRegistry;
srvr : TServerInformation;
Expand All @@ -531,7 +532,7 @@ function TFHIRTxRegistryWebServer.resolve(version, tx, usage: String; var matche
begin
if (version = '') then
raise EFslException.Create('A version is required');
if (tx = '') then
if (cs = '') then
raise EFslException.Create('A code system url is required');

matches := '';
Expand All @@ -545,12 +546,12 @@ function TFHIRTxRegistryWebServer.resolve(version, tx, usage: String; var matche
added := false;
if (srvr.UsageList.Count = 0) or (srvr.UsageList.IndexOf(usage) > -1) then
begin
if (srvr.isAuth(tx)) then
if (srvr.isAuthCS(cs)) then
begin
for ver in srvr.Versions do
begin
if TSemanticVersion.matches(version, ver.version, semverAuto) then
if TServerRegistryUtilities.hasMatchingCodeSystem(tx, ver.Terminologies, false) then
if TServerRegistryUtilities.hasMatchingCodeSystem(cs, ver.CodeSystems, false) then
begin
populate(result.forceArr['authoritative'].addObject, srvr, ver);
added := true;
Expand All @@ -561,7 +562,65 @@ function TFHIRTxRegistryWebServer.resolve(version, tx, usage: String; var matche
begin
for ver in srvr.Versions do
if TSemanticVersion.matches(version, ver.version, semverAuto) then
if TServerRegistryUtilities.hasMatchingCodeSystem(tx, ver.Terminologies, false) then
if TServerRegistryUtilities.hasMatchingCodeSystem(cs, ver.CodeSystems, false) then
begin
populate(result.forceArr['candidates'].addObject, srvr, ver);
added := true;
end;
end;
if (added) then
CommaAdd(matches, srvr.Code);
end;
end;
result.link;
finally
result.free;
end;
if matches = '' then
matches := '--';
end;

function TFHIRTxRegistryWebServer.resolveVS(version, vs, usage: String;
var matches: String): TJsonObject;
var
reg : TServerRegistry;
srvr : TServerInformation;
ver : TServerVersionInformation;
added : boolean;
begin
if (version = '') then
raise EFslException.Create('A version is required');
if (vs = '') then
raise EFslException.Create('A ValueSet url is required');

matches := '';
result := TJsonObject.Create;
try
result.str['formatVersion'] := '1';
result.str['registry-url'] := FInfo.address;
for reg in FInfo.Registries do
for srvr in reg.Servers do
begin
added := false;
if (srvr.UsageList.Count = 0) or (srvr.UsageList.IndexOf(usage) > -1) then
begin
if (srvr.isAuthVS(vs)) then
begin
for ver in srvr.Versions do
begin
if TSemanticVersion.matches(version, ver.version, semverAuto) then
if TServerRegistryUtilities.hasMatchingValueSet(vs, ver.ValueSets, false) then
begin
populate(result.forceArr['authoritative'].addObject, srvr, ver);
added := true;
end;
end;
end
else
begin
for ver in srvr.Versions do
if TSemanticVersion.matches(version, ver.version, semverAuto) then
if TServerRegistryUtilities.hasMatchingValueSet(vs, ver.ValueSets, false) then
begin
populate(result.forceArr['candidates'].addObject, srvr, ver);
added := true;
Expand Down Expand Up @@ -593,17 +652,17 @@ function TFHIRTxRegistryWebServer.renderInfo: String;
for r in FInfo.Registries do
begin
if (r.error <> '') then
b.append('<tr><td title='+FormatTextToHTML(r.Name)+'">&nbsp;<img src="/assets/images/tx-registry.png">&nbsp;'+r.Code+'</td><td>'+FormatTextToHTML(r.Address)+'. Error: '+FormatTextToHTML(r.Error)+'</td></tr>')
b.append('<tr><td title='+FormatTextToHTML(r.Name)+'">&nbsp;<img src="/assets/images/tx-registry.png">&nbsp;'+r.Code+'</td><td><a href="'+FormatTextToHTML(r.Address)+'">'+FormatTextToHTML(r.Address)+'</a>. Error: '+FormatTextToHTML(r.Error)+'</td></tr>')
else
b.append('<tr><td title='+FormatTextToHTML(r.Name)+'">&nbsp;&nbsp;<img src="/assets/images/tx-registry.png">&nbsp;'+r.Code+'</td><td>'+FormatTextToHTML(r.Address)+'</td></tr>');
b.append('<tr><td title='+FormatTextToHTML(r.Name)+'">&nbsp;&nbsp;<img src="/assets/images/tx-registry.png">&nbsp;'+r.Code+'</td><td><a href="'+FormatTextToHTML(r.Address)+'">'+FormatTextToHTML(r.Address)+'</a></td></tr>');
for s in r.Servers do
begin
if (s.AuthList.Count > 0) or (s.UsageList.count > 0) then
b.append('<tr><td title='+FormatTextToHTML(s.Name)+'">&nbsp;&nbsp;&nbsp;&nbsp;<img src="/assets/images/tx-server.png">&nbsp;'+s.Code+'</td><td>'+FormatTextToHTML(s.Address)+'. '+s.details+'</td></tr>')
if (s.AuthCSList.Count > 0) or (s.AuthVSList.Count > 0) or (s.UsageList.count > 0) then
b.append('<tr><td title='+FormatTextToHTML(s.Name)+'">&nbsp;&nbsp;&nbsp;&nbsp;<img src="/assets/images/tx-server.png">&nbsp;'+s.Code+'</td><td><a href="'+FormatTextToHTML(s.Address)+'">'+FormatTextToHTML(s.Address)+'</a>. '+s.details+'</td></tr>')
else
b.append('<tr><td title='+FormatTextToHTML(s.Name)+'">&nbsp;&nbsp;&nbsp;&nbsp;<img src="/assets/images/tx-server.png">&nbsp;'+s.Code+'</td><td>'+FormatTextToHTML(s.Address)+'</td></tr>');
b.append('<tr><td title='+FormatTextToHTML(s.Name)+'">&nbsp;&nbsp;&nbsp;&nbsp;<img src="/assets/images/tx-server.png">&nbsp;'+s.Code+'</td><td><a href="'+FormatTextToHTML(s.Address)+'">'+FormatTextToHTML(s.Address)+'</a></td></tr>');
for v in s.Versions do
b.append('<tr><td>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<img src="/assets/images/tx-version.png">&nbsp;v'+TSemanticVersion.getMajMin(v.Version)+'</td><td>'+FormatTextToHTML(v.Address)+'. Status: '+FormatTextToHTML(v.Details)+'. '+inttostr(v.Terminologies.Count)+' Items</td></tr>');
b.append('<tr><td>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<img src="/assets/images/tx-version.png">&nbsp;v'+TSemanticVersion.getMajMin(v.Version)+'</td><td><a href="'+FormatTextToHTML(v.Address)+'">'+FormatTextToHTML(v.Address)+'</a>. Status: '+FormatTextToHTML(v.Details)+'. '+inttostr(v.CodeSystems.Count)+' Items</td></tr>');
end;
end;
b.Append('</table>');
Expand Down Expand Up @@ -723,7 +782,7 @@ function TFHIRTxRegistryWebServer.doRequest(AContext: TIdContext; request: TIdHT
else if request.document = PathWithSlash+'resolve' then
begin
result := 'Resolve '+pm.Value['fhirVersion']+' server for '+pm.Value['url']+' (usage = '+pm.Value['usage']+')';
json := resolve(pm.Value['fhirVersion'], pm.Value['url'], pm.Value['usage'], desc);
json := resolveCS(pm.Value['fhirVersion'], pm.Value['url'], pm.Value['usage'], desc);
try
response.ResponseNo := 200;
response.ContentType := 'application/json';
Expand Down
59 changes: 53 additions & 6 deletions server/endpoint_txsvr.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -117,6 +117,7 @@ TTerminologyServerOperationEngine = class (TFHIROperationEngine)
function tokenMatchesCoding(obj: TFhirObject; sp: TSearchParameter): boolean; overload;
function tokenMatchesCoding(c: TFhirCodingW; sp: TSearchParameter): boolean; overload;
function tokenMatchesIdentifier(obj: TFhirObject; sp: TSearchParameter): boolean; overload;
function makeWrapper(rn : String; p : TFHIRResourceProxyV) : TFHIRMetadataResourceW;
protected
function context : TFHIRServerContext;
procedure StartTransaction; override;
Expand Down Expand Up @@ -579,6 +580,24 @@ function hasScope(request : TFHIRRequest; name : String) : boolean;
result := (request.ResourceName = name) or ((request.ResourceName = '') and request.Parameters['_type'].Contains(name));
end;

function onlyHasElements(ts : TStringList; names : array of String) : boolean;
var
s : String;
begin
result := true;
for s in ts do
if not StringArrayExists(names, s) then
exit(false);
end;

function TTerminologyServerOperationEngine.makeWrapper(rn : String; p : TFHIRResourceProxyV) : TFHIRMetadataResourceW;
begin
result := factory.wrapResource(factory.makeResource(rn)) as TFHIRMetadataResourceW;
result.id := p.id;
result.url := p.url;
result.version := p.version;
end;

procedure TTerminologyServerOperationEngine.ExecuteSearch(request: TFHIRRequest; response: TFHIRResponse);
var
search : TFslList<TSearchParameter>;
Expand All @@ -589,21 +608,26 @@ procedure TTerminologyServerOperationEngine.ExecuteSearch(request: TFHIRRequest;
bundle : TFHIRBundleBuilder;
op : TFHIROperationOutcomeW;
base : String;
isMatch : boolean;
isMatch, defCount : boolean;
i, t, offset, count : integer;
be : TFhirBundleEntryW;
p : TFHIRResourceProxyV;
useProxy : boolean;
begin
if FEngine = nil then
FEngine := context.ServerFactory.makeEngine(context.ValidatorContext.Link, TUcumServiceImplementation.Create(context.TerminologyServer.CommonTerminologies.Ucum.link));

offset := 0;
count := 50;
defCount := true;
for i := 0 to request.Parameters.Count - 1 do
if request.Parameters.Name[i] = SEARCH_PARAM_NAME_OFFSET then
offset := StrToIntDef(request.Parameters.Value[request.Parameters.Name[i]], 0)
else if request.Parameters.Name[i] = '_count' then
begin
count := StrToIntDef(request.Parameters.Value[request.Parameters.Name[i]], 0);
defCount := false;
end;
if (count < 2) then
count := TX_SEARCH_PAGE_DEFAULT
else if (Count > TX_SEARCH_PAGE_LIMIT) then
Expand All @@ -630,18 +654,39 @@ procedure TTerminologyServerOperationEngine.ExecuteSearch(request: TFHIRRequest;

list := TFslMetadataResourceList.create;
try
useProxy := false;
if spp.elements.count > 0 then
if onlyHasElements(spp.elements, ['id', 'url' ,'version']) then
begin
useProxy := true;
if (defCount) then
count := 100000;
end;

if (hasScope(request, 'CodeSystem')) then
for p in FData.CodeSystems.Values do
list.add(p.resourceW.link as TFhirMetadataResourceW);
if useProxy then
list.add(makeWrapper('CodeSystem', p))
else
list.add(p.resourceW.link as TFhirMetadataResourceW);
if (hasScope(request, 'ValueSet')) then
for p in FData.ValueSets.Values do
list.add(p.resourceW.link as TFhirMetadataResourceW);
if useProxy then
list.add(makeWrapper('ValueSet', p))
else
list.add(p.resourceW.link as TFhirMetadataResourceW);
if (hasScope(request, 'ConceptMap')) then
for p in FData.ConceptMaps.Values do
list.add(p.resourceW.link as TFhirMetadataResourceW);
if useProxy then
list.add(makeWrapper('ConceptMap', p))
else
list.add(p.resourceW.link as TFhirMetadataResourceW);
if (hasScope(request, 'NamingSystem')) then
for p in FData.NamingSystems.Values do
list.add(p.resourceW.link as TFhirMetadataResourceW);
if useProxy then
list.add(makeWrapper('NamingSystem', p))
else
list.add(p.resourceW.link as TFhirMetadataResourceW);

filtered := TFslMetadataResourceList.create;
try
Expand All @@ -660,6 +705,8 @@ procedure TTerminologyServerOperationEngine.ExecuteSearch(request: TFHIRRequest;
filtered.add(res.link);
end;

bundle.setTotal(filtered.count);

if (offset > 0) or (Count < filtered.count) then
begin
bundle.addLink('first', base+'&'+SEARCH_PARAM_NAME_OFFSET+'=0&'+SEARCH_PARAM_NAME_COUNT+'='+inttostr(Count));
Expand All @@ -681,7 +728,7 @@ procedure TTerminologyServerOperationEngine.ExecuteSearch(request: TFHIRRequest;
be := bundle.makeEntry;
try
bundle.addEntry(be, false);
be.Url := res.url;
be.Url := URLPath([context.FormalURLPlain, res.fhirType, res.id]);
be.resource := res.Resource.Link;
finally
be.free;
Expand Down
15 changes: 14 additions & 1 deletion server/search_base.pas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -33,7 +33,7 @@
interface

uses
SysUtils,
SysUtils, Classes,
fsl_base, fsl_utilities, fsl_http,
fhir_objects, fhir_common,
fhir_indexing, indexing;{,
Expand Down Expand Up @@ -81,12 +81,16 @@ TSearchParameter = class (TFslObject)

TSearchParser = class (TFslObject)
private
FElements : TStringList;
FSearchControls : TFHIRSearchControlParameterSet;
function processParam(indexes : TFHIRIndexInformation; resourceType, name, value : String) : TSearchParameter;
public
constructor Create(searchControls : TFHIRSearchControlParameterSet);
destructor Destroy; override;

function parse(indexes : TFHIRIndexInformation; resourceType : String; pm : THTTPParameters) : TFslList<TSearchParameter>;
function buildUrl(base : String; search : TFslList<TSearchParameter>): String;
property Elements : TStringList read FElements;
end;

const
Expand Down Expand Up @@ -382,6 +386,8 @@ function TSearchParser.processParam(indexes : TFHIRIndexInformation; resourceTyp
result := TSearchParameter.Create;
result.control := cp;
result.value := value;
if (cp = scpElements) then
FElements.CommaText := value;
end;
end;
end;
Expand All @@ -390,6 +396,13 @@ constructor TSearchParser.Create(searchControls: TFHIRSearchControlParameterSet)
begin
inherited Create;
FSearchControls := searchControls;
FElements := TStringList.create;
end;

destructor TSearchParser.Destroy;
begin
FElements.free;
inherited Destroy;
end;

end.
Loading

0 comments on commit 21b1109

Please sign in to comment.