frmbackdrug.frm

医院门诊医生工作站,vb6 SqlServer

         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   210
      Left            =   45
      TabIndex        =   30
      Top             =   525
      Width           =   735
   End
End
Attribute VB_Name = "frmBackDrug"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public Sickobj As clsSick
Private OldSkID As String
Public isHouse As Boolean
Public mFlag As Boolean
Private WithEvents CmnHlp As frmInputHelp
Attribute CmnHlp.VB_VarHelpID = -1


Private Sub UpdateFair()
    Dim Row As Integer
    Dim Amount As Integer, BackAmount As Integer
    Dim Cprice As Currency
    
    For Row = 1 To spd.MaxRows
        spd.Row = Row
        spd.Col = 5
        Amount = Val(spd.Text)
        spd.Col = 6
        BackAmount = Val(spd.Text)
        If BackAmount < 0 Or BackAmount > Amount Then
            spd.value = 0
            BackAmount = 0
        End If
        spd.Col = 7
        Cprice = Val(spd.Text)
        spd.Col = 9
        spd.Text = Format(Cprice * BackAmount, "0.00")
    Next
End Sub

Private Sub InitForm()
    Set Lct.CN = gdbobj.CN
    init
End Sub
Private Sub init()
    hisFormClear Me
    chkOut.value = 0
    chkBaby.value = 0
    chkFlush.value = 0
    spd.MaxRows = 0
    Lct.Visible = False
    mskDate(0) = gfnGetTime(gstrCOMN_DATE)
    mskDate(1) = gfnGetTime(gstrCOMN_DATE)
'    If Not (SickObj Is Nothing) Then
'        Set SickObj = Nothing
'    End If
    If Not isHouse Then Label1 = "住院病人退费"
    txtselect.Enabled = False
    txtselect.Tag = ""
    txtselect = ""
End Sub

Private Sub btg_Click(ByVal WhichB As Integer)
    Dim Obj As Object, ErrDes As String, Row As Long, Col As Long
    
    Select Case WhichB
        Case 0
            Set Obj = ValidInput(ErrDes, Row, Col)
            If Not (Obj Is Nothing) Then
                MsgBox ErrDes, vbCritical
                hisActiveSpreadCell spd, Row, Col
                Exit Sub
            End If
            UpdateFair
            If Not Save() Then
                MsgBox gdbobj.ErrDes, vbCritical
                Exit Sub
            End If
            If Lct.CurPos < Lct.Count Then
                Lct.CurPos = Lct.CurPos + 1
            Else
                If mFlag Then
                    Unload Me
                    Exit Sub
                End If
                init
                txtSkID.SetFocus
            End If
        Case 1
            init
            txtSkID.SetFocus
        Case 2
            Query
        Case 3
            Unload Me
    End Select
End Sub

Private Sub CmnHlp_ResSelect(ByVal SelData As Variant, ByVal STag As String)
    If TypeName(SelData) <> "Nothing" Then
        txtselect = SelData(1)
        txtselect.Tag = SelData(0)
        QueryM CStr(SelData(0))
    Else
        txtselect = ""
        txtselect.Tag = ""
    End If
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        hisToActiveCtl(Me).SetFocus
    End If
End Sub

Private Sub Form_Load()
    hisFormToCenter Me, frmMain
    Set CmnHlp = New frmInputHelp
    Set CmnHlp.CN = gdbobj.CN
    InitForm
    If gtydSysConfig.ifBackCurDate Then
        mskDate(0).Enabled = False
        mskDate(1).Enabled = False
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set frmBackDrug = Nothing
End Sub

Private Sub Lct_PosChanged(ByVal Pos As Long, ByVal OldPos As Long)
    If Lct.Tag = 0 Then
        FillData
    Else
        FillDataM txtselect.Tag
    End If
End Sub


Private Sub mskDate_LostFocus(Index As Integer)
    If Not IsDate(mskDate(Index)) Then
        MsgBox gstrDATE_ERROR_MSG, vbCritical
        mskDate(Index).SetFocus
    End If
End Sub

Private Sub spd_EditMode(ByVal Col As Long, ByVal Row As Long, ByVal Mode As Integer, ByVal ChangeMade As Boolean)
    Dim Amount As Integer, BackAmount As Integer, Cprice As Currency
    
    If ChangeMade Then
        If Col = 6 Then
            spd.Row = Row
            spd.Col = 5
            Amount = Val(spd.Text)
            spd.Col = 6
            BackAmount = Val(spd.Text)
            If BackAmount < 0 Or BackAmount > Amount Then
                spd.value = 0
                BackAmount = 0
            End If
            spd.Col = 7
            Cprice = Val(spd.Text)
            spd.Col = 9
            spd.Text = Format(Cprice * BackAmount, "0.00")
        End If
    End If
End Sub

Private Sub spd_LeaveCell(ByVal Col As Long, ByVal Row As Long, ByVal NewCol As Long, ByVal NewRow As Long, Cancel As Boolean)
    gpdSpreadControl spd, Col, Row, NewCol, NewRow
End Sub

Private Sub txtselect_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        If txtselect <> "" Then
            If isHouse Then
                CmnHlp.SQL = "select itemcode,itemname,model from m_drug where brief like '##%' " & gfnMakeLimit(gtydSysConfig.ItemCode, "m_Drug.ItemCode")
            Else
                CmnHlp.SQL = "select itemcode,itemname,null from m_Item where brief like '##%' "
            End If
            CmnHlp.FormatHead = "|名                       称|规          格|"
            CmnHlp.InitPut = txtselect
            CmnHlp.WidthRate = 1.8
            CmnHlp.ShowHelp vbModal
        End If
    End If

End Sub

Private Sub txtSkID_GotFocus()
    OldSkID = txtSkID
End Sub

Private Sub txtSkID_LostFocus()
    Dim mStr As String
    
    If txtSkID = OldSkID Then Exit Sub
    If txtSkID = "" Then
        init
        Exit Sub
    End If
    If Sickobj Is Nothing Then
        Set Sickobj = New clsSick
    End If
    Sickobj.SkIDByQuery = txtSkID
    If Not Sickobj.IfRegInfo Then
        MsgBox "病案号> " & txtSkID & " <不存在", vbCritical
        init
        txtSkID.SetFocus
        Exit Sub
    Else
        If Sickobj.Num <= 0 Then
            MsgBox "病人未住过院!", vbCritical
            init
            txtSkID.SetFocus
            Exit Sub
        End If
        If Sickobj.IFOutHosp Then
            If chkFlush.value = 0 Then
                If Sickobj.IFFoot Then
                    MsgBox Sickobj.Name & " 已出院结算! 不能再退药,如果确需退药。请选择结算后退药", vbCritical
                Else
                    MsgBox Sickobj.Name & " 已办出院通知! 不能再退药,如果确需退药,请先取消出院通知后再退药。", vbCritical
                End If
                init
                txtSkID.SetFocus
                Exit Sub
            Else
                If Not Sickobj.IFFoot Then
                    MsgBox Sickobj.Name & " 已办出院通知! 不能再退药,如果确需退药,请先取消出院通知或结算后再退药。", vbCritical
                    init
                    txtSkID.SetFocus
                    Exit Sub
                End If
            End If
        End If
    End If
    Call gfnFillDataBySickRegInfo(Me, Sickobj)
    txtselect.Enabled = True
    spd.MaxRows = 0 '避免错退
    Lct.Visible = False
End Sub
Private Sub Query()
    Dim stardate As String
    Dim EndDate As String
    stardate = Format(mskDate(0), "yymmdd")
    EndDate = Format(CDate(mskDate(1)) + 1, "yymmdd")
    If Sickobj Is Nothing Then Exit Sub
    If isHouse Or gstrMODULEID = "B6" Then
        If isHouse Then
            Lct.SQL = "SELECT FairMarkMain.DepCode,FairMarkMain.DcCode,FairMarkMain.MarkDate, " _
                & "FairMarkMain.HdCode,FairMarkMain.MarkSerial,FairMarkMain.Flag " _
                & "FROM (FairMarkMain INNER JOIN FairMarkSub ON FairMarkMain.MarkSerial =FairMarkSub.MarkSerial) " _
                & "INNER JOIN m_Drug ON FairMarkSub.ItemCode =m_Drug.ItemCode " _
                & "WHERE FairMarkMain.SkSerial = '" & Sickobj.SkSerial & "' and fairMarkSub.Amount>0 " _
                & gfnMakeLimit(gtydSysConfig.ItemCode, "m_Drug.ItemCode") _
                & " AND FairMarkMain.Markserial >='" & stardate & "' AND FairMarkMain.Markserial <='" & EndDate & "' " _
                & "and FairMarkSub.dscode='" & gtydSysConfig.DepCode & "' " _
                & "GROUP BY FairMarkMain.DepCode,FairMarkMain.DcCode,FairMarkMain.MarkDate, " _
                & "FairMarkMain.HdCode,FairMarkMain.MarkSerial,FairMarkMain.Flag "
        Else
            Lct.SQL = "SELECT FairMarkMain.DepCode,FairMarkMain.DcCode,FairMarkMain.MarkDate, " _
                & "FairMarkMain.HdCode,FairMarkMain.MarkSerial,FairMarkMain.Flag " _
                & "FROM (FairMarkMain INNER JOIN FairMarkSub ON FairMarkMain.MarkSerial =FairMarkSub.MarkSerial) " _
                & "INNER JOIN m_Drug ON FairMarkSub.ItemCode =m_Drug.ItemCode " _
                & "WHERE FairMarkMain.SkSerial = '" & Sickobj.SkSerial & "' and fairMarkSub.Amount>0 and m_drug.itemcode<'D' " _
                & " AND FairMarkMain.Markserial >='" & stardate & "' AND FairMarkMain.Markserial <='" & EndDate & "' " _
                & "and FairMarkSub.dscode is null " _
                & "GROUP BY FairMarkMain.DepCode,FairMarkMain.DcCode,FairMarkMain.MarkDate, " _
                & "FairMarkMain.HdCode,FairMarkMain.MarkSerial,FairMarkMain.Flag "
        End If
    Else
        Lct.SQL = "SELECT FairMarkMain.DepCode,FairMarkMain.DcCode,FairMarkMain.MarkDate, " _
            & "FairMarkMain.HdCode,FairMarkMain.MarkSerial,FairMarkMain.Flag " _
            & "FROM (FairMarkMain INNER JOIN FairMarkSub ON FairMarkMain.MarkSerial =FairMarkSub.MarkSerial) " _
            & "WHERE FairMarkMain.SkSerial = '" & Sickobj.SkSerial & "' and fairMarkSub.Amount>0 and itemcode>'D' " _
            & " AND FairMarkMain.Markserial >='" & stardate & "' AND FairMarkMain.Markserial <='" & EndDate & "' " _
            & "GROUP BY FairMarkMain.DepCode,FairMarkMain.DcCode,FairMarkMain.MarkDate, " _
            & "FairMarkMain.HdCode,FairMarkMain.MarkSerial,FairMarkMain.Flag "
        If gtydSysConfig.CanInputDrug Then
            Lct.SQL = Lct.SQL & "union " _
            & "SELECT FairMarkMain.DepCode,FairMarkMain.DcCode,FairMarkMain.MarkDate, " _
            & "FairMarkMain.HdCode,FairMarkMain.MarkSerial,FairMarkMain.Flag " _
            & "FROM (FairMarkMain INNER JOIN FairMarkSub ON FairMarkMain.MarkSerial =FairMarkSub.MarkSerial) " _
            & "INNER JOIN m_Drug ON FairMarkSub.ItemCode =m_Drug.ItemCode " _
            & "WHERE FairMarkMain.SkSerial = '" & Sickobj.SkSerial & "' and fairMarkSub.Amount>0 and dscode is null " _
            & " AND FairMarkMain.Markserial >='" & stardate & "' AND FairMarkMain.Markserial <='" & EndDate & "' " _
            & "GROUP BY FairMarkMain.DepCode,FairMarkMain.DcCode,FairMarkMain.MarkDate, " _
            & "FairMarkMain.HdCode,FairMarkMain.MarkSerial,FairMarkMain.Flag "
        End If
    End If
    Lct.Refresh
    If Lct.Count >= 1 Then
        Lct.Visible = True
        Lct.Tag = 0
        FillData
    Else
        Lct.Visible = False
        If isHouse Then
            MsgBox "没有本药房所需要信息！", vbCritical
        Else
            MsgBox "没有需退费的数据！", vbCritical
        End If
    End If
End Sub

Private Sub QueryM(ItemCode As String)
    If Sickobj Is Nothing Then Exit Sub
    If isHouse Then
        Lct.SQL = "SELECT FairMarkMain.DepCode,FairMarkMain.DcCode,FairMarkMain.MarkDate, " _
            & "FairMarkMain.HdCode,FairMarkMain.MarkSerial,FairMarkMain.Flag ,batchid " _
            & "FROM (FairMarkMain INNER JOIN FairMarkSub ON FairMarkMain.MarkSerial =FairMarkSub.MarkSerial) " _
            & "INNER JOIN m_Drug ON FairMarkSub.ItemCode =m_Drug.ItemCode " _
            & "WHERE FairMarkMain.SkSerial = '" & Sickobj.SkSerial & "' and fairMarkSub.Amount>0 and m_Drug.ItemCode='" & ItemCode & "' " _
            & "and FairMarkSub.dscode='" & gtydSysConfig.DepCode & "' " _
            & "GROUP BY FairMarkMain.DepCode,FairMarkMain.DcCode,FairMarkMain.MarkDate, " _
            & "FairMarkMain.HdCode,FairMarkMain.MarkSerial,FairMarkMain.Flag,batchid "
    Else
        Lct.SQL = "SELECT FairMarkMain.DepCode,FairMarkMain.DcCode,FairMarkMain.MarkDate, " _
            & "FairMarkMain.HdCode,FairMarkMain.MarkSerial,FairMarkMain.Flag " _
            & "FROM (FairMarkMain INNER JOIN FairMarkSub ON FairMarkMain.MarkSerial =FairMarkSub.MarkSerial) " _
            & "WHERE FairMarkMain.SkSerial = '" & Sickobj.SkSerial & "' and fairMarkSub.Amount>0 and fairmarksub.itemcode>'D' " _
            & " AND fairmarksub.itemcode='" & ItemCode & "' " _
            & "GROUP BY FairMarkMain.DepCode,FairMarkMain.DcCode,FairMarkMain.MarkDate, " _
            & "FairMarkMain.HdCode,FairMarkMain.MarkSerial,FairMarkMain.Flag "
    End If
    Lct.Refresh
    If Lct.Count >= 1 Then
        Lct.Tag = 1
        Lct.Visible = True
        FillDataM ItemCode
    Else
        Lct.Visible = False
        If isHouse Then
            MsgBox "没有本药房所需要信息！", vbCritical
        Else
            MsgBox "没有需退费的数据！", vbCritical
        End If
        txtselect = ""
        txtselect.Tag = ""
        
    End If
End Sub

Private Sub FillData()
    Dim tmprs As Recordset
    Dim StrSQL As String
    If isHouse Then
        StrSQL = "SELECT FairMarkSub.ItemCode,m_Drug.BaseUnit,m_Drug.ItemName,m_Drug.Model,FairMarkSub.Unit," _
            & "FairMarkSub.Factor,FairMarkSub.CPrice,FairMarkSub.Gprice,FairMarkSub.Amount,FairBack.BackAmount," _
            & "FairMarkSub.MarkSerial,FairMarksub.depcode,FairMarkSub.num,FairMarkSub.factor,batchid " _
            & "FROM FairMarkSub " _
            & "Left join (select FairMarkBack.MarkSerial,num,sum(BackAmount) as 'BackAmount' from FairMarkBack " _
            & "           left join fairMarkMain on FairMarkMain.markserial=fairMarkBack.MarkSerial " _
            & "           where FairMarkMain.SkSerial='" & Sickobj.SkSerial & "' " _