frmwjyc.frm

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

'            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")
'
'                                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 cmbDWei_Click()
   If cmbDWei.Text <> "" Then
      
       YYID = arrYYID(cmbDWei.ItemData(cmbDWei.ListIndex))
       
   End If
End Sub

Private Sub cmdExit_Click()
   Unload Me
End Sub

Private Sub cmdOK_Click()
   On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strTemp As String
    Dim strSelect As String
    Dim strTJ As String
    Dim strCondition As String
    Dim strKSMC As String
    Dim rstemp As ADODB.Recordset
    Dim rsPerson As ADODB.Recordset
    Dim rsHZ As ADODB.Recordset
    Dim nodTemp As Node
    Dim blnKShi As Boolean '是否选择了科室。使用变量避免多次访问控件
    Dim blnExportZJJL As Boolean
    Dim blnExportZJJY As Boolean
    Dim strOldColumn As String
    
    Dim strDXPYSX As String
    Dim strXXPYSX As String
    Dim intType As Integer
    Dim strXMID As String
    Dim strFileName As String
    Dim i As Integer, j As Integer, l As Integer
    Dim arrKSMC() As String '按科室导出时的列标题
    Dim arrKSMC_XX() As String
    Dim arrXXTitle() As String '按项目导出时的列标题
    Dim arrXXMC() As String
    Dim arrDXPYSX() As String
    Dim arrXXID() As String
    Dim arrXXPYSX() As String
    Dim arrXXType() As Integer
    Dim intXXIndex As Integer
    Dim blnHave As Boolean
    Dim blnSel As Boolean
    Dim strYYID As String
    Dim strUnnormal As String
    Dim strColTitle As String
    Dim lngGUID As Long
    
    '获取文件名
    strFileName = GetFileName(Me.CommonDialog1, "Microsoft Excel 工作簿（*.xls）|*.xls", "另存为", _
            lvwDWei.SelectedItem.SubItems(1) & " 未见异常名单导出.xls", WRITEFILE)
    If strFileName = "" Then GoTo ExitLab
    
    Me.MousePointer = vbHourglass
    
    

    strYYID = lvwDWei.SelectedItem.Text
     strSQL = "select HealthID as 档案号,yyrxm as 姓名,sex as 性别,age as 年龄,hf as 婚否 ,data_zjjl.Jlvalue as 总检结论 from set_grxx, Data_zjjl where set_grxx.yyid='" & strYYID & "' and data_zjjl.Guid=Set_grxx.guid and data_zjjl.JLValue='已体检项目未见异常。'"
    
      ExportToExcel strSQL, strFileName, lvwDWei.SelectedItem.SubItems(1)
    
    GoTo ExitLab
    

    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
'    If Err.Number = VARCHAR_TO_FLOAT_ERROR Then
''        GoTo ErrorResume
'    End If
    Resume Next
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
    Dim itmTemp As ListItem
    
    Screen.MousePointer = vbHourglass
    Me.Top = 2000
    Me.Left = 2000
    '选中项目树中所有节点
'    SelectNodeAll
    
    lvwDWei.View = lvwReport
    lvwDWei.FullRowSelect = True
    lvwDWei.LabelEdit = lvwManual

    '显示所有预约的团体
    '刷新团体信息

    strSQL = "select YYID,DWMC,TJRQ" _
            & " 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, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount > 0 Then
        ReDim arrYYID(rstemp.RecordCount)
                
        '添加已经预约过的团体
        rstemp.MoveFirst
        For i = 1 To rstemp.RecordCount
            Set itmTemp = lvwDWei.ListItems.Add(, , rstemp("YYID"))
            
            itmTemp.SubItems(1) = rstemp("DWMC")
            itmTemp.SubItems(2) = rstemp("TJRQ")
            arrYYID(i) = rstemp("yyid") 'YYID字段太长，ItemData属性无法存放，只能存入数组
            rstemp.MoveNext
        Next
        rstemp.Close
        Set rstemp = Nothing
    End If
    If lvwDWei.ListItems.Count > 0 Then
        lvwDWei.ListItems(1).Selected = True

        
        cmdOK.Enabled = True
    Else
        cmdOK.Enabled = False
    End If
    '
       
    '显示所有预约的团体
    '刷新团体信息
    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)
        
        '首先添加一个空行，以便用户不选择单位
        
        '添加已经预约过的团体
        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 XPCommandButton1_Click()
    On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim i As Integer
    Dim itmTemp As ListItem
   
    
     If dtpBegin.Value > dtpStop.Value Then
        MsgBox "起始日期不应大于终止日期！请核对后重新输入！", vbInformation, "提示"
        dtpBegin.SetFocus
        GoTo ExitLab
    End If
    '显示所有预约的团体
    '刷新团体信息
     lvwDWei.ListItems.Clear
     
    strSQL = "select YYID,DWMC,TJRQ" _
            & " from YY_TJDJ,SET_DW" _
            & " where YY_TJDJ.DWID=SET_DW.DWID" _
            & " and YY_TJDJ.YYID='" & YYID & "' and YY_TJDJ.TJRQ>='" & dtpBegin.Value & "' and YY_TJDJ.TJRQ<='" & dtpStop.Value & "'" _
            & " order by JLRQ desc"

    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount > 0 Then
        
                
        '添加已经预约过的团体
        rstemp.MoveFirst
        For i = 1 To rstemp.RecordCount
            Set itmTemp = lvwDWei.ListItems.Add(, , rstemp("YYID"))
            itmTemp.SubItems(1) = rstemp("DWMC")
            itmTemp.SubItems(2) = rstemp("TJRQ")
          
            rstemp.MoveNext
        Next
        rstemp.Close
        Set rstemp = Nothing
    End If
    If lvwDWei.ListItems.Count > 0 Then
        lvwDWei.ListItems(1).Selected = True

        
        cmdOK.Enabled = True
    Else
        cmdOK.Enabled = False
    End If
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub