From 459e7926226d241b763ce47db7b94d2d3316c8ce Mon Sep 17 00:00:00 2001 From: Grahame Grieve Date: Tue, 21 May 2024 01:22:48 -0500 Subject: [PATCH 1/5] fix failing memory tracking test --- library/fhir.inc | 2 +- library/fsl/tests/fsl_tests.pas | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/library/fhir.inc b/library/fhir.inc index 5bd4dd022..62366c8a4 100644 --- a/library/fhir.inc +++ b/library/fhir.inc @@ -92,7 +92,7 @@ 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} diff --git a/library/fsl/tests/fsl_tests.pas b/library/fsl/tests/fsl_tests.pas index fcc8d06a0..639013196 100644 --- 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; From 52cca28c76ae54964276e20935dc601c96742eb2 Mon Sep 17 00:00:00 2001 From: Grahame Grieve Date: Tue, 21 May 2024 01:46:54 -0500 Subject: [PATCH 2/5] Add provisional features work from Connectathon #36 --- library/fhir.inc | 1 + server/endpoint_storage.pas | 43 +++++++++ server/endpoint_txsvr.pas | 3 + server/operations_r4.pas | 52 +++++++++++ server/session.pas | 165 ++++++++++++++++++++++++++++++++- server/storage.pas | 10 ++ server/tx_operations.pas | 176 ++++++++++++++++++++++++++++++++++++ 7 files changed, 446 insertions(+), 4 deletions(-) diff --git a/library/fhir.inc b/library/fhir.inc index 62366c8a4..4c79fa9ec 100644 --- a/library/fhir.inc +++ b/library/fhir.inc @@ -96,4 +96,5 @@ Doing so is useful for leak hunting in production, but is also a little costly. {$ENDIF} +{.$.DEFINE DEV_FEATURES} diff --git a/server/endpoint_storage.pas b/server/endpoint_storage.pas index f2f48707b..7269b69dc 100644 --- a/server/endpoint_storage.pas +++ b/server/endpoint_storage.pas @@ -151,6 +151,10 @@ TStorageWebEndpoint = class (TFhirWebServerEndpoint) FAdaptors: TFslMap; FThreads : TFslList; + {$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 index 0bfcf54e0..d44fd3279 100644 --- 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/operations_r4.pas b/server/operations_r4.pas index 468af6e4b..7aad219ae 100644 --- a/server/operations_r4.pas +++ b/server/operations_r4.pas @@ -294,6 +294,20 @@ TFhirAddMetaDataOperation = class (TFhirNativeOperationR4) function formalURL : String; override; end; + { TFhirFeatureNegotiation } + + TFhirFeatureNegotiation = class (TFhirNativeOperationR4) + protected + function isWrite : boolean; override; + function owningResource : String; override; + public + function Name : String; override; + function Types : TArray; override; + function CreateDefinition(base : String) : TFHIROperationDefinitionW; override; + function Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response : TFHIRResponse; tt : TTimeTracker) : String; override; + function formalURL : String; override; + end; + TFhirDeleteMetaDataOperation = class (TFhirNativeOperationR4) protected function isWrite : boolean; override; @@ -686,6 +700,7 @@ procedure TFhirNativeOperationEngineR4.registerOperations; FOperations.add(TFhirGetMetaDataOperation.Create(Factory.link, ServerContext.TerminologyServer.CommonTerminologies.Languages.Link)); FOperations.add(TFhirAddMetaDataOperation.Create(Factory.link, ServerContext.TerminologyServer.CommonTerminologies.Languages.Link)); FOperations.add(TFhirDeleteMetaDataOperation.Create(Factory.link, ServerContext.TerminologyServer.CommonTerminologies.Languages.Link)); + FOperations.add(TFhirFeatureNegotiation.Create(Factory.link, ServerContext.TerminologyServer.CommonTerminologies.Languages.Link)); FOperations.add(TFhirDiffOperation.Create(Factory.link, ServerContext.TerminologyServer.CommonTerminologies.Languages.Link)); FOperations.add(TFhirConvertOperation.Create(Factory.link, ServerContext.TerminologyServer.CommonTerminologies.Languages.Link)); FOperations.add(TFhirTransformOperation.Create(Factory.link, ServerContext.TerminologyServer.CommonTerminologies.Languages.Link)); @@ -2263,6 +2278,43 @@ function TFhirAddMetaDataOperation.Types: TArray; result := FFactory.ResourceNames; end; +{ TFhirFeatureNegotiation } + +function TFhirFeatureNegotiation.isWrite: boolean; +begin + Result := false; +end; + +function TFhirFeatureNegotiation.owningResource: String; +begin + Result := ''; +end; + +function TFhirFeatureNegotiation.Name: String; +begin + Result := 'feature-query'; +end; + +function TFhirFeatureNegotiation.Types: TArray; +begin + Result := []; +end; + +function TFhirFeatureNegotiation.CreateDefinition(base: String): TFHIROperationDefinitionW; +begin + Result := nil; +end; + +function TFhirFeatureNegotiation.Execute(context: TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response: TFHIRResponse; tt: TTimeTracker): String; +begin + raise EFslException.create('not done yet'); +end; + +function TFhirFeatureNegotiation.formalURL: String; +begin + result := 'http://www.hl7.org/fhir/uv/capstmt/OperationDefinition/feature-query'; +end; + { TFhirDeleteMetaDataOperation } function TFhirDeleteMetaDataOperation.CreateDefinition(base: String): TFHIROperationDefinitionW; diff --git a/server/session.pas b/server/session.pas index f8cc83f9f..3b16e255a 100644 --- a/server/session.pas +++ b/server/session.pas @@ -254,6 +254,49 @@ TFhirSession = class (TFslObject) function isAnonymous : boolean; end; + {$IFDEF DEV_FEATURES} + { TFhirFeatureQueryItem } + + TFhirFeatureQueryItem = class (TFslObject) + private + FFeature : String; + FContext : String; + FValues : TFslList; + public + constructor create(feature, context : String; value : TFHIRObject); + destructor Destroy; override; + class function fromParam(factory : TFHIRFactory; param : String) : TFhirFeatureQueryItem; + function toParam : String; + property Feature : String read FFeature write FFeature; + property Context : String read FContext write FContext; + property values : TFslList read FValues; + end; + + TNullOrBoolean = (nbNone, nbFalse, nbTrue); + TFeatureQueryProcessingStatus = (fqpsUnknown, fqpsUnknownFeature, fqpsUnknownContext, fqpsUnableToEvaluate, fqpsAllOk); + + { TFhirFeatureQueryAnswer } + + TFhirFeatureQueryAnswer = class (TFslObject) + private + FFeature : String; + FContext : String; + FProcessingStatus : TFeatureQueryProcessingStatus; + FValues : TFslList; + FAnswer : TNullOrBoolean; + public + constructor create(feature, context : String; value : TFHIRObject); + constructor create(feature, context : String; answer : boolean); + destructor Destroy; override; + property Feature : String read FFeature write FFeature; + property Context : String read FContext write FContext; + property ProcessingStatus : TFeatureQueryProcessingStatus read FProcessingStatus write FProcessingStatus; + property Values : TFslList read FValues; + property Answer : TNullOrBoolean read FAnswer write FAnswer; + procedure setAnswer(value : boolean); + end; + {$ENDIF} + { A FHIR request. @@ -311,7 +354,10 @@ TFHIRRequest = class (TFslObject) FVersion: TFHIRVersion; FTransactionResource: TFhirResourceV; FSecureURL: String; - FContentLanguage : String; + FContentLanguage : String; + {$IFDEF DEV_FEATURES} + FRequiredFeatures : TFslList; + {$ENDIF} procedure SetResource(const Value: TFhirResourceV); procedure SetSource(const Value: TFslBuffer); procedure SetSession(const Value: TFhirSession); @@ -375,7 +421,10 @@ TFHIRRequest = class (TFslObject) Preferred language of the requester (used for error messages) } Property LangList : THTTPLanguageList read FLangList write SetLangList; - + + {$IFDEF DEV_FEATURES} + property requiredFeatures : TFslList read FRequiredFeatures; + {$ENDIF} published { The full URL of the original request, if the request was made on a RESTful interface (else empty) @@ -665,6 +714,11 @@ TFHIRResponse = class (TFslObject) end; +{$IFDEF DEV_FEATURES} +Const CODES_TFeatureQueryProcessingStatus : array [TFeatureQueryProcessingStatus] of String = ('unknown', 'feature', 'context', 'unsure', 'all-ok'); +{$ENDIF} + + Function IdTail(s : String):String; Function IdHead(s : String):String; @@ -1076,11 +1130,17 @@ constructor TFHIRRequest.Create(worker: TFHIRWorkerContextWithFactory; origin : FOrigin := origin; FCompartmentInformation := compartmentInformation; FElements := TStringList.Create; - Version := worker.Factory.version; + Version := worker.Factory.version; + {$IFDEF DEV_FEATURES} + FRequiredFeatures := TFslList.create; + {$ENDIF} end; destructor TFHIRRequest.Destroy; -begin +begin + {$IFDEF DEV_FEATURES} + FRequiredFeatures.free; + {$ENDIF} FLangList.free; FElements.free; FAdaptor.free; @@ -1617,6 +1677,103 @@ procedure TFhirSession.SetUser(const Value: TSCIMUser); end; +{$IFDEF DEV_FEATURES} +{ TFhirFeatureQueryItem } + +constructor TFhirFeatureQueryItem.create(feature, context: String; value: TFHIRObject); +begin + inherited create; + FFeature := feature; + FContext := context; + FValues := TFslList.create; + if (value <> nil) then + FValues.add(value); +end; + +destructor TFhirFeatureQueryItem.Destroy; +begin + FValues.free; + inherited Destroy; +end; + +class function TFhirFeatureQueryItem.fromParam(factory : TFHIRFactory; param: String): TFhirFeatureQueryItem; +var + ss, f, c, v: String; +begin + if (param.contains('(')) and (param.endsWith(')')) then + begin + StringSplit(param, '(', ss, v); + v := copy(v, 1, length(v)-1); + end + else + ss := param; + if (ss.contains('@') ) then + StringSplit(ss, '@', f, c) + else + f := ss; + result := TFhirFeatureQueryItem.create(f, c, factory.makeString(v)); +end; + +function TFhirFeatureQueryItem.toParam: String; +var + i : integer; +begin + result := FFeature; + if FContext <> '' then + result := result + '@'+FContext; + if FValues.count > 0 then + begin + result := result+'('; + for i := 0 to FValues.count - 1 do + begin + if i > 0 then + result := result + ','; + result := result + FValues[i].toString; + end; + result := result + ')'; + end; +end; + +{ TFhirFeatureQueryAnswer } + +constructor TFhirFeatureQueryAnswer.create(feature, context: String; value : TFHIRObject); +begin + inherited Create; + FFeature := feature; + FContext := context; + FValues := TFslList.create; + if (value <> nil) then + FValues.add(value); +end; + +constructor TFhirFeatureQueryAnswer.create(feature, context: String; answer: boolean); +begin + inherited Create; + FFeature := feature; + FContext := context; + FValues := TFslList.create; + if answer then + FAnswer := nbTrue + else + FAnswer := nbFalse; +end; + +destructor TFhirFeatureQueryAnswer.Destroy; +begin + FValues.Free; + inherited Destroy; +end; + +procedure TFhirFeatureQueryAnswer.setAnswer(value: boolean); +begin + if value then + FAnswer := nbTrue + else + FAnswer := nbFalse; +end; + +{$ENDIF} + { TFHIRFormatAdaptor } function TFHIRFormatAdaptor.Link: TFHIRFormatAdaptor; diff --git a/server/storage.pas b/server/storage.pas index bac315339..d80ff820d 100644 --- a/server/storage.pas +++ b/server/storage.pas @@ -258,6 +258,9 @@ TFHIROperationEngine = class (TFslObject) procedure AuditRest(session : TFhirSession; intreqid, extreqid, ip, resourceName : string; id, ver : String; verkey : integer; op : TFHIRCommandType; provenance : TFhirProvenanceW; opName : String; httpCode : Integer; name, message : String; patients : TArray); overload; virtual; abstract; function patientIds(request : TFHIRRequest; res : TFHIRResourceV) : TArray; virtual; abstract; function DoSearch(request: TFHIRRequest; requestType: String; params: String) : TFHIRBundleW; virtual; + {$IFDEF DEV_FEATURES} + procedure processFeature(item : TFhirFeatureQueryItem; answer : TFhirFeatureQueryAnswer); virtual; + {$ENDIF} property clientCacheManager : TClientCacheManager read GetClientCacheManager; property Operations : TFslList read FOperations; @@ -655,6 +658,13 @@ function TFHIROperationEngine.DoSearch(request: TFHIRRequest; raise EFHIRException.Create('This server does not implement the "DoSearch" function'); end; +{$IFDEF DEV_FEATURES} +procedure TFHIROperationEngine.processFeature(item: TFhirFeatureQueryItem; answer: TFhirFeatureQueryAnswer); +begin + // nothing +end; +{$ENDIF} + procedure TFHIROperationEngine.NoMatch(request: TFHIRRequest; response: TFHIRResponse); begin response.HTTPCode := 404; diff --git a/server/tx_operations.pas b/server/tx_operations.pas index 35eba7c54..20ef3ff2f 100644 --- a/server/tx_operations.pas +++ b/server/tx_operations.pas @@ -160,6 +160,26 @@ TFhirConceptMapClosureOperation = class (TFhirTerminologyOperation) function formalURL : String; override; end; + {$IFDEF DEV_FEATURES} + { TFhirFeatureNegotiation } + + TFhirFeatureNegotiation = class (TFhirOperation) + protected + function isWrite : boolean; override; + function owningResource : String; override; + + procedure loadFromParameters(list : TFslList; params : THTTPParameters); + procedure loadFromResource(list : TFslList; params : TFhirResourceV); + function processFeature(context : TOperationContext; manager: TFHIROperationEngine; feature : TFhirFeatureQueryItem) : TFhirFeatureQueryAnswer; + procedure encodeAnswer(p : TFhirParametersParameterW; answer : TFhirFeatureQueryAnswer); + public + function Name : String; override; + function Types : TArray; override; + function CreateDefinition(base : String) : TFHIROperationDefinitionW; override; + function Execute(context : TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response : TFHIRResponse; tt : TTimeTracker) : String; override; + function formalURL : String; override; + end; + {$ENDIF} implementation @@ -1581,4 +1601,160 @@ function TFhirTerminologyOperation.loadCoded(request : TFHIRRequest; loadType : raise ETerminologyError.Create('Unable to find code to validate (looked for coding | codeableConcept | code+system in parameters ='+request.Parameters.Source+')', itNotFound); end; + +{$IFDEF DEV_FEATURES} +{ TFhirFeatureNegotiation } + +function TFhirFeatureNegotiation.isWrite: boolean; +begin + Result := false; +end; + +function TFhirFeatureNegotiation.owningResource: String; +begin + Result := ''; +end; + +procedure TFhirFeatureNegotiation.loadFromParameters(list: TFslList; params: THTTPParameters); +var + s : String; +begin + for s in params.values('param') do + list.add(TFhirFeatureQueryItem.fromParam(FFactory, s)); +end; + +procedure TFhirFeatureNegotiation.loadFromResource(list: TFslList; params: TFhirResourceV); +var + p : TFHIRParametersW; + pp, ppp : TFhirParametersParameterW; + f, c: String; + v : TFHIRObject; +begin + p := FFactory.wrapParams(params.link); + try + for pp in p.parameterList do + if pp.name = 'feature' then + begin + v := nil; + for ppp in pp.partList do + begin + if ppp.name = 'name' then + f := ppp.valueString + else if ppp.name = 'context' then + c := ppp.valueString + else if ppp.name = 'value' then + v := ppp.value.link; + end; + if (f <> '') then + list.add(TFhirFeatureQueryItem.create(f, c, v)); + end; + finally + p.free; + end; +end; + +function TFhirFeatureNegotiation.processFeature(context : TOperationContext; manager: TFHIROperationEngine; feature: TFhirFeatureQueryItem): TFhirFeatureQueryAnswer; +begin + result := TFhirFeatureQueryAnswer.create; + try + result.Feature := feature.Feature; + result.Context := feature.context; + if (feature.feature = 'instantiates') then + begin + if (result.Context = '') then + begin + result.ProcessingStatus := fqpsAllOk; + if (feature.values.Empty) then + result.values.add(FFactory.makeUri('http://hl7.org/fhir/CapabilityStatement/terminology-server')) + else + begin + result.values.addAll(feature.values.Link); + result.setAnswer(feature.Values[0].ToString = 'http://hl7.org/fhir/CapabilityStatement/terminology-server'); + end; + end + else + result.ProcessingStatus := fqpsUnknownContext; + end + else + begin + result.ProcessingStatus := fqpsUnknownFeature; + manager.processFeature(feature, result); + end; + result.link; + finally + result.free; + end; +end; + +procedure TFhirFeatureNegotiation.encodeAnswer(p: TFhirParametersParameterW; answer: TFhirFeatureQueryAnswer); +var + v : TFHIRObject; +begin + p.addParamUri('name', answer.Feature); + if (answer.Context <> '') then + p.addParamUri('context', answer.Context); + for v in answer.Values do + p.addParam('value', v.link); + p.addParamCode('processing-status', CODES_TFeatureQueryProcessingStatus[answer.ProcessingStatus]); + if (answer.Answer <> nbNone) then + if (answer.Answer = nbFalse) then + p.addParamBool('answer', false) + else + p.addParamBool('answer', true); +end; + +function TFhirFeatureNegotiation.Name: String; +begin + Result := 'feature-query'; +end; + +function TFhirFeatureNegotiation.Types: TArray; +begin + Result := []; +end; + +function TFhirFeatureNegotiation.CreateDefinition(base: String): TFHIROperationDefinitionW; +begin + Result := nil; +end; + +function TFhirFeatureNegotiation.Execute(context: TOperationContext; manager: TFHIROperationEngine; request: TFHIRRequest; response: TFHIRResponse; tt: TTimeTracker): String; +var + features : TFslList; + feature : TFhirFeatureQueryItem; + answers : TFslList; + answer : TFhirFeatureQueryAnswer; + p : TFHIRParametersW; +begin + features := TFslList.create; + try + loadFromParameters(features, request.Parameters); + if (request.Resource <> nil) and (request.Resource.fhirType = 'Parameters') then + loadFromResource(features, request.resource); + answers := TFslList.create; + try + for feature in features do + answers.add(processFeature(context, manager, feature)); + p := FFactory.makeParameters; + try + for answer in answers do + encodeAnswer(p.addParam('feature'), answer); + response.resource := p.Resource.link; + finally + p.free; + end; + finally + answers.free; + end; + finally + features.free; + end; +end; + +function TFhirFeatureNegotiation.formalURL: String; +begin + result := 'http://www.hl7.org/fhir/uv/capstmt/OperationDefinition/feature-query'; +end; +{$ENDIF} + end. From 34955f751482e9221460b11615f5371457f83fc8 Mon Sep 17 00:00:00 2001 From: Grahame Grieve Date: Sat, 29 Jun 2024 15:18:32 +0930 Subject: [PATCH 3/5] better handling of supplements --- library/fhir/fhir_common.pas | 1 + library/fhir/fhir_tx.pas | 11 ++++----- library/ftx/fhir_valuesets.pas | 41 +++++++++++++++++++++++----------- 3 files changed, 35 insertions(+), 18 deletions(-) diff --git a/library/fhir/fhir_common.pas b/library/fhir/fhir_common.pas index 87724c812..95580982a 100644 --- 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 index 93cfef86b..778f6a393 100644 --- 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/ftx/fhir_valuesets.pas b/library/ftx/fhir_valuesets.pas index 0d8b29881..2776f9967 100644 --- 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.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.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 From caab685b3be8e3a70219468150cf091529b0cc6f Mon Sep 17 00:00:00 2001 From: Grahame Grieve Date: Sat, 29 Jun 2024 15:19:12 +0930 Subject: [PATCH 4/5] better handling of default snomed versions --- server/endpoint_snomed.pas | 5 ++++- server/tx_manager.pas | 9 +++++---- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/server/endpoint_snomed.pas b/server/endpoint_snomed.pas index fbd0b076f..e3c839e1f 100644 --- 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/tx_manager.pas b/server/tx_manager.pas index 040001cbc..83f46b3d7 100644 --- a/server/tx_manager.pas +++ b/server/tx_manager.pas @@ -1742,7 +1742,7 @@ procedure TCommonTerminologies.load(txlist: TFHIRServerConfigSection; testing : s : string; sn: TSnomedServices; sp : TSnomedProviderFactory; -// def : boolean; + def : boolean; p : TUriServices; function fixFile(name, fn : String) : String; begin @@ -1795,9 +1795,10 @@ procedure TCommonTerminologies.load(txlist: TFHIRServerConfigSection; testing : sn.Load(fixFile('sct', tx['source'].value)); sp := TSnomedProviderFactory.Create(sn.link, FI18n.link); try - add(sp, tx['default'].readAsBool); - if not FProviderClasses.ContainsKey(sn.systemUri()+URI_VERSION_BREAK+sn.EditionUri) then - FProviderClasses.Add(sn.systemUri()+URI_VERSION_BREAK+sn.EditionUri, sp.link); + def := tx['default'].readAsBool; + add(sp, def); + if not FProviderClasses.ContainsKey(sn.systemUri()+URI_VERSION_BREAK+sn.EditionUri) or def then + FProviderClasses.AddOrSetValue(sn.systemUri()+URI_VERSION_BREAK+sn.EditionUri, sp.link); finally sp.free; end; From a4e7ca06e32e0f8b2170c6a9f6dc2f117cdb0b27 Mon Sep 17 00:00:00 2001 From: Grahame Grieve Date: Sat, 29 Jun 2024 06:43:29 +0000 Subject: [PATCH 5/5] Release Version 3.4.7 --- install/install-tk.iss | 8 ++++---- install/install.iss | 8 ++++---- library/version.inc | 6 +++--- server/fhirconsole.lpi | 2 +- server/fhirserver.dproj | 4 ++-- server/fhirserver.lpi | 2 +- toolkit2/fhirtoolkit.lpi | 2 +- 7 files changed, 16 insertions(+), 16 deletions(-) diff --git a/install/install-tk.iss b/install/install-tk.iss index de2ab8280..0e0b5832f 100644 --- 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 index 470ae0070..b89efc64d 100644 --- 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/version.inc b/library/version.inc index e3c80f681..bdc47bcf3 100644 --- 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/fhirconsole.lpi b/server/fhirconsole.lpi index ae7bbf7b0..92d2adcd3 100644 --- a/server/fhirconsole.lpi +++ b/server/fhirconsole.lpi @@ -18,7 +18,7 @@ - + diff --git a/server/fhirserver.dproj b/server/fhirserver.dproj index 824f5bb09..2d19c3297 100644 --- a/server/fhirserver.dproj +++ b/server/fhirserver.dproj @@ -92,7 +92,7 @@ true 3 4 - 6 + 7 false @@ -167,7 +167,7 @@ true false 3 - 6 + 7 none 4 false diff --git a/server/fhirserver.lpi b/server/fhirserver.lpi index 4ddd7936d..e4fd90957 100644 --- a/server/fhirserver.lpi +++ b/server/fhirserver.lpi @@ -19,7 +19,7 @@ - + diff --git a/toolkit2/fhirtoolkit.lpi b/toolkit2/fhirtoolkit.lpi index e472ae24c..94610d340 100644 --- a/toolkit2/fhirtoolkit.lpi +++ b/toolkit2/fhirtoolkit.lpi @@ -17,7 +17,7 @@ - +