frminpatidrugget.frm

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

    spd.BlockMode = True
    spd.Col = 2
    spd.Col2 = 3
    spd.Row = 1
    spd.Row2 = spd.MaxRows
    spd.Lock = False
    spd.BlockMode = False
    
End Sub
Private Sub PutSpread(ByVal Row As Integer, ByVal ItemCode, ByVal ItemName, ByVal model, _
        ByVal unit, ByVal Amount, ByVal Cprice, ByVal Factor, ByVal gprice, ByVal MarkSerial, ByVal Num, ByVal Baby, batchid)
    Dim i As Integer
    
    gUnitobj.Add ItemCode

    spd.Redraw = False
    spd.Row = Row
    spd.Col = 1
    spd.Text = ItemName
    spd.Col = 2
    spd.Text = batchid & "\" & model & " * " & Int(Factor)
    spd.Col = 3
    If gUnitobj(ItemCode).Count = 1 Then
        spd.CellType = SS_CELL_TYPE_EDIT
        spd.Text = unit
        spd.Lock = True
    Else
        spd.CellType = SS_CELL_TYPE_COMBOBOX
        spd.Lock = False
        For i = 1 To gUnitobj(ItemCode).Count
            spd.TypeComboBoxIndex = -1
            spd.TypeComboBoxString = gUnitobj(ItemCode).Item(i).unit
            If gUnitobj(ItemCode).Item(i).unit = unit Then
                spd.TypeComboBoxCurSel = i - 1
            End If
        Next i
    End If
    spd.Col = 4
    spd.Text = Amount / Factor
    spd.Col = 5
    If Cprice = 0 Then
        spd.Lock = False
    Else
        spd.Lock = True
    End If
    
    spd.Text = Cprice * Factor
    spd.Col = 6
    spd.Text = Cprice * Amount
    spd.Col = 7
    spd.Text = ItemCode
    spd.Col = 8
    spd.Text = Factor
    spd.Col = 9
    spd.Text = gprice
    spd.Col = 10
    spd.Text = MarkSerial
    spd.Col = 11
    spd.value = Baby
    spd.Redraw = True
    spd.Col = 12
    spd.Text = Num
End Sub


Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn And Me.ActiveControl.Name <> "spd" Then
        hisToActiveCtl(Me).SetFocus
    End If
End Sub

Private Sub Form_Load()
    hisFormToCenter Me, frmMain
    InitForm
    Set Lct.CN = gdbobj.CN
End Sub

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

Private Sub Lct_PosChanged(ByVal Pos As Long, ByVal OldPos As Long)
    FillData Lct.CurColumns(0)
End Sub



Private Sub mcr_Click(ByVal WhichB As UseMaintainCtl.BUTTONKEY)
    Dim ErrDes As String
    Dim tmpObj As Object
    
    Select Case WhichB
        Case BK_ADD
            Set tmpObj = ValidInput(ErrDes)
            If Not (tmpObj Is Nothing) Then
                MsgBox ErrDes, vbCritical
                tmpObj.SetFocus
                Exit Sub
            End If
            If Save Then
                init
                txtSkID.SetFocus
            Else
                MsgBox gdbobj.ErrDes, vbCritical
            End If
        Case BK_CLEAR
            init
            txtSkID.SetFocus
        Case BK_QUERY
            Set QueryObj = New frmComnQuery1
            QueryObj.QueryType = 6
            QueryObj.Show vbModal
        Case BK_TRANS
            init
            txtSkID.SetFocus
        
        Case BK_EXIT
            Unload Me
        
    End Select
End Sub



Private Sub QueryObj_Ack(ByVal Cdt As String)
    Lct.SQL = "SELECT DISTINCT FairMarkmain.MarkSerial,fairmarkmain.skserial " _
        & "FROM (FairMarkMain INNER JOIN FairMarkSub ON FairMarkMain.MarkSerial =FairMarkSub.MarkSerial) " _
        & "INNER JOIN m_Drug ON FairMarkSub.ItemCode=m_drug.ItemCode " _
        & " where  " & Cdt & " and FairMarkSub.dscode='" & gtydSysConfig.DepCode & "' and fairmarkmain.flag & 8 =8 "

    Lct.Refresh
    If Lct.Count > 0 Then
        Lct.Visible = True
        mcr.Status = CL_UPDATE
        FillData Lct.CurColumns(0), Lct.CurColumns(1)
    Else
        mcr.Status = CL_ADD
        Lct.Visible = False
    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
    End If
    If OutFlag And Not Sickobj.IFFoot And gtydSysConfig.ifgetoutFoot Then
        MsgBox "<" & Sickobj.Name & ">此病人还未结算!不能取药!", vbCritical
        init
        txtSkID.SetFocus
        Exit Sub
    End If
    Call gfnFillDataBySickRegInfo(Me, Sickobj)
    mcr.KeyEnabled(BK_QUERY) = True
    If Sickobj.OutDate = "" Then
        lblOutDate = ""
    Else
        lblOutDate = Format(Sickobj.OutDate, gstrCOMN_DATE)
    End If
    FillData ""
End Sub


Public Function Save()
    Dim i As Integer, j As Integer
    Dim MarkSerial As String, ItemName As String
    Dim ItemCode As String, Amount As Integer, Cprice As Currency, gmoney As Currency, batchid As String
    Dim gprice As Currency, unit As String, Factor As Integer, Fair As Currency, TotalFair As Currency
    Dim Flag As Integer
    Dim DrugAmountsObj As clsDrugAmounts, MarkSerialSQL As String

  
On Error GoTo errlbl
    If gtydSysConfig.IfDecStore Then
        Set DrugAmountsObj = New clsDrugAmounts
        DrugAmountsObj.Direct = -1
        DrugAmountsObj.DtType = tsH_PATIENT_OUT
        DrugAmountsObj.DsCode = gtydSysConfig.DepCode
        For i = 1 To spd.MaxRows
            spd.Row = i
            spd.Col = 5
            Cprice = Val(spd.Text)
            spd.Col = 9
            gprice = Val(spd.Text)
            spd.Col = 7
            ItemCode = spd.Text
            spd.Col = 1
            ItemName = spd.Text
            spd.Col = 2
            If InStr(spd.Text, "\") > 1 Then
                batchid = left(spd.Text, InStr(spd.Text, "\") - 1)
            Else
                batchid = ""
            End If
            spd.Col = 8
            Factor = Val(spd.Text)
            spd.Col = 4
            Amount = Val(spd.Text) * Factor
            If gtydSysConfig.IfDecStore Then DrugAmountsObj.Add ItemCode, ItemName, CLng(Amount), CStr(batchid), Cprice, gprice
        Next i
        DrugAmountsObj.GetStorage
        If Not DrugAmountsObj.JugeStorageForOut Then
            gdbobj.ErrDes = DrugAmountsObj.Info
            Exit Function
        End If
    End If
    gdbobj.CNExe.BeginTrans
    If gtydSysConfig.IfDecStore Then
        If Not DrugAmountsObj.UpDateStorage Then
            GoTo errlbl
        End If
    End If
    For i = 1 To spd.MaxRows
        spd.Row = i
        spd.Col = 10
        If MarkSerialSQL <> spd.Text Then
            If Not gdbobj.DBExec("UPDATE FairMarkMain " _
                & " set FetchDate = '" & gfnGetTime() & "',FetchHdCode = '" & gtydSysConfig.HdCode _
                & "' WHERE MarkSerial='" & spd.Text & "'") Then
                
                GoTo errlbl
            End If
        End If
        MarkSerialSQL = spd.Text
        spd.Col = 12
        If Not gdbobj.DBExec("UPDATE FairMarkSub Set DsCode ='" & gtydSysConfig.DepCode & "' " _
            & " WHERE MarkSerial='" & MarkSerialSQL & "' and num=" & spd.Text) Then
            
            GoTo errlbl
        End If
    Next i
    Save = True
    gdbobj.CNExe.CommitTrans
    Exit Function
errlbl:
    gdbobj.CNExe.RollbackTrans
End Function


Private Sub Sum()
    Dim i As Integer
    Dim TotalFair As Currency
    
    spd.Col = 6
    For i = 1 To spd.MaxRows
        spd.Row = i
        TotalFair = TotalFair + spd.Text
    Next i
    lblTotalFair = Format(TotalFair, gstrMONEY_FORMAT)
End Sub

Public Function ValidInput(ErrDes As String) As Object
    If Sickobj Is Nothing Then
        ErrDes = "必须输入病人信息!"
        Set ValidInput = Me.txtSkID
        Exit Function
    End If
    If spd.MaxRows = 0 And OutFlag Then
        ErrDes = "没有出院带药项目!"
        Set ValidInput = spd
    End If
    If spd.MaxRows = 0 And Not OutFlag Then
        ErrDes = "没有取药项目!"
        Set ValidInput = spd
    End If
    
End Function
Private Sub FillData(Optional MarkSerial = "", Optional SkSerial As String)
    Dim SQL As String, i As Integer
    If Sickobj Is Nothing Then Set Sickobj = New clsSick
    Sickobj.SkSerialByQuery = SkSerial
    If MarkSerial = "" Then
        SQL = "SELECT FairMarkSub.MarkSerial,FairMarkSub.num,FairMarkSub.ItemCode,ItemName,Model,FairMarkSub.Unit,FairMarkSub.CPrice," _
            & "FairMarkSub.Amount-COALESCE(backamount,0) as amount,FairMarkSub.Factor,FairMarkMain.Flag,batchid " _
            & "FROM (FairMarkMain INNER JOIN FairMarkSub ON FairMarkMain.MarkSerial =FairMarkSub.MarkSerial) " _
            & "INNER JOIN m_Drug ON FairMarkSub.ItemCode=m_drug.ItemCode " _
            & "LEFT JOIN (select Markserial,num,sum(COALESCE(backamount,0)) as backamount from FairMarkBack " _
            & "           group by markserial,num) Back ON FairMarkSub.markserial=back.markserial and FairMarkSub.num=back.num " _
            & " where FairMarkSub.dscode is null AND SkSerial = '" & Sickobj.SkSerial & "' and amount>0 " _
            & " and (backamount<>amount or backamount is null) " & gfnMakeLimit(gtydSysConfig.ItemCode, "m_drug.Itemcode")
    Else
        SQL = "SELECT FairMarkSub.MarkSerial,FairMarkSub.num,FairMarkSub.ItemCode,ItemName,Model,FairMarkSub.Unit,FairMarkSub.CPrice," _
            & "FairMarkSub.Amount-COALESCE(backamount,0) as amount,FairMarkSub.Factor,FairMarkMain.Flag,batchid " _
            & "FROM (FairMarkMain INNER JOIN FairMarkSub ON FairMarkMain.MarkSerial =FairMarkSub.MarkSerial) " _
            & "INNER JOIN m_Drug ON FairMarkSub.ItemCode=m_drug.ItemCode " _
            & "LEFT JOIN (select Markserial,num,sum(COALESCE(backamount,0)) as backamount from FairMarkBack " _
            & "           group by markserial,num) Back ON FairMarkSub.markserial=back.markserial and FairMarkSub.num=back.num " _
            & " where FairMarkmain.markserial='" & MarkSerial & "' and dscode='" & gtydSysConfig.DepCode & "' and (backamount<>amount or backamount is null) and amount>0 "
    End If
    If OutFlag Then
       SQL = SQL & " and FairMarkMain.Flag & 4 =4 "
    Else
       SQL = SQL & " and FairMarkMain.Flag & 4 =0 "
    End If
    SQL = SQL & " order By FairMarkSub.markserial"
    spd.MaxRows = 0
    i = 1
    If gdbobj.GetRs(SQL) > 0 Then
        FillBaseInfo Sickobj
        mflag = gdbobj.Rs!Flag
        Do Until gdbobj.Rs.EOF
            spd.MaxRows = spd.MaxRows + 1
            PutSpread i, gdbobj.Rs!ItemCode, gdbobj.Rs!ItemName, gdbobj.Rs!model, _
                gdbobj.Rs!unit, gdbobj.Rs!Amount, gdbobj.Rs!Cprice, gdbobj.Rs!Factor, _
                0#, gdbobj.Rs!MarkSerial, gdbobj.Rs!Num, IIf((gdbobj.Rs!Flag And 2) = 2, True, False), _
                IIf(IsNull(gdbobj.Rs!batchid), "", gdbobj.Rs!batchid)
            gdbobj.Rs.MoveNext
            i = i + 1
        Loop
        Sum
        If MarkSerial <> "" Then
            spd.BlockMode = True
            spd.Col = 2
            spd.Col2 = 3
            spd.Row = 1
            spd.Row2 = spd.MaxRows
            spd.Lock = True
            spd.BlockMode = False
        End If
    Else
        If gdbobj.GetRs("select *from fairmarkmain where skserial='" & Sickobj.SkSerial & "' and flag & 32=32") > 0 Then
            MsgBox "请先到住院处记账后再取药！", vbInformation
            init
            txtSkID.SetFocus
        Else
            MsgBox "没有未取药品!", vbCritical
        End If
        init
        txtSkID.SetFocus
    End If
End Sub

Private Sub FillBaseInfo(Sickobj As clsSick)
    txtSkID.Text = Sickobj.SkID
    lblName.Caption = Sickobj.Name
    lblSex.Caption = Sickobj.SexDes
    lblAge.Caption = Sickobj.Age
    lblPtType.Caption = Sickobj.PtDes
    lblAddr.Caption = Sickobj.Addr
    lblContactor.Caption = Sickobj.Contactor
    lblContactorAddr.Caption = Sickobj.ContactorAddr
    lblDepCode.Caption = Sickobj.DepCode
    lblBedNum.Caption = Sickobj.BedNum
    lblInDate.Caption = Sickobj.InDate
    lblOutDate.Caption = IIf(IsNull(Sickobj.OutDate), "", Sickobj.OutDate)
    lblFair.Caption = Sickobj.Fair
    lblRemFair.Caption = Sickobj.RemFair
End Sub