Merge pull request #14 from HealthIntersections/master

catch up
costateixeira · Aug 5, 2024 · 6d6e2db · 6d6e2db
2 parents be93e8f + a4e7ca0
commit 6d6e2db
Show file tree

Hide file tree

Showing 20 changed files with 509 additions and 44 deletions.
diff --git a/install/install-tk.iss b/install/install-tk.iss
@@ -3,11 +3,11 @@
 ; AppID can never be changed as subsequent installations require the same installation ID each time
 AppID=FHIRToolkit
 AppName=Health Intersections FHIR Toolkit
-AppVerName=FHIRToolkit v3.4.6
+AppVerName=FHIRToolkit v3.4.7
 
 ; compilation control
 OutputDir=..\install\build
-OutputBaseFilename=fhirtoolkit-win64-3.4.6
+OutputBaseFilename=fhirtoolkit-win64-3.4.7
 Compression=lzma2/ultra64
 
 ; 64 bit
@@ -32,11 +32,11 @@ UninstallFilesDir={app}\uninstall
 ; win2000+ add/remove programs support
 AppPublisher=Health Intersections P/L
 AppPublisherURL=http://www.healthintersections.com.au
-AppVersion=3.4.6
+AppVersion=3.4.7
 AppSupportURL=https://github.com/grahamegrieve/fhirserver
 AppUpdatesURL=https://github.com/grahamegrieve/fhirserver
 AppCopyright=Copyright (c) Health Intersections Pty Ltd 2020+
-VersionInfoVersion=3.4.6.0
+VersionInfoVersion=3.4.7.0
 
 ; dialog support
 LicenseFile=..\license

diff --git a/install/install.iss b/install/install.iss
@@ -3,11 +3,11 @@
 ; AppID can never be changed as subsequent installations require the same installation ID each time
 AppID=FHIRServer
 AppName=Health Intersections FHIR Server
-AppVerName=FHIRServer v3.4.6
+AppVerName=FHIRServer v3.4.7
 
 ; compilation control
 OutputDir=..\install\build
-OutputBaseFilename=fhirserver-win64-3.4.6
+OutputBaseFilename=fhirserver-win64-3.4.7
 Compression=lzma2/ultra64
 
 ; 64 bit
@@ -34,11 +34,11 @@ UninstallFilesDir={app}\uninstall
 ; win2000+ add/remove programs support
 AppPublisher=Health Intersections P/L
 AppPublisherURL=http://www.healthintersections.com.au
-AppVersion=3.4.6
+AppVersion=3.4.7
 AppSupportURL=https://github.com/grahamegrieve/fhirserver
 AppUpdatesURL=https://github.com/grahamegrieve/fhirserver
 AppCopyright=Copyright (c) Health Intersections Pty Ltd 2011+
-VersionInfoVersion=3.4.6.0
+VersionInfoVersion=3.4.7.0
 
 ; dialog support
 LicenseFile=..\license

diff --git a/library/fhir.inc b/library/fhir.inc
@@ -92,8 +92,9 @@ Or in the case of FPC compiled applications, statically bound
 The base class TFslObject can track all instantiated objects.
 Doing so is useful for leak hunting in production, but is also a little costly.
 }
-{.$.DEFINE OBJECT_TRACKING}
+{$DEFINE OBJECT_TRACKING}
 
 {$ENDIF}
 
+{.$.DEFINE DEV_FEATURES}
 
diff --git a/library/fhir/fhir_common.pas b/library/fhir/fhir_common.pas
@@ -757,6 +757,7 @@   TFhirCodeSystemPropertyW = class (TFHIRXVersionElementWrapper)
   end;
 
   TFhirCodeSystemContentMode = (cscmNull, cscmNotPresent, cscmExample, cscmFragment, cscmComplete, cscmSupplement);
+  TFhirCodeSystemContentModeSet = set of TFhirCodeSystemContentMode;
 
 const
   CODES_TFhirCodeSystemContentMode : Array[TFhirCodesystemContentMode] of String = ('null', 'not-present', 'example', 'fragment', 'complete', 'supplement');

diff --git a/library/fhir/fhir_tx.pas b/library/fhir/fhir_tx.pas
@@ -195,7 +195,7 @@   TTerminologyWorker = class (TFslObject)
     function sizeInBytesV(magic : integer) : cardinal; override;
     procedure deadCheck(place : String); virtual;
     function findInAdditionalResources(url, version, resourceType : String; error : boolean) : TFHIRMetadataResourceW;
-    function findCodeSystem(url, version : String; params : TFHIRTxOperationParams; nullOk : boolean) : TCodeSystemProvider;
+    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);
@@ -360,7 +360,7 @@ function TTerminologyWorker.findInAdditionalResources(url, version, resourceType
   end;
 end;
 
-function TTerminologyWorker.findCodeSystem(url, version: String; params: TFHIRTxOperationParams; nullOk: boolean): TCodeSystemProvider;
+function TTerminologyWorker.findCodeSystem(url, version: String; params: TFHIRTxOperationParams; kinds : TFhirCodeSystemContentModeSet; nullOk: boolean): TCodeSystemProvider;
 var
   r, r2 : TFHIRMetadataResourceW;
   cs, cs2 : TFhirCodeSystemW;
@@ -391,11 +391,12 @@ function TTerminologyWorker.findCodeSystem(url, version: String; params: TFHIRTx
   if (result <> nil) then
     exit(result);
 
-  if (cs <> nil) and (cs.content = cscmFragment) then
+  if (cs <> nil) and (cs.content in kinds) then
   begin
     cse := TFHIRCodeSystemEntry.Create(cs.link);
     try
-      loadSupplements(cse, url);
+      if cs.content <> cscmSupplement then
+        loadSupplements(cse, url);
       exit(TFhirCodeSystemProvider.Create(FLanguages.link, FI18n.link, FFactory.link, cse.link));
     finally
       cse.free;
@@ -516,7 +517,7 @@ procedure TFHIRCodeSystemInformationProvider.lookupCode(coding: TFHIRCodingW; pr
   params := TFHIRTxOperationParams.Create;
   try
     params.defaultToLatestVersion := true;
-    provider := findCodeSystem(coding.systemUri, coding.version, profile, false);
+    provider := findCodeSystem(coding.systemUri, coding.version, profile, [cscmComplete, cscmFragment], false);
     try
       resp.name := provider.name(nil);
       resp.systemUri := provider.systemUri;

diff --git a/library/fsl/tests/fsl_tests.pas b/library/fsl/tests/fsl_tests.pas
@@ -751,6 +751,7 @@ procedure TFslUtilitiesTestCases.TestObjectTracking;
 var
   a, b, c, d : TFslTestObject;
 begin
+  {$IFDEF OBJECT_TRACKING}
   // ---------------------
   a := TFslTestObject.Create;
   b := TFslTestObject.Create;
@@ -1091,6 +1092,7 @@ procedure TFslUtilitiesTestCases.TestObjectTracking;
   a.free;
   AssertEqual(1, classCount('TFslTestObject'));
   d.free;
+  {$ENDIF}
   AssertEqual(0, classCount('TFslTestObject'));
 end;
 

diff --git a/library/ftx/fhir_valuesets.pas b/library/ftx/fhir_valuesets.pas
@@ -495,7 +495,7 @@ function TValueSetChecker.determineSystem(code: String): String;
     for vsi in FValueSet.includes do
     begin
       deadCheck('determineSystem');
-      cs := findCodeSystem(vsi.systemUri, '', nil, true);
+      cs := findCodeSystem(vsi.systemUri, '', nil, [cscmComplete, cscmFragment], true);
       if (cs = nil) then
         exit('');
       try
@@ -681,7 +681,7 @@ procedure TValueSetChecker.prepareConceptSet(desc: string; cc: TFhirValueSetComp
     end;
   end;
   if not FOthers.ExistsByKey(cc.systemUri) then
-    FOthers.Add(cc.systemUri, findCodeSystem(cc.systemUri, cc.version, FParams, true));
+    FOthers.Add(cc.systemUri, findCodeSystem(cc.systemUri, cc.version, FParams, [cscmComplete, cscmFragment], true));
   if cc.version = '' then
     cs := FOthers.matches[cc.systemUri] as TCodeSystemProvider
   else
@@ -812,7 +812,7 @@ function TValueSetChecker.check(path, system, version, code: String; abstractOk,
         op.addIssue(isWarning, itInvalid, path, msg, oicInvalidData);
         exit(bFalse);
       end;
-      cs := findCodeSystem(system, version, FParams, true);
+      cs := findCodeSystem(system, version, FParams, [cscmComplete, cscmFragment], true);
       try
         if cs = nil then
         begin
@@ -827,6 +827,13 @@ function TValueSetChecker.check(path, system, version, code: String; abstractOk,
             messages.add(msg);
             op.addIssue(isError, itInvalid, addToPath(path, 'system'), msg, oicInvalidData);
           end
+          else if findCodeSystem(system, version, FParams, [cscmSupplement], true) <> nil then
+          begin                                                                                
+            vss.free;
+            msg := FI18n.translate('CODESYSTEM_CS_NO_SUPPLEMENT', FParams.languages, [system]);
+            messages.add(msg);
+            op.addIssue(isError, itInvalid, addToPath(path, 'system'), msg, oicInvalidData);
+          end
           else if (version <> '') then
           begin
             msg := FI18n.translate('UNKNOWN_CODESYSTEM_VERSION', FParams.languages, [system, version, '['+listVersions(system)+']']);
@@ -929,7 +936,7 @@ function TValueSetChecker.check(path, system, version, code: String; abstractOk,
     else if (false) then
     begin
       // anyhow, we ignore the value set (at least for now)
-      cs := findCodeSystem(system, version, FParams, true);
+      cs := findCodeSystem(system, version, FParams, [cscmComplete, cscmFragment], true);
       try
         if cs = nil then
         begin
@@ -1091,7 +1098,7 @@ function TValueSetChecker.check(path, system, version, code: String; abstractOk,
             else
               cs := TCodeSystemProvider(FOthers.matches[cc.systemUri+'|'+v]).link;
             if (cs = nil) then
-              cs := findCodeSystem(system, v, FParams, true);
+              cs := findCodeSystem(system, v, FParams, [cscmComplete, cscmFragment], true);
             if (cs = nil) then
             begin
               if (not FParams.membershipOnly) then
@@ -1209,7 +1216,7 @@ function TValueSetChecker.check(path, system, version, code: String; abstractOk,
             else
               cs := TCodeSystemProvider(FOthers.matches[ccc.systemUri+'|'+v]).link;
             if (cs = nil) then
-              cs := findCodeSystem(system, v, FParams, true);
+              cs := findCodeSystem(system, v, FParams, [cscmComplete, cscmFragment], true);
             if (cs = nil) then
             begin
               if (not FParams.membershipOnly) then
@@ -1568,7 +1575,7 @@ function TValueSetChecker.check(issuePath : String; code: TFhirCodeableConceptW;
                   p := issuePath;
                 op.addIssue(isError, itInvalid, p, m, oicInvalidData);
               end;
-              prov := findCodeSystem(ws, c.version, FParams, true);
+              prov := findCodeSystem(ws, c.version, FParams, [cscmComplete, cscmFragment], true);
               try
                if (prov = nil) then
                begin
@@ -1579,11 +1586,19 @@ function TValueSetChecker.check(issuePath : String; code: TFhirCodeableConceptW;
                    m := FI18n.translate('Terminology_TX_System_ValueSet2', FParams.languages, [ws]);
                    msg(m);
                    op.addIssue(isError, itInvalid, addToPath(path, 'system'), m, oicInvalidData);
-                   cause := itNotFound;
+                   cause := itInvalid;
+                 end
+                 else if findCodeSystem(ws, c.version, FParams, [cscmSupplement], true) <> nil then
+                 begin
+                   vss.free;
+                   m := FI18n.translate('CODESYSTEM_CS_NO_SUPPLEMENT', FParams.languages, [ws]);
+                   msg(m);
+                   op.addIssue(isError, itInvalid, addToPath(path, 'system'), m, oicInvalidData);
+                   cause := itInvalid;
                  end
                  else
                  begin
-                   prov2 := findCodeSystem(ws, '', FParams, true);
+                   prov2 := findCodeSystem(ws, '', FParams, [cscmComplete, cscmFragment], true);
                    try
                      bAdd := true;
                      if (prov2 = nil) and (c.version = '') then
@@ -3229,7 +3244,7 @@ procedure TFHIRValueSetExpander.checkSource(cset: TFhirValueSetComposeIncludeW;
 
   if cset.systemUri <> '' then
   begin
-    cs := findCodeSystem(cset.systemUri, cset.version, FParams, false);
+    cs := findCodeSystem(cset.systemUri, cset.version, FParams, [cscmComplete, cscmFragment], false);
     try
 
       if cs.contentMode <> cscmComplete then
@@ -3352,7 +3367,7 @@ procedure TFHIRValueSetExpander.includeCodes(cset: TFhirValueSetComposeIncludeW;
     begin
       filters := TFslList<TCodeSystemProviderFilterContext>.create;
       try
-        cs := findCodeSystem(cset.systemUri, cset.version, FParams, false);
+        cs := findCodeSystem(cset.systemUri, cset.version, FParams, [cscmComplete, cscmFragment], false);
         try
           //Logging.log('Processing '+vsId+',code system "'+cset.systemUri+'|'+cset.version+'", '+inttostr(cset.filterCount)+' filters, '+inttostr(cset.conceptCount)+' concepts');
           checkSupplements(cs, cset);
@@ -3674,7 +3689,7 @@ procedure TFHIRValueSetExpander.excludeCodes(cset: TFhirValueSetComposeIncludeW;
     begin
       filters := TFslList<TCodeSystemProviderFilterContext>.create;
       try
-        cs := findCodeSystem(cset.systemUri, cset.version, FParams, false);
+        cs := findCodeSystem(cset.systemUri, cset.version, FParams, [cscmComplete, cscmFragment], false);
         try
           //Logging.log('Processing '+vsId+',code system "'+cset.systemUri+'|'+cset.version+'", '+inttostr(cset.filterCount)+' filters, '+inttostr(cset.conceptCount)+' concepts');
           checkSupplements(cs, cset);
@@ -4045,7 +4060,7 @@ function TFHIRConceptMapTranslator.checkCode(op: TFhirOperationOutcomeW; langLis
   d : String;
 begin
   result := false;
-  cp := findCodeSystem(system, version, nil, true);
+  cp := findCodeSystem(system, version, nil, [cscmComplete, cscmFragment], true);
   if cp <> nil then
   begin
     try

diff --git a/library/version.inc b/library/version.inc
@@ -1,3 +1,3 @@
- FHIR_CODE_FULL_VERSION = '3.4.6';
- FHIR_CODE_RELEASE_DATE = '2024-05-18';
- FHIR_CODE_RELEASE_DATETIME = '20240518123655.539Z';
+ FHIR_CODE_FULL_VERSION = '3.4.7';
+ FHIR_CODE_RELEASE_DATE = '2024-06-29';
+ FHIR_CODE_RELEASE_DATETIME = '20240629060621.820Z';
diff --git a/server/endpoint_snomed.pas b/server/endpoint_snomed.pas
@@ -422,7 +422,10 @@ function TSnomedWebServer.chooseSnomedRelease: String;
     for ss in FTx.Snomed do
     begin
       html.StartTableRow;
-      html.AddTableCellURL(ss.EditionName, '/snomed/'+ss.editionId+'-'+ss.VersionDate);
+      if (ss = FTx.DefSnomed) then
+        html.AddTableCellURL(ss.EditionName+' (default)', '/snomed/'+ss.editionId+'-'+ss.VersionDate)
+      else
+        html.AddTableCellURL(ss.EditionName, '/snomed/'+ss.editionId+'-'+ss.VersionDate);
       html.AddTableCell(ss.VersionUri);
       html.AddTableCell(ss.VersionDate);
       html.AddTableCell(inttostr(ss.UseCount));

diff --git a/server/endpoint_storage.pas b/server/endpoint_storage.pas
@@ -151,6 +151,10 @@   TStorageWebEndpoint = class (TFhirWebServerEndpoint)
     FAdaptors: TFslMap<TFHIRFormatAdaptor>;
     FThreads : TFslList<TAsyncTaskThread>;
 
+    {$IFDEF DEV_FEATURES}
+    procedure processRequiredFeatures(request : TFHIRRequest; header: String);
+    procedure checkRequiredFeatures(op: TFHIROperationEngine; request : TFHIRRequest; response : TFHIRResponse);
+    {$ENDIF}
     procedure SetTerminologyWebServer(const Value: TTerminologyWebServer);
     Procedure HandleOWinToken(AContext: TIdContext; secure: boolean; request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo);
     function HandleRequest(AContext: TIdContext; request: TIdHTTPRequestInfo; response: TIdHTTPResponseInfo; ssl, secure: boolean; path: String; logId : String; esession: TFHIRSession; cert: TIdOpenSSLX509; tt : TTimeTracker) : String;
@@ -800,6 +804,39 @@ procedure TStorageWebEndpoint.SetAuthServer(const Value: TAuth2Server);
   FAuthServer := Value;
 end;
 
+{$IFDEF DEV_FEATURES}
+procedure TStorageWebEndpoint.processRequiredFeatures(request: TFHIRRequest; header: String);
+var
+  s : String;
+begin
+  if (header <> '') then
+    for s in header.Split([';']) do
+      request.requiredFeatures.Add(TFhirFeatureQueryItem.fromParam(FContext.Factory, s.trim));
+end;
+
+procedure TStorageWebEndpoint.checkRequiredFeatures(op: TFHIROperationEngine; request: TFHIRRequest; response : TFHIRResponse);
+var
+  feature : TFhirFeatureQueryItem;
+  answer : TFhirFeatureQueryAnswer;
+begin
+  for feature in request.requiredFeatures do
+  begin
+    answer := TFhirFeatureQueryAnswer.create;
+    try
+      answer.Feature := feature.Feature;
+      answer.Context := feature.Context;
+      answer.Values.addAll(feature.Values);
+      answer.ProcessingStatus := fqpsUnknownFeature;
+      op.processFeature(feature, answer);
+      if (answer.Answer <> nbTrue) then
+        raise ERestfulException.create('TStorageWebEndpoint.checkRequiredFeatures', 501, itNotSupported, 'The feature '''+feature.toParam+''' is not supported', request.langList);
+    finally
+      answer.free;
+    end;
+  end;
+end;
+{$ENDIF}
+
 procedure TStorageWebEndpoint.SetTerminologyWebServer(const Value: TTerminologyWebServer);
 begin
   FTerminologyWebServer.free;
@@ -1286,6 +1323,9 @@ function TStorageWebEndpoint.HandleRequest(AContext: TIdContext; request: TIdHTT
                   request.RawHeaders.Values['X-Provenance'], sBearer, oStream, oResponse, aFormat, redirect, form, secure, ssl, relativeReferenceAdjustment, style,
                   esession, cert, tt);
                 try
+                  {$IFDEF DEV_FEATURES}
+                  processRequiredFeatures(oRequest, request.RawHeaders.Values['Required-Feature']);
+                  {$ENDIF}
                   oRequest.externalRequestId := request.RawHeaders.Values['X-Request-Id'];
                   oRequest.internalRequestId := logId;
                   if TFHIRWebServerClientInfo(AContext.Data).Session = nil then
@@ -1712,6 +1752,9 @@ function TStorageWebEndpoint.ProcessRequest(Context: TOperationContext; request:
   try
     op.OnPopulateConformance := PopulateConformance;
     op.OnCreateBuilder := doGetBundleBuilder;
+    {$IFDEF DEV_FEATURES}
+    checkRequiredFeatures(op, request, response);
+    {$ENDIF}
     result := op.Execute(Context, request, response, tt);
     self.Context.Storage.yield(op, nil);
   except

diff --git a/server/endpoint_txsvr.pas b/server/endpoint_txsvr.pas
@@ -1312,6 +1312,9 @@ function TTerminologyFhirServerStorage.createOperationContext(langList : THTTPLa
   result.Operations.add(TFhirConceptMapTranslationOperation.create(FServerContext.Factory.link, FServerContext.TerminologyServer.Link, FServerContext.TerminologyServer.CommonTerminologies.Languages.link));
   result.Operations.add(TFhirConceptMapClosureOperation.create(FServerContext.Factory.link, FServerContext.TerminologyServer.Link, FServerContext.TerminologyServer.CommonTerminologies.Languages.link));
   result.Operations.add(TFhirVersionsOperation.create(Factory.link, FServerContext.TerminologyServer.CommonTerminologies.Languages.link));
+  {$IFDEF DEV_FEATURES}
+  result.Operations.add(TFhirFeatureNegotiation.create(Factory.link, FServerContext.TerminologyServer.CommonTerminologies.Languages.link));
+  {$ENDIF}
 end;
 
 function TTerminologyFhirServerStorage.FetchResource(key: integer): TFHIRResourceV;

diff --git a/server/fhirconsole.lpi b/server/fhirconsole.lpi
@@ -18,7 +18,7 @@
     <VersionInfo>
       <MajorVersionNr Value="3"/>
       <MinorVersionNr Value="4"/>
-      <RevisionNr Value="6"/>
+      <RevisionNr Value="7"/>
       <Attributes pvaDebug="False"/>
     </VersionInfo>
     <BuildModes Count="8">

diff --git a/server/fhirserver.dproj b/server/fhirserver.dproj
@@ -92,7 +92,7 @@
     <VerInfo_IncludeVerInfo>true</VerInfo_IncludeVerInfo>
     <VerInfo_MajorVer>3</VerInfo_MajorVer>
     <VerInfo_MinorVer>4</VerInfo_MinorVer>
-    <VerInfo_Release>6</VerInfo_Release>
+    <VerInfo_Release>7</VerInfo_Release>
     <VerInfo_Debug>false</VerInfo_Debug>
   </PropertyGroup>
   <PropertyGroup Condition="&apos;$(Base_Win32)&apos;!=&apos;&apos;">
@@ -167,7 +167,7 @@
     <DCC_RangeChecking>true</DCC_RangeChecking>
     <DCC_DebugDCUs>false</DCC_DebugDCUs>
     <VerInfo_MajorVer>3</VerInfo_MajorVer>
-    <VerInfo_Release>6</VerInfo_Release>
+    <VerInfo_Release>7</VerInfo_Release>
     <AppDPIAwarenessMode>none</AppDPIAwarenessMode>
     <VerInfo_MinorVer>4</VerInfo_MinorVer>
     <VerInfo_Debug>false</VerInfo_Debug>