frmdwtjxj.frm

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

    Dim Status
    Dim strSQL As String
    Dim strSelect As String 'SQL语句的Select部分
    Dim strSJ As String '散检部分
    Dim strTJ As String '团检部分
    Dim strTJ_A As String '团检部分
    Dim strCondition As String '用户输入的查询条件
    Dim rsHZ As ADODB.Recordset
    Dim itmHZ As ListItem
    
    Me.MousePointer = vbHourglass
    
    '在查询过程中禁用打印按钮
    cmdPrint.Enabled = False
    
    '是否选择了单位
'    If cmbDWei.Text = "" Then
'        MsgBox "请选择要汇总的单位！", vbInformation, "提示"
'        GoTo ExitLab
'    End If
    
    '日期是否符合规范
    If dtpBegin.Value > dtpStop.Value Then
        MsgBox "起始日期不应大于终止日期！请核对后重新输入！", vbInformation, "提示"
        dtpBegin.SetFocus
        GoTo ExitLab
    End If
    
    '******************************************************
    '检验完毕
    '******************************************************
    '***********************************
    '以下构建查询语句的Select部分
    '***********************************
    strSelect = "select distinct SET_GRXX.GUID as 流水号" _
            & ",HealthID as " & g_strSystemIDTitle _
            & ",SelfBH as " & g_strSelfIDTitle _
            & ",SET_GRXX.YYID as 团体号,YYRXM as 姓名" _
            & ",SET_GRXX.SEX as 性别,SET_GRXX.TJRQ as 体检日期"
    
    '***********************************
    '以下构建用户的查询条件
    '***********************************
    '体检日期
'    strCondition = " and DATA_KSXJ.TJRQ>='" & dtpBegin.Value & "'" _
'            & " and DATA_KSXJ.TJRQ<='" & dtpStop.Value & "'"
'
    '***********************************
    '以下根据用户选择决定显示全部还是只显示团检客户
    '***********************************
    '如果选择了团体
    If cmbDWei.Text <> "" Then
        strTJ = " from SET_GRXX,FZ_FZSJ" _
                & " where not (SET_GRXX.YYID is null)" _
                & " and SET_GRXX.YYID='" & arrYYID(cmbDWei.ItemData(cmbDWei.ListIndex)) & "'" _
                & " and SET_GRXX.GUID=FZ_FZSJ.GUID" _
                & " and FZ_FZSJ.SFTJ in (1,2)"
    Else
        '这个时候要考虑到散检客户
        strSJ = " from SET_GRXX,YY_SJDJ" _
                & " where SET_GRXX.YYID is null" _
                & " and SET_GRXX.GUID=YY_SJDJ.GUID" _
                & " and YY_SJDJ.SFTJ in (1,2)"
    
        '团体全部
       strTJ_A = " from SET_GRXX,FZ_FZSJ" _
                & " where not (SET_GRXX.YYID is null)" _
                & " and SET_GRXX.GUID=FZ_FZSJ.GUID" _
                & " and FZ_FZSJ.SFTJ in (1,2)"
    End If
    
    '***********************************
    '构建最后的查询语句
    '***********************************
    If strSJ = "" Then
        strSQL = strSelect & strTJ _
                & " and SET_GRXX.TJRQ>='" & dtpBegin.Value & "'" _
                & " and SET_GRXX.TJRQ<='" & dtpStop.Value & " 23:59:59'"
    Else
        strSQL = strSelect & strTJ_A _
                & " and SET_GRXX.TJRQ>='" & dtpBegin.Value & "'" _
                & " and SET_GRXX.TJRQ<='" & dtpStop.Value & " 23:59:59'" _
                & " union " _
                & strSelect & strSJ _
                & " and SET_GRXX.TJRQ>='" & dtpBegin.Value & "'" _
                & " and SET_GRXX.TJRQ<='" & dtpStop.Value & " 23:59:59'"
    End If
    
    '***********************************
    '执行查询
    '***********************************
    Set rsHZ = New ADODB.Recordset
    rsHZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsHZ.RecordCount >= 1 Then
        '显示到ListView控件
        lvwSJRY.ListItems.Clear
        rsHZ.MoveFirst
        Do
            Set itmHZ = lvwSJRY.ListItems.Add(, "W" & rsHZ("流水号"), rsHZ(g_strSystemIDTitle))
            itmHZ.SubItems(1) = rsHZ(g_strSelfIDTitle) & ""
            itmHZ.SubItems(2) = rsHZ("姓名")
            itmHZ.SubItems(3) = rsHZ("性别")
            itmHZ.SubItems(4) = rsHZ("体检日期")
            itmHZ.SubItems(5) = IIf(IsNull(rsHZ("团体号")), "S", rsHZ("团体号"))
            
            rsHZ.MoveNext
        Loop Until rsHZ.EOF
        
        rsHZ.Close
        Set rsHZ = Nothing
        
        '选中第一行
        Set lvwSJRY.SelectedItem = lvwSJRY.ListItems(1)
        '调用单击事件
        lvwSJRY_Click
    Else
        MsgBox "没有找到匹配记录！请重新输入查询条件", vbInformation, "提示"
    End If
    
    '如果列表里面选择有记录，则启用打印按钮
    If Not (lvwSJRY.SelectedItem Is Nothing) Then
        cmdPrint.Enabled = True
    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 nodTemp As Node
    Dim rsYY As ADODB.Recordset
    Dim i As Integer
    
    Screen.MousePointer = vbArrowHourglass
    
    dtpBegin.Value = Date
    dtpStop.Value = Date
    
    Me.Height = 8205
    Me.Width = 11115
    
    
    '显示所有预约的团体
    '刷新团体信息
    strSQL = "select YYID,DWMC" _
            & " from YY_TJDJ,SET_DW" _
            & " where YY_TJDJ.DWID=SET_DW.DWID" _
            & " order by JLRQ desc"
    Set rsYY = New ADODB.Recordset
    rsYY.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
    cmbDWei.Clear
    If rsYY.RecordCount > 0 Then
        ReDim arrYYID(rsYY.RecordCount)
        
        '首先添加一个空行，以便用户不选择单位
        cmbDWei.AddItem ""
        
        '添加已经预约过的团体
        rsYY.MoveFirst
        For i = 1 To rsYY.RecordCount
            cmbDWei.AddItem rsYY("DWMC")
            cmbDWei.ItemData(cmbDWei.NewIndex) = i
            arrYYID(i) = rsYY("YYID") 'YYID字段太长，ItemData属性无法存放，只能存入数组
            
            rsYY.MoveNext
        Next
        rsYY.Close
        Set rsYY = Nothing
        
        cmbDWei.ListIndex = 0
    End If
    
    '设置ListView的列名及列宽
    Call SetObjectTitleAndWidth(Me.lvwSJRY, 1, 2)
    
    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 FrmDWTJXJ = Nothing
End Sub

Private Sub lvwSJRY_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL_JL As String
    Dim strSQL_JY As String
    Dim rstemp As ADODB.Recordset
    Dim lngGUID As Long
    Dim strHealthID As String '当前选中客户
    Dim strType As String '散检还是团检客户
    
    Me.MousePointer = vbHourglass
    
    '判断是否有选择
    If lvwSJRY.ListItems.Count < 1 Then
        TxtZJJL.Text = ""
        txtZJJY.Text = ""
        GoTo ExitLab
    End If
    If lvwSJRY.SelectedItem Is Nothing Then
        TxtZJJL.Text = ""
        txtZJJY.Text = ""
        GoTo ExitLab
    End If
    
    '获取编号
    lngGUID = Val(Mid(lvwSJRY.SelectedItem.Key, 2))
    
    '构建查询语句
    strSQL_JL = "select JLValue from DATA_ZJJL" _
            & " where GUID=" & lngGUID
    strSQL_JY = "select JyValue from DATA_ZJJY" _
            & " where GUID=" & lngGUID
    '获取总检结论
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL_JL, GCon, adOpenStatic, adLockOptimistic
    If Not (rstemp.EOF) Then
        TxtZJJL.Text = rstemp("JLValue") & ""
        
        rstemp.Close
    Else
        TxtZJJL.Text = ""
    End If
    
    '获取总检建议
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL_JY, GCon, adOpenStatic, adLockOptimistic
    If Not (rstemp.EOF) Then
        txtZJJY.Text = rstemp("JYValue") & ""
        
        rstemp.Close
    Else
        txtZJJY.Text = ""
    End If
    
    Set rstemp = Nothing
        
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub lvwSJRY_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
    If mintlvPXFC = 1 Then
         mintlvPXFC = 0
         lvwSJRY.SortOrder = lvwAscending
    Else
        mintlvPXFC = 1
        lvwSJRY.SortOrder = lvwDescending
    End If
    '单击 ColumnHeader 对象时，将根据
    '那一列的子项目把 ListView 控件排序。
    '设置 SortKey 为 ColumnHeader 的索引值减 1
    lvwSJRY.SortKey = ColumnHeader.Index - 1
    '设置 Sorted 为 True 以将列表排序。
    lvwSJRY.Sorted = True

End Sub

Private Sub lvwSJRY_DblClick()
    If Not (lvwSJRY.SelectedItem Is Nothing) Then
    '************20040327 加入 闻*******************
        frmTJResult.ShowPersonInfo Val(Mid(lvwSJRY.SelectedItem.Key, 2)), lvwSJRY.SelectedItem.SubItems(3)
    '************20040327 加入完 闻*******************
    End If
End Sub

Private Sub lvwSJRY_KeyUp(KeyCode As Integer, Shift As Integer)
    If (KeyCode = vbKeyUp) Or (KeyCode = vbKeyDown) Then
        lvwSJRY_Click
    End If
End Sub

Public Sub PrintReport()
On Error GoTo Print_Cancel
    Dim Status
    Dim Msg As String
    Dim PrintNummber As Integer
    Dim i As Integer, j As Integer
    Dim lngGUID As Long
    Dim strHealthID As String
    Dim strBBID As String

    'cdlPDHidePrintToFile+cdlPDHelpButton
    
    '------Flags 属性（“打印”对话框）-----------------------
    'cdlPDAllPages &H0 返回或设置全部页选项按钮的状态。
    'cdlPDCollate &H10 返回或设置分页复选框的状态。
    'cdlPDDisablePrintToFile &H80000 使打印到文件复选框无效。
    'cdlPDHelpButton &H800 要求对话框显示帮助按钮。
    'cdlPDHidePrintToFile &H100000 隐藏打印到文件复选框。
    'cdlPDNoPageNums &H8 使页选项按钮和相关的编辑控件无效。
    'cdlPDNoSelection &H4 使选择选项按钮无效。
    'cdlPDNoWarning &H80 防止没有缺省打印机时显示警告信息。
    'cdlPDPageNums &H2 返回或设置页选项按钮的状态。
    'cdlPDPrintSetup &H40 使系统显示“打印设置”对话框而不是“打印”对话框。
    'cdlPDPrintToFile &H20 返回或设置打印到文件复选框的状态。
    'cdlPDReturnDC &H100 为该对话框中选择的打印机返回一个设备描述体。设备描述体返回到对话框的 hDC 属性中。