frmprecontract.frm

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

         Top             =   4470
         Width           =   1575
      End
      Begin VB.Label Label12 
         Alignment       =   1  'Right Justify
         BackStyle       =   0  'Transparent
         Caption         =   "邮政编码："
         Height          =   255
         Left            =   300
         TabIndex        =   35
         Top             =   4059
         Width           =   1575
      End
      Begin VB.Label Label11 
         Alignment       =   1  'Right Justify
         BackStyle       =   0  'Transparent
         Caption         =   "联系地址："
         Height          =   255
         Left            =   300
         TabIndex        =   34
         Top             =   6525
         Width           =   1575
      End
      Begin VB.Label Label10 
         Alignment       =   1  'Right Justify
         BackStyle       =   0  'Transparent
         Caption         =   "负责人移动电话："
         Height          =   255
         Left            =   300
         TabIndex        =   33
         Top             =   3237
         Width           =   1575
      End
      Begin VB.Label Label9 
         Alignment       =   1  'Right Justify
         BackStyle       =   0  'Transparent
         Caption         =   "负责人办公电话："
         Height          =   255
         Left            =   300
         TabIndex        =   32
         Top             =   2826
         Width           =   1575
      End
      Begin VB.Label Label8 
         Alignment       =   1  'Right Justify
         BackStyle       =   0  'Transparent
         Caption         =   "单位负责人："
         Height          =   255
         Left            =   300
         TabIndex        =   31
         Top             =   2415
         Width           =   1575
      End
      Begin VB.Label Label7 
         Alignment       =   1  'Right Justify
         BackStyle       =   0  'Transparent
         Caption         =   "联系人移动电话："
         Height          =   255
         Left            =   300
         TabIndex        =   30
         Top             =   2004
         Width           =   1575
      End
      Begin VB.Label Label6 
         Alignment       =   1  'Right Justify
         BackStyle       =   0  'Transparent
         Caption         =   "联系人办公电话："
         Height          =   255
         Left            =   300
         TabIndex        =   29
         Top             =   1593
         Width           =   1575
      End
      Begin VB.Label Label5 
         Alignment       =   1  'Right Justify
         BackStyle       =   0  'Transparent
         Caption         =   "单位联系人："
         Height          =   255
         Left            =   300
         TabIndex        =   28
         Top             =   1182
         Width           =   1575
      End
      Begin VB.Label Label4 
         Alignment       =   1  'Right Justify
         BackStyle       =   0  'Transparent
         Caption         =   "五笔简码："
         Height          =   255
         Left            =   3990
         TabIndex        =   27
         Top             =   3525
         Visible         =   0   'False
         Width           =   1575
      End
      Begin VB.Label Label3 
         Alignment       =   1  'Right Justify
         BackStyle       =   0  'Transparent
         Caption         =   "拼音简码："
         Height          =   255
         Left            =   3990
         TabIndex        =   26
         Top             =   3135
         Visible         =   0   'False
         Width           =   1575
      End
      Begin VB.Label Label2 
         Alignment       =   1  'Right Justify
         BackStyle       =   0  'Transparent
         Caption         =   "单位名称："
         Height          =   255
         Left            =   300
         TabIndex        =   25
         Top             =   771
         Width           =   1575
      End
      Begin VB.Label Label1 
         Alignment       =   1  'Right Justify
         BackStyle       =   0  'Transparent
         Caption         =   "预约编号："
         Height          =   255
         Left            =   300
         TabIndex        =   24
         Top             =   360
         Width           =   1575
      End
   End
End
Attribute VB_Name = "frmPrecontract"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim menuOperation As OperationType
Dim mblnClick As Boolean

Private Sub cmbGHF_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub cmbGSEX_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub cmbGTCan_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim i As Integer, j As Integer
    Dim strDXID As String
    Dim blnHave As Boolean
    
    If cmbGTCan.Text = "" Then
        '清除所有选择
        For i = 1 To tvwGDXiang.Nodes.Count
            tvwGDXiang.Nodes(i).Checked = False
        Next
        '去掉套餐描述
        lblGInfo.Caption = ""
        Exit Sub
    End If
    
    '显示该套餐描述
    strSQL = "select TCMC from SET_TC" _
            & " where TCID='" _
            & LongToString(cmbGTCan.ItemData(cmbGTCan.ListIndex), 5) & "'"
    Set rsTemp = New ADODB.Recordset
    rsTemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    lblGInfo.Caption = rsTemp("TCMC")
    rsTemp.Close
    
    '获取该套餐包含的大项
    strSQL = "select DXID from SET_TCDX" _
            & " where TCID='" _
            & LongToString(cmbGTCan.ItemData(cmbGTCan.ListIndex), 5) & "'"
    Set rsTemp = New ADODB.Recordset
    rsTemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
    If rsTemp.RecordCount > 0 Then
        '循环每个大项，如果该大项包含在当前套餐中，则选中，否则不选中
        For i = 1 To tvwGDXiang.Nodes.Count
            '只处理大项
            If Len(tvwGDXiang.Nodes(i).Key) = 5 Then
                strDXID = Mid(tvwGDXiang.Nodes(i).Key, 2)
                
                blnHave = False
                rsTemp.MoveFirst
                For j = 1 To rsTemp.RecordCount
                    If rsTemp("DXID") = strDXID Then
                        blnHave = True
                        Exit For
                    End If
                    rsTemp.MoveNext
                Next j
                
                '检查是否包含
                If blnHave = True Then
                    tvwGDXiang.Nodes(i).Checked = True
                    blnHave = False
                Else
                    tvwGDXiang.Nodes(i).Checked = False
                End If
            End If
        Next i
    End If
    
    Set rsTemp = Nothing
    
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

Private Sub cmbGTCan_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub cmbTDWei_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    
    If mblnClick = False Then Exit Sub
    '如果单位不存在则直接退出
    If cmbTDWei.ListIndex = -1 Then Exit Sub
    
    '单位存在的情况，调出历史记录
    strSQL = "select * from SET_DW" _
            & " where DWID='" _
            & LongToString(cmbTDWei.ItemData(cmbTDWei.ListIndex), 5) & "'"
    Set rsTemp = New ADODB.Recordset
    rsTemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    '填充窗体上的文本框
    txtTPYSX.Text = rsTemp("PYSX")
    txtTWBSX.Text = rsTemp("WBSX")
    txtTLXR.Text = rsTemp("LXR")
    txtTLXRBGDH.Text = rsTemp("LXRBGDH")
    txtTLXRYDDH.Text = rsTemp("LXRYDDH")
    txtTFZR.Text = rsTemp("FZR")
    txtTFZRBGDH.Text = rsTemp("FZRBGDH")
    txtTFZRYDDH.Text = rsTemp("FZRYDDH")
    txtTYZBM.Text = rsTemp("YZBM")
    txtTLXDZ.Text = rsTemp("LXDZ")
    txtTYWYH.Text = rsTemp("YWYH")
    txtTYHZH.Text = rsTemp("YHZH")
    txtTQYXZ.Text = rsTemp("QYXZ")
    '关闭记录集
    rsTemp.Close
    Set rsTemp = Nothing
    
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

Private Sub cmbTDWei_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub cmbTDWei_LostFocus()
    If cmbTDWei.ListIndex < 0 Then
        txtTPYSX.Text = GetPYJM(cmbTDWei.Text)
    End If
End Sub

Private Sub cmbTTCan_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim strDXID As String
    Dim i As Integer, j As Integer
    Dim blnHave As Boolean
    
    If cmbTTCan.Text = "" Then
        '清除所有选择
        For i = 1 To tvwTDXiang.Nodes.Count
            tvwTDXiang.Nodes(i).Checked = False
        Next
        '去掉套餐描述
        lblTInfo.Caption = ""
        Exit Sub
    End If
    
    '显示该套餐描述
    strSQL = "select TCMS from SET_TC" _
            & " where TCID='" _
            & LongToString(cmbTTCan.ItemData(cmbTTCan.ListIndex), 5) & "'"
    Set rsTemp = New ADODB.Recordset
    rsTemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    lblTInfo.Caption = rsTemp("TCMS")
    rsTemp.Close
    
    '获取该套餐包含的大项
    strSQL = "select DXID from SET_TCDX" _
            & " where TCID='" _
            & LongToString(cmbTTCan.ItemData(cmbTTCan.ListIndex), 5) & "'"
    Set rsTemp = New ADODB.Recordset
    rsTemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
    If rsTemp.RecordCount > 0 Then
        '循环每个大项，如果该大项包含在当前套餐中，则选中，否则不选中
        For i = 1 To tvwTDXiang.Nodes.Count
            If Len(tvwTDXiang.Nodes(i).Key) = 5 Then
                strDXID = Mid(tvwTDXiang.Nodes(i).Key, 2)
                
                blnHave = False
                rsTemp.MoveFirst
                For j = 1 To rsTemp.RecordCount
                    If rsTemp("DXID") = strDXID Then
                        blnHave = True
                        Exit For
                    End If
                    rsTemp.MoveNext
                Next j
                
                '检查是否包含
                If blnHave = True Then
                    tvwTDXiang.Nodes(i).Checked = True
                Else
                    tvwTDXiang.Nodes(i).Checked = False
                End If
            End If
        Next i
    End If
    
    Set rsTemp = Nothing
    
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

Private Sub cmbTTCan_KeyPress(KeyAscii As Integer)
    EnterToTab KeyAscii
End Sub

Private Sub cmdAdd_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strHealthID As String '个人id
    Dim strYYID As String '团体id
    Dim rsTemp As ADODB.Recordset
    
    ClearInput

'************20040327 加入代码 闻***********************
    If optGRen.Value = True Then
         fraTJBZ.Enabled = True
         fraGRen.Enabled = True
    ElseIf optTTi.Value = True Then
         fraTTi.Enabled = True
    End If
    mblSFBC = False
'************20040327 加入代码完 闻***********************

'*******************************20040327 封闭***************************************
    '生成预约序号
    If optGRen.Value = True Then '个人
        '生成当前最大的id
        '获取当前的最大编号
        strHealthID = Format(Date, "yyyymmdd")
        strSQL = "select SJYYXLH from YY_XLH where RiQi='" & Date & "'"
        Set rsTemp = New ADODB.Recordset
        rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rsTemp.RecordCount = 0 Then
            strHealthID = strHealthID & "0001"
            txtTJXH.Text = 1