dlgaffirm.frm

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

    '********************20040507加入 闻*******************************
    '获得查询码
    Set rstemp = New ADODB.Recordset
    rstemp.Open "select GUID,HealthID,YYRXM from SET_GRXX where GUID=" & lngGUID, GCon, adOpenStatic, adLockReadOnly
    tmpHealthID = rstemp("HealthID")
'    strTmpQueryCode = TmpclsDisk.GetFixedSerialNumber(rsTemp("YYRXM") & rsTemp("HealthID"), 8)
    strTmpQueryCode = LongToString(rstemp("GUID"), 6) & TmpclsDisk.GetFixedSerialNumber(rstemp("GUID") & rstemp("HealthID"), 8)
    Set cmdTemp = New ADODB.Command
    Set cmdTemp.ActiveConnection = GCon
    cmdTemp.CommandText = "update SET_GRXX set CXM='" & strTmpQueryCode & "' where GUID=" & lngGUID
    cmdTemp.Execute
    TxtCXM.Text = strTmpQueryCode
    '********************20040507加入完 闻*****************************
    
    '*******************************************************************
    '发卡
    '*******************************************************************
    Call SendCardW(rstemp("HealthID"), TxtGSelfBH.Text, GCon, , False, True)
    '禁用“确认”按钮
    cmdAffirm.Enabled = False
    cmdIDCardAndPerson.Enabled = False
    
    '将该条记录从MSHFlexGrid1移入MSHFlexGrid2,利用刷新显示
    RefreshGrid
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    mblnReCheck = False
    mblnBuCha = False
    m_enuCheckType = None
    
    Me.MousePointer = vbDefault
    '跳转
    txtQuerySelfBH.SetFocus
End Sub

Private Sub CmdCancelAffirm_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsPerson As ADODB.Recordset
    Dim i As Integer, j As Integer
    Dim intRow As Integer
    Dim lngGUID As Long
    Dim strYYID As String '团检客户所属的团体编号
    
    Me.MousePointer = vbHourglass
    
    intRow = Me.MSHFlexGrid2.Row '当前行
    '检查是否有选择
    If Me.MSHFlexGrid2.TextMatrix(intRow, 0) = "" Then GoTo ExitLab
    
    '取消之前让用户确认
    If MsgBox("您确认要取消客户“" & Me.MSHFlexGrid2.TextMatrix(intRow, 4) _
            & "”的确认吗？", vbQuestion + vbYesNo + vbDefaultButton2, _
            "询问") = vbNo Then GoTo ExitLab
    
    '获取唯一编号
    lngGUID = Val(Me.MSHFlexGrid2.TextMatrix(intRow, 0))
    
    If Me.MSHFlexGrid2.TextMatrix(intRow, 5) = "" Then
        '散检客户
        strSQL = "update YY_SJDJ set SFTJ=0" _
                & " where GUID=" & lngGUID
        GCon.Execute strSQL
    Else
        '团检客户
        '首先检查是否参与分组
        strSQL = "select YYID from FZ_FZSJ" _
                & " where GUID=" & lngGUID
        Set rsPerson = New ADODB.Recordset
        rsPerson.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If rsPerson.RecordCount < 1 Then
            MsgBox "客户“" & Me.MSHFlexGrid2.TextMatrix(intRow, 4) _
                    & "”尚未参与分组，无法确认！" _
                    & vbCrLf & "请首先对该客户进行分组！", vbInformation, "提示"
            GoTo ExitLab
        End If
        
        '记录编号
        strYYID = rsPerson("YYID")
        
        '首先更新FZ_FZSJ表
        strSQL = "Update FZ_FZSJ set SFTJ=0" _
                & " where GUID=" & lngGUID
        GCon.Execute strSQL
        
'        '然后更新YY_TJDJ表
'        strSQL = "Update YY_TJDJ set SFTJ=1" _
'                & " where YYID='" & strYYID & "'"
'        GCon.Execute strSQL
    End If
    
    '将SET_GRXX中QRDJ字段恢复为0
    strSQL = "Update SET_GRXX set QRDJ=0" _
                & " where GUID=" & lngGUID
    GCon.Execute strSQL
    
    '********************20040412加入 闻*******************************
    '将该条记录从MSHFlexGrid1移入MSHFlexGrid2,利用刷新显示
    RefreshGrid
    '********************20040412加入完 闻*****************************
    
    '*******************20040412封闭 闻*******************************
'    '改变当前已确认用户的背景色
'    With Me.MSHFlexGrid1
'        .Row = intRow
'        For i = 0 To 4
'            .col = i
'            .CellBackColor = lngAffirm
'        Next
'    End With
    '*******************20040412封闭完 闻*******************************
    '禁用“确认”按钮
    CmdCancelAffirm.Enabled = False
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdFaKa_Click()
    Dim strCard As String
    Dim strHealthID As String
    Dim intRow As Integer
    
    If mintGrid = 1 Then
        If Me.MSHFlexGrid1.TextMatrix(1, 0) = "" Then Exit Sub
        
        intRow = Me.MSHFlexGrid1.Row
        
        strHealthID = Me.MSHFlexGrid1.TextMatrix(intRow, 1)
    ElseIf mintGrid = 2 Then
        If Me.MSHFlexGrid2.TextMatrix(1, 0) = "" Then Exit Sub
        
        intRow = Me.MSHFlexGrid2.Row
        
        strHealthID = Me.MSHFlexGrid2.TextMatrix(intRow, 1)
    End If
    If strHealthID = "" Then Exit Sub
    
'    strCard = InputBox("请输入卡号：", "发卡")
    strCard = Trim(TxtGSelfBH.Text)
    If strCard = "" Then Exit Sub
    
    SendCard strHealthID, strCard
End Sub

Private Sub cmdIDCardAndPerson_Click()
    Dim strRet As String
    Dim strFileName
    
    strRet = dlgIDCardAndPerson.ShowPhotoAndScan
    Set dlgIDCardAndPerson = Nothing
    
    If strRet = "" Then GoTo ExitLab
    strFileName = Split(strRet, "|")
    m_strPhotoFile = strFileName(0)
    m_strScanFile = strFileName(1)
    
    GoTo ExitLab
ExitLab:
    '
End Sub

Private Sub cmdModify_Click()
    If txtGYYID.Text <> "" Then
        menuOperation = Modify
        
        SetGRInput True
'        姓名不允许修改
'        txtGYYRXM.Enabled = False
        
        mblnAdd = False
        
        cmdAdd.Enabled = False
        cmdModify.Enabled = False
        cmdPrintGuider.Enabled = False
        cmdPay.Enabled = False
        cmdFaKa.Enabled = False
        
        cmdAffirm.Enabled = True
        cmdIDCardAndPerson.Enabled = True
        '修改时禁用“取消确认”按钮
        CmdCancelAffirm.Enabled = False
    End If
    
    '清除复查标志
    mblnReCheck = False
    mblnBuCha = False
    m_enuCheckType = None
End Sub

Private Sub cmdPay_Click()
    Dim lngGUID As Long
    
    If mintGrid = 1 Then
        lngGUID = Val(Me.MSHFlexGrid1.TextMatrix(MSHFlexGrid1.Row, 0))
    ElseIf mintGrid = 2 Then
        lngGUID = Val(Me.MSHFlexGrid2.TextMatrix(MSHFlexGrid2.Row, 0))
    End If
    dlgPayMoney.ShowPersonMoney lngGUID, _
            g_typPersonAffirm.Price_InAffirm, g_typPersonAffirm.Charging_InAffirm
    Set dlgPayMoney = Nothing
End Sub

Private Sub cmdPrintBarCode_Click()
    Dim strPersonName As String
    Dim lngGUID As Long
    Dim strHealthID As String
    Dim strSelfID As String
    Dim strBarCode As String
    
    If mintGrid = 1 Then
        lngGUID = CLng(Val(Me.MSHFlexGrid1.TextMatrix(Me.MSHFlexGrid1.Row, 0)))
        strHealthID = Me.MSHFlexGrid1.TextMatrix(Me.MSHFlexGrid1.Row, 1)
    Else
        lngGUID = CLng(Val(Me.MSHFlexGrid2.TextMatrix(Me.MSHFlexGrid2.Row, 0)))
        strHealthID = Me.MSHFlexGrid2.TextMatrix(Me.MSHFlexGrid2.Row, 1)
    End If
    
    '是否有自定义编号
    strSelfID = Trim(TxtGSelfBH.Text)
    If g_enuBarCodeContents = BC_SELFID Then
        If strSelfID = "" Then
            MsgBox "没有设置自定义编号，无法实现条码输出！", vbInformation, "提示"
            GoTo ExitLab
        End If
    End If
    '开始打印
    strPersonName = txtGYYRXM.Text & "  " & cmbGSEX.Text
    If g_enuBarCodeContents = BC_SELFID Then
        strBarCode = strSelfID
    Else
        strBarCode = strHealthID
    End If
    Call clsPrintBarCode.PrintBarcode(strBarCode, , , , , strPersonName, txtGYYRSFZH.Text, lngGUID)
    GoTo ExitLab
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub cmdPrintGuider_Click()
    Dim lngGUID As Long
    
    If mintGrid = 1 Then
        lngGUID = CLng(Val(Me.MSHFlexGrid1.TextMatrix(Me.MSHFlexGrid1.Row, 0)))
    Else
        lngGUID = CLng(Val(Me.MSHFlexGrid2.TextMatrix(Me.MSHFlexGrid2.Row, 0)))
    End If
    
    Call PrintPersonGuider(lngGUID)
End Sub

'打印导引单(青医模式)
Private Sub cmdPrintGuider_Click_QY()
On Error GoTo ErrMsg
    Dim Status
    Dim lngGUIDTemp As Long     '临时记录当前选中的体检者的GUID
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim rsKS As ADODB.Recordset
    Dim strTemp As String               '临时记录当前行要打印的内容
    Dim strTempTitle As String          '记录导引单抬头(当前人员的姓名性别年龄)
    Dim intPage As Integer
    Dim sngTitleTop  As Single          '页面上边距
    Dim sngLineInterval As Single       '行间距
    Dim sngLeft, sngRight As Single     '左、右页边距
    Dim sngCurrX, sngCurrY As Single    '当前打印机纵坐标
    Dim intLineCount As Integer         '当前页已打印的行数
    Dim i As Integer
    Dim intLinePerPage As Integer       '每页打印的行数
    
    intLinePerPage = 48
    
'打印表头
    If DetectPrinter() = False Then
        MsgBox "您还未安装打印机", vbInformation, "提示"
        Exit Sub
    End If
    
    '初始为第一页
    intPage = 1
    
    '设成A4纸
    Printer.ScaleMode = vbMillimeters
    Printer.ScaleWidth = 210
    Printer.ScaleHeight = 297
    sngTitleTop = 25
    sngLeft = 15
    sngRight = 15
    sngLineInterval = 2
    
    GoSub PrintTitle
    GoSub PrintLine
    
    '调整字体
    With Printer
        .FontName = "宋体"
        .FontSize = 9
        .FontBold = False
        .FontItalic = False
        .FontUnderline = False
    End With
    intLineCount = 1
    
    lngGUIDTemp = MSHFlexGrid2.TextMatrix(MSHFlexGrid2.Row, 0)
    
    '打印个人信息
    Set rstemp = New ADODB.Recordset
    rstemp.Open "select * from SET_GRXX where GUID=" & lngGUIDTemp, GCon, adOpenStatic, adLockReadOnly
    strTempTitle = "姓名: " & rstemp("YYRXM") & "      性别：" & rstemp("SEX") & "      年龄：" & rstemp("Age") & ""
'    Printer.CurrentX = sngCurrX
'    Printer.CurrentY = sngCurrY
'    Printer.Print strTempTitle
'    sngCurrY = sngCurrY + Printer.TextHeight("高度") + sngLineInterval
'    intLineCount = intLineCount + 1


    '找出当前体检者人都登记了什么科室的项目
    strSQL = "select GUID,YY_SJDJDX.DXID,DXMC,DXJG from YY_SJDJDX,SET_DX where " _
            & " YY_SJDJDX.DXID=SET_DX.DXID" _
            & " and GUID=" & lngGUIDTemp _
            & " order by YY_SJDJDX.DXID"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount = 0 Then
        MsgBox "当前人员未选择项目，无法打印导引单", vbInformation, "提示"
        Exit Sub
    End If
    rstemp.MoveFirst
    Do While Not rstemp.EOF
'        Set rsKS = New ADODB.Recordset
'        strSQL = "select * from SET_KSSZ where KSID='" & Mid(rsTemp("DXID"), 1, 2) & "'"
'        rsKS.Open strSQL, GCon, adOpenStatic, adLockReadOnly

        If intLineCount >= intLinePerPage Then
            intLineCount = 1
            Printer.NewPage
            intPage = intPage + 1
            GoSub PrintTitle
            GoSub PrintLine
            '调整字体
            With Printer
                .FontName = "宋体"
                .FontSize = 9
                .FontBold = False
                .FontItalic = False
                .FontUnderline = False
            End With
        End If
        
        Printer.CurrentX = sngCurrX
        Printer.CurrentY = sngCurrY
        Printer.Print strTempTitle
        sngCurrY = sngCurrY + Printer.TextHeight("高度") + sngLineInterval
        intLineCount = intLineCount + 1
    
        strTemp = ""
        strTemp = "体检项目：" & rstemp("DXMC")

        Printer.CurrentX = sngCurrX
        Printer.CurrentY = sngCurrY
        Printer.Print strTemp
        
        Printer.CurrentX = sngCurrX
        sngCurrY = sngCurrY + Printer.TextHeight("高度") + sngLineInterval
        Printer.CurrentY = sngCurrY