frmfetch.frm

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

Private Sub mcr_StatusChanged()
    If mcr.Status = CL_ADD Then
        LockInput False
        lct.Visible = False
        lblDate.Visible = False
        lblHander.Visible = False
        fraRecipe.Visible = True
    Else
        LockInput False
        lct.Visible = True
        lblDate.Visible = True
        lblHander.Visible = True
        fraRecipe.Visible = False
    End If
End Sub

Private Sub mskPkCount_GotFocus()
    mskPkCount.SelStart = 0
    mskPkCount.SelLength = Len(mskPkCount)
End Sub

Private Sub mskPkCount_LostFocus()
    loaddata False
    Sum
End Sub

Private Sub QueryObj_Ack(ByVal Cdt As String)
    If Cdt <> "" Then
        lct.SQL = "SELECT Open_RecipeMain.RecipeSerial " _
            & "FROM Open_RecipeMain WHERE Open_RecipeMain.FetchDate IS NOT NULL " _
            & " AND Open_RecipeMain.DsCode = '" & gtydSysConfig.DepCode & "' AND " & Cdt
        lct.Refresh
        If lct.Count >= 1 Then
            mcr.Status = CL_UPDATE
            FillQuery
        End If
    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 RemainAmount As Single, FetchAmount As Single
    Dim Cprice As Currency
    
    If ChangeMade Then
        If Col = 5 Then
           spd.Row = Row
           spd.Col = 4
           RemainAmount = Val(spd.Text)
           spd.Col = 5
           FetchAmount = spd.Text
           If FetchAmount < 0 Or FetchAmount > RemainAmount Then
                MsgBox "取药数量不能小于 0 或着 大于 收费数量!", vbCritical
                spd.Text = RemainAmount
                hisActiveSpreadCell spd, Row, Col - 1
            Else
                spd.Col = 6
                Cprice = spd.Text
                spd.Col = 7
                If FetchAmount = RemainAmount Then
                    spd.Text = CurFetchObj.Item(Row).ActFair
                Else
                    spd.Text = Cprice * FetchAmount
                End If
                
           End If
           loaddata False
           Sum

        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 spd_RightClick(ByVal ClickType As Integer, ByVal Col As Long, ByVal Row As Long, ByVal MouseX As Long, ByVal MouseY As Long)
    Call usp.RightClick
End Sub

Private Sub txtID_GotFocus()
    mID = txtID
    txtID.SelStart = 0
    txtID.SelLength = Len(txtID)
End Sub

Public Sub txtID_LostFocus()
    Dim SQL As String
    Dim i As Integer
    Dim GType As Integer
    Dim fetch As Boolean
    If mID = txtID Then Exit Sub
    If txtID = "" Then
        init
        Exit Sub
    End If
    If Sickobj Is Nothing Then
        Set Sickobj = New clsSickOP
    End If
    Sickobj.SkIDByBaseQuery = txtID
    txtName = Sickobj.Name
    txtPtType = Sickobj.PtDes
    If Sickobj.Id = "" Then
        init
        txtID.SetFocus
        Exit Sub
    End If
    SQL = "SELECT Open_ActReceiveSub.ActRevSerial,Open_ActReceiveSub.RecipeNum,Open_ActReceiveSubItem.comment," _
        & "Open_ActReceiveSubItem.Num,Open_ActReceiveSub.DcCode,m_Doctor.DcName," _
        & "Open_ActReceiveSub.DepCode,m_Depart.DepName,Open_ActReceiveSubItem.Flag," _
        & "m_Drug.ItemCode,m_Drug.ItemName,m_Drug.Model,Open_ActReceiveSubItem.Cprice,m_Drug.BaseUnit," _
        & "Open_ActReceiveSubItem.Unit,Open_ActReceiveSubItem.Factor,m_Drug.Gprice," _
        & "Open_ActReceiveSubItem.Amount,Open_ActReceiveSubItem.Fair,Open_ActReceiveSubItem.FetchAmount,Open_ActReceiveSubItem.FetchFair, " _
        & "Open_ActReceiveSubItem.revDepcode,Open_ActReceiveSub.recentFetchDate, " _
        & "Open_ActReceiveMain.RecentDate,Open_ActReceiveMain.SheetID, " _
        & "Open_ActReceiveSub.DsCode,m_Drug.Cprice as 'T_Price',Open_ActReceiveSub.rate,Open_ActReceiveSub.PKCount,batchid " _
        & "FROM ((((Open_ActReceiveMain INNER JOIN Open_ActReceiveSub " _
        & "ON Open_ActReceiveMain.ActRevSerial =Open_ActReceiveSub.ActRevSerial) " _
        & " INNER JOIN Open_ActReceiveSubItem " _
        & " ON Open_ActReceiveSub.ActRevSerial =Open_ActReceiveSubItem.ActRevSerial" _
        & " AND Open_ActReceiveSub.recipeNum =Open_ActReceiveSubItem.RecipeNum) " _
        & " INNER JOIN m_Drug ON m_Drug.ItemCode = Open_ActReceiveSubItem.ItemCode) " _
        & " INNER JOIN m_Depart ON Open_ActReceiveSub.DepCode =m_Depart.DepCode) " _
        & " LEFT JOIN m_Doctor ON Open_ActReceiveSub.DcCode =m_Doctor.DcCode " _
        & " WHERE Open_ActReceiveSub.Status & 1 =0 " _
        & " AND Open_ActReceiveMain.PatientID = '" & Sickobj.Id & "'  and  RecentFetchDate is null"
    If gtydSysConfig.ConFigureRev = False Then
        SQL = SQL & " AND Open_ActReceiveSub.DsCode ='" & gtydSysConfig.DepCode & "'"
    End If
    SQL = SQL & gfnMakeLimit(gtydSysConfig.ItemCode, "m_Drug.ItemCode")
    SQL = SQL & " ORDER BY Open_ActReceiveSub.ActRevSerial,Open_ActReceiveSub.RecipeNum,Open_ActReceiveSubItem.Num"
    Set Fetchsobj = New clsFetchs
    Fetchsobj.Make SQL
    If Fetchsobj.Count = 0 Then
        MsgBox "病人无收费记录!", vbCritical
        init
        txtID.SetFocus
        Exit Sub
    End If
    
    For i = 1 To Fetchsobj.Count
        If Fetchsobj.Item(i).RecentFetchDate <> "" Then
            fetch = True
        Else
            fetch = False
        
        End If
    Next i
    If fetch Then
        MsgBox "此病人已经退过药了不能再取药!或退费后重新开处方.", vbCritical
        init
        txtID.SetFocus
        Exit Sub
    End If
    FillData
End Sub
'
Private Sub checkstore(tmpFetchObj As clsFetchItem)
    Dim tmpamount As Long
    Dim Amount As Long
    Dim tfObj As clsFetchItem
    Dim OldFlag As Boolean, DelFlag As Boolean
    Dim Cprice As Double, gprice As Double
    Dim FetchFair  As Currency
    Dim FetchAmount As Long
    Dim TotalAmount As Long
    Dim TotalFair As Currency
    Dim SQL As String
    If tmpFetchObj.FetchAmount <= 0 Then Exit Sub
'    If tmpFetchObj.ItemName = "六味地黄水丸" Then
'        Exit Sub
'    End If
    Amount = tmpFetchObj.FetchAmount
    Cprice = tmpFetchObj.FetchFair / tmpFetchObj.FetchAmount
    SQL = "select BatchID,Amount,house_DrugBus.Cprice,house_DrugBus.Gprice,ItemName,Model " _
        & "from house_DrugBus " _
        & "inner join m_drug on m_drug.itemcode=house_DrugBus.itemcode " _
        & "where house_DrugBus.ItemCode='" & tmpFetchObj.ItemCode & "' and dscode='" & gtydSysConfig.DepCode & "' and amount>0 and house_drugBus.Cprice=" & tmpFetchObj.Cprice
    If gdbobj.GetRs(SQL) > 0 Then
        Do While Not gdbobj.Rs.EOF
            tmpamount = tmpamount + gdbobj.Rs(1)
            If gdbobj.Rs(0) = tmpFetchObj.batchid Then
                If gdbobj.Rs(1) = tmpFetchObj.FetchAmount Then Exit Sub
                If gdbobj.Rs(1) <= tmpFetchObj.FetchAmount Then
                    FetchFair = tmpFetchObj.FetchFair
                    FetchAmount = tmpFetchObj.FetchAmount
                    TotalAmount = tmpFetchObj.TotalAmount
                    TotalFair = tmpFetchObj.TotalFair
                    gprice = tmpFetchObj.gprice
                    Amount = tmpFetchObj.FetchAmount - gdbobj.Rs(1)
                    tmpFetchObj.FetchAmount = gdbobj.Rs(1)
                    tmpFetchObj.FetchFair = gdbobj.Rs(1) * Cprice
                    tmpFetchObj.TotalAmount = gdbobj.Rs(1)
                    tmpFetchObj.TotalFair = gdbobj.Rs(1) * Cprice
                    tmpFetchObj.gprice = IIf(IsNull(gdbobj.Rs(3)), 0, gdbobj.Rs(3))
                    tmpFetchObj.NewFlag = 1
                    OldFlag = True
                Else
                    Exit Sub
                End If
            End If
            gdbobj.Rs.MoveNext
        Loop
        DelFlag = True
        If tmpamount > Amount Then
            gdbobj.Rs.MoveFirst
            Do While Not gdbobj.Rs.EOF
                If gdbobj.Rs(0) <> tmpFetchObj.batchid Then
                    If gdbobj.Rs(1) <= Amount Then
                        Set tfObj = CurFetchObj.Add(CurFetchObj.Count + 1, CurFetchObj.Count + 1, tmpFetchObj.ItemCode, gdbobj.Rs!ItemName, gdbobj.Rs!model, _
                            gdbobj.Rs!Cprice, gdbobj.Rs(1), gdbobj.Rs(1) * Cprice, 0, 0, gdbobj.Rs(1), Cprice * gdbobj.Rs(1), _
                            tmpFetchObj.Factor, tmpFetchObj.unit, tmpFetchObj.BaseUnit, tmpFetchObj.Flag, IIf(IsNull(gdbobj.Rs(3)), 0, gdbobj.Rs(3)), _
                            tmpFetchObj.RevDepCode, gdbobj.Rs(0), tmpFetchObj.Comment)
                        tfObj.NewFlag = 2
                    Else
                        If OldFlag Then
                            Set tfObj = CurFetchObj.Add(CurFetchObj.Count + 1, CurFetchObj.Count + 1, tmpFetchObj.ItemCode, gdbobj.Rs!ItemName, gdbobj.Rs!model, _
                                Cprice, Amount, Amount * Cprice, 0, 0, Amount, Cprice * Amount, tmpFetchObj.Factor, _
                                tmpFetchObj.unit, tmpFetchObj.BaseUnit, tmpFetchObj.Flag, IIf(IsNull(gdbobj.Rs(3)), 0, gdbobj.Rs(3)), _
                                tmpFetchObj.RevDepCode, gdbobj.Rs(0), tmpFetchObj.Comment)
                            tfObj.NewFlag = 2
                        Else
                            tmpFetchObj.batchid = gdbobj.Rs(0)
                            tmpFetchObj.gprice = gdbobj.Rs(3)
                        End If
                        Exit Sub
                    End If
                    Amount = Amount - gdbobj.Rs(1)
                Else
                    DelFlag = False
                End If
                gdbobj.Rs.MoveNext
            Loop
            If DelFlag Then tmpFetchObj.NewFlag = -1

        Else
            If OldFlag Then
                tmpFetchObj.FetchAmount = FetchAmount
                tmpFetchObj.FetchFair = FetchFair
                tmpFetchObj.TotalAmount = TotalAmount
                tmpFetchObj.TotalFair = TotalFair
                tmpFetchObj.gprice = gprice
                tmpFetchObj.NewFlag = 0
            End If
        End If
        
    End If
End Sub

Private Sub loaddata(Opt As Boolean)
    Dim i As Integer
    If Val(mskPkCount) = 0 Then mskPkCount.Text = "1  "
    For i = 1 To spd.MaxRows
        spd.Row = i
        spd.Col = 5
'        spd.Col = CurFetchObj.Count
        CurFetchObj.Item(i).FetchAmount = spd.Text * CurFetchObj.Item(i).Factor * Val(mskPkCount)
        spd.Col = 7
        CurFetchObj.Item(i).FetchFair = spd.Text * Val(mskPkCount)
        If Opt Then checkstore CurFetchObj.Item(i)
    Next i
    If Opt Then FillDataByFetch
    CurFetchObj.FetchDate = gfnGetTime
    CurFetchObj.HdCode = gtydSysConfig.HdCode
    CurFetchObj.PKCount = Val(mskPkCount)
End Sub
Private Function ValidCheck() As Object
    Dim i As Integer
    Dim Having As Boolean
    
    If Sickobj Is Nothing Then
        MsgBox "请输入病人ID!", vbCritical
        Set ValidCheck = txtID
        Exit Function
    End If
    For i = 1 To spd.MaxRows
        spd.Row = i
        spd.Col = 5
        If Val(spd.Text) <> 0 Then
            Having = True
        End If
    Next i
    If Not Having Then
        MsgBox "此病人无取药项目!", vbCritical
        Set ValidCheck = spd
        Exit Function
    End If
    
End Function
Private Sub FillQuery()
    Dim QueryRecipeObj As clsRecipe
    Dim i As Integer
        
    Set QueryRecipeObj = New clsRecipe
    Set Sickobj = New clsSickOP
    QueryRecipeObj.RecipeSerialByQuery = lct.CurColumns(0)

    Sickobj.SkIDByBaseQuery = QueryRecipeObj.PatientID
    txtID = Sickobj.Id
    txtName = Sickobj.Name
    txtPtType = Sickobj.PtDes
    txtDoctor = QueryRecipeObj.DcName
    txtDepart = QueryRecipeObj.DepName
    lblDate = QueryRecipeObj.FetchDate
    Me.lblHander = QueryRecipeObj.FetchHdName
    spd.MaxRows = QueryRecipeObj.Count
    If QueryRecipeObj.PKCount > 1 Then
        fraPK.Visible = True
    Else
        fraPK.Visible = False
    End If
    For i = 1 To spd.MaxRows
        spd.Row = i
        spd.Col = 1
        spd.Text = QueryRecipeObj.Item(i).ItemName
        spd.Col = 2
        spd.Text = QueryRecipeObj.Item(i).batchid & "\" & QueryRecipeObj.Item(i).model
        spd.Col = 3
        spd.Text = QueryRecipeObj.Item(i).unit
        spd.Col = 4
        spd.Text = QueryRecipeObj.Item(i).Amount / QueryRecipeObj.Item(i).Factor / QueryRecipeObj.PKCount
        spd.Col = 5
        spd.Text = QueryRecipeObj.Item(i).Amount / QueryRecipeObj.Item(i).Factor / QueryRecipeObj.PKCount
        spd.Col = 6
        spd.Text = QueryRecipeObj.Item(i).Cprice * QueryRecipeObj.Item(i).Factor
        spd.Col = 7
        spd.Text = QueryRecipeObj.Item(i).Fair / QueryRecipeObj.PKCount
        spd.Col = 8
        spd.value = IIf(QueryRecipeObj.Item(i).Pub, 1, 0)
        spd.Col = 9
        spd.value = IIf(QueryRecipeObj.Item(i).Export, 1, 0)
    Next i
    lblFair = Format(QueryRecipeObj.TotalFair, gstrMONEY_FORMAT)
    lblPubFair = Format(QueryRecipeObj.TotalPubFair, gstrMONEY_FORMAT)
    lblSelfFair = Format(QueryRecipeObj.TotalSelfFair, gstrMONEY_FORMAT)
    lblOutFair = Format(QueryRecipeObj.TotalExportFair, gstrMONEY_FORMAT)
    lblFairTotal = Format(QueryRecipeObj.TotalFair, gstrMONEY_FORMAT)
    lblPubFairTotal = Format(QueryRecipeObj.TotalPubFair, gstrMONEY_FORMAT)
    lblSelfFairTotal = Format(QueryRecipeObj.TotalSelfFair, gstrMONEY_FORMAT)
    lblOutFairTotal = Format(QueryRecipeObj.TotalExportFair, gstrMONEY_FORMAT)
    
'    Sum
End Sub

Private Sub LockInput(Optional Locked As Boolean = True)
    Dim tmpObj As Object
    
    For Each tmpObj In Me.Controls
        If TypeName(tmpObj) = "TextBox" Or TypeName(tmpObj) = "ComboBox" _
            Or TypeName(tmpObj) = "CheckBox" Then
                tmpObj.Enabled = Not Locked
        End If
        If TypeName(tmpObj) = "vaSpread" Then
            gpdLockSpread tmpObj, Locked
        End If
    Next
End Sub

Private Function chkAmount() As Boolean
    Dim i As Integer
    Dim ActAmount As Double, FetchAmount As Double
    
    For i = 1 To spd.MaxRows
        spd.Row = i
        spd.Col = 4
        ActAmount = Val(spd.Text)
        spd.Col = 5
        FetchAmount = Val(spd.Text)
        If ActAmount <> FetchAmount Then
            If MsgBox("第 " & i & " 条药品没取完！是否继续?", vbYesNo + 32) = vbYes Then
                chkAmount = True
            End If
            Exit Function
        Else
            chkAmount = True
        End If
    Next i
                
End Function