Merge branch 'HealthIntersections:master' into linux-docker

dependencies/Indy10/Protocols/IdHL7.pas

@@ -79,9 +79,7 @@
 
     Original author Grahame Grieve
 
-    This code was donated by HL7Connect.com
-    For more HL7 open source code see
-    http://www.hl7connect.com/tools
+    This code was donated by Kestral Computing
 
   This unit implements support for the Standard HL7 minimal Lower Layer
   protocol. For further details, consult the HL7 standard (www.hl7.org).

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.16
+AppVerName=FHIRToolkit v3.4.18
 
 ; compilation control
 OutputDir=..\install\build
-OutputBaseFilename=fhirtoolkit-win64-3.4.16
+OutputBaseFilename=fhirtoolkit-win64-3.4.18
 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.16
+AppVersion=3.4.18
 AppSupportURL=https://github.com/grahamegrieve/fhirserver
 AppUpdatesURL=https://github.com/grahamegrieve/fhirserver
 AppCopyright=Copyright (c) Health Intersections Pty Ltd 2020+
-VersionInfoVersion=3.4.16.0
+VersionInfoVersion=3.4.18.0
 
 ; dialog support
 LicenseFile=..\license

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.16
+AppVerName=FHIRServer v3.4.18
 
 ; compilation control
 OutputDir=..\install\build
-OutputBaseFilename=fhirserver-win64-3.4.16
+OutputBaseFilename=fhirserver-win64-3.4.18
 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.16
+AppVersion=3.4.18
 AppSupportURL=https://github.com/grahamegrieve/fhirserver
 AppUpdatesURL=https://github.com/grahamegrieve/fhirserver
 AppCopyright=Copyright (c) Health Intersections Pty Ltd 2011+
-VersionInfoVersion=3.4.16.0
+VersionInfoVersion=3.4.18.0
 
 ; dialog support
 LicenseFile=..\license

library/fdb/fdb_logging.pas

@@ -293,8 +293,7 @@ class function TFDBLogEntry.HTMLDoco : String;
   '<p>Lists the actual current usage of connections. Typically, a few connections'+#13#10+
   'are in use at any one time - the usage list should roll over constantly. If'+#13#10+
   'connections are persisting in this list, then there is a problem in the code'+#13#10+
-  'that manages the connection (either in HL7Connect, or in a script - check'+#13#10+
-  'scripts to see whether the given name comes from a script).</p>'+#13#10+
+  'that manages the connection.</p>'+#13#10+
   ''+#13#10+
   '<p><b>Table</b></p>'+#13#10+
   '<p>The table summarises the past history of connection usage, and doesn''t include connections in use</p>'+#13#10+

library/fhir/fhir_objects.pas

@@ -88,9 +88,6 @@
   SUPPORTED_VERSIONS = [fhirVersionRelease2, fhirVersionRelease3, fhirVersionRelease4];
 
 Type
-  {
-    Possible command types supported by HL7Connect FHIR interfaces
-  }
   TFHIRCommandType = (
     fcmdUnknown, { Unknown command}
     fcmdRead, { Read the resource}

library/fhir/fhir_parser.pas

@@ -58,7 +58,6 @@
     '<script src="/js/jquery.ui.draggable.js"></script>'+#13#10+
     '<script type="text/javascript" src="/js/jtip.js"></script>'+#13#10+
     '<script type="text/javascript" src="/js/jcookie.js"></script>'+#13#10+
-    '<script type="text/javascript" src="/js/hl7connect.js"></script>'+#13#10+
     '<script type="text/javascript" src="/js/fhir-gw.js"></script>'+#13#10;
   MAP_ATTR_NAME = 'B88BF977DA9543B8A5915C84A70F03F7';
 

library/fhir/fhir_tx.pas

@@ -27,12 +27,12 @@   TTerminologyOperationContext = class (TFslObject)
     FContexts : TStringList;
     FLangList : THTTPLanguageList;
     FI18n : TI18nSupport;
-    FDeadTime : Cardinal;
+    FTimeLimit : Cardinal;
     FNotes : TStringList;
     FOwnsNotes : boolean;
     FOnGetCurrentRequestCount: TGetCurrentRequestCountEvent;
   public
-    constructor Create(i18n : TI18nSupport; id : String; langList : THTTPLanguageList; deadTime : cardinal; getRequestCount : TGetCurrentRequestCountEvent);
+    constructor Create(i18n : TI18nSupport; id : String; langList : THTTPLanguageList; timeLimit : cardinal; getRequestCount : TGetCurrentRequestCountEvent);
     destructor Destroy; override;
 
     property reqId : String read FId;
@@ -246,7 +246,7 @@ implementation
 
 { TTerminologyOperationContext }
 
-constructor TTerminologyOperationContext.Create(i18n: TI18nSupport; id : String; langList : THTTPLanguageList; deadTime : cardinal; getRequestCount : TGetCurrentRequestCountEvent);
+constructor TTerminologyOperationContext.Create(i18n: TI18nSupport; id : String; langList : THTTPLanguageList; timeLimit : cardinal; getRequestCount : TGetCurrentRequestCountEvent);
 begin
   inherited create;
   FI18n := i18n;
@@ -255,7 +255,7 @@ constructor TTerminologyOperationContext.Create(i18n: TI18nSupport; id : String;
   FContexts := TStringList.create;
   FStartTime := GetTickCount64;
   FOnGetCurrentRequestCount := getRequestCount;
-  FDeadTime := deadTime;
+  FTimeLimit := timeLimit;
   FNotes := TStringList.create;
   FOwnsNotes := true;
 end;
@@ -272,7 +272,7 @@ destructor TTerminologyOperationContext.Destroy;
 
 function TTerminologyOperationContext.copy: TTerminologyOperationContext;
 begin
-  result := TTerminologyOperationContext.create(FI18n.link, FId, FLangList.link, FDeadTime, OnGetCurrentRequestCount);
+  result := TTerminologyOperationContext.create(FI18n.link, FId, FLangList.link, FTimeLimit, OnGetCurrentRequestCount);
   result.FContexts.assign(FContexts);
   result.FStartTime := FStartTime;
   result.FNotes.free;
@@ -282,19 +282,27 @@ function TTerminologyOperationContext.copy: TTerminologyOperationContext;
 
 function TTerminologyOperationContext.deadCheck(var time : integer): boolean;
 var
-  dt : UInt64;
+  timeToDie : UInt64;
   rq : integer;
 begin
-  time := FDeadTime;
+  time := FTimeLimit;
   if UnderDebugger then
     exit(false);
 
-  // once timelimit is hit, living on borrowed time until request counts build
-  if assigned(OnGetCurrentRequestCount) and (OnGetCurrentRequestCount > 10) then
-    time := time * 5;
-
-  dt := FStartTime + (time * 1000);
-  result := GetTickCount64 > dt;
+  timeToDie := FStartTime + (time * 1000);
+  if (GetTickCount64 > timeToDie) then
+    exit(true)
+  else
+  begin
+    if assigned(OnGetCurrentRequestCount) and (OnGetCurrentRequestCount < 10) then
+    begin
+      // once timelimit is hit, living on borrowed time until request counts build
+      time := time + (time div 2);
+      // but we only give it so much time
+    end;
+    timeToDie := FStartTime + (time * 1000);
+    result := GetTickCount64 > timeToDie;
+  end;
 end;
 
 procedure TTerminologyOperationContext.seeContext(vurl: String);
@@ -322,7 +330,7 @@ procedure TTerminologyOperationContext.addNote(vs : TFHIRValueSetW; note: String
   s : string;
 begin
   s := DescribePeriodMS(GetTickCount64 - FStartTime)+' '+vs.vurl+': '+note;
-  if UnderDebugger then
+  if false and UnderDebugger then
     Logging.log(s);
   FNotes.add(s);
 end;
@@ -542,6 +550,7 @@ procedure TTerminologyWorker.deadCheck(place: String);
   if FOpContext.deadCheck(time) then
   begin
     FOpContext.addNote(vsHandle, 'Operation took too long @ '+place+' ('+className+')');
+    Logging.log('Operation took too long @ '+place+' ('+className+')');
     raise costDiags(ETooCostly.create(FI18n.translate('VALUESET_TOO_COSTLY_TIME', FParams.HTTPlanguages, ['??', inttostr(time), opName])));
   end;
 end;

library/fsl/fsl_lang.pas

@@ -139,13 +139,18 @@   TIETFLang = class (TFslObject)
     function isLangRegion : boolean;
   end;
 
+  { TIETFLanguageEntry }
+
   TIETFLanguageEntry = class (TFslObject)
   private
     FCode: String;
-    FDisplay: String;
+    FDisplays: TStringList;
   public
+    constructor Create; override;
+    destructor Destroy; override;
+
     property code : String read FCode write FCode;
-    property display : String read FDisplay write FDisplay;
+    property displays : TStringList read FDisplays;
   end;
 
   TIETFLanguageLanguage = class (TIETFLanguageEntry)
@@ -205,8 +210,9 @@   TIETFLanguageDefinitions = class (TFslObject)
     class function checkSource(source : String) : String;
     function parse(code : String; var msg : String) : TIETFLang; overload;
     function parse(code : String) : TIETFLang; overload;
-    function present(code : TIETFLang) : String; overload;
-    function present(code : TIETFLang; template : String) : String; overload;
+    function present(code : TIETFLang; i : integer = 0) : String; overload;
+    function present(code : TIETFLang; i : integer; template : String) : String; overload;
+    function displayCount(code : TIETFLang) : integer;
 
     function getDisplayForRegion(code : String):String;
     function getDisplayForLang(code : String):String;
@@ -604,6 +610,21 @@ function TIETFLang.matches(other: TIETFLang): boolean;
   exit(FLanguage = other.FLanguage);
 end;
 
+{ TIETFLanguageEntry }
+
+constructor TIETFLanguageEntry.Create;
+begin
+  inherited Create;
+  FDisplays := TStringList.create;
+  FDisplays.Delimiter := '|';
+end;
+
+destructor TIETFLanguageEntry.Destroy;
+begin
+  FDisplays.free;
+  inherited Destroy;
+end;
+
 { TIETFLanguageDefinitions }
 
 constructor TIETFLanguageDefinitions.Create(source : String);
@@ -744,12 +765,17 @@ function TIETFLanguageDefinitions.parse(code: String): TIETFLang;
   result := parse(code, m);
 end;
 
-function TIETFLanguageDefinitions.present(code: TIETFLang; template: String): String;
+function TIETFLanguageDefinitions.present(code: TIETFLang; i : integer; template: String): String;
 begin
-  result := template.Replace('{{lang}}', FLanguages[code.language].display).Replace('{{region}}', FRegions[code.region].display);
+  result := template.Replace('{{lang}}', FLanguages[code.language].displays[i]).Replace('{{region}}', FRegions[code.region].displays[0]);
 end;
 
-function TIETFLanguageDefinitions.present(code: TIETFLang): String;
+function TIETFLanguageDefinitions.displayCount(code: TIETFLang): integer;
+begin
+  result := FLanguages[code.language].displays.Count;
+end;
+
+function TIETFLanguageDefinitions.present(code: TIETFLang; i : integer = 0): String;
 var
   b : TFslStringBuilder;
   first : boolean;
@@ -770,17 +796,17 @@ function TIETFLanguageDefinitions.present(code: TIETFLang): String;
   begin
     b := TFslStringBuilder.Create;
     try
-      b.append(FLanguages[code.language].display);
+      b.append(FLanguages[code.language].displays[i]);
       if (code.region <> '') or (code.script <> '') or (code.variant <> '') then
       begin
         b.Append(' (');
         first := true;
         if (code.script <> '') then
-          note('Script', FScripts[code.script].display);
+          note('Script', FScripts[code.script].displays[0]);
         if (code.region <> '') then
-          note('Region', FRegions[code.region].display);
+          note('Region', FRegions[code.region].displays[0]);
         if (code.variant <> '') then
-          note('Variant', FVariants[code.variant].display);
+          note('Variant', FVariants[code.variant].displays[0]);
         b.Append(')');
       end;
 
@@ -801,8 +827,12 @@ function TIETFLanguageDefinitions.readVars(st: TStringList; i: integer; vars: TF
     if not st[i].StartsWith(' ') then
     begin
       StringSplit(st[i], ':', l, r);
-      if not vars.ContainsKey(l.trim) then
-        vars.Add(l.trim, r.Trim);
+      l := l.trim;
+      r := r.trim;
+      if not vars.ContainsKey(l) then
+        vars.Add(l, r)
+      else
+        vars.Values[l] := vars.Values[l]+'|'+r;
     end;
     inc(i);
   end;
@@ -1108,7 +1138,7 @@ function TIETFLanguageDefinitions.loadExtLang(vars: TFslStringDictionary; i: int
   cc := TIETFLanguageExtLang.Create;
   try
     cc.code := vars['Subtag'];
-    cc.display := vars['Description'];
+    cc.displays.DelimitedText := vars['Description'];
     if FExtLanguages.ContainsKey(cc.code) then
       raise EFSLException.create('IETFLang: Unable to parse definitions expecting Type: duplicate extlang code '+cc.code+' at line '+inttostr(i+1));
     FExtLanguages.Add(cc.code, cc.Link);
@@ -1121,11 +1151,12 @@ function TIETFLanguageDefinitions.loadExtLang(vars: TFslStringDictionary; i: int
 function TIETFLanguageDefinitions.loadLanguage(vars : TFslStringDictionary; i: integer): integer;
 var
   cc : TIETFLanguageLanguage;
+  s : string;
 begin
   cc := TIETFLanguageLanguage.Create;
   try
     cc.code := vars['Subtag'];
-    cc.display := vars['Description'];
+    cc.displays.DelimitedText := vars['Description'];
     if (vars.ContainsKey('Suppress-Script')) then
       cc.sscript := vars['Suppress-Script'];
     if (vars.ContainsKey('Scope')) then
@@ -1146,7 +1177,7 @@ function TIETFLanguageDefinitions.loadRegion(vars: TFslStringDictionary; i: inte
   cc := TIETFLanguageRegion.Create;
   try
     cc.code := vars['Subtag'];
-    cc.display := vars['Description'];
+    cc.displays.DelimitedText := vars['Description'];
     if FRegions.ContainsKey(cc.code) then
       raise EFSLException.create('IETFLang: Unable to parse definitions expecting Type: duplicate region code '+cc.code+' at line '+inttostr(i+1));
     FRegions.Add(cc.code, cc.Link);
@@ -1163,7 +1194,7 @@ function TIETFLanguageDefinitions.loadScript(vars: TFslStringDictionary; i: inte
   cc := TIETFLanguageScript.Create;
   try
     cc.code := vars['Subtag'];
-    cc.display := vars['Description'];
+    cc.displays.DelimitedText := vars['Description'];
     if FScripts.ContainsKey(cc.code) then
       raise EFSLException.create('IETFLang: Unable to parse definitions expecting Type: duplicate script code '+cc.code+' at line '+inttostr(i+1));
     FScripts.Add(cc.code, cc.Link);
@@ -1180,7 +1211,7 @@ function TIETFLanguageDefinitions.loadVariant(vars: TFslStringDictionary; i: int
   cc := TIETFLanguageVariant.Create;
   try
     cc.code := vars['Subtag'];
-    cc.display := vars['Description'];
+    cc.displays.DelimitedText := vars['Description'];
     if FVariants.ContainsKey(cc.code) then
       raise EFSLException.create('IETFLang: Unable to parse definitions expecting Type: duplicate region code '+cc.code+' at line '+inttostr(i+1));
     FVariants.Add(cc.code, cc.Link);