Merge pull request #178 from HealthIntersections/gg-202112-valueset-display

Gg 202112 valueset display

Author: grahamegrieve

.gitignore

@@ -73,4 +73,5 @@ exec/Resources
 /dependencies/Indy10-mod-static
 /dependencies/indy-master
 /release-notes.md
-/install/build
+/install/build
+/release-notes-old.md

build/linux-toolchain.sh

@@ -14,7 +14,7 @@ echo "Get fpclazup"
 
 mkdir tools
 
-wget -q https://github.com/LongDirtyAnimAlf/Reiniero-fpcup/releases/download/v2.2.0b/fpclazup-x86_64-linux -O tools/fpclazup
+wget -q https://github.com/LongDirtyAnimAlf/Reiniero-fpcup/releases/download/v2.2.0g/fpclazup-x86_64-linux -O tools/fpclazup
 
 chmod +x tools/fpclazup
 

library/ftx/fhir_valuesets.pas

@@ -169,7 +169,7 @@   TValueSetWorker = class (TFslObject)
     function sizeInBytesV(magic : integer) : cardinal; override;
     procedure listDisplays(displays : TCodeDisplays; cs : TCodeSystemProvider; c: TCodeSystemProviderContext); overload;
     procedure listDisplays(displays : TCodeDisplays; c: TFhirCodeSystemConceptW); overload;
-    procedure listDisplays(displays: TCodeDisplays; c: TFhirValueSetComposeIncludeConceptW); overload;
+    procedure listDisplays(displays: TCodeDisplays; c: TFhirValueSetComposeIncludeConceptW; vs : TFHIRValueSetW); overload;
   public
     constructor Create(factory : TFHIRFactory; getVS: TGetValueSetEvent; getCS : TGetProviderEvent; getVersions : TGetSystemVersionsEvent; txResources : TFslMetadataResourceList; languages : TIETFLanguageDefinitions); overload;
     destructor Destroy; override;
@@ -185,7 +185,7 @@   TValueSetChecker = class (TValueSetWorker)
     function determineSystem(code : String) : String;
     function check(system, version, code : String; abstractOk, implySystem : boolean; displays : TCodeDisplays; var message, ver : String; var cause : TFhirIssueType; op : TFhirOperationOutcomeW; var contentMode : TFhirCodeSystemContentMode) : boolean; overload;
     function findCode(cs : TFhirCodeSystemW; code: String; list : TFhirCodeSystemConceptListW; displays : TCodeDisplays; out isabstract : boolean): boolean;
-    function checkConceptSet(cs: TCodeSystemProvider; cset : TFhirValueSetComposeIncludeW; code : String; abstractOk : boolean; displays : TCodeDisplays; var message : String) : boolean;
+    function checkConceptSet(cs: TCodeSystemProvider; cset : TFhirValueSetComposeIncludeW; code : String; abstractOk : boolean; displays : TCodeDisplays; vs : TFHIRValueSetW; var message : String) : boolean;
     procedure prepareConceptSet(desc: string; cc: TFhirValueSetComposeIncludeW);
     function getName: String;
   protected
@@ -220,7 +220,7 @@   TFHIRValueSetExpander = class (TValueSetWorker)
     procedure handleDefine(cs : TFhirCodeSystemW; list : TFslList<TFhirValueSetExpansionContainsW>; map : TFslMap<TFhirValueSetExpansionContainsW>; limitCount : integer; source : TFhirValueSetCodeSystemW; defines : TFhirCodeSystemConceptListW; filter : TSearchFilterText; expansion : TFhirValueSetExpansionW; imports : TFslList<TFHIRImportedValueSet>);
     procedure importValueSet(list : TFslList<TFhirValueSetExpansionContainsW>; map : TFslMap<TFhirValueSetExpansionContainsW>; vs : TFHIRValueSetW; expansion : TFhirValueSetExpansionW; imports : TFslList<TFHIRImportedValueSet>; offset : integer);
     procedure excludeValueSet(list: TFslList<TFhirValueSetExpansionContainsW>; map: TFslMap<TFhirValueSetExpansionContainsW>; vs : TFHIRValueSetW; expansion : TFhirValueSetExpansionW; imports : TFslList<TFHIRImportedValueSet>; offset : integer);
-    procedure processCodes(doDelete : boolean; list : TFslList<TFhirValueSetExpansionContainsW>; map : TFslMap<TFhirValueSetExpansionContainsW>; limitCount : integer; cset : TFhirValueSetComposeIncludeW; filter : TSearchFilterText; dependencies : TStringList; expansion : TFhirValueSetExpansionW; var notClosed : boolean);
+    procedure processCodes(doDelete : boolean; list : TFslList<TFhirValueSetExpansionContainsW>; map : TFslMap<TFhirValueSetExpansionContainsW>; limitCount : integer; cset : TFhirValueSetComposeIncludeW; vsSrc : TFHIRValueSetW; filter : TSearchFilterText; dependencies : TStringList; expansion : TFhirValueSetExpansionW; var notClosed : boolean);
     procedure handleCompose(list : TFslList<TFhirValueSetExpansionContainsW>; map : TFslMap<TFhirValueSetExpansionContainsW>; limitCount : integer; source : TFhirValueSetW; filter : TSearchFilterText; dependencies : TStringList; expansion : TFhirValueSetExpansionW; var notClosed : boolean);
 
     function passesImports(imports : TFslList<TFHIRImportedValueSet>; system, code : String; offset : integer) : boolean;
@@ -769,7 +769,7 @@ function TValueSetChecker.check(system, version, code : String; abstractOk, impl
               raise ETerminologyError.create('Value Set Validation depends on supplement '+s+' on '+cs.systemUri(nil)+' that is not known');
           end;
 
-          result := ((system = SYSTEM_NOT_APPLICABLE) or (cs.systemUri(nil) = system)) and checkConceptSet(cs, cc, code, abstractOk, displays, message);
+          result := ((system = SYSTEM_NOT_APPLICABLE) or (cs.systemUri(nil) = system)) and checkConceptSet(cs, cc, code, abstractOk, displays, FValueSet, message);
         end
         else
           result := false;
@@ -799,7 +799,7 @@ function TValueSetChecker.check(system, version, code : String; abstractOk, impl
               if not cs.hasSupplement(s) then
                 raise ETerminologyError.create('Value Set Validation depends on supplement '+s+' on '+cs.systemUri(nil)+' that is not known');
             end;
-            excluded := ((system = SYSTEM_NOT_APPLICABLE) or (cs.systemUri(nil) = system)) and checkConceptSet(cs, cc, code, abstractOk, displays, message);
+            excluded := ((system = SYSTEM_NOT_APPLICABLE) or (cs.systemUri(nil) = system)) and checkConceptSet(cs, cc, code, abstractOk, displays, FValueSet, message);
           end;
           for s in cc.valueSets do
           begin
@@ -1082,7 +1082,7 @@ function TValueSetChecker.check(system, version, code: String; implySystem : boo
     cs.Close(ctxt);
 end;
 
-function TValueSetChecker.checkConceptSet(cs: TCodeSystemProvider; cset : TFhirValueSetComposeIncludeW; code: String; abstractOk : boolean; displays : TCodeDisplays; var message : String): boolean;
+function TValueSetChecker.checkConceptSet(cs: TCodeSystemProvider; cset : TFhirValueSetComposeIncludeW; code: String; abstractOk : boolean; displays : TCodeDisplays; vs : TFHIRValueSetW; var message : String): boolean;
 var
   i : integer;
   fc : TFhirValueSetComposeIncludeFilterW;
@@ -1117,7 +1117,7 @@ function TValueSetChecker.checkConceptSet(cs: TCodeSystemProvider; cset : TFhirV
       if Loc <> nil then
       begin
         listDisplays(displays, cs, loc);
-        listDisplays(displays, cc);
+        listDisplays(displays, cc, vs);
         result := (abstractOk or not cs.IsAbstract(loc));
         cs.close(loc);
         exit;
@@ -1463,9 +1463,9 @@ procedure TFHIRValueSetExpander.handleCompose(list: TFslList<TFhirValueSetExpans
     checkSource(c, expansion, limitCount, filter);
 
   for c in source.includes.forEnum do
-    processCodes(false, list, map, limitCount, c, filter, dependencies, expansion, notClosed);
+    processCodes(false, list, map, limitCount, c, source, filter, dependencies, expansion, notClosed);
   for c in source.excludes.forEnum do
-    processCodes(true, list, map, limitCount, c, filter, dependencies, expansion, notClosed);
+    processCodes(true, list, map, limitCount, c, source, filter, dependencies, expansion, notClosed);
 end;
 
 procedure TFHIRValueSetExpander.handleDefine(cs : TFhirCodeSystemW; list : TFslList<TFhirValueSetExpansionContainsW>; map : TFslMap<TFhirValueSetExpansionContainsW>; limitCount : integer; source : TFhirValueSetCodeSystemW; defines : TFhirCodeSystemConceptListW; filter : TSearchFilterText; expansion : TFhirValueSetExpansionW; imports : TFslList<TFHIRImportedValueSet>);
@@ -1506,11 +1506,16 @@ procedure TValueSetWorker.listDisplays(displays : TCodeDisplays; c: TFhirCodeSys
     displays.see(ccd.language, ccd.value);
 end;
 
-procedure TValueSetWorker.listDisplays(displays : TCodeDisplays; c: TFhirValueSetComposeIncludeConceptW);
+procedure TValueSetWorker.listDisplays(displays : TCodeDisplays; c: TFhirValueSetComposeIncludeConceptW; vs : TFHIRValueSetW);
 var
   cd : TFhirValueSetComposeIncludeConceptDesignationW;
   first : boolean;
 begin
+  if c.display <> '' then
+  begin
+    displays.Clear;
+    displays.see(vs.language, c.display, true);
+  end;
   first := true;
   for cd in c.designations.forEnum do
   begin
@@ -1813,7 +1818,7 @@ procedure TFHIRValueSetExpander.checkSource(cset: TFhirValueSetComposeIncludeW;
   end;
 end;
 
-procedure TFHIRValueSetExpander.processCodes(doDelete : boolean; list: TFslList<TFhirValueSetExpansionContainsW>; map: TFslMap<TFhirValueSetExpansionContainsW>; limitCount : integer; cset: TFhirValueSetComposeIncludeW; filter : TSearchFilterText; dependencies : TStringList; expansion : TFhirValueSetExpansionW; var notClosed : boolean);
+procedure TFHIRValueSetExpander.processCodes(doDelete : boolean; list: TFslList<TFhirValueSetExpansionContainsW>; map: TFslMap<TFhirValueSetExpansionContainsW>; limitCount : integer; cset: TFhirValueSetComposeIncludeW; vsSrc : TFHIRValueSetW; filter : TSearchFilterText; dependencies : TStringList; expansion : TFhirValueSetExpansionW; var notClosed : boolean);
 var
   cs : TCodeSystemProvider;
   i, count, offset : integer;
@@ -1986,7 +1991,7 @@ procedure TFHIRValueSetExpander.processCodes(doDelete : boolean; list: TFslList<
                 if (cctxt <> nil) and (not FParams.activeOnly or not cs.IsInactive(cctxt)) and passesFilters(cctxt, 0) then
                 begin
                   listDisplays(cds, cs, cctxt);
-                  listDisplays(cds, cc);
+                  listDisplays(cds, cc, vsSrc);
                   if filter.passes(cds) or filter.passes(cc.code) then
                     processCode(doDelete, limitCount, list, map, cs.systemUri(nil), cs.version(nil), cc.code, cds, cs.Definition(cctxt), expansion, valueSets);
                 end;

library/fui/fui_lcl_managers.pas

@@ -61,12 +61,31 @@
 
   TControlOperation = (copNone, copAdd, copAddSet, copEdit, copDelete, copUp, copDown, copReload, copExecute, copRefresh, copStop, copCopy, copUpdate);
 
+  { TControlEntryMenuItem }
+
+  TControlEntryMenuItem = class (TFslObject)
+  private
+    FMenuItem: TMenuItem;
+    FMode: String;
+    FOp: TControlOperation;
+  public
+    function link : TControlEntryMenuItem; overload;
+
+    property menuItem : TMenuItem read FMenuItem write FMenuItem;
+    property op : TControlOperation read FOp write FOp;
+    property mode : String read FMode write FMode;
+  end;
+
   TControlEntry = class (TFslObject)
   private
     FControl: TControl;
     FMode: String;
     FOp: TControlOperation;
+    FMenuItems : TFslList<TControlEntryMenuItem>;
+    FMenu : TPopupMenu;
   public
+    destructor Destroy; override;
+
     function link : TControlEntry; overload;
 
 
@@ -93,6 +112,7 @@   TListOrTreeManagerBase = class abstract (TFslObject)
     procedure doControl(sender : TObject); virtual; abstract;
     procedure doMnuClick(Sender: TObject); virtual; abstract;
     procedure updateControls(op : TControlOperation; allowed : boolean);
+    procedure updateMenuControls;
     procedure SetImages(AValue: TImagelist); virtual;
   public
     constructor Create; override;
@@ -106,7 +126,9 @@   TListOrTreeManagerBase = class abstract (TFslObject)
     procedure getCopyModes(modes : TStringList); virtual;
 
     procedure registerControl(c : TControl; op : TControlOperation; mode : String = '');
-    function registerMenuEntry(caption : String; imageIndex : integer; op : TControlOperation; mode : String = '') : TMenuItem;
+    function registerControlForMenu(c : TControl; menu : TPopupMenu) : TControlEntry;
+    function registerMenuEntry(caption : String; imageIndex : integer; op : TControlOperation; mode : String = '') : TMenuItem; overload;
+    function registerMenuEntry(grp : TControlEntry; caption : String; imageIndex : integer; op : TControlOperation; mode : String = '') : TMenuItem; overload;
     function registerSubMenuEntry(parent : TMenuItem; caption : String; imageIndex : integer; op : TControlOperation; mode : String = '') : TMenuItem;
   end;
 
@@ -555,6 +577,13 @@   TPanelStack = class (TFslObject)
 
 Implementation
 
+{ TControlEntryMenuItem }
+
+function TControlEntryMenuItem.link: TControlEntryMenuItem;
+begin
+  result := TControlEntryMenuItem(inherited link);
+end;
+
 { TPanelStackSubPanel }
 
 constructor TPanelStackSubPanel.create(container, heading: TPanel);
@@ -679,6 +708,12 @@ procedure TObjectManager.registerControl(propName: String; control: TCheckBox);
 
 { TControlEntry }
 
+destructor TControlEntry.Destroy;
+begin
+  FMenuItems.Free;
+  inherited Destroy;
+end;
+
 function TControlEntry.link: TControlEntry;
 begin
   result := TControlEntry(inherited link);
@@ -727,6 +762,20 @@ procedure TListOrTreeManagerBase.registerControl(c : TControl; op : TControlOper
   end;
 end;
 
+function TListOrTreeManagerBase.registerControlForMenu(c: TControl; menu : TPopupMenu): TControlEntry;
+begin
+  result := TControlEntry.create;
+  try
+    result.control := c;
+    result.op := copNone;
+    result.FMenu := menu;
+    c.enabled := false;
+    FControls.add(result.link);
+  finally
+    result.free;
+  end;
+end;
+
 function TListOrTreeManagerBase.registerMenuEntry(caption: String; imageIndex: integer; op: TControlOperation; mode : String = '') : TMenuItem;
 var
   list : TStringList;
@@ -758,6 +807,22 @@ function TListOrTreeManagerBase.registerMenuEntry(caption: String; imageIndex: i
   end;
 end;
 
+function TListOrTreeManagerBase.registerMenuEntry(grp: TControlEntry; caption: String; imageIndex: integer; op: TControlOperation; mode: String): TMenuItem;
+var
+  list : TStringList;
+  i : integer;
+begin
+  result  := TMenuItem.create(nil);
+  grp.FMenu.Items.add(result);
+  result.caption := caption;
+  result.imageIndex := imageIndex;
+  result.Tag := Integer(op);
+  if mode <> '' then
+    result.name := 'mnuMode'+mode;
+  if op <> copNone then
+    result.OnClick := doMnuClick;
+end;
+
 function TListOrTreeManagerBase.registerSubMenuEntry(parent: TMenuItem; caption: String; imageIndex: integer; op: TControlOperation; mode: String): TMenuItem;
 begin
   result  := TMenuItem.create(nil);
@@ -783,13 +848,38 @@ procedure TListOrTreeManagerBase.updateControls(op: TControlOperation; allowed:
   i : integer;
 begin
   for entry in FControls do
+  begin
     if entry.op = op then
       entry.control.enabled := allowed;
+    if (entry.FMenu <> nil) then
+      for i := 0 to entry.FMenu.Items.Count - 1 do
+        if (TControlOperation(entry.FMenu.Items[i].tag) = op) then
+          entry.FMenu.Items[i].enabled := allowed;
+  end;
   for i := 0 to FPopup.Items.Count - 1 do
     if (TControlOperation(FPopup.Items[i].tag) = op) then
       FPopup.Items[i].enabled := allowed;
 end;
 
+procedure TListOrTreeManagerBase.updateMenuControls;
+var
+  entry : TControlEntry;
+  i : integer;
+  ok : boolean;
+begin
+  for entry in FControls do
+  begin
+    if (entry.FMenu <> nil) then
+    begin
+      ok := false;
+      for i := 0 to entry.FMenu.Items.Count - 1 do
+        if entry.FMenu.Items[i].Enabled then
+          ok := true;
+      entry.control.Enabled := ok;
+    end;
+  end;
+end;
+
 { TListManager }
 
 constructor TListManager<T>.Create;
@@ -973,6 +1063,7 @@ procedure TListManager<T>.updateStatus;
   updateControls(copUpdate, opUpdate in ops);
   updateControls(copStop, opStop in ops);
   updateControls(copCopy, FHasCopy);
+  updateMenuControls();
   FCanEdit := opEdit in ops;
 
   focusItemChange(focus);
@@ -2011,6 +2102,7 @@ procedure TTreeManager<T>.updateStatus;
   updateControls(copUpdate, opUpdate in ops);
   updateControls(copStop, opStop in ops);
   updateControls(copCopy, FHasCopy);
+  updateMenuControls;
   FCanEdit := opEdit in ops;
 
   focusItemChange(focus);
@@ -2536,6 +2628,7 @@ procedure TVTreeManager<T>.updateStatus;
   updateControls(copUpdate, opUpdate in ops);
   updateControls(copStop, opStop in ops);
   updateControls(copCopy, FHasCopy);
+  updateMenuControls;
   FCanEdit := opEdit in ops;
 
   focusItemChange(focus);

server/client_cache_manager.pas

@@ -118,8 +118,11 @@ procedure TClientCacheManagerEntry.update(list: TFslMetadataResourceList);
     FList.RemoveAll(remove);
     for i in list do
     begin
-      FSize := FSize + i.sizeInBytes(magic);
-      FList.Add(i.link);
+      if (i.url <> '') then
+      begin
+        FSize := FSize + i.sizeInBytes(magic);
+        FList.Add(i.link);
+      end;
     end;
   finally
     remove.Free;

server/fhirserver.res

@@ -1,3 +1,4 @@
+<?xml version="1.0" encoding="UTF-8"?>
 <CONFIG>
   <ProjectOptions>
     <Version Value="12"/>
@@ -16,9 +17,7 @@
     <VersionInfo>
       <UseVersionInfo Value="True"/>
       <MajorVersionNr Value="2"/>
-      <MinorVersionNr Value="0"/>
       <RevisionNr Value="9"/>
-      <Attributes pvaDebug="False"/>
     </VersionInfo>
     <BuildModes>
       <Item Name="default" Default="True"/>