RAHLO4 ;HIRMFO/GJC-File rpt (data from bridge program) ; Feb 03, 2021@10:32:37
;;5.0;Radiology/Nuclear Medicine;**4,8,81,84,175**;Mar 16, 1998;Build 2
;
;Integration Agreements
;----------------------
;NOW^%DTC(10000); %ZTLOAD(10063); FIND^DIC(2051); ^DIE(10018); ^DIK(10013); $$GET1^DIQ(2056)
;GETS^DIQ(2056); ^XMD(10070)
;
TASK ; Task ORU message
S ZTDESC="Rad/Nuc Med Compiling HL7 ORU Message",ZTDTH=$H,ZTIO="",ZTRTN="RPT^RAHLRPC",ZTSAVE("RADFN")="",ZTSAVE("RADTI")="",ZTSAVE("RACNI")="",ZTSAVE("RARPT")=""
;Next line of coding will assure that ORU (report) message will be sent after posible ORM message. (10 second)
S $P(ZTDTH,",",2)=$P(ZTDTH,",",2)+4 S:$P(ZTDTH,",",2)>86400 ZTDTH=$P(ZTDTH,",")+1_","_($P(ZTDTH,",",2)-86400)
S:$L($G(RANOSEND)) ZTSAVE("RANOSEND")="" D ^%ZTLOAD
K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
Q
VOICE ; voice dictation auto-print (background process)
Q:$P(^RA(79.1,+$G(RAMLC),0),U,26)'="Y" ; Voice Dictation Auto-Print
S ZTIO=$$GET1^DIQ(3.5,+$P(^RA(79.1,+$G(RAMLC),0),U,10),.01) ; dev name
Q:ZTIO']"" ; quit if the device does not exist
S ZTDTH=$H,ZTRTN="DQ^RARTR",ZTSAVE("RARPT")=""
S ZTDESC="Rad/Nuc Med voice dictation auto-print"
D ^%ZTLOAD K RAMES,ZTDESC,ZTSK,ZTIO,ZTSAVE,ZTRTN,RASV,ZTDTH
Q
;
UPMEM ;copy (prim:dx,stf,res),rpt ien to other members of same print set
;
;Note: updated w/RA5_0P175 & called from only RAHLO1.
; no IAs dedicated to this tag^routine
; variable: RAMDV set in EDTCHK^RAHLQ (required) RAMDV=.1
; node of division (#79) translated from "YyNn" to "1100"
;
K DIE,DA,DR S DA=RACNI,DA(1)=RADTI,DA(2)=RADFN
; first clear those fields.
S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
S DR="13///@;12///@;15///@" D ^DIE
; now set those fields based on lead case of printset
S DR="13////"_RA13_";12////"_RA12_";15////"_RA15 D ^DIE K DA,DR,DIE
; if the study has been canceled check if rpts are allowed.
N RAY3,RASTATUS S RAY3=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
S RASTATUS=$P($G(^RA(72,+$P(RAY3,U,3),0)),"^",3) ;order value
; Note: if canceled and division does not allow rpts on canceled
; studies quit.
I RASTATUS=0,($P(RAMDV,"^",22)'=1) Q
; hard set the report pointer to the study
S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)=RARPT
Q
SETPHYS ;set Primary Resident or Staff, either piece 12 or piece 15 of case
Q:RADPIECE'=15&(RADPIECE'=12)
S DR=RADPIECE_"////"_$G(RAVERF)
S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI
S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
D ^DIE K DA,DR
Q
KILSECDG ;kill secondary diagnoses nodes of this case
Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))
Q:RADFN=""!(RADTI="")!(RACNI="")
Q:'$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0))
S DA(3)=RADFN,DA(2)=RADTI,DA(1)=RACNI
N RA1 S RA1=""
K1 S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RA1)) G:RA1="" KQ
S DA=RA1
S DIK="^RADPT("_DA(3)_",""DT"","_DA(2)_",""P"","_DA(1)_",""DX"","
D ^DIK
G K1
KQ K DA Q
;
PCEXTR(RASUB,RASEG,RAPCE,RADEL) ; extract the right piece of data
; from the right data node
; input: RASUB-data node subscript
; RASEG-HL7 segment (minus the segment header)
; RAPCE-data's piece position
; RADEL-delimiter (field separator)
S RAHL70="",RAHL7X=0,RAHL7OFF=$L(RASEG,RADEL)
S RAHL7LST=$P(RASEG,RADEL,RAHL7OFF)
I RAPCE<RAHL7OFF S RAHL70=$P(RASEG,RADEL,RAPCE) D KILL Q RAHL70
I RAHL7OFF=RAPCE D ; check if data wraps to the next node (if any)
. S RAHL70=$P(RASEG,RADEL,RAPCE),II1=$O(^TMP("RARPT-HL7",$J,RASUB,0))
. S:'II1 RAHL7X=1 Q:'II1
. S RAHL70=RAHL70_$P(^TMP("RARPT-HL7",$J,RASUB,II1),RADEL),RAHL7X=1
. Q
I RAHL7X D KILL Q RAHL70
; check if this node has descendent data nodes
I '$O(^TMP("RARPT-HL7",$J,RASUB,0)) D KILL Q "" ; descendents not found
S I=0,RAHL7CNT=RAHL7OFF
F S I=$O(^TMP("RARPT-HL7",$J,RASUB,I)) Q:I'>0 D Q:RAHL7X
. S RAHL7SUB=$G(^TMP("RARPT-HL7",$J,RASUB,I))
. S RAHL7PRE=$O(^TMP("RARPT-HL7",$J,RASUB,I),-1)
. S:RAHL7PRE RAHL7LST=$$LSTPCE(^TMP("RARPT-HL7",$J,RASUB,RAHL7PRE),RADEL)
. F II1=1:1:$L(RAHL7SUB,RADEL) D Q:RAHL7X
.. ; HL7 may have broken the string on data!
.. I II1=1 S RAHL7ARY(RAHL7CNT)=RAHL7LST_$P(RAHL7SUB,RADEL)
.. E D ; for the case II1'=1
... S RAHL7CNT=RAHL7CNT+1
... S RAHL7ARY(RAHL7CNT)=$P(RAHL7SUB,RADEL,II1)
... Q
.. I RAHL7CNT=RAPCE,(II1'=$L(RAHL7SUB,RADEL)) S RAHL7X=1,RAHL70=RAHL7ARY(RAHL7CNT)
.. I RAHL7CNT=RAPCE,(II1=$L(RAHL7SUB,RADEL)) D
... ; grab the 1st piece of the next node (if any)
... S RAHL7X=1,RAHL70=RAHL7ARY(RAHL7CNT)
... S N1=+$O(^TMP("RARPT-HL7",$J,RASUB,I)) Q:'N1
... S RAHL70=RAHL70_$P(^TMP("RARPT-HL7",$J,RASUB,N1),RADEL)
... Q
.. K:'RAHL7X RAHL7ARY
.. Q
. Q
D KILL
Q RAHL70
KILL ; kill the RAHLD* variables
K I,II1,N1,RAHL7ARY,RAHL7CNT,RAHL7LST,RAHL7OFF,RAHL7PRE,RAHL7SUB,RAHL7X
Q
LSTPCE(X,DEL) ; given a string and a delimiter, return the last piece
Q $P(X,DEL,$L(X,DEL))
CKDUPA ; if duplicate addendum, send msg to members of unverify rpt mailgroup
S RADUPA=0 ; 0 means not a duplicate
N I1,I2,X1,X2,X3,X4,X21,R0,R1,R2,MATCH,XMSUB
S I1="I",I2="RAIMP" I $O(^RARPT(RARPT,I1,0))'="" D ISITDUP ;Q:'RADUPA
;
I 'RADUPA S I1="R",I2="RATXT" I $O(^RARPT(RARPT,I1,0))'="" D ISITDUP Q:'RADUPA
;S I1="R",I2="RATXT" I $O(^RARPT(RARPT,I1,0))'="" D ISITDUP Q:'RADUPA
;
S XMSUB="Duplicate addendum being sent to Vista"
;
; check to see if mail message already sent for
; this case no. TODAY only. if so quit - no need to
; re-send to save time backwards $ORDER, duplicate
; most likely to be most recently.
S (XMB,XMATCH)=""
D NOW^%DTC S RATDY=X K X
F S XMB=$O(^XMB(3.9,"B",$E(XMSUB,1,30),XMB),-1) Q:XMB="" D Q:XMATCH'=""
.I $P($$GET1^DIQ(3.9,XMB,1.4,"I"),".")'=RATDY S XMATCH=0 Q ;(DBIA2860)
.Q:$G(^XMB(3.9,XMB,2,6,0))'[RALONGCN
.S XMATCH=1
K XMB,RATDY
Q:XMATCH=1
;
; send mail to members of unverify bulletin (DBIA2861)
; find ien of unverify bulletin
D FIND^DIC(3.6,"","","","RAD/NUC MED REPORT UNVERIFIED",1,"","","","R0")
Q:'$D(R0("DILIST",2,1))#2
; find name of mail group linked to that bulletin
D GETS^DIQ(3.6,R0("DILIST",2,1),"4*","EI","R1")
; check to see if MailGroup is PUBLIC, otherwise quit
S X=$G(R1(3.62,"1,"_R0("DILIST",2,1)_",",.01,"I")) I X="" K X Q
I $$GET1^DIQ(3.8,X_",",4,"I")'="PU" K X Q
S X=$G(R1(3.62,"1,"_R0("DILIST",2,1)_",",.01,"E")) I X="" K X Q
N XMDUZ,XMTEXT,XMY,MSGTXT,XRAVERF,XRATRANS,XRADFN
S X="G."_X,XMY(X)="" K X ;recipient mail group
;
S XMDUZ=.5
S MSGTXT(1)=$G(^TMP("RARPT-REC",$J,RASUB,"VENDOR"))_" is sending duplicate addenda to Radiology/Nuclear Medicine."
S MSGTXT(2)=" "
S MSGTXT(3)="The following radiology report was sent with a duplicate addendum:"
S:RADFN'="" XRADFN=$$GET1^DIQ(2,RADFN,.01)
S:$G(XRADFN)="" XRADFN="Unknown"
S MSGTXT(4)=" 1) Patient : "_XRADFN
S MSGTXT(5)=" 2) SSN : "_$$SSN^RAUTL()
S MSGTXT(6)=" 3) Case Number : "_RALONGCN
S:RAVERF'="" XRAVERF=$$GET1^DIQ(200,RAVERF,.01)
S:$G(XRAVERF)="" XRAVERF="Unknown"
S MSGTXT(7)=" 4) Verifier : "_XRAVERF
S:RATRANSC'="" XRATRANS=$$GET1^DIQ(200,RATRANSC,.01)
S:$G(XRATRANS)="" XRATRANS="Unknown"
S MSGTXT(8)=" 5) Transcriptionist : "_XRATRANS
S MSGTXT(9)=" "
S MSGTXT(10)="Please notify IRM."
S XMTEXT="MSGTXT("
D ^XMD
Q
ISITDUP ; X1=last ien ^RARPT, X2=LAST IEN ^TMP, x21=first ien ^TMP
Q:'$O(^TMP("RARPT-REC",$J,RASUB,I2,0))
N X1,X2,X21,X3,X4,XX
S RADUPA=0 ; Reset to zero otherwise Imp Text match will override
S X1=$O(^RARPT(RARPT,I1,""),-1)
S XX=$G(^RARPT(RARPT,I1,X1,0)) S XX=$S(XX=""!(XX=" "):0,1:1)
S X2=$O(^TMP("RARPT-REC",$J,RASUB,I2,""),-1),X21=$O(^(0))
S X3=X1-X2+XX Q:X3<1 ; begin comparison from ^RARPT(RARPT,I1,X3
; chk 1st line of previous addendum
Q:^RARPT(RARPT,I1,X3,0)'["Addendum: " S X4=^(0)
S X4=$E(X4,$L("Addendum: ")+1,$L(X4)) ; exclude "Addendum: " from X4
Q:X4'=^TMP("RARPT-REC",$J,RASUB,I2,X21)
; chk remaining lines
S X21=X21+1 F X1=X21:1:X2 S X3=X3+1 Q:^RARPT(RARPT,I1,X3,0)'=^TMP("RARPT-REC",$J,RASUB,I2,X1)
Q:X1<X2
S RADUPA=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAHLO4 8130 printed Dec 13, 2024@02:35:24 Page 2
RAHLO4 ;HIRMFO/GJC-File rpt (data from bridge program) ; Feb 03, 2021@10:32:37
+1 ;;5.0;Radiology/Nuclear Medicine;**4,8,81,84,175**;Mar 16, 1998;Build 2
+2 ;
+3 ;Integration Agreements
+4 ;----------------------
+5 ;NOW^%DTC(10000); %ZTLOAD(10063); FIND^DIC(2051); ^DIE(10018); ^DIK(10013); $$GET1^DIQ(2056)
+6 ;GETS^DIQ(2056); ^XMD(10070)
+7 ;
TASK ; Task ORU message
+1 SET ZTDESC="Rad/Nuc Med Compiling HL7 ORU Message"
SET ZTDTH=$HOROLOG
SET ZTIO=""
SET ZTRTN="RPT^RAHLRPC"
SET ZTSAVE("RADFN")=""
SET ZTSAVE("RADTI")=""
SET ZTSAVE("RACNI")=""
SET ZTSAVE("RARPT")=""
+2 ;Next line of coding will assure that ORU (report) message will be sent after posible ORM message. (10 second)
+3 SET $PIECE(ZTDTH,",",2)=$PIECE(ZTDTH,",",2)+4
if $PIECE(ZTDTH,",",2)>86400
SET ZTDTH=$PIECE(ZTDTH,",")+1_","_($PIECE(ZTDTH,",",2)-86400)
+4 if $LENGTH($GET(RANOSEND))
SET ZTSAVE("RANOSEND")=""
DO ^%ZTLOAD
+5 KILL ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+6 QUIT
VOICE ; voice dictation auto-print (background process)
+1 ; Voice Dictation Auto-Print
if $PIECE(^RA(79.1,+$GET(RAMLC),0),U,26)'="Y"
QUIT
+2 ; dev name
SET ZTIO=$$GET1^DIQ(3.5,+$PIECE(^RA(79.1,+$GET(RAMLC),0),U,10),.01)
+3 ; quit if the device does not exist
if ZTIO']""
QUIT
+4 SET ZTDTH=$HOROLOG
SET ZTRTN="DQ^RARTR"
SET ZTSAVE("RARPT")=""
+5 SET ZTDESC="Rad/Nuc Med voice dictation auto-print"
+6 DO ^%ZTLOAD
KILL RAMES,ZTDESC,ZTSK,ZTIO,ZTSAVE,ZTRTN,RASV,ZTDTH
+7 QUIT
+8 ;
UPMEM ;copy (prim:dx,stf,res),rpt ien to other members of same print set
+1 ;
+2 ;Note: updated w/RA5_0P175 & called from only RAHLO1.
+3 ; no IAs dedicated to this tag^routine
+4 ; variable: RAMDV set in EDTCHK^RAHLQ (required) RAMDV=.1
+5 ; node of division (#79) translated from "YyNn" to "1100"
+6 ;
+7 KILL DIE,DA,DR
SET DA=RACNI
SET DA(1)=RADTI
SET DA(2)=RADFN
+8 ; first clear those fields.
+9 SET DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
+10 SET DR="13///@;12///@;15///@"
DO ^DIE
+11 ; now set those fields based on lead case of printset
+12 SET DR="13////"_RA13_";12////"_RA12_";15////"_RA15
DO ^DIE
KILL DA,DR,DIE
+13 ; if the study has been canceled check if rpts are allowed.
+14 NEW RAY3,RASTATUS
SET RAY3=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+15 ;order value
SET RASTATUS=$PIECE($GET(^RA(72,+$PIECE(RAY3,U,3),0)),"^",3)
+16 ; Note: if canceled and division does not allow rpts on canceled
+17 ; studies quit.
+18 IF RASTATUS=0
IF ($PIECE(RAMDV,"^",22)'=1)
QUIT
+19 ; hard set the report pointer to the study
+20 SET $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)=RARPT
+21 QUIT
SETPHYS ;set Primary Resident or Staff, either piece 12 or piece 15 of case
+1 if RADPIECE'=15&(RADPIECE'=12)
QUIT
+2 SET DR=RADPIECE_"////"_$GET(RAVERF)
+3 SET DA(2)=RADFN
SET DA(1)=RADTI
SET DA=RACNI
+4 SET DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
+5 DO ^DIE
KILL DA,DR
+6 QUIT
KILSECDG ;kill secondary diagnoses nodes of this case
+1 if '$DATA(RADFN)!('$DATA(RADTI))!('$DATA(RACNI))
QUIT
+2 if RADFN=""!(RADTI="")!(RACNI="")
QUIT
+3 if '$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0))
QUIT
+4 SET DA(3)=RADFN
SET DA(2)=RADTI
SET DA(1)=RACNI
+5 NEW RA1
SET RA1=""
K1 SET RA1=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RA1))
if RA1=""
GOTO KQ
+1 SET DA=RA1
+2 SET DIK="^RADPT("_DA(3)_",""DT"","_DA(2)_",""P"","_DA(1)_",""DX"","
+3 DO ^DIK
+4 GOTO K1
KQ KILL DA
QUIT
+1 ;
PCEXTR(RASUB,RASEG,RAPCE,RADEL) ; extract the right piece of data
+1 ; from the right data node
+2 ; input: RASUB-data node subscript
+3 ; RASEG-HL7 segment (minus the segment header)
+4 ; RAPCE-data's piece position
+5 ; RADEL-delimiter (field separator)
+6 SET RAHL70=""
SET RAHL7X=0
SET RAHL7OFF=$LENGTH(RASEG,RADEL)
+7 SET RAHL7LST=$PIECE(RASEG,RADEL,RAHL7OFF)
+8 IF RAPCE<RAHL7OFF
SET RAHL70=$PIECE(RASEG,RADEL,RAPCE)
DO KILL
QUIT RAHL70
+9 ; check if data wraps to the next node (if any)
IF RAHL7OFF=RAPCE
Begin DoDot:1
+10 SET RAHL70=$PIECE(RASEG,RADEL,RAPCE)
SET II1=$ORDER(^TMP("RARPT-HL7",$JOB,RASUB,0))
+11 if 'II1
SET RAHL7X=1
if 'II1
QUIT
+12 SET RAHL70=RAHL70_$PIECE(^TMP("RARPT-HL7",$JOB,RASUB,II1),RADEL)
SET RAHL7X=1
+13 QUIT
End DoDot:1
+14 IF RAHL7X
DO KILL
QUIT RAHL70
+15 ; check if this node has descendent data nodes
+16 ; descendents not found
IF '$ORDER(^TMP("RARPT-HL7",$JOB,RASUB,0))
DO KILL
QUIT ""
+17 SET I=0
SET RAHL7CNT=RAHL7OFF
+18 FOR
SET I=$ORDER(^TMP("RARPT-HL7",$JOB,RASUB,I))
if I'>0
QUIT
Begin DoDot:1
+19 SET RAHL7SUB=$GET(^TMP("RARPT-HL7",$JOB,RASUB,I))
+20 SET RAHL7PRE=$ORDER(^TMP("RARPT-HL7",$JOB,RASUB,I),-1)
+21 if RAHL7PRE
SET RAHL7LST=$$LSTPCE(^TMP("RARPT-HL7",$JOB,RASUB,RAHL7PRE),RADEL)
+22 FOR II1=1:1:$LENGTH(RAHL7SUB,RADEL)
Begin DoDot:2
+23 ; HL7 may have broken the string on data!
+24 IF II1=1
SET RAHL7ARY(RAHL7CNT)=RAHL7LST_$PIECE(RAHL7SUB,RADEL)
+25 ; for the case II1'=1
IF '$TEST
Begin DoDot:3
+26 SET RAHL7CNT=RAHL7CNT+1
+27 SET RAHL7ARY(RAHL7CNT)=$PIECE(RAHL7SUB,RADEL,II1)
+28 QUIT
End DoDot:3
+29 IF RAHL7CNT=RAPCE
IF (II1'=$LENGTH(RAHL7SUB,RADEL))
SET RAHL7X=1
SET RAHL70=RAHL7ARY(RAHL7CNT)
+30 IF RAHL7CNT=RAPCE
IF (II1=$LENGTH(RAHL7SUB,RADEL))
Begin DoDot:3
+31 ; grab the 1st piece of the next node (if any)
+32 SET RAHL7X=1
SET RAHL70=RAHL7ARY(RAHL7CNT)
+33 SET N1=+$ORDER(^TMP("RARPT-HL7",$JOB,RASUB,I))
if 'N1
QUIT
+34 SET RAHL70=RAHL70_$PIECE(^TMP("RARPT-HL7",$JOB,RASUB,N1),RADEL)
+35 QUIT
End DoDot:3
+36 if 'RAHL7X
KILL RAHL7ARY
+37 QUIT
End DoDot:2
if RAHL7X
QUIT
+38 QUIT
End DoDot:1
if RAHL7X
QUIT
+39 DO KILL
+40 QUIT RAHL70
KILL ; kill the RAHLD* variables
+1 KILL I,II1,N1,RAHL7ARY,RAHL7CNT,RAHL7LST,RAHL7OFF,RAHL7PRE,RAHL7SUB,RAHL7X
+2 QUIT
LSTPCE(X,DEL) ; given a string and a delimiter, return the last piece
+1 QUIT $PIECE(X,DEL,$LENGTH(X,DEL))
CKDUPA ; if duplicate addendum, send msg to members of unverify rpt mailgroup
+1 ; 0 means not a duplicate
SET RADUPA=0
+2 NEW I1,I2,X1,X2,X3,X4,X21,R0,R1,R2,MATCH,XMSUB
+3 ;Q:'RADUPA
SET I1="I"
SET I2="RAIMP"
IF $ORDER(^RARPT(RARPT,I1,0))'=""
DO ISITDUP
+4 ;
+5 IF 'RADUPA
SET I1="R"
SET I2="RATXT"
IF $ORDER(^RARPT(RARPT,I1,0))'=""
DO ISITDUP
if 'RADUPA
QUIT
+6 ;S I1="R",I2="RATXT" I $O(^RARPT(RARPT,I1,0))'="" D ISITDUP Q:'RADUPA
+7 ;
+8 SET XMSUB="Duplicate addendum being sent to Vista"
+9 ;
+10 ; check to see if mail message already sent for
+11 ; this case no. TODAY only. if so quit - no need to
+12 ; re-send to save time backwards $ORDER, duplicate
+13 ; most likely to be most recently.
+14 SET (XMB,XMATCH)=""
+15 DO NOW^%DTC
SET RATDY=X
KILL X
+16 FOR
SET XMB=$ORDER(^XMB(3.9,"B",$EXTRACT(XMSUB,1,30),XMB),-1)
if XMB=""
QUIT
Begin DoDot:1
+17 ;(DBIA2860)
IF $PIECE($$GET1^DIQ(3.9,XMB,1.4,"I"),".")'=RATDY
SET XMATCH=0
QUIT
+18 if $GET(^XMB(3.9,XMB,2,6,0))'[RALONGCN
QUIT
+19 SET XMATCH=1
End DoDot:1
if XMATCH'=""
QUIT
+20 KILL XMB,RATDY
+21 if XMATCH=1
QUIT
+22 ;
+23 ; send mail to members of unverify bulletin (DBIA2861)
+24 ; find ien of unverify bulletin
+25 DO FIND^DIC(3.6,"","","","RAD/NUC MED REPORT UNVERIFIED",1,"","","","R0")
+26 if '$DATA(R0("DILIST",2,1))#2
QUIT
+27 ; find name of mail group linked to that bulletin
+28 DO GETS^DIQ(3.6,R0("DILIST",2,1),"4*","EI","R1")
+29 ; check to see if MailGroup is PUBLIC, otherwise quit
+30 SET X=$GET(R1(3.62,"1,"_R0("DILIST",2,1)_",",.01,"I"))
IF X=""
KILL X
QUIT
+31 IF $$GET1^DIQ(3.8,X_",",4,"I")'="PU"
KILL X
QUIT
+32 SET X=$GET(R1(3.62,"1,"_R0("DILIST",2,1)_",",.01,"E"))
IF X=""
KILL X
QUIT
+33 NEW XMDUZ,XMTEXT,XMY,MSGTXT,XRAVERF,XRATRANS,XRADFN
+34 ;recipient mail group
SET X="G."_X
SET XMY(X)=""
KILL X
+35 ;
+36 SET XMDUZ=.5
+37 SET MSGTXT(1)=$GET(^TMP("RARPT-REC",$JOB,RASUB,"VENDOR"))_" is sending duplicate addenda to Radiology/Nuclear Medicine."
+38 SET MSGTXT(2)=" "
+39 SET MSGTXT(3)="The following radiology report was sent with a duplicate addendum:"
+40 if RADFN'=""
SET XRADFN=$$GET1^DIQ(2,RADFN,.01)
+41 if $GET(XRADFN)=""
SET XRADFN="Unknown"
+42 SET MSGTXT(4)=" 1) Patient : "_XRADFN
+43 SET MSGTXT(5)=" 2) SSN : "_$$SSN^RAUTL()
+44 SET MSGTXT(6)=" 3) Case Number : "_RALONGCN
+45 if RAVERF'=""
SET XRAVERF=$$GET1^DIQ(200,RAVERF,.01)
+46 if $GET(XRAVERF)=""
SET XRAVERF="Unknown"
+47 SET MSGTXT(7)=" 4) Verifier : "_XRAVERF
+48 if RATRANSC'=""
SET XRATRANS=$$GET1^DIQ(200,RATRANSC,.01)
+49 if $GET(XRATRANS)=""
SET XRATRANS="Unknown"
+50 SET MSGTXT(8)=" 5) Transcriptionist : "_XRATRANS
+51 SET MSGTXT(9)=" "
+52 SET MSGTXT(10)="Please notify IRM."
+53 SET XMTEXT="MSGTXT("
+54 DO ^XMD
+55 QUIT
ISITDUP ; X1=last ien ^RARPT, X2=LAST IEN ^TMP, x21=first ien ^TMP
+1 if '$ORDER(^TMP("RARPT-REC",$JOB,RASUB,I2,0))
QUIT
+2 NEW X1,X2,X21,X3,X4,XX
+3 ; Reset to zero otherwise Imp Text match will override
SET RADUPA=0
+4 SET X1=$ORDER(^RARPT(RARPT,I1,""),-1)
+5 SET XX=$GET(^RARPT(RARPT,I1,X1,0))
SET XX=$SELECT(XX=""!(XX=" "):0,1:1)
+6 SET X2=$ORDER(^TMP("RARPT-REC",$JOB,RASUB,I2,""),-1)
SET X21=$ORDER(^(0))
+7 ; begin comparison from ^RARPT(RARPT,I1,X3
SET X3=X1-X2+XX
if X3<1
QUIT
+8 ; chk 1st line of previous addendum
+9 if ^RARPT(RARPT,I1,X3,0)'["Addendum
QUIT
SET X4=^(0)
+10 ; exclude "Addendum: " from X4
SET X4=$EXTRACT(X4,$LENGTH("Addendum: ")+1,$LENGTH(X4))
+11 if X4'=^TMP("RARPT-REC",$JOB,RASUB,I2,X21)
QUIT
+12 ; chk remaining lines
+13 SET X21=X21+1
FOR X1=X21:1:X2
SET X3=X3+1
if ^RARPT(RARPT,I1,X3,0)'=^TMP("RARPT-REC",$JOB,RASUB,I2,X1)
QUIT
+14 if X1<X2
QUIT
+15 SET RADUPA=1
+16 QUIT
