modprogramentry.bas

来自「1、以DLL形式提供医生工作站 2、 根据【检查项目】」· BAS 代码 · 共 159 行

Attribute VB_Name = "modProgramEntry"
'----------------------------------------------------------------------------------------------------
'modProgramEntry.bas
'作者：刘辉
'时间：2008-4-8
'说明：数据库连接提示
'----------------------------------------------------------------------------------------------------

Option Explicit


'begin====启动接收服务===modProgramEntry=========================================================

Public Const KILL_EXE = "kill.exe"
Public Const HTSCP_EXE = "htscp.exe"
Public Const HTCONFIG = "HT-CONFIG.exe"

Const SECTION_WORKSTATION = "WORKSTATION"
Const KEY_TEMPDCM_LOCAL_ROOT = "TEMPDCM_LOCAL_ROOT"
Const CONFIG_FILE = "htpacs.ini"
Dim strConfigFilePath As String
Dim strTempDcmRoot As String
Dim strScpExePath As String
Dim strScpDirectory As String

Sub Main()
On Error GoTo ErrHandler
    If App.PrevInstance Then
        MsgBox "程序已经在运行!", vbOKOnly + vbInformation, "提示"
        Exit Sub
    End If
    
    ERROR_STRING = ""
    'If Not modGlobalDbConnect.InitializeConnection(App.Path + "\" + modGlobalDbConnect.DefDbConfName) Then
    'If Not InitPacsConnection Then
    
    'If Not InitPacsConnectionReg Then
    If Not InitPacsConnRegEncrypt Then
        Dim strErr As String
        strErr = "PACS数据库连接初始化出错,请配置连接。"
        'If ERROR_STRING <> "" Then
        '    strErr = strErr + ",原因:<" + ERROR_STRING + ">"
        'End If
        MsgBox strErr + "请与系统管理员联系!", vbExclamation, "提示"
        ERROR_STRING = ""
        Call ShellExecute(0, "open", "HT-CONFIG.exe", "", App.Path, vbHide)
        Exit Sub
    End If
    
    Call SystemInit
    
'    Load frmFirst
'    frmFirst.Show

    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub

Public Sub SystemInit()
On Error GoTo ErrHandler
    IF_LOGON = False

    Dim nRet As Long
    HOSPITAL_NAME = Space(256)
    nRet = GetPrivateProfileString("WORKSTATION", "HOSPITAL_NAME", "医院影像科", _
        HOSPITAL_NAME, 256, App.Path + "\" + CONFIG_FILE_NAME)
    HOSPITAL_NAME = left$(HOSPITAL_NAME, nRet)
    
    If HOSPITAL_NAME = "" Then
        HOSPITAL_NAME = "医院影像科"
    End If
    
    STATION_NAME = Space(256)
    
    nRet = GetPrivateProfileString("WORKSTATION", "STATION_NAME", "", _
        STATION_NAME, 256, App.Path + "\" + CONFIG_FILE_NAME)
    
    STATION_NAME = Trim(left$(STATION_NAME, nRet))
    STATION_NAME = DelInvaildChr(STATION_NAME)
    
    
    If STATION_NAME = "" Then
        STATION_NAME = "工作站"
    End If
    
    SERVER_IP = Space(256)
    nRet = GetPrivateProfileString("WORKSTATION", "SERVER_IP", "", _
        SERVER_IP, 256, App.Path + "\" + CONFIG_FILE_NAME)
    SERVER_IP = left(SERVER_IP, nRet)
    
    If SERVER_IP = "" Then
        SERVER_IP = "127.0.0.1"
    End If
    
    DCM_LOCAL_ROOT = Space(256)
    nRet = GetPrivateProfileString("WORKSTATION", "DCM_LOCAL_ROOT", "", _
        DCM_LOCAL_ROOT, 256, App.Path + "\" + CONFIG_FILE_NAME)
    DCM_LOCAL_ROOT = left(DCM_LOCAL_ROOT, nRet)
    
    If DCM_LOCAL_ROOT = "" Then
        DCM_LOCAL_ROOT = "127.0.0.1\D:DICOM"
    End If
    
    STATION_TYPE = Space(256)
    nRet = GetPrivateProfileString("STATIONTYPE", "STATION_TYPE", "", _
        STATION_TYPE, 256, App.Path + "\" + CONFIG_FILE_NAME)
    STATION_TYPE = left(STATION_TYPE, nRet)
    
    If STATION_TYPE <> "C/S" And STATION_TYPE <> "STAND_ALONE" Then
        STATION_TYPE = "STAND_ALONE"
    End If
    
    strConfigFilePath = App.Path + "\" + CONFIG_FILE
    strTempDcmRoot = Space(256)
    nRet = GetPrivateProfileString(SECTION_WORKSTATION, KEY_TEMPDCM_LOCAL_ROOT, "", strTempDcmRoot, _
        256, strConfigFilePath)
    strTempDcmRoot = left(strTempDcmRoot, nRet)
    If Trim(strTempDcmRoot) <> "" Then
    '        strScpDirectory = App.Path & "\" & SCP_DIRECTORY
        strScpDirectory = Trim(strTempDcmRoot)
    End If
    
    'FASHION_OF_FTP = Space(256)
    'nRet = GetPrivateProfileString("PHOTO_MEMORY", "FASHION_OF_FTP", "", _
    '    FASHION_OF_FTP, 256, App.Path + "\" + CONFIG_FILE_NAME)
    'FASHION_OF_FTP = Left(FASHION_OF_FTP, nRet)
    
    'DCM_LOCAL_ROOT = Left$(DCM_LOCAL_ROOT, nRet)
    'If FASHION_OF_FTP = "" Then
    '    FASHION_OF_FTP = "FTP"
    'End If
    
    Exit Sub
ErrHandler:
    HOSPITAL_NAME = "医院影像科"
    STATION_NAME = "工作站"
End Sub
'========启动接收服务============================================================
Public Function InitSCP()
On Error GoTo ErrHandler
    Dim nRtn As Long
    strScpExePath = App.Path & "\htscp.exe"
    nRtn = ShellExecute(0, "open", strScpExePath, _
    " 104  -tn -fe .dcm  -od " & strScpDirectory & " -xcr move_dcm_ct.exe", _
        App.Path, vbHide)
    If nRtn > 32 Then
    Else
        MsgBox "接收服务启动失败!", vbExclamation, "提示"
    End If
    
    Exit Function
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Function