fix missing versions in terminology capabilities

Author: Grahame Grieve

library/fhir/fhir_common.pas

@@ -1520,6 +1520,7 @@   TFhirTerminologyCapabilitiesW = class (TFHIRXVersionResourceWrapper)
 
     procedure contact(kind : TContactType; value : String); virtual; abstract;
     procedure systemUri(url : String); virtual; abstract;
+    procedure systemVersion(url : String); virtual; abstract;
     procedure addExpansionParameter(code, doco : String); virtual; abstract;
   end;
 

library/fhir3/fhir3_common.pas

@@ -1301,6 +1301,7 @@   TFhirTerminologyCapabilities3 = class (TFhirTerminologyCapabilitiesW)
     function wrapExtension(extension : TFHIRObject) : TFHIRExtensionW; override;
     procedure contact(kind : TContactType; value : String); override;
     procedure systemUri(url : String); override;
+    procedure systemVersion(url : String); override;
     procedure addExpansionParameter(code, doco : String); override;
   end;
 
@@ -7030,6 +7031,15 @@ procedure TFhirTerminologyCapabilities3.systemUri(url: String);
   (FRes as TFhirParameters).AddParameter('system', TFhirUri.Create(url));
 end;
 
+procedure TFhirTerminologyCapabilities3.systemVersion(url: String);
+var
+  u, v : String;
+begin
+  StringSplit(url, '|', u, v);
+  (FRes as TFhirParameters).AddParameter('system', TFhirUri.Create(u));
+  (FRes as TFhirParameters).AddParameter('version', TFhirCode.Create(v))
+end;
+
 procedure TFhirTerminologyCapabilities3.addExpansionParameter(code, doco : String);
 begin
   (FRes as TFhirParameters).AddParameter('expansion.parameter', TFhirCode.Create(code));

library/fhir4/fhir4_common.pas

@@ -1289,6 +1289,7 @@   TFhirTerminologyCapabilities4 = class (TFhirTerminologyCapabilitiesW)
     function wrapExtension(extension : TFHIRObject) : TFHIRExtensionW; override;
     procedure contact(kind : TContactType; value : String); override;
     procedure systemUri(url : String); override;
+    procedure systemVersion(url : String); override;
     procedure addExpansionParameter(code, doco : String); override;
   end;
 
@@ -6852,6 +6853,18 @@ procedure TFhirTerminologyCapabilities4.systemUri(url: String);
   tc.codeSystemList.Append.uri := url;
 end;
 
+procedure TFhirTerminologyCapabilities4.systemVersion(url: String);
+var
+  cs : TFhirTerminologyCapabilitiesCodeSystem;
+  u, v : String;
+begin
+  StringSplit(url, '|', u, v);
+  cs := tc.codeSystemList.Append;
+  cs.uri := u;
+  if (v <> '') then
+    cs.versionList.Append.code := v;
+end;
+
 function TFhirTerminologyCapabilities4.tc: TFhirTerminologyCapabilities;
 begin
   result := (Fres as TFhirTerminologyCapabilities);

library/fhir4b/fhir4b_common.pas

@@ -1291,6 +1291,7 @@   TFhirTerminologyCapabilities4B = class (TFhirTerminologyCapabilitiesW)
     function wrapExtension(extension : TFHIRObject) : TFHIRExtensionW; override;
     procedure contact(kind : TContactType; value : String); override;
     procedure systemUri(url : String); override;
+    procedure systemVersion(url : String); override;
     procedure addExpansionParameter(code, doco : String); override;
   end;
 
@@ -6826,6 +6827,18 @@ procedure TFhirTerminologyCapabilities4B.systemUri(url: String);
   tc.codeSystemList.Append.uri := url;
 end;
 
+procedure TFhirTerminologyCapabilities4B.systemVersion(url: String);
+var
+  cs : TFhirTerminologyCapabilitiesCodeSystem;
+  u, v : String;
+begin
+  StringSplit(url, '|', u, v);
+  cs := tc.codeSystemList.Append;
+  cs.uri := u;
+  if (v <> '') then
+    cs.versionList.Append.code := v;
+end;
+
 function TFhirTerminologyCapabilities4B.tc: TFhirTerminologyCapabilities;
 begin
   result := (Fres as TFhirTerminologyCapabilities);

library/fhir5/fhir5_common.pas

@@ -1297,6 +1297,7 @@   TFhirTerminologyCapabilities5 = class (TFhirTerminologyCapabilitiesW)
     function wrapExtension(extension : TFHIRObject) : TFHIRExtensionW; override;
     procedure contact(kind : TContactType; value : String); override;
     procedure systemUri(url : String); override;
+    procedure systemVersion(url : String); override;
     procedure addExpansionParameter(code, doco : String); override;
   end;
 
@@ -6846,6 +6847,18 @@ procedure TFhirTerminologyCapabilities5.systemUri(url: String);
   tc.codeSystemList.Append.uri := url;
 end;
 
+procedure TFhirTerminologyCapabilities5.systemVersion(url: String);
+var
+  cs : TFhirTerminologyCapabilitiesCodeSystem;
+  u, v : String;
+begin
+  StringSplit(url, '|', u, v);
+  cs := tc.codeSystemList.Append;
+  cs.uri := u;
+  if (v <> '') then
+    cs.versionList.Append.code := v;
+end;
+
 function TFhirTerminologyCapabilities5.tc: TFhirTerminologyCapabilities;
 begin
   result := (Fres as TFhirTerminologyCapabilities);

server/storage.pas

@@ -1241,8 +1241,8 @@ function TFHIROperationEngine.ExecuteTerminologyCapabilities(request: TFHIRReque
       oConf.status := psActive;
       oConf.date := TFslDateTime.makeUTC;
 
-      for s in ServerContext.TerminologyServer.listSystems do
-        oConf.systemUri(s);
+      for s in ServerContext.TerminologyServer.listSystemVersions do
+        oConf.systemVersion(s);
 
       oConf.addExpansionParameter('cache-id', 'This server supports caching terminology resources between calls. Clients only need to send value sets and codesystems once; there after they are automatically in scope for calls with the same cache-id. The cache is retained for 30 min from last call');
       oConf.addExpansionParameter('tx-resource', 'Additional valuesets needed for evaluation e.g. value sets referred to from the import statement of the value set being expanded');

server/tx_manager.pas

@@ -257,6 +257,7 @@   TTerminologyServerStore = class (TFslObject)
     function ValueSetCount : integer;
     function CodeSystemCount : integer;
     function listSystems : TArray<String>;
+    function listSystemVersions : TArray<String>;
 
     procedure declareCodeSystems(list : TFslList<TFhirResourceV>);
     function supportsSystem(s : String; version : String) : boolean;
@@ -1457,6 +1458,34 @@ function TTerminologyServerStore.listSystems: TArray<String>;
   end;
 end;
 
+function TTerminologyServerStore.listSystemVersions: TArray<String>;
+var
+   ts : TStringList;
+   p : TCodeSystemProviderFactory;
+   i : integer;
+   cs : TFHIRCodeSystemEntry;
+begin
+  ts := TStringList.Create;
+  try
+    ts.Sorted := true;
+    ts.Duplicates := TDuplicates.dupIgnore;
+    FLock.Lock('listSystems');
+    try
+      for p in ProviderClasses.Values do
+        ts.Add(p.systemUri+'|'+p.version);
+      for cs in FCodeSystems.list do
+        ts.Add(cs.url+'|'+cs.version);
+    finally
+      FLock.Unlock;
+    end;
+    SetLength(result, ts.Count);
+    for i := 0 to ts.Count - 1 do
+      result[i] := ts[i];
+  finally
+    ts.free;
+  end;
+end;
+
 procedure TTerminologyServerStore.listVersions(url: String; list: TStringList);
 var
   cs : TFHIRCodeSystemEntry;