formyxhz.frm

本系统可用于医院和专业体检中心的健康体检管理

        strTJ = " from SET_GRXX,FZ_FZSJ,FZ_FZSY,SET_TJBZDT,set_xx_bz,[Data_" & strDXPYSX & "]" _
                & " where not (SET_GRXX.YYID is null)" _
                & " and SET_GRXX.YYID=FZ_FZSJ.YYID" _
                & " and SET_GRXX.GUID=FZ_FZSJ.GUID"
        If cmbDWei.Text <> "" Then
            '只有选择团体时才加下一判断
            strTJ = strTJ & " and FZ_FZSJ.YYID='" & arrYYID(cmbDWei.ItemData(cmbDWei.ListIndex)) & "'"
        End If
         '数值型或计算型项目，跟据新的标准查询，说明型根据原有标准查询
        If intType = 1 Or intType = 3 Then
            strTJ = strTJ & " and FZ_FZSJ.FZID=FZ_FZSY.FZID" _
                & " and FZ_FZSY.BZID=SET_TJBZDT.BZID" _
                & " and SET_TJBZDT.XMID='" & strXMID & "'" _
                & " and [Data_" & strDXPYSX & "].GUID=SET_GRXX.GUID and set_xx_bz.xx_id=SET_TJBZDT.XMID and set_xx_bz.zcz='正常值'"
        Else
            strTJ = strTJ & " and FZ_FZSJ.FZID=FZ_FZSY.FZID" _
                & " and FZ_FZSY.BZID=SET_TJBZDT.BZID" _
                & " and SET_TJBZDT.XMID='" & strXMID & "'" _
                & " and [Data_" & strDXPYSX & "].GUID=SET_GRXX.GUID "
        End If
        
        If cmbDWei.Text = "" Then
            '这个时候要考虑到散检客户
            strSJ = " from SET_GRXX,YY_SJDJ,SET_TJBZDT,set_xx_bz,[Data_" & strDXPYSX & "]" _
                    & " where SET_GRXX.GUID in (" _
                    & "select GUID from YY_SJDJDX"
            '说明选择的是小项
            strSJ = strSJ & " where DXID='" & Mid(tvwXMu.SelectedItem.Parent.Key, 2) & "'"
            strSJ = strSJ & ")"
            strSJ = strSJ & " and SET_GRXX.GUID=[Data_" & strDXPYSX & "].GUID" _
                    & " and SET_GRXX.GUID=YY_SJDJ.GUID" _
                    & " and YY_SJDJ.BZID=SET_TJBZDT.BZID" _
                    & " and SET_TJBZDT.XMID='" & strXMID & "'" _
                    & " and SFTJ=2 "
                    
             '数值型或计算型项目，跟据新的标准查询，说明型根据原有标准查询
            If intType = 1 Or intType = 3 Then
                strSJ = strSJ & "and set_xx_bz.xx_id=SET_TJBZDT.XMID and set_xx_bz.zcz='正常值'"
            End If
        End If
        
        '***********************************
        '构建最后的查询语句
        '***********************************
        If strSJ = "" Then
            strSQL = strSelect & strTJ & strCondition
        Else
            strSQL = strSelect & strTJ & strCondition _
                    & " union " _
                    & strSelect & strSJ & strCondition
        End If
        
        '***********************************
        '执行查询
        '***********************************
        Set rsHZ = New ADODB.Recordset
        rsHZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rsHZ.RecordCount >= 1 Then
            rsHZ.Close
            Set rsHZ = Nothing
            RefreshGrid Me, MSHFlexGrid1, strSQL
        Else
            MsgBox "没有找到匹配记录！请重新输入查询条件", vbInformation, "提示"
            MSHFlexGrid1.Clear
        End If
        
    End If
    
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub Form_Load()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim i As Integer
    
    Screen.MousePointer = vbArrowHourglass
    
    dtpBegin.Value = Date
    dtpStop.Value = Date
    Me.MSHFlexGrid1.ColWidth(0) = 0
    
    Me.Height = 8505
    Me.Width = 10800
    
    '显示所有项目
    ShowXiangMu True
    
    '显示所有预约的团体
    '刷新团体信息
    strSQL = "select YYID,DWMC" _
            & " from YY_TJDJ,SET_DW" _
            & " where YY_TJDJ.DWID=SET_DW.DWID" _
            & " order by JLRQ desc"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
    cmbDWei.Clear
    If rstemp.RecordCount > 0 Then
        ReDim arrYYID(rstemp.RecordCount)
        
        '首先添加一个空行，以便用户不选择单位
        cmbDWei.AddItem ""
        
        '添加已经预约过的团体
        rstemp.MoveFirst
        For i = 1 To rstemp.RecordCount
            cmbDWei.AddItem rstemp("DWMC")
            cmbDWei.ItemData(cmbDWei.NewIndex) = i
            arrYYID(i) = rstemp("YYID") 'YYID字段太长，ItemData属性无法存放，只能存入数组
            
            rstemp.MoveNext
        Next
        rstemp.Close
        Set rstemp = Nothing
        
        cmbDWei.ListIndex = 0
    End If
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set FormYXHZ = Nothing
End Sub

Private Sub MSHFlexGrid1_DblClick()
    If Me.MSHFlexGrid1.TextMatrix(1, 1) <> "" Then
        frmTJResult.ShowPersonInfo Val(Me.MSHFlexGrid1.TextMatrix(Me.MSHFlexGrid1.Row, 0)), Me.MSHFlexGrid1.TextMatrix(Me.MSHFlexGrid1.Row, 2)
    End If
End Sub

'显示所有项目（对团检和散检），部分项目（对团检）
Private Sub ShowXiangMu(ByVal blnAll As Boolean, Optional ByVal strYYID As String)
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim nodTemp As Node
    Dim nodRoot As MSComctlLib.Node
    Dim rsKShi As ADODB.Recordset
    Dim rsDX As ADODB.Recordset
    Dim rsXX As ADODB.Recordset
    Dim i As Integer
    
    Me.MousePointer = vbHourglass
    
    tvwXMu.Nodes.Clear
    
'    If blnAll = False Then
'        tvwXMu.CheckBoxes = True
'    Else
'        tvwXMu.CheckBoxes = False
'    End If
    
    '首先显示一个根节点
    Set nodRoot = tvwXMu.Nodes.Add(, , "W", "所有项目")
    nodRoot.Expanded = True
    
    '显示所有科室
    strSQL = "select KSID,KSMC from SET_KSSZ"
    If blnAll = False Then
        '如果不是显示所有科室，则只显示有选择的科室
        strSQL = strSQL & " where KSID in (" _
                & "select left(DXID,2) from YY_SJDJDX" _
                & " where GUID in (" _
                    & "select GUID from SET_GRXX" _
                    & " where YYID='" & strYYID & "')" _
                & ")"
    End If
    '按顺序号排序
    strSQL = strSQL & " order by SXH"
    Set rsKShi = New ADODB.Recordset
    rsKShi.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsKShi.RecordCount > 0 Then
        rsKShi.MoveFirst
        Do
            '添加科室
            '关键字长度：1＋2＝3
            Set nodTemp = tvwXMu.Nodes.Add("W", tvwChild, "W" & rsKShi("KSID"), rsKShi("KSMC"))
'            nodTemp.Expanded = True
            
            strSQL = "select DXID,DXMC,DXSFYZX from SET_DX" _
                    & " where left(DXID,2)='" & rsKShi("KSID") & "'"
            If blnAll = False Then
                '如果不是显示所有项目，则只显示有选择的大项
                strSQL = strSQL & " and DXID in(" _
                        & "select distinct DXID from YY_SJDJDX" _
                        & " where GUID in (" _
                            & "select GUID from SET_GRXX" _
                            & " where YYID='" & strYYID & "')" _
                        & ")"
            End If
            '判断性别
            If optMale.Value = True Then '男性
                strSQL = strSQL & " and DXNNTY<>2"
            ElseIf optFemale.Value = True Then '女性
                strSQL = strSQL & " and DXNNTY<>1"
            End If
            
            '按顺序号排序
            strSQL = strSQL & " order by SXH"
            Set rsDX = New ADODB.Recordset
            rsDX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            If rsDX.RecordCount > 0 Then
                rsDX.MoveFirst
                Do
                    '添加大项
                    '关键字长度：1＋4＝5
                    Set nodTemp = tvwXMu.Nodes.Add("W" & rsKShi("KSID"), tvwChild, "W" & rsDX("DXID"), rsDX("DXMC"))
'                    nodTemp.Expanded = True
                    
                    If rsDX("DXSFYZX") = 1 Then '有子项
                        strSQL = "select XXID,XXMC from SET_XX" _
                                & " where XXID in (" _
                                    & "select XXID from SET_ZH_Data" _
                                    & " where DXID='" & rsDX("DXID") & "'" _
                                & ")"
                        '判断性别
                        If optMale.Value = True Then '男性
                            strSQL = strSQL & " and XXNNTY<>2"
                        ElseIf optFemale.Value = True Then '女性
                            strSQL = strSQL & " and XXNNTY<>1"
                        End If
                        
                        '按顺序号排序
                        strSQL = strSQL & " order by SXH"
                        Set rsXX = New ADODB.Recordset
                        rsXX.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
                        If rsXX.RecordCount > 0 Then
                            rsXX.MoveFirst
                            Do
                                '添加小项
                                '关键字长度：1＋4＋7＝12
                                tvwXMu.Nodes.Add "W" & rsDX("DXID"), tvwChild, "W" & rsDX("DXID") & rsXX("XXID"), rsXX("XXMC")
'                                nodTemp.Expanded = True
                                
                                rsXX.MoveNext
                            Loop Until rsXX.EOF
                            rsXX.Close
                        End If
                    End If
                     
                    rsDX.MoveNext
                Loop Until rsDX.EOF
                rsDX.Close
            End If
            
            rsKShi.MoveNext
        Loop Until rsKShi.EOF
        rsKShi.Close
    End If
    
    '如果是团检，则选中根节点
    If blnAll = False Then
        nodRoot.Checked = True
        tvwXMu_NodeCheck nodRoot
    End If
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub tvwXMu_NodeCheck(ByVal Node As MSComctlLib.Node)
On Error Resume Next
    Dim strKey As String
    Dim i As Integer
    
'    If tvwXMu.SelectedItem Is Nothing Then Exit Sub
    If cmbDWei.Text = "" Then Exit Sub
    
    strKey = Mid(Node.Key, 2)
    If Node.Checked = False Then
        For i = 1 To tvwXMu.Nodes.Count
            If Node.Parent Is tvwXMu.Nodes(i) Then
                If Err.Number = 0 Then
                    tvwXMu.Nodes(i).Checked = False
                Else
                    Err.Clear
                End If
            ElseIf Node.Parent.Parent Is tvwXMu.Nodes(i) Then
                If Err.Number = 0 Then
                    tvwXMu.Nodes(i).Checked = False
                Else
                    Err.Clear
                End If
            ElseIf Node.Parent.Parent.Parent Is tvwXMu.Nodes(i) Then
                If Err.Number = 0 Then
                    tvwXMu.Nodes(i).Checked = False
                Else
                    Err.Clear
                End If
            End If
        Next
        
        Exit Sub
    End If
    
    Err.Clear
    Select Case Len(strKey)
        Case 0 '选择了根节点
            '选中所有节点
            For i = 1 To tvwXMu.Nodes.Count
                tvwXMu.Nodes(i).Checked = True
            Next
        Case 2 '选择了科室
            '选中科室下的所有节点
            For i = 1 To tvwXMu.Nodes.Count
                If tvwXMu.Nodes(i).Parent Is Node Then
                    If Err.Number = 0 Then
                        tvwXMu.Nodes(i).Checked = True
                    Else
                        Err.Clear
                    End If
                Else
                    If tvwXMu.Nodes(i).Parent.Parent Is Node Then
                        If Err.Number = 0 Then
                            tvwXMu.Nodes(i).Checked = True
                        Else
                            Err.Clear
                        End If
                    End If
                End If
            Next
        Case 4 '选择了大项
            '选中大项下的所有节点
            For i = 1 To tvwXMu.Nodes.Count
                If tvwXMu.Nodes(i).Parent Is Node Then
                    If Err.Number = 0 Then
                        tvwXMu.Nodes(i).Checked = True
                    Else
                        Err.Clear
                    End If
                End If
            Next
        Case 7 '选择了小项
        '
    End Select
End Sub