ISHRC.Add

Example

Add a new HRI for every loaded CDO transaction and display some information about the observations tree for every CDO transaction.

sub main                     
  Dim aPatient
  Dim aFilter
  Dim aCDOForms, aCDOForm 
  Dim aConcepts, aProviderConcept
  Dim aProvider
  Dim aFormRootHRC
  Dim i
  Dim aMessage

  Set aPatient = Profile.SelectPatient
  set aFilter = Profile.CreateCdoFormFilter
  aFilter.PatientId = aPatient.Id
  set aCDOForms = Profile.LoadCdoForms(aFilter) ' ISHRObservations

  '--- Add Provider Information into every CDO form
  set aFilter = Profile.CreateConceptsFilter
  aFilter.AddConceptRef "IH", "IH191", False
  set aConcepts = Profile.LoadConcepts(aFilter)
  set aProviderConcept = aConcepts.Item(0) 

  set aProvider = Profile.LoadProvider(Profile.CurrentUserCode)

  for i = 0 to aCDOForms.Count - 1  
    set aFormRootHRC = aCDOForms.Item(i).AsHRC
    AppendObservedProvider aFormRootHRC, aProviderConcept, aProvider 
  next
  
  '--- Display forms content
  aMessage = "CDO Forms (Count = " & aCDOForms.Count & "):"    
  for i = 0 to aCDOForms.Count - 1  
    set aCDOForm = aCDOForms.Item(i) 'ISHRObservation
    aMessage = aMessage & vbNewLine & (i + 1) & ") " & aCDOForm.Name &_
      GetHRCInfo(aCDOForm.AsHRC, 0)  
  next   
  Profile.MsgBox(aMessage)
end sub

sub AppendObservedProvider(aFormRootHRC, aProviderConcept, aProvider)
  Dim aProvHRI, aObs
  Dim i
  
  const CID_IBCDO_HRIText = 100511
  set aProvHRI = nothing
  for i = 0 to aFormRootHRC.Count - 1
    set aObs = aFormRootHRC.Item(i)
    if (aObs.TypeId = CID_IBCDO_HRIText) and _ 
      (aObs.TermsetCode = aProviderConcept.Termset) and _ 
      (aObs.ConceptCode = aProviderConcept.Code) then
      set aProvHRI = aObs.AsHRI
    end if
  next 'i

  if aProvHRI is nothing then  
    set aProvHRI = aFormRootHRC.Add(CID_IBCDO_HRIText, aProviderConcept).AsHRI
    aProvHRI.Content.Value = aProvider.Code
  end if  
end sub 

function GetHRIInfo(aHRI, aLevel)
  Dim aInfo, aSep
  aSep = Space(4 * aLevel)
  aInfo = aSep & " * HRI name: " & aHRI.Name & vbTab & aHRI.TypeID & vbTab & aHRI.ConceptCode & VbNewLine
  GetHRIInfo = aInfo    
end function

function GetHRCInfo(aHRC, aLevel)
  Dim aInfo, aSep
  Dim i
  Dim aObs 
 
  aSep = Space(4 * aLevel)
  aInfo = vbNewLine &_ 
    aSep & " * HRC name: " & aHRC.Name & VbNewLine
    
  for i = 0 to aHRC.Count - 1
    set aObs = aHRC.Item(i)
    if aObs.IsHRI then
      aInfo = aInfo & GetHRIInfo(aObs.AsHRI, aLevel + 1)
    else          
      aInfo = aInfo & GetHRCInfo(aObs.AsHRC, aLevel + 1)
    end if 
  next

  GetHRCInfo = aInfo
end function