Private Sub Test()
Debug.Print GetFacturaJSON
End Sub
Public Function GetFacturaJSON() As String
Dim FacturaList As Collection
Dim FacturaJSON As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = CurrentDb
Set rs = db.OpenRecordset("qrytblFacturasJSON")
Set FacturaList = New Collection
Do While Not rs.EOF
FacturaList.Add GetFacturaDict(db, rs)
rs.MoveNext
Loop
rs.Close
If FacturaList.Count > 1 Then ' use List/Collection
FacturaJSON = JsonConverter.ConvertToJson(FacturaList)
ElseIf FacturaList.Count = 1 Then ' FActuraDict as first level
FacturaJSON = JsonConverter.ConvertToJson(FacturaList(1))
End If
GetFacturaJSON = FacturaJSON
End Function
Private Function GetFacturaDict(ByVal db As DAO.Database, ByVal FacturaRs As DAO.Recordset) As Dictionary
Dim FacturaDict As Dictionary
Dim UsuariosList As Collection
Dim DictRsKeys() As String
DictRsKeys = Split("numDocumentoIdObligado,numFactura,tipoNota,numNota", ",")
Set FacturaDict = New Dictionary
Dim i As Long
For i = LBound(DictRsKeys) To UBound(DictRsKeys)
FacturaDict.Add DictRsKeys(i), FacturaRs.Fields(DictRsKeys(i)).Value
Next
Set UsuariosList = GetUsuariosCollection(db, FacturaRs!numFactura.Value) '<--- normaly a filter is required .. but won't work with this example data!
FacturaDict.Add "usuarios", UsuariosList
Set GetFacturaDict = FacturaDict
End Function
Private Function GetUsuariosCollection(ByVal db As DAO.Database, ByVal numFactura As String) As Collection
Dim UsuariosList As Collection
Set UsuariosList = New Collection
Dim rs As DAO.Recordset
' correct logic, but will not work with example data
'Set rs = db.OpenRecordset("select * from qrytblUsuariosJSON where numFactura = '" & Replace(numFactura, "'", "''") & "'")
' => without filter
Set rs = db.OpenRecordset("qrytblUsuariosJSON")
Do While Not rs.EOF
UsuariosList.Add GetUsuariosDict(db, rs)
rs.MoveNext
Loop
rs.Close
Set GetUsuariosCollection = UsuariosList
End Function
Private Function GetUsuariosDict(ByVal db As DAO.Database, ByVal UsuariosRs As DAO.Recordset)
Dim DictRsKeys() As String
DictRsKeys = Split("tipoDocumentoIdentificacion,numDocumentoIdentificacion,tipoUsuario,fechaNacimiento,codSexo,codPaisResidencia,codPaisOrigen" & _
",codMunicipioResidencia,codZonaTerritorialResidencia,incapacidad,consecutivo", ",")
Dim UsuariosDict As Dictionary
Set UsuariosDict = New Dictionary
Dim i As Long
For i = LBound(DictRsKeys) To UBound(DictRsKeys)
UsuariosDict.Add DictRsKeys(i), UsuariosRs.Fields(DictRsKeys(i)).Value
Next
' servicios
UsuariosDict.Add "servicios", GetServiciosDict(db, UsuariosRs!numFactura.Value) ' ... no List/Collection?
Set GetUsuariosDict = UsuariosDict
End Function
Private Function GetServiciosDict(ByVal db As DAO.Database, ByVal numFactura As String)
Dim DictRsKeys() As String
DictRsKeys = Split("tipoDocumentoIdentificacion,numDocumentoIdentificacion,tipoUsuario,fechaNacimiento,codSexo,codPaisResidencia,codPaisOrigen" & _
",codMunicipioResidencia,codZonaTerritorialResidencia,incapacidad,consecutivo", ",")
Dim ServiciosDict As Dictionary
Set ServiciosDict = New Dictionary
' consultas
ServiciosDict.Add "consultas", GetConsultasCollection(db, numFactura)
' procedimientos
ServiciosDict.Add "procedimientos", GetProcedimientosCollection(db, numFactura)
Set GetServiciosDict = ServiciosDict
End Function
Private Function GetConsultasCollection(ByVal db As DAO.Database, ByVal numFactura As String) As Collection
Dim ConsultasList As Collection
Set ConsultasList = New Collection
Dim rs As DAO.Recordset
' correct logic, but will not work with example data
'Set rs = db.OpenRecordset("select * from qrytblConsultasJSON where numFactura = '" & Replace(numFactura, "'", "''") & "'")
' => without filter
Set rs = db.OpenRecordset("qrytblConsultasJSON")
Do While Not rs.EOF
ConsultasList.Add GetConsultasDict(db, rs)
rs.MoveNext
Loop
rs.Close
Set GetConsultasCollection = ConsultasList
End Function
Private Function GetConsultasDict(ByVal db As DAO.Database, ByVal ConsultasRs As DAO.Recordset)
Dim DictRsKeys() As String
DictRsKeys = Split("codPrestador,fechaInicioAtencion,numAutorizacion,codConsulta,modalidadGrupoServicioTecSal,grupoServicios" & _
",codServicio,finalidadTecnologiaSalud,causaMotivoAtencion,codDiagnosticoPrincipal,codDiagnosticoRelacionado1" & _
",codDiagnosticoRelacionado2,codDiagnosticoRelacionado3,tipoDiagnosticoPrincipal,tipoDocumentoIdentificacion" & _
",numDocumentoIdentificacion,vrServicio,conceptoRecaudo,valorPagoModerador,numFEVPagoModerador,consecutivo", ",")
Dim ConsultasDict As Dictionary
Set ConsultasDict = New Dictionary
Dim i As Long
For i = LBound(DictRsKeys) To UBound(DictRsKeys)
ConsultasDict.Add DictRsKeys(i), ConsultasRs.Fields(DictRsKeys(i)).Value
Next
Set GetConsultasDict = ConsultasDict
End Function
Private Function GetProcedimientosCollection(ByVal db As DAO.Database, ByVal numFactura As String) As Collection
Dim ProcedimientosList As Collection
Set ProcedimientosList = New Collection
Dim rs As DAO.Recordset
' correct logic, but will not work with example data
'Set rs = db.OpenRecordset("select * from qrytblProcedimientosJSON where numFactura = '" & Replace(numFactura, "'", "''") & "'")
' => without filter
Set rs = db.OpenRecordset("qrytblProcedimientosJSON")
Do While Not rs.EOF
ProcedimientosList.Add GetProcedimientosDict(db, rs)
rs.MoveNext
Loop
rs.Close
Set GetProcedimientosCollection = ProcedimientosList
End Function
Private Function GetProcedimientosDict(ByVal db As DAO.Database, ByVal ProcedimientosRs As DAO.Recordset)
Dim DictRsKeys() As String
'DictRsKeys = Split("codPrestador,fechaInicioAtencion,idMIPRES,numAutorizacion,codProcedimiento,viaIngresoServicioSalud,modalidadGrupoServicioTecSal" & _
",grupoServicios,codServicio,finalidadTecnologiaSalud,codDiagnosticoPrincipal,codDiagnosticoRelacionado" & _
",codComplicacion,tipoDocumentoIdentificacion,numDocumentoIdentificacion,vrServicio,conceptoRecaudo,valorPagoModerador" & _
",numFEVPagoModerador,consecutivo", ",")
DictRsKeys = Split("codPrestador,fechaInicioAtencion,idMIPRES,numAutorizacion,viaIngresoServicioSalud,modalidadGrupoServicioTecSal" & _
",grupoServicios,codServicio,finalidadTecnologiaSalud,codDiagnosticoPrincipal,codDiagnosticoRelacionado" & _
",codComplicacion,tipoDocumentoIdentificacion,numDocumentoIdentificacion,vrServicio,conceptoRecaudo,valorPagoModerador" & _
",numFEVPagoModerador,consecutivo", ",")
Dim ProcedimientosDict As Dictionary
Set ProcedimientosDict = New Dictionary
Dim i As Long
For i = LBound(DictRsKeys) To UBound(DictRsKeys)
ProcedimientosDict.Add DictRsKeys(i), ProcedimientosRs.Fields(DictRsKeys(i)).Value
Next
Set GetProcedimientosDict = ProcedimientosDict
End Function
