危急值上报后写入留言备注服务日志

博主：猫不是猫
发布时间：2024 年 04 月 22 日
823 次浏览
暂无评论
20782字数
分类： PACS5.5 放射 VBS脚本

* 调用exe上报无法写入，所以写了个触发器处理

> 先创建触发器

```sql
CREATE OR REPLACE TRIGGER trg_criticalvalueinfo
AFTER INSERT ON criticalvalueinfo
FOR EACH ROW
DECLARE
    v_remark_uid VARCHAR2(32);
BEGIN
    IF :NEW.STATUS = 1 THEN
        -- 生成主键
        v_remark_uid := SYS_GUID();

-- 执行插入操作
        INSERT INTO remark_info
        (REMARK_UID,
         CHECKSERIALNUM,
         EVENTTYPEID,
         REMARK_TYPE,
         REMARK_OBJECT,
         REMARK_ISVISABLE,
         REMARK_ISHASHINTINFO,
         CREATOR,
         CREATE_TIME,
         UPDATER,
         UPDATE_TIME)
        VALUES
        (v_remark_uid,
         :NEW.CHECKSERIALNUM,
         '5060',
         0,
         '',
         1,
         1,
         :NEW.SENDER,
         SYSDATE,
         :NEW.SENDER,
         SYSDATE);

-- 执行remark_hint_info表的插入操作
        INSERT INTO remark_hint_info
        (REMARK_UID, REMARK_INFO, CREATOR, CREATE_TIME)
        VALUES
        (v_remark_uid, :NEW.CRITICALVALUE, :NEW.SENDER, SYSDATE);
    END IF;
END;

```

> 然后Rpt_VerifyRpt.vbs脚本有带了一部分处理的操作，为避免冲突，需要删掉，以下是完整的内容

```vbnet
Call Main()

Sub Main()
	'---------------启用词汇校验判断功能(如果启动该功能，将下6行注释代码开启)---------------   
	if JudgeGlossary=True Then
		Parameters.SetNamedValue "ReturnValue","false"
		Exit Sub
	End If
  
	'---------------启用描述为空提醒功能--------------- 
	If Not PromptIfReportEmpty Then
		Exit Sub
	End If

'---------------启用阳性率设置提醒功能--------------- 
	'Call PromptIfMasculine 
    If Not PromptIfMasculine Then 
      Parameters.SetNamedValue "ReturnValue","false"
       Exit Sub 
    End If 
   
	'---------------启用胶片未排版提醒功能--------------- 
'	if NotifyFilmState=True THEN
'		Parameters.SetNamedValue "ReturnValue","false"
'		Exit Sub
'	End If

'分支7：启用危急值上报提醒功能 
    If Not PromptCriticalValues Then 
       Parameters.SetNamedValue "ReturnValue","false"
       Exit Sub 
    End If

' Parameters.SetNamedValue "ReturnValue","true"

End Sub

'-------启用描述诊断词汇校验功能函数------
Function JudgeGlossary
  SexName = CStr(Rpt.Data.GetNamedValue("SexName"))
  DESCRIBE = CStr(Rpt.Data.GetNamedValue("DESCRIBE"))
  DIAGNOSE = CStr(Rpt.Data.GetNamedValue("DIAGNOSE"))
  StudyScription = CStr(Rpt.Data.GetNamedValue("StudyScription"))

'---------------调用左、右方向性词汇校验函数JudgeGlossaryLR(DESCRIBE,DIAGNOSE)---------------
  If JudgeGlossaryLR(StudyScription,DESCRIBE,DIAGNOSE)=True Then
     JudgeGlossary=True
     Exit Function
  Else
     JudgeGlossary=false
  End If 
'---------------根据患者性别调用性别禁用词汇函数---------------   
  If SexName="女" Then
     If JudgeGlossarySexF(DESCRIBE,DIAGNOSE,lsname)=True Then
      	ReturnValue=MyScript.MsgBox("报告中出现与女性不符词汇："&lsname&" 是否确定要提交?","性别校验",vbQuestion+vbYesNo)
      	If CInt(ReturnValue)=vbNo Then
	        JudgeGlossary=True
        	Exit Function  
      	else
	      ReturnValue=MyScript.MsgBox("报告中出现与女性不符词汇："&lsname&" 是否确定要提交?","性别校验二次确定",vbQuestion+vbYesNo)
	      If CInt(ReturnValue)=vbNo Then
		JudgeGlossary=True
        	Exit Function
	      else
		JudgeGlossary=False    
	      end if
      end if
'        ReturnValue=MyScript.MsgBox("报告中出现与女性不符词汇："&lsname&" ",vbExclamation)
'        JudgeGlossary=True
'        Exit Function
     Else
        JudgeGlossary=False
     End If 
  ElseIf SexName="男" Then
   If JudgeGlossarySexM(DESCRIBE,DIAGNOSE,lsname)=True Then  
'        ReturnValue=MyScript.MsgBox("报告中出现与男性不符词汇："&lsname&" ",vbExclamation)
'        JudgeGlossary=True
'        Exit Function
      ReturnValue=MyScript.MsgBox("报告中出现与男性不符词汇："&lsname&" 是否确定要提交?","性别校验",vbQuestion+vbYesNo)
      If CInt(ReturnValue)=vbNo Then
	JudgeGlossary=True
	Exit Function    
      else
	ReturnValue=MyScript.MsgBox("报告中出现与男性不符词汇："&lsname&" 是否确定要提交?","性别校验二次确定",vbQuestion+vbYesNo)
	If CInt(ReturnValue)=vbNo Then
		JudgeGlossary=True
        	Exit Function
	else
		JudgeGlossary=False    
	end if
      end if
    Else
        JudgeGlossary=False    
    End If 
  Else
    JudgeGlossary=false
  End If

'---------------调用相斥词汇校验函数---------------

If JudgeGlossaryAfoul(DESCRIBE,DIAGNOSE)=True Then
     JudgeGlossary=True
     Exit Function
  Else
     JudgeGlossary=False    
  End If

'---------------调用根据检查项目进行词汇校验函数---------------  
  If JudgeGlossaryStudy(StudyScription,DESCRIBE,DIAGNOSE)=True Then
     JudgeGlossary=True
     Exit Function
  Else
     JudgeGlossary=False    
  End If
End Function

'---------------左、右方向性词汇校验（描述与诊断中出现方向性词汇左右不一致提示）---------------
Function JudgeGlossaryLR(StudyScription, DESCRIBE,DIAGNOSE)
  '如果Scription中出现左右或双 直接退出
  Li_StudyScription_LR=InStr(1,StudyScription,"左右")
  Li_StudyScription_S=InStr(1,StudyScription,"双")
  Li_StudyScription_L=InStr(1,StudyScription,"左")
  Li_StudyScription_R=InStr(1,StudyScription,"右")
  if Li_StudyScription_LR>0 Or Li_StudyScription_S>0 Or (Li_StudyScription_L<=0 And  Li_StudyScription_R<=0) then
    JudgeGlossaryLR=False
    Exit Function
  end if
  Li_StudyScription_Left=InStr(1,StudyScription,"左")
  Li_StudyScription_Right=InStr(1,StudyScription,"右")
  Li_DESCRIBE_Left=InStr(1,DESCRIBE,"左")
  Li_DESCRIBE_Right=InStr(1,DESCRIBE,"右")
  Li_DIAGNOSE_Left=InStr(1,DIAGNOSE,"左")
  Li_DIAGNOSE_Right=InStr(1,DIAGNOSE,"右")
  '如果Scription中出现左
  if Li_StudyScription_Left > 0 then
    '如果描述中出现右
    if Li_DESCRIBE_Right > 0 then
      ReturnValue=MyScript.MsgBox("检查项目中有左，但是报告描述中出现右，是否继续？"&VbCrLf&"是为继续，否为取消。","左右校验",vbQuestion+vbYesNo)
      If CInt(ReturnValue)=vbNo Then
        JudgeGlossaryLR=True
        Exit Function
      else
        JudgeGlossaryLR=False
      end if
    end if
    '如果诊断中出现右
    if Li_DIAGNOSE_Right > 0 then
      ReturnValue=MyScript.MsgBox("检查项目中有左，但是报告诊断中出现右，是否继续？"&VbCrLf&"是为继续，否为取消。","左右校验",vbQuestion+vbYesNo)
      If CInt(ReturnValue)=vbNo Then
        JudgeGlossaryLR=True
        Exit Function
      else
        JudgeGlossaryLR=False
      end if
    end if
  end if

'如果Scription中出现右
  if Li_StudyScription_Right > 0 then
    if Li_DESCRIBE_Left > 0 then
      ReturnValue=MyScript.MsgBox("检查项目中有右，但是报告描述中出现左，是否继续？"&VbCrLf&"是为继续，否为取消。","左右校验",vbQuestion+vbYesNo)
      If CInt(ReturnValue)=vbNo Then
        JudgeGlossaryLR=True
        Exit Function
      else
        JudgeGlossaryLR=False
      end if
    end if
    if Li_DIAGNOSE_Left > 0 then
      ReturnValue=MyScript.MsgBox("检查项目中有右，但是报告诊断中出现左，是否继续？"&VbCrLf&"是为继续，否为取消。","左右校验",vbQuestion+vbYesNo)
      If CInt(ReturnValue)=vbNo Then
        JudgeGlossaryLR=True
        Exit Function
      else
        JudgeGlossaryLR=False
      end if
    end if
  end if
  '检查项目中没左右
  if Li_StudyScription_Left = 0 and Li_StudyScription_Right=0 then
    if Li_DESCRIBE_Left > 0 and Li_DIAGNOSE_Right > 0 then' (Li_DESCRIBE_Left > 0 and Li_DESCRIBE_Right = 0) and Li_DIAGNOSE_Right > 0 then 
      ReturnValue=MyScript.MsgBox("报告描述中有左，但是报告诊断中出现右，是否继续？"&VbCrLf&"是为继续，否为取消。","左右校验",vbQuestion+vbYesNo)
      If CInt(ReturnValue)=vbNo Then
        JudgeGlossaryLR=True
        Exit Function
      else
        JudgeGlossaryLR=False
      end if
    end if
  end if 
  if Li_StudyScription_Left = 0 and Li_StudyScription_Right=0 then
    if Li_DESCRIBE_Right > 0 and Li_DIAGNOSE_Left > 0 then '(Li_DESCRIBE_Right > 0 and Li_DESCRIBE_Left = 0) and Li_DIAGNOSE_Left > 0 then 
      ReturnValue=MyScript.MsgBox("报告描述中有有右，但是报告诊断中出现左，是否继续？"&VbCrLf&"是为继续，否为取消。","左右校验",vbQuestion+vbYesNo)
      If CInt(ReturnValue)=vbNo Then
        JudgeGlossaryLR=True
        Exit Function
      else
        JudgeGlossaryLR=False
      end if
    end if
  end if 
  JudgeGlossaryLR=False
End Function

'---------------女性患者词汇校验（女性患者报告中出现不应该出现的词汇判断）---------------
Function JudgeGlossarySexF(DESCRIBE,DIAGNOSE,ByRef lsname)
  Set fs = CreateObject("Scripting.FileSystemObject") 
  Set ts = fs.OpenTextFile("Config/女禁用词", 1) 
  While Not ts.AtEndOfStream
    lsname= Trim(ts.ReadLine())
    If InStr(1,DESCRIBE,lsname)>0 Or InStr(1,DIAGNOSE,lsname)>0 Then
      JudgeGlossarySexF = True
      ts.close
      Exit Function
    Else
      JudgeGlossarySexF = False
    End if
  Wend 
  ts.Close
End Function

'---------------男性患者词汇校验（男性患者报告中出现不应该出现的词汇判断）---------------
Function JudgeGlossarySexM(DESCRIBE,DIAGNOSE,ByRef lsname)
  Set fs = CreateObject("Scripting.FileSystemObject") 
  Set ts = fs.OpenTextFile("Config/男禁用词", 1) 
  While Not ts.AtEndOfStream
    lsname= Trim(ts.ReadLine())
    If InStr(1,DESCRIBE,lsname)>0 Or InStr(1,DIAGNOSE,lsname)>0 Then
      JudgeGlossarySexM = True
      ts.close
      Exit Function
    Else
      JudgeGlossarySexM = False
    End if
  Wend 
  ts.Close
End Function

'---------------相斥词汇校验（报告中不应该同时出现的词汇）---------------
Function JudgeGlossaryAfoul(DESCRIBE,DIAGNOSE)
  Set fs = CreateObject("Scripting.FileSystemObject") 
  Set ts = fs.OpenTextFile("Config/相斥词汇", 1)
  While Not ts.AtEndOfStream
    lsname= Trim(ts.ReadLine())
    Li_return=InStr(1,lsname,"#")
    If li_return > 0 Then   
      LeftString=Left(lsname,Li_return -1)
      RightString=Right(lsname,Len(lsname)-Li_return)
      Li_LeftStringDESCRIBE=InStr(1,DESCRIBE,LeftString)
      Li_LeftStringDIAGNOSE=InStr(1,DIAGNOSE,LeftString)
      Li_RightStringDESCRIBE=InStr(1,DESCRIBE,RightString)
      Li_RightStringDIAGNOSE=InStr(1,DIAGNOSE,RightString)
      If (Li_LeftStringDESCRIBE>0 Or Li_LeftStringDIAGNOSE>0) And (Li_RightStringDESCRIBE>0 Or Li_RightStringDIAGNOSE>0) Then
        ReturnValue=MyScript.MsgBox("报告中出现常理不应该同时出现的词汇："&lsname&"，是否继续？是为继续，否为取消。","描述诊断中词汇互斥", "互斥词汇校验",vbQuestion+vbYesNo)
        If CInt(ReturnValue)=vbNo Then
          JudgeGlossaryAfoul=True
          ts.Close
          Exit Function
        Else
          JudgeGlossaryAfoul=False		 
        End If   	 
      End If
    End If 
  Wend
  JudgeGlossaryAfoul=False 
  ts.Close
End Function

'---------------根据检查项目进行词汇校验（根据检查项目判断报告中不应该出现的词汇）---------------
Function JudgeGlossaryStudy(StudyScription,DESCRIBE,DIAGNOSE)
  Set fs = CreateObject("Scripting.FileSystemObject") 
  Set ts = fs.OpenTextFile("Config/检查项目禁用词汇", 1)
  While Not ts.AtEndOfStream
    lsname= Trim(ts.ReadLine())
'    MyVar = MsgBox (lsname, 65, "调试")
    Li_return=InStr(1,lsname,"#")
    If li_return > 0 Then 
      LeftString=Left(lsname,Li_return -1)
      RightString=Right(lsname,Len(lsname)-Li_return)
      Li_RightStringDESCRIBE=InStr(1,DESCRIBE,RightString)
      Li_RightStringDIAGNOSE=InStr(1,DIAGNOSE,RightString)
      If LeftString=StudyScription Then
        If Li_RightStringDESCRIBE>0 Or Li_RightStringDIAGNOSE>0 Then
          ReturnValue=MyScript.MsgBox("报告中出现常理当前检查项目不应该出现的词汇："&RightString&"，是否继续？是为继续，否为取消。", "根据检查项目进行词汇校验",vbQuestion+vbYesNo)
          If CInt(ReturnValue)=vbNo Then
            JudgeGlossaryStudy=True
            ts.Close
            Exit Function
          Else
            JudgeGlossaryStudy=False
          End If   	  	 
        End If
      End If
    End If  
  Wend
  JudgeGlossaryStudy=False 
  ts.Close
End Function

'---------------根据检查项目进行词汇校验（根据检查项目判断报告中不应该出现的词汇）---------------
Function JudgeGlossaryStudy1(StudyScription,DESCRIBE,DIAGNOSE)
  Set fs = CreateObject("Scripting.FileSystemObject") 
  Set ts = fs.OpenTextFile("Config/检查项目互斥词", 1)
  While Not ts.AtEndOfStream
    lsname= Trim(ts.ReadLine())
    'MyVar = MsgBox (lsname, "调试", 65)
    Li_return=InStr(1,lsname,"#")
    If li_return > 0 Then 
      LeftString=Left(lsname,Li_return -1)
      RightString=Right(lsname,Len(lsname)-Li_return)
      Li_RightStringDESCRIBE=InStr(1,DESCRIBE,RightString)
      Li_RightStringDIAGNOSE=InStr(1,DIAGNOSE,RightString)
      If InStr(1, StudyScription, LeftString) > 0 Then
        If Li_RightStringDESCRIBE>0 Or Li_RightStringDIAGNOSE>0 Then
          ReturnValue=MyScript.MsgBox("报告中出现常理当前检查项目不应该出现的词汇："&RightString&"，是否继续？是为继续，否为取消。", "根据检查项目判断",vbQuestion+vbYesNo)
          If CInt(ReturnValue)=vbNo Then
            JudgeGlossaryStudy1=True
            ts.Close
            Exit Function
          Else
            JudgeGlossaryStudy1=False
          End If   	  	 
        End If
      End If
    End If  
  Wend
  JudgeGlossaryStudy1=False 
  ts.Close
End Function

Function PromptIfReportEmpty
	isReportEmpty = Parameters.GetNamedValue("ISREPORTEMPTY")
	If isReportEmpty="1" Then
		MyScript.MsgBox "本报告的描述内容为空，不能提交，请确认后再提交!", vbOKOnly+vbExclamation
		PromptIfReportEmpty = False
		Exit Function
	End If

PromptIfReportEmpty = True
End Function

Function PromptIfMasculine
	Masculine = Rpt.Data.GetNamedValue("IFMASCULINE")
	If Masculine<>"1" And Masculine<>"2" Then
		ReturnValue=MyScript.MsgBox("请确认检查是否为阳性？是为阳性，否为阴性。",vbQuestion+vbYesNo)

If CInt(ReturnValue)=vbNo Then

Rpt.Data.SetNamedValue "IFMASCULINE","1"
			PromptIfMasculine=True
			Exit Function
		ElseIf CInt(ReturnValue)=vbYes Then

Rpt.Data.SetNamedValue "IFMASCULINE","2"
			PromptIfMasculine=True
			Exit Function
		Else
	 	   PromptIfMasculine=False
		   Exit Function
		End If
	else
		PromptIfMasculine=True
	End If

End Function

' Sub PromptIfMasculine
	' Masculine = Rpt.Data.GetNamedValue("IFMASCULINE")
	' If Masculine<>"1" And Masculine<>"2" Then
		' ReturnValue=MyScript.MsgBox("请确认检查是否为阳性？是为阳性，否为阴性。",vbQuestion+vbYesNo)
		' If CInt(ReturnValue)=vbNo Then
			' Rpt.Data.SetNamedValue "IFMASCULINE","1"
		' Else
			' Rpt.Data.SetNamedValue "IFMASCULINE","2"
		' End If 
	' End If
' End Sub

'Function  PromptIfMasculine
'	Masculine = Rpt.Data.GetNamedValue("IFMASCULINE")
'	If Masculine="-1" Then
'		MyScript.MsgBox "请选择当前检查的阴阳性再提交报告！",vbExclamation+vbOKOnly
'		PromptIfMasculine=False 
'		Exit Function 
'	End If
'	PromptIfMasculine=True 
'End Function

Function NotifyFilmState
	Checkserialnum = Rpt.Data.GetNamedValue("CHECKSERIALNUM")
	sql = "SELECT PUTOUTFILM FROM STUDYINFO WHERE CHECKSERIALNUM='"&Checkserialnum&"'"
	Set Conn=Rpt.GetDBConn
	Set rs = Conn.Execute(sql)
	If not rs.eof Then
		If CInt(rs("PUTOUTFILM"))=0 Then 
			ReturnValue=MyScript.MsgBox("胶片未排版，请排版胶片并提交，是否继续？是为继续，否为取消。", "胶片排版", vbQuestion+vbYesNo)
			if CInt(ReturnValue)=vbNo Then 
				NotifyFilmState=True
			else
           			NotifyFilmState=False
			end if
		End If 
	End If
End Function

Function JudgeCrisisValue()
    IsCrisis=Rpt.Data.GetNamedValue("IsCrisis")
    CrisisValue=Rpt.Data.GetNamedValue("CriticalValue")
    DESCRIBE = CStr(Rpt.Data.GetNamedValue("DESCRIBE"))
    DIAGNOSE = CStr(Rpt.Data.GetNamedValue("DIAGNOSE"))
    If CInt(IsCrisis)=1 Then 
       If CrisisValue="" Then 
          MyScript.MsgBox"请选择危急值说明再提交报告！"
          JudgeCrisisValue=False 
          Exit Function 
       Else 
          JudgeCrisisValue=True 
          Exit Function 
       End If 
    Else 
       If CrisisValue<>"" Then 
	      strarr=Split (CrisisValue,",")
	      For i=0 to UBound (strarr)
	          If InStr(1,DESCRIBE,strarr(i))>0  Then 
	             ReturnValue=MyScript.MsgBox("检查描述中存在危急值 '"&strarr(i)&"',是否继续？"&VbCrLf&"是为继续，否为返回记录危急值并通知临床。",vbQuestion+vbYesNo)
	             if CInt(ReturnValue)=vbNo Then 
	                JudgeCrisisValue=False 
	                Exit Function 
	             End If 
	          Else 
	             If InStr(1,DIAGNOSE,strarr(i))>0 Then 
	                ReturnValue=MyScript.MsgBox("检查结论中存在危急值 '"&strarr(i)&"',是否继续？"&VbCrLf&"是为继续，否为返回记录危急值并通知临床。",vbQuestion+vbYesNo)
	                if CInt(ReturnValue)=vbNo Then 
	                   JudgeCrisisValue=False 
	                   Exit Function 
	                End If 
	             End If 
	          End If 
	      Next 
       End If 
    End If 
    JudgeCrisisValue=True 
End Function

'****************************************************************************************************
'分支7：验证影像危急值
Function PromptCriticalValues()
	On Error Resume Next
	'--------------------------------------------------------------------------
	'初始化参数
	Dim CHECKSERIALNUM,DIAGRPTID,DESCRIBE,DIAGNOSE,USERID

CHECKSERIALNUM = CStr(Rpt.Data.GetNamedValue("CHECKSERIALNUM"))
	DIAGRPTID = CStr(Rpt.Data.GetNamedValue("DIAGRPTID"))
    DESCRIBE = CStr(Rpt.Data.GetNamedValue("DESCRIBE"))
    DIAGNOSE = CStr(Rpt.Data.GetNamedValue("DIAGNOSE"))
	DOCID1=Trim(CStr(Rpt.Data.GetNamedValue("DOCID1")))
	DOCID2=Trim(CStr(Rpt.Data.GetNamedValue("DOCID2")))
	DOCID3=Trim(CStr(Rpt.Data.GetNamedValue("DOCID3")))
	USERID=CStr(Rpt.Data.GetNamedValue("USERID"))
	Set Conn = Rpt.GetDBConn

'--------------------------------------------------------------------------
	'判断危急值操作，提交报告时为标记/上报
	Dim STATUS,STATUSStr,SENDER
	'常见几种情况：
	'1、三线审核报告时才能上报危急值，其他为标记状态，下面行改为：If DOCID3<>"" Then
	'2、二线审核报告时才能上报危急值，其他为标记状态，下面行改为：If DOCID2<>"" Then
	'3、一线提交报告时即可上报危急值，其他为标记状态，下面行改为：If DOCID1<>"" Then
	If DOCID1<>"" Then '注意此处设置为一线不为空即可上报
		STATUS = 1
		STATUSStr = "上报"
		SENDER = USERID
	Else
		STATUS = 0
		STATUSStr = "标记"
		SENDER = USERID
	End If

'--------------------------------------------------------------------------
	'分支7：校验影像危急值，提示用户选择操作

'分支7：获取标签页RptTag中的危急值勾选状态和选择值
    ISCRISIS=Rpt.Data.GetNamedValue("ISCRISIS")
    CRITICALVALUE=Rpt.Data.GetNamedValue("CRITICALVALUE")	'请注意：经测试CRITICALVALUE只有在勾选状态下为实际选择的值，非勾选状态时返回所有危急值字典拼接字符串！！！

'分支7：已勾选影像危急值，提示必选项
	If CInt(ISCRISIS)=1 Then 
		If CRITICALVALUE="" Then 
			MyScript.MsgBox "请选择危急值项目后再提交报告！", "医学影像危急值提示：", vbExclamation + vbOKOnly
			PromptCriticalValues=False 
			Exit Function 
		Else 
			'保存危急值记录（criticalvalueinfo表）
			Ret = SaveCriticalValue(CRITICALVALUE,STATUS,STATUSStr,CHECKSERIALNUM,USERID,Conn)
	
			'置空自动识别危急值标记
			Rpt.Data.SetNamedValue "IsAutoVerifyCritical",CStr("0")
	
			PromptCriticalValues=True 
			Exit Function
		End If
	'分支7：未勾选影像危急值，则根据报告描述/诊断自动识别危急值，然后进行提示
	Else
		JudgeCritical = JudgeCritical_Dic(DESCRIBE,DIAGNOSE) '影像危急值关键词判断（读取数据库影像危急值字典表）

If JudgeCritical <> "" Then
			ReturnValue = MyScript.MsgBox("报告中出现影像危急值关键词：" & JudgeCritical & "！" &VbCrLf&_
				"是否上报影像危急值？" &VbCrLf& "【是】上报危急值！"&VbCrLf&_
				"【否】 不上报危急值，且继续提交报告。"&VbCrLf&_
				"【取消】或者【关闭窗口】则重新编辑报告。", "医学影像危急值提示：", vbQuestion+vbYesNoCancel)
			'【是】
			If CInt(ReturnValue) = vbYes Then
				CRITICALVALUE = JudgeCritical
		
				'保存危急值记录（criticalvalueinfo表）
	
				Ret = SaveCriticalValue(CRITICALVALUE,STATUS,STATUSStr,CHECKSERIALNUM,USERID,Conn)
		
				'保存自动识别危急值的标签及备注留言信息
		
				'记录自动识别危急值标记
				Rpt.Data.SetNamedValue "IsAutoVerifyCritical",CStr("1")
		
				PromptCriticalValues=True
				Exit Function
			'【否】
			elseif CInt(ReturnValue) = vbNo THEN
			PromptCriticalValues = True
			'【其他】
			Else
				PromptCriticalValues = False
				Exit Function
			End If
		End If
	End If
    PromptCriticalValues=True 
End Function

'保存危急值记录(criticalvalueinfo表)
Function SaveCriticalValue(CRITICALVALUE,STATUS,STATUSStr,CHECKSERIALNUM,USERID,Conn)
	On Error Resume Next
	Dim msg
	'参数验证
	If CRITICALVALUE = "" Then
		Exit Function
	End If

'该检查仅允许上报唯一的危急值（建议开启，请结合现场情况）
	'作废历史危急值记录，状态更新为-1，不开启则屏蔽下两行
	sqlDelete = "update criticalvalueinfo set STATUS=-1 where CHECKSERIALNUM='" & CHECKSERIALNUM & "'"
	Conn.Execute(sqlDelete)

'获取数据库时间
	Dim SENDTIME
	sql = "select to_char(sysdate,'yyyy-mm-dd hh24:mi:ss') sendtime from dual"
	Set rs = Conn.Execute(sql)
	SENDTIME = rs("sendtime")

'生成危急值记录ID（主键）
	Dim CRITICALVALUEID
	sql = "select sys_guid()||'' criticalvalueid from dual"
	Set rs = Conn.Execute(sql)
	CRITICALVALUEID = rs("criticalvalueid")

'插入危急值记录
	sqlInsert = "insert into criticalvalueinfo (CRITICALVALUEID, CHECKSERIALNUM, STATUS, SENDER, CRITICALVALUE, SENDTIME) " &_
		"values ('" & CRITICALVALUEID & "','" & CHECKSERIALNUM & "','" & STATUS & "','" & USERID & "'," &_
		"'" & CRITICALVALUE & "',to_date('"&SENDTIME&"','yyyy-mm-dd hh24:mi:ss')) "
	Set rs = Conn.Execute(sqlInsert,rows)

'危急值写入提示
	If rows > 0 Then
		msg = "危急值：" & CRITICALVALUE & "，已" & STATUSStr & "！"

'危急值上报：调用PACS危急值接口服务，不开启则屏蔽下两行（请结合现场情况）

MyScript.MsgBox msg, "医学影像危急值提示：", vbInformation + vbOKOnly
	Else
		msg = "危急值" & STATUSStr & "失败，数据写入错误！"
		MyScript.MsgBox msg, "医学影像危急值错误：", vbCritical + vbOKOnly
	End If
End Function

'危急值关键词自动识别（读取数据库危急值字典表）多个用,连接
Function JudgeCritical_Dic(DESCRIBE,DIAGNOSE)
	On Error Resume Next
	CHKDEPTID = CStr(Rpt.Data.GetNamedValue("CHKDEPTID"))
	DEVICETYPEID = CStr(Rpt.Data.GetNamedValue("DEVICETYPEID"))
	If CHKDEPTID = "" Then
		CHKDEPTID = "1"
	End If
	sql = "select criticalvalueid,criticalvaluename from dict_criticalvalue "&_
	      " where departmentid='" & CHKDEPTID & "' "&_
	      "   and devicetypeid='" & DEVICETYPEID & "' "&_
	      "   and isavailable = 1 order by criticalvaluetypeid,orderno"
	Set Conn=Rpt.GetDBConn
	Set rs = Conn.Execute(sql)
	While not rs.eof
		lsname = rs("criticalvaluename")
		If InStr(1,DESCRIBE,lsname) > 0 Or InStr(1,DIAGNOSE,lsname) > 0 Then
			If JudgeCritical_Dic = "" Then
				JudgeCritical_Dic = lsname
			ElseIf Instr(1,JudgeCritical_Dic,lsname) = 0 Then
				JudgeCritical_Dic = JudgeCritical_Dic & "," & lsname
			End If
		End If
		rs.MoveNext
	Wend
End Function
```

最后修改：2024 年 04 月 22 日

如果觉得我的文章对你有用，请随意赞赏

发表评论取消回复
使用cookie技术保留您的个人信息以便您下次快速评论，继续评论表示您已同意该条款

评论 *

私密评论

名称 *

🎲

邮箱 *

地址

危急值上报后写入留言备注服务日志

猫不是猫 • 2024 年 04 月 22 日

* 调用exe上报无法写入，所以写了个触发器处理

> 先创建触发器

```

> 然后Rpt_VerifyRpt.vbs脚本有带了一部分处理的操作，为避免冲突，需要删掉，以下是完整的内容

```vbnet
Call Main()

'分支7：启用危急值上报提醒功能 
    If Not PromptCriticalValues Then 
       Parameters.SetNamedValue "ReturnValue","false"
       Exit Sub 
    End If

' Parameters.SetNamedValue "ReturnValue","true"

End Sub

'---------------调用相斥词汇校验函数---------------

If JudgeGlossaryAfoul(DESCRIBE,DIAGNOSE)=True Then
     JudgeGlossary=True
     Exit Function
  Else
     JudgeGlossary=False    
  End If

PromptIfReportEmpty = True
End Function

If CInt(ReturnValue)=vbNo Then

Rpt.Data.SetNamedValue "IFMASCULINE","1"
			PromptIfMasculine=True
			Exit Function
		ElseIf CInt(ReturnValue)=vbYes Then

Rpt.Data.SetNamedValue "IFMASCULINE","2"
			PromptIfMasculine=True
			Exit Function
		Else
	 	   PromptIfMasculine=False
		   Exit Function
		End If
	else
		PromptIfMasculine=True
	End If

End Function

'--------------------------------------------------------------------------
	'分支7：校验影像危急值，提示用户选择操作

'获取数据库时间
	Dim SENDTIME
	sql = "select to_char(sysdate,'yyyy-mm-dd hh24:mi:ss') sendtime from dual"
	Set rs = Conn.Execute(sql)
	SENDTIME = rs("sendtime")

'生成危急值记录ID（主键）
	Dim CRITICALVALUEID
	sql = "select sys_guid()||'' criticalvalueid from dual"
	Set rs = Conn.Execute(sql)
	CRITICALVALUEID = rs("criticalvalueid")

'危急值写入提示
	If rows > 0 Then
		msg = "危急值：" & CRITICALVALUE & "，已" & STATUSStr & "！"

'危急值上报：调用PACS危急值接口服务，不开启则屏蔽下两行（请结合现场情况）

危急值上报后写入留言备注服务日志

发表评论取消回复
使用cookie技术保留您的个人信息以便您下次快速评论，继续评论表示您已同意该条款

白嫖国产开源大模型DeepSeek

使用宝塔-docker容器部署青龙面板

【Linux】入门学习第二天笔记整理

[04]放射工作站上线整理记录

患者列表右键统计当前患者列表中的图像数

部分设置存储表(备忘)

危急值调用exe上报(初始化脚本)

导出图像自定义目录名称

PACS部门信息从HIS表导入

右键菜单-修改报告医生

危急值上报后写入留言备注服务日志

发表评论 取消回复 使用cookie技术保留您的个人信息以便您下次快速评论，继续评论表示您已同意该条款

危急值上报后写入留言备注服务日志

发表评论取消回复
使用cookie技术保留您的个人信息以便您下次快速评论，继续评论表示您已同意该条款