frmfqcx.frm

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

    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 rstemp As ADODB.Recordset
    Dim itmHZ As ListItem
    Dim curTotal_XMJG As Currency
    Dim curTotal_CJJG As Currency
    Dim curTotal_ZFJG As Currency
    
    Me.MousePointer = vbHourglass
    
    '是否选择了单位
'    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 SET_GRXX.GUID as 流水号,HealthID as " & g_strSystemIDTitle _
            & ",SelfBH as " & g_strSelfIDTitle & ",TJSerialNum as 体检序号" _
            & ",YYRXM as 姓名,SET_GRXX.SEX as 性别,SET_GRXX.AGE as 年龄" _
            & ",SET_GRXX.TJRQ as 体检日期" _
            & ",SET_GRXX.XMJG as 项目价格,SET_GRXX.CJJG as 成交价格" _
            & ",SET_GRXX.YYID"
    
    '***********************************
    '以下根据用户选择决定显示全部还是只显示团检客户
    '***********************************
    '如果选择了一个团体
    If cmbDWei.Text <> "" Then
        strTJ = " from SET_GRXX,FZ_FZSJ" _
                    & " where SET_GRXX.YYID='" & arrYYID(cmbDWei.ItemData(cmbDWei.ListIndex)) & "'" _
                    & " and SET_GRXX.GUID=FZ_FZSJ.GUID" _
                    & " and FZ_FZSJ.SFTJ in (1,2)"
        If txtName.Text <> "" Then
            strTJ = strTJ & " and YYRXM like '%" & Trim(txtName.Text) & "%'"
        End If
        If cmbSex.Text <> "" Then
            strTJ = strTJ & " and SET_GRXX.SEX='" & cmbSex.Text & "'"
        End If
    End If
    If cmbDWei.Text = "" Then
        '这个时候要考虑到散检客户
        strSJ = " from SET_GRXX,YY_SJDJ" _
                & " where SET_GRXX.GUID=YY_SJDJ.GUID" _
                & " and YY_SJDJ.SFTJ in (1,2)"
    
        '团体全部
       strTJ_A = " from SET_GRXX,FZ_FZSJ" _
                & " where SET_GRXX.YYID=FZ_FZSJ.YYID" _
                & " and SET_GRXX.GUID=FZ_FZSJ.GUID" _
                & " and FZ_FZSJ.SFTJ in (1,2)"
        If txtName.Text <> "" Then
            strSJ = strSJ & " and YYRXM like '%" & Trim(txtName.Text) & "%'"
            strTJ_A = strTJ_A & " and YYRXM like '%" & Trim(txtName.Text) & "%'"
        End If
        If cmbSex.Text <> "" Then
            strSJ = strSJ & " and SET_GRXX.SEX='" & cmbSex.Text & "'"
            strTJ_A = strTJ_A & " and SET_GRXX.SEX='" & cmbSex.Text & "'"
        End If
    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
    DoEvents
    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) = rsHZ("体检日期")
       
                strSQL = "select Sum(DXJG) from SET_DX" _
                        & " where DXID in(" _
                            & "select DXID from YY_SJDJDX" _
                            & " where GUID=" & rsHZ("流水号") _
                        & ")"
'                Set rstemp = New ADODB.Recordset
'                rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
'                If Not rstemp.EOF Then
'                    If Not IsNull(rstemp(0)) Then
'                        itmHZ.SubItems(6) = rstemp(0)
'
'                        curTotal_XMJG = curTotal_XMJG + rstemp(0)
'                    End If
'                    rstemp.Close
'                End If

            
           ' itmHZ.SubItems(7) = rsHZ("成交价格") & ""
             
            '是否有单位
            If Not IsNull(rsHZ("YYID")) Then
                strSQL = "select DWMC from SET_DW,YY_TJDJ" _
                        & " where YY_TJDJ.YYID='" & rsHZ("YYID") & "'" _
                        & " and YY_TJDJ.DWID=SET_DW.DWID"
                Set rstemp = New ADODB.Recordset
                rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
                If Not rstemp.EOF Then
                    itmHZ.SubItems(9) = rstemp("DWMC")
                    rstemp.Close
                End If
            End If
            
            '成交价格
'            If Not IsNull(rsHZ("成交价格")) Then
'                curTotal_CJJG = curTotal_CJJG + rsHZ("成交价格")
'            End If
            
            '已支付费用
            
            If itmHZ.Index Mod 150 = 0 Then DoEvents
            
            rsHZ.MoveNext
        Loop Until rsHZ.EOF
        
        rsHZ.Close
        Set rsHZ = Nothing
        
        '最后添加一栏总费用
      '  Set itmHZ = lvwSJRY.ListItems.Add(, "W", "总计")
'        If Not g_blnSystemID Then
'            itmHZ.SubItems(1) = "总计"
'        End If
'        itmHZ.SubItems(6) = curTotal_XMJG
'        itmHZ.SubItems(7) = curTotal_CJJG
        
        Set lvwSJRY.SelectedItem = lvwSJRY.ListItems(1)
        lvwSJRYClick
    Else
        MsgBox "没有找到匹配记录！请重新输入查询条件", vbInformation, "提示"
    End If
    
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
End Sub

Private Sub lvwSJRYClick()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strSQL1 As String
    Dim rsHZ As ADODB.Recordset
    Dim rstemp As ADODB.Recordset
    Dim itmHZ As ListItem
    Dim lngGUID As Long
    Dim curTotal_XMJG As Currency
    Dim curTotal_CJJG As Currency
    Dim curTotal_ZFJG As Currency
    
    Me.MousePointer = vbHourglass
    
    lvwFYQD.ListItems.Clear
    
    '判断是否有选择
    If lvwSJRY.ListItems.Count < 1 Then
        lblTitle.Caption = "放弃项目"
        GoTo ExitLab
    End If
    If lvwSJRY.SelectedItem Is Nothing Then
       lblTitle.Caption = "放弃项目"
        GoTo ExitLab
    End If
    
    '是否单击了“合计”一栏
    If Len(lvwSJRY.SelectedItem.Key) = 1 Then
        lblTitle.Caption = "放弃项目"
        GoTo ExitLab
    End If
    
   ' cmdPrint.Enabled = True
    lblTitle.Caption = lvwSJRY.SelectedItem.SubItems(2) & " 的 放弃项目"
    
    '获取ID号和类型
    lngGUID = Val(Mid(lvwSJRY.SelectedItem.Key, 2))
    '提取选择的项目

    strSQL = "select DXMC,KSMC,SET_DX.dxid ,set_zh_data.xxid,set_xx.xxmc,set_xx.xxpysx,set_dx.dxpysx from SET_DX,YY_SJDJDX,SET_KSSZ,set_zh_data,set_xx" _
              & " Where YY_SJDJDX.GUID =" & lngGUID _
              & " and YY_SJDJDX.DXID=SET_DX.DXID " _
              & " and left(SET_DX.DXID,2)=SET_KSSZ.KSID and set_zh_data.dxid=set_dx.dxid and set_zh_data.xxid=set_xx.xxid " _
              & "order by SET_KSSZ.SXH,SET_DX.SXH "
    Set rsHZ = New ADODB.Recordset
    rsHZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If Not (rsHZ.EOF) Then
        rsHZ.MoveFirst
        Do
            strSQL1 = "select [" & rsHZ("xxpysx") & "] from [Data_" & rsHZ("dxpysx") & "] Where [" & rsHZ("xxpysx") & "]='放弃' and Guid=" & lngGUID
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL1, GCon, adOpenStatic, adLockOptimistic
            If Not (rstemp.EOF) Then
            
            Set itmHZ = lvwFYQD.ListItems.Add(, , rsHZ("KSMC"))
            itmHZ.SubItems(1) = rsHZ("DXMC")
            itmHZ.SubItems(2) = rsHZ("xxmc") & ""
            rstemp.Close
            End If
            
            rsHZ.MoveNext
        Loop Until rsHZ.EOF
        rsHZ.Close
        

    End If
    Set rsHZ = Nothing
    
    mstrFYQD = strSQL
    
    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 = vbHourglass
    
    dtpBegin.Value = Date
    dtpStop.Value = Date
    
    Me.Height = 8355
    Me.Width = 9795
    
    
    '显示所有预约的团体
    '刷新团体信息
    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 lvwSJRY_KeyUp(KeyCode As Integer, Shift As Integer)
   If (KeyCode = vbKeyUp) Or (KeyCode = vbKeyDown) Then
        lvwSJRYClick
    End If
End Sub

Private Sub lvwSJRY_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
   lvwSJRYClick
    
    If lvwSJRY.ListItems.Count > 0 Then
    
        If Button = vbRightButton Then
            If Len(lvwSJRY.SelectedItem.Key) > 1 Then
                PopupMenu fMainForm.mnuPrint_
            End If
        Else
            If Len(lvwSJRY.SelectedItem.Key) > 1 Then
               ' cmdPrint.Enabled = True
            Else
               ' cmdPrint.Enabled = False
            End If
        End If
    End If
End Sub