clssickop.cls

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

    If recnum > 0 Then
        recCount = recnum
    Else
        recnum = 1
    End If
    Set mPg = New clsPage
    Set mPg.gdbobj = gdbobj
    If Not mPg.ReadFromDB("Open_RevSheet") Then Exit Function
    For Num = recnum To recCount
        sql = "select Revserial,Open_RecipeMain.recipeserial From Open_RecipeMain " _
            & "inner join Open_ReceiveSub on Open_ReceiveSub.recipeserial=Open_RecipeMain.recipeserial " _
            & "where actrevserial='" & ActRevSerial & "' and recipenum=" & Num
    
        Set FairObj = New clsItemFairs
        Set tmprs = New Recordset
        Set tmprs = gdbobj.GetNewRs("Open_GetRevCatiFair1 '" & ActRevSerial & "'," & Num)
        Do While Not tmprs.EOF
            FairObj.DepName = IIf(IsNull(tmprs!DepName), "", tmprs!DepName)
            FairObj.DcName = IIf(IsNull(tmprs!DcName), "", tmprs!DcName)
            FairObj.DsName = IIf(IsNull(tmprs!DsName), "", tmprs!DsName)
            FairObj.Add tmprs!CusmID, tmprs!Des, tmprs!fair
            tmprs.MoveNext
        Loop
        mPg.IDValue("INSID") = Me.INSID
        mPg.IDValue("SheetID") = SheetID
        mPg.IDValue("PatientID") = PatientID
        mPg.IDValue("Name") = Name
        mPg.IDValue("RevDate") = gfnGetTime("yyyy-mm-dd")
        mPg.IDValue("RevYear") = Format(gfnGetTime("yyyy-mm-dd"), "yyyy")
        mPg.IDValue("RevMonth") = Format(gfnGetTime("yyyy-mm-dd"), "mm")
        mPg.IDValue("RevDay") = Format(gfnGetTime("yyyy-mm-dd"), "dd")
        mPg.IDValue("HdName") = gtydSysConfig.HdName
        mPg.IDValue("HdCode") = gtydSysConfig.hdCode
        mPg.IDValue("PtType") = PtDes
        mPg.IDValue("DepName") = FairObj.DepName
        mPg.IDValue("DsName") = FairObj.DsName
        mPg.IDValue("DcName") = FairObj.DcName
        mPg.IDValue("HospName") = gtydSysConfig.HospName
        If gPatientTypesObj(PtID).Label Then
            If Not mPg.IDObject("IfLabel") Is Nothing Then mPg.IDValue("IfLabel") = mPg.IDObject("IfLabel").Str
        Else
            mPg.IDValue("IfLabel") = ""
        End If
        I = 1
        Do
            If mPg.IDObject("Cancel" & I) Is Nothing Then Exit Do
            mPg.IDValue("Cancel" & I) = "作废"
            I = I + 1
        Loop
        j = 1
        
        For I = 1 To FairObj.Count
            If mPg.IDObject(FairObj.Item(I).Id) Is Nothing Then
                mPg.IDValue("AddItemDes1") = FairObj.Item(I).Des
                mPg.IDValue("AddItemFair1") = Format(FairObj.Item(I).fair, gstrMONEY_FORMAT)
                j = j + 1
            Else
                mPg.IDValue(FairObj.Item(I).Id) = Format(FairObj.Item(I).fair, gstrMONEY_FORMAT)
                mPg.IDValue(FairObj.Item(I).Id & "Des") = FairObj.Item(I).Des
            End If
            mPg.IDValue("ItemDes1") = FairObj.Item(I).Des
            mPg.IDValue("ItemFair1") = Format(FairObj.Item(I).fair, gstrMONEY_FORMAT)
            mPg.IDValue("Cancel1") = ""
            capstr = Format(FairObj.Item(I).fair * 100, "##################")
            Capnum = 0
            For Capnum = 0 To Len(capstr) - 1
                mPg.IDValue("FairCap" & Format(Capnum, "0")) = GetCap(mID(capstr, Len(capstr) - Capnum, 1))
            Next Capnum
            mPg.IDValue("TotalFairCap") = hisGetMoneyCap(FairObj.Item(I).fair)
            mPg.IDValue("TotalFair") = Format(FairObj.Item(I).fair, gstrMONEY_FORMAT)
            If gtydSysConfig.Status <> 0 Then
               mPg.RPrint
            Else
               mPg.PreView vbModal
            End If
            mPg.IDValue("ItemDes1") = ""
            mPg.IDValue("ItemFair1") = ""
            mPg.IDValue("Cancel1") = ""
            mPg.IDValue("AddItemDes1") = ""
            mPg.IDValue("AddItemFair1") = ""
            For Capnum = 0 To Len(capstr) - 1
                mPg.IDValue("FairCap" & Format(Capnum, "0")) = ""
            Next Capnum
            Set tmprs = gdbobj.GetNewRs(sql)
            If Not tmprs.EOF Then
                Call gdbobj.DBExec("update Open_ReceiveSubSheet set sheetid= '" & SheetID & "' " _
                       & "WHERE revserial='" & tmprs(0) & "' and recipeserial='" & tmprs(1) & "'")
            End If
            If Num < recCount Then
'                insertsheet ActRevSerial & recnum, oldSheetid, SheetID
                If gDecSheet = 0 Then
                    gpdAddSheetID
                Else
                    gpdDecSheetID
                End If
                SheetID = gstrSheetID
            End If
        Next I
        
        For I = 1 To FairObj.Count
            If mPg.IDObject(FairObj.Item(I).Id) Is Nothing Then
                mPg.IDValue("AddItemDes" & j) = ""
                mPg.IDValue("AddItemFair" & j) = ""
                j = j + 1
            Else
                mPg.IDValue(FairObj.Item(I).Id) = ""
                mPg.IDValue(FairObj.Item(I).Id & "des") = ""
            End If
            mPg.IDValue("ItemDes" & I) = ""
            mPg.IDValue("ItemFair" & I) = ""
            mPg.IDValue("Cancel" & I) = ""
        Next I
    Next Num
    MPrint1 = True
errlbl:
End Function

Public Function MPrint2(ByVal SheetID As String, ByVal ActRevSerial As String, recnum As Integer) As Boolean
    Dim mPg As clsPage
    Dim FairObj As clsItemFairs
    Dim I As Integer, j As Integer, recCount As Integer, Num As Integer, Capnum As Integer
    Dim capstr As String
    Dim tmprs As Recordset
    Dim sql As String
On Error GoTo errlbl
    If gdbobj.GetRs("select count(*) from open_actReceiveSub where actrevserial='" & ActRevSerial & "'") > 0 Then
        recCount = gdbobj.Rs(0)
    End If
    If recnum > 0 Then
        recCount = recnum
    Else
        recnum = 1
    End If
    
    Set mPg = New clsPage
    Set mPg.gdbobj = gdbobj
    If Not mPg.ReadFromDB("Open_RevSheet") Then Exit Function
    For Num = recnum To recCount
        sql = "select Revserial,Open_RecipeMain.recipeserial From Open_RecipeMain " _
            & "inner join Open_ReceiveSub on Open_ReceiveSub.recipeserial=Open_RecipeMain.recipeserial " _
            & "where actrevserial='" & ActRevSerial & "' and recipenum=" & Num
        Set FairObj = New clsItemFairs
        Set tmprs = New Recordset
        Set tmprs = gdbobj.GetNewRs("Open_GetRevCatiFair1 '" & ActRevSerial & "'," & Num)
        Do While Not tmprs.EOF
            FairObj.DepName = IIf(IsNull(tmprs!DepName), "", tmprs!DepName)
            FairObj.DcName = IIf(IsNull(tmprs!DcName), "", tmprs!DcName)
            FairObj.DsName = IIf(IsNull(tmprs!DsName), "", tmprs!DsName)
            FairObj.Add tmprs!CusmID, tmprs!Des, tmprs!fair
            tmprs.MoveNext
        Loop
        mPg.IDValue("INSID") = Me.INSID
        mPg.IDValue("SheetID") = SheetID
        mPg.IDValue("PatientID") = PatientID
        mPg.IDValue("Name") = Name
        mPg.IDValue("RevDate") = gfnGetTime("yyyy-mm-dd")
        mPg.IDValue("HdName") = gtydSysConfig.HdName
        mPg.IDValue("HdCode") = gtydSysConfig.hdCode
        mPg.IDValue("PtType") = PtDes
        mPg.IDValue("DepName") = FairObj.DepName
        mPg.IDValue("DsName") = FairObj.DsName
        mPg.IDValue("DcName") = FairObj.DcName
        mPg.IDValue("HospName") = gtydSysConfig.HospName
        If gPatientTypesObj(PtID).Label Then
            If Not mPg.IDObject("IfLabel") Is Nothing Then mPg.IDValue("IfLabel") = mPg.IDObject("IfLabel").Str
            
        Else
            mPg.IDValue("IfLabel") = ""
        End If
        capstr = Format(FairObj.fair * 100, "##################")
        Capnum = 0
        For Capnum = 0 To Len(capstr) - 1
            mPg.IDValue("FairCap" & Format(Capnum, "0")) = GetCap(mID(capstr, Len(capstr) - Capnum, 1))
        Next Capnum
            
        mPg.IDValue("TotalFairCap") = hisGetMoneyCap(FairObj.fair)
        mPg.IDValue("TotalFair") = Format(FairObj.fair, gstrMONEY_FORMAT)
        I = 1
        Do
            If mPg.IDObject("Cancel" & I) Is Nothing Then Exit Do
            mPg.IDValue("Cancel" & I) = "作废"
            I = I + 1
        Loop
        j = 1
        
        For I = 1 To FairObj.Count
            If mPg.IDObject(FairObj.Item(I).Id) Is Nothing Then
                mPg.IDValue("AddItemDes" & j) = FairObj.Item(I).Des
                mPg.IDValue("AddItemFair" & j) = Format(FairObj.Item(I).fair, gstrMONEY_FORMAT)
                j = j + 1
            Else
                mPg.IDValue(FairObj.Item(I).Id) = Format(FairObj.Item(I).fair, gstrMONEY_FORMAT)
                mPg.IDValue(FairObj.Item(I).Id & "Des") = FairObj.Item(I).Des
            End If
            mPg.IDValue("ItemDes" & I) = FairObj.Item(I).Des
            mPg.IDValue("ItemFair" & I) = Format(FairObj.Item(I).fair, gstrMONEY_FORMAT)
            mPg.IDValue("Cancel" & I) = ""
        Next I
        
        If gtydSysConfig.Status > 0 Then
            mPg.RPrint
        Else
           mPg.PreView vbModal
        End If
        For Capnum = 0 To Len(capstr) - 1
            mPg.IDValue("FairCap" & Format(Capnum, "0")) = ""
        Next Capnum
        For I = 1 To FairObj.Count
            If mPg.IDObject(FairObj.Item(I).Id) Is Nothing Then
                mPg.IDValue("AddItemDes" & j) = ""
                mPg.IDValue("AddItemFair" & j) = ""
                j = j + 1
            Else
                mPg.IDValue(FairObj.Item(I).Id) = ""
                mPg.IDValue(FairObj.Item(I).Id & "des") = ""
            End If
            mPg.IDValue("ItemDes" & I) = ""
            mPg.IDValue("ItemFair" & I) = ""
            mPg.IDValue("Cancel" & I) = ""
        Next I
        Set tmprs = gdbobj.GetNewRs(sql)
        If Not tmprs.EOF Then
            Call gdbobj.DBExec("update Open_ReceiveSubSheet set sheetid= '" & SheetID & "' " _
                   & "WHERE revserial='" & tmprs(0) & "' and recipeserial='" & tmprs(1) & "'")
        End If
        If Num < recCount Then
            If gDecSheet = 0 Then
                gpdAddSheetID
            Else
                gpdDecSheetID
            End If
            SheetID = gstrSheetID
        End If
    Next Num
    MPrint2 = True
errlbl:
End Function

Public Function Refresh(ByVal ActRevSerial As String)
    If Update_Open_m_PatientBaseInfo(HISDBUpdate, Name:=Name, _
        PtID:=PtID, Brief:=hisGetChinesePYCode(Name), _
        UpdateCondition:="PatientID = '" & PatientID & "'") Then
        
        Refresh = True
    End If
End Function

Public Function Save(ByVal UpType As DbOpType, Optional FigFlag As Boolean = False) As Boolean
On Error GoTo errlbl
    Select Case UpType
        Case DbOpType.HISDbInsert
            If Not Update_Open_m_PatientBaseInfo(HISDbInsert, PatientID, Name, Sex, BirthDate, PtID, _
                hisGetChinesePYCode(Name), IIf(FigFlag, 1, 0)) Then
                
                GoTo errlbl
            End If
            
            Call Update_m_PatientBaseInfoApd(HISDbInsert, PatientID, INSID, Nation, IDCardNO, Worker, _
                Tel, Post, Address, Format(Date, "yyyy-mm-dd ") & Format(Time, "HH:NN:SS"), fbPtID)
            
        Case DbOpType.HISDBUpdate
            If Not Update_Open_m_PatientBaseInfo(HISDBUpdate, PatientID, Name, Sex, _
                IIf(BirthDate = "", Null, Format(BirthDate, gstrCOMN_DATE)), _
                PtID, hisGetChinesePYCode(Name), UpdateCondition:="PatientID = '" & Id & "'") Then