RARTR3 ;HIRMFO/SWM-Queue/print Radiology Reports (utility) ;8/31/99 13:57
;;5.0;Radiology/Nuclear Medicine;**8,10,19,27,35,45,75,47**;Mar 16, 1998;Build 21
MEMS1 ;--- modifiers --- handle cases within print set
N RACNISAV,RAY3SAV,RAMEMARR,RACDIS,RALDIS
D EN2^RAUTL20(.RAMEMARR) Q:'$O(RAMEMARR(0))
S RACNISAV=RACNI,RAY3SAV=RAY3,RACNI=0
D CDIS^RAPROD S (RAREZON,RACNI)=0
;for printsets print the REASON FOR STUDY along with the lead procedure
;(avoid duplicate printing of the same data)
F S RACNI=$O(RAMEMARR(RACNI)) Q:'RACNI D S:$G(RAXIT) RAOOUT=1 Q:$D(RAOOUT)
. S RAY3=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
. ;Check if cancelled & not part of printset
. I $P(^RA(72,+$P(RAY3,"^",3),0),"^",3)=0,($P(RAY3,"^",17)="") Q
. D MODS^RAUTL2
. ; If printing page at a time we need to check the length - RA*5*8
. I '$D(RAUTOE),$Y>(IOSL-6),IOST["C-" S RAP="" D WAIT^RART1 I X="^"!(X="P")!(X="T") S RAOOUT=1 Q
. D OUT1 Q:$G(RAXIT) S RAREZON=1
. D:+$P(RAY3,"^",28) RDIO^RARTUTL(+$P(RAY3,"^",28)) Q:$D(RAOOUT)
. D:+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) PHARM^RARTUTL(RACNI_","_RADTI_","_RADFN_",")
. Q
S RACNI=RACNISAV,RAY3=RAY3SAV K RAREZON
Q
OUT1 ;
; $O(RAMEMARR(0)) may be defined, if previously called MEMS1^RARTR3
; RALDIS flags long display wanted, comes from certain output options
; RACDIS(n) exists if case n is to be displayed
; RACDIS(n) not set for dupl proc+pmod+cptmod so don't display
I $O(RAMEMARR(0)),'$G(RALDIS),'$D(RACDIS(RACNI)) Q
S RASTUDY=$P($G(^RAO(75.1,+$P(RAY3,U,11),.1)),U) ;Convey 'Reason for Study' P75
I $D(RAUTOE) G MAIL1
W !,$$XAM()
;check for contrast media; display if CM data exists (patch 45)
S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RACNI)
I $L(RACMDATA) D
.W !?5,"Contrast Media :"
.F RAIZ=1:1 Q:$P(RACMDATA,", ",RAIZ)="" D
..W ?22,$P(RACMDATA,", ",RAIZ)
..W:$P(RACMDATA,", ",RAIZ+1)'="" !
..I $Y>(IOSL-5) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF W !
..Q
.K RAIZ
.QUIT
K RACMDATA Q:$G(RAXIT)
W:Y'="None" !?RATAB,"Proc Modifiers : ",Y
N I,J
W:Y(1)'="None" !?RATAB,"CPT Modifiers : "
I Y(1)'="None" F I=1:1 Q:$P(Y(2),", ",I)']"" S J=$P(Y(2),", ",I),J=$$BASICMOD^RACPTMSC(J,DT) W ?22,$P(J,"^",2)," ",$P(J,"^",3) W:$P(Y(2),", ",I+1)]"" ! I $Y>(IOSL-5) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF W !
I $L(RASTUDY),$G(RAREZON,0)=0 W ! D DIWP^RAUTL5(RATAB,68,"Reason for Study: "_RASTUDY) ;P75
K RASTUDY
Q
;
MAIL1 S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$$XAM()
;check for contrast media; display if CM data exists (patch 45)
S RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RACNI)
I $L(RACMDATA) D
.S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Contrast Media : "_$P(RACMDATA,", ")
.F RAIZ=2:1 Q:$P(RACMDATA,", ",RAIZ)="" S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$P(RACMDATA,", ",RAIZ)
.K RAIZ
.Q
K RACMDATA
S:Y'="None" ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Proc Modifiers : "_Y
I Y(1)'="None" D
.S J=$P(Y(2),", ",1),J=$$BASICMOD^RACPTMSC(J,DT) S:+J<0 $P(J,"^",2,3)="None^"
.S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" CPT Modifiers : "_$S(J]"":$P(J,"^",2)_" "_$P(J,"^",3),1:"")
.F I=2:1 Q:$P(Y(2),", ",I)']"" S J=$P(Y(2),", ",I),J=$$BASICMOD^RACPTMSC(J,DT) S ^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$P(J,"^",2)_" "_$P(J,"^",3)
.Q
I $L(RASTUDY),$G(RAREZON,0)=0 D S RAREZON=1
.N RAY S RASTUDY="Reason for Study: "_RASTUDY
.I $L(RASTUDY)'>68 S $P(RAY," ",6)="",^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAY_RASTUDY Q
.I $L(RASTUDY)>68 D
..K ^UTILITY($J,"W") N %,DIW,DIWF,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,RAI,RAX,X,X1,Z
..S DIWF="",DIWL=1,DIWR=65,X=RASTUDY D ^DIWP
..S RAI=0 F S RAI=$O(^UTILITY($J,"W",DIWL,RAI)) Q:'RAI D
...S RAX=$G(^UTILITY($J,"W",DIWL,RAI,0))
...I RAI=1 S $P(RAY," ",6)="",^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAY_RAX
...I RAI'=1 S $P(RAY," ",24)="",^TMP($J,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAY_RAX
...Q
..Q
.K ^UTILITY($J,"W")
.Q
K RASTUDY
Q
;
XAM() ; Return exam data information. Case number, exam status & procedure
; name build into one string. Assumes RAY3 is the 0 node for exam data
Q:$G(RAY3)="" "" ; no exam information present.
N RAPROC,RAXAMSTR S RAXAMSTR=""
N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
S RACNDSP=$S((RASSAN'=""):RASSAN,1:+RAY3)
I $G(RAMDIV)="" S RAMDIV=$P($G(^RADPT(RADFN,"DT",RADTI,0)),"^",3)
I $G(RALDIS)!('$O(RAMEMARR(0)))!($O(RAMEMARR(0))&($G(RACDIS(RACNI))=1)) D
. I $$USESSAN^RAHLRU1() S $E(RAXAMSTR,1,5)="(Case" S $E(RAXAMSTR,7,(7+$L(RACNDSP)))=RACNDSP
. I '$$USESSAN^RAHLRU1() S $E(RAXAMSTR,1,5)="(Case" S $E(RAXAMSTR,7,(7+$L(+RAY3)))=+RAY3
. S $E(RAXAMSTR,$L(RAXAMSTR)+2,79)=$S($D(^RA(72,+$P(RAY3,"^",3),0)):$E($P(^(0),"^"),1,8)_")",1:"Unknown)")
. Q
E S:$G(RACDIS(RACNI)) $E(RAXAMSTR,1)="(",$E(RAXAMSTR,9,14)=RACDIS(RACNI)_"x",$E(RAXAMSTR,20)=")"
S RAPROC=$G(^RAMIS(71,+$P(RAY3,"^",2),0))
I $$USESSAN^RAHLRU1() S $E(RAXAMSTR,32,65)=$S($P(RAPROC,"^")]"":$E($P(RAPROC,"^"),1,33),1:"Unknown")
I '$$USESSAN^RAHLRU1() S $E(RAXAMSTR,22,54)=$S($P(RAPROC,"^")]"":$E($P(RAPROC,"^"),1,33),1:"Unknown")
N RADISPLY
S RADISPLY=$G(^RAMIS(71,+$P($G(^RADPT(+RADFN,"DT",+RADTI,"P",+RACNI,0)),U,2),0)) ; set $ZR to 71 for prccpt^radd1, not call raprod since store result
S RADISPLY=$$PRCCPT^RADD1()
I $$USESSAN^RAHLRU1() S $E(RAXAMSTR,65,79)=RADISPLY
I '$$USESSAN^RAHLRU1() S $E(RAXAMSTR,55,79)=RADISPLY
Q RAXAMSTR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRARTR3 5536 printed Sep 23, 2025@20:15:35 Page 2
RARTR3 ;HIRMFO/SWM-Queue/print Radiology Reports (utility) ;8/31/99 13:57
+1 ;;5.0;Radiology/Nuclear Medicine;**8,10,19,27,35,45,75,47**;Mar 16, 1998;Build 21
MEMS1 ;--- modifiers --- handle cases within print set
+1 NEW RACNISAV,RAY3SAV,RAMEMARR,RACDIS,RALDIS
+2 DO EN2^RAUTL20(.RAMEMARR)
if '$ORDER(RAMEMARR(0))
QUIT
+3 SET RACNISAV=RACNI
SET RAY3SAV=RAY3
SET RACNI=0
+4 DO CDIS^RAPROD
SET (RAREZON,RACNI)=0
+5 ;for printsets print the REASON FOR STUDY along with the lead procedure
+6 ;(avoid duplicate printing of the same data)
+7 FOR
SET RACNI=$ORDER(RAMEMARR(RACNI))
if 'RACNI
QUIT
Begin DoDot:1
+8 SET RAY3=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+9 ;Check if cancelled & not part of printset
+10 IF $PIECE(^RA(72,+$PIECE(RAY3,"^",3),0),"^",3)=0
IF ($PIECE(RAY3,"^",17)="")
QUIT
+11 DO MODS^RAUTL2
+12 ; If printing page at a time we need to check the length - RA*5*8
+13 IF '$DATA(RAUTOE)
IF $Y>(IOSL-6)
IF IOST["C-"
SET RAP=""
DO WAIT^RART1
IF X="^"!(X="P")!(X="T")
SET RAOOUT=1
QUIT
+14 DO OUT1
if $GET(RAXIT)
QUIT
SET RAREZON=1
+15 if +$PIECE(RAY3,"^",28)
DO RDIO^RARTUTL(+$PIECE(RAY3,"^",28))
if $DATA(RAOOUT)
QUIT
+16 if +$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0))
DO PHARM^RARTUTL(RACNI_","_RADTI_","_RADFN_",")
+17 QUIT
End DoDot:1
if $GET(RAXIT)
SET RAOOUT=1
if $DATA(RAOOUT)
QUIT
+18 SET RACNI=RACNISAV
SET RAY3=RAY3SAV
KILL RAREZON
+19 QUIT
OUT1 ;
+1 ; $O(RAMEMARR(0)) may be defined, if previously called MEMS1^RARTR3
+2 ; RALDIS flags long display wanted, comes from certain output options
+3 ; RACDIS(n) exists if case n is to be displayed
+4 ; RACDIS(n) not set for dupl proc+pmod+cptmod so don't display
+5 IF $ORDER(RAMEMARR(0))
IF '$GET(RALDIS)
IF '$DATA(RACDIS(RACNI))
QUIT
+6 ;Convey 'Reason for Study' P75
SET RASTUDY=$PIECE($GET(^RAO(75.1,+$PIECE(RAY3,U,11),.1)),U)
+7 IF $DATA(RAUTOE)
GOTO MAIL1
+8 WRITE !,$$XAM()
+9 ;check for contrast media; display if CM data exists (patch 45)
+10 SET RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RACNI)
+11 IF $LENGTH(RACMDATA)
Begin DoDot:1
+12 WRITE !?5,"Contrast Media :"
+13 FOR RAIZ=1:1
if $PIECE(RACMDATA,", ",RAIZ)=""
QUIT
Begin DoDot:2
+14 WRITE ?22,$PIECE(RACMDATA,", ",RAIZ)
+15 if $PIECE(RACMDATA,", ",RAIZ+1)'=""
WRITE !
+16 IF $Y>(IOSL-5)
SET RAXIT=$$EOS^RAUTL5()
if RAXIT
QUIT
WRITE @IOF
WRITE !
+17 QUIT
End DoDot:2
+18 KILL RAIZ
+19 QUIT
End DoDot:1
+20 KILL RACMDATA
if $GET(RAXIT)
QUIT
+21 if Y'="None"
WRITE !?RATAB,"Proc Modifiers : ",Y
+22 NEW I,J
+23 if Y(1)'="None"
WRITE !?RATAB,"CPT Modifiers : "
+24 IF Y(1)'="None"
FOR I=1:1
if $PIECE(Y(2),", ",I)']""
QUIT
SET J=$PIECE(Y(2),", ",I)
SET J=$$BASICMOD^RACPTMSC(J,DT)
WRITE ?22,$PIECE(J,"^",2)," ",$PIECE(J,"^",3)
if $PIECE(Y(2),", ",I+1)]""
WRITE !
IF $Y>(IOSL-5)
SET RAXIT=$$EOS^RAUTL5()
if RAXIT
QUIT
WRITE @IOF
WRITE !
+25 ;P75
IF $LENGTH(RASTUDY)
IF $GET(RAREZON,0)=0
WRITE !
DO DIWP^RAUTL5(RATAB,68,"Reason for Study: "_RASTUDY)
+26 KILL RASTUDY
+27 QUIT
+28 ;
MAIL1 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=""
+1 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=$$XAM()
+2 ;check for contrast media; display if CM data exists (patch 45)
+3 SET RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RACNI)
+4 IF $LENGTH(RACMDATA)
Begin DoDot:1
+5 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Contrast Media : "_$PIECE(RACMDATA,", ")
+6 FOR RAIZ=2:1
if $PIECE(RACMDATA,", ",RAIZ)=""
QUIT
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$PIECE(RACMDATA,", ",RAIZ)
+7 KILL RAIZ
+8 QUIT
End DoDot:1
+9 KILL RACMDATA
+10 if Y'="None"
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" Proc Modifiers : "_Y
+11 IF Y(1)'="None"
Begin DoDot:1
+12 SET J=$PIECE(Y(2),", ",1)
SET J=$$BASICMOD^RACPTMSC(J,DT)
if +J<0
SET $PIECE(J,"^",2,3)="None^"
+13 SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" CPT Modifiers : "_$SELECT(J]"":$PIECE(J,"^",2)_" "_$PIECE(J,"^",3),1:"")
+14 FOR I=2:1
if $PIECE(Y(2),", ",I)']""
QUIT
SET J=$PIECE(Y(2),", ",I)
SET J=$$BASICMOD^RACPTMSC(J,DT)
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=" "_$PIECE(J,"^",2)_" "_$PIECE(J,"^",3)
+15 QUIT
End DoDot:1
+16 IF $LENGTH(RASTUDY)
IF $GET(RAREZON,0)=0
Begin DoDot:1
+17 NEW RAY
SET RASTUDY="Reason for Study: "_RASTUDY
+18 IF $LENGTH(RASTUDY)'>68
SET $PIECE(RAY," ",6)=""
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAY_RASTUDY
QUIT
+19 IF $LENGTH(RASTUDY)>68
Begin DoDot:2
+20 KILL ^UTILITY($JOB,"W")
NEW %,DIW,DIWF,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,RAI,RAX,X,X1,Z
+21 SET DIWF=""
SET DIWL=1
SET DIWR=65
SET X=RASTUDY
DO ^DIWP
+22 SET RAI=0
FOR
SET RAI=$ORDER(^UTILITY($JOB,"W",DIWL,RAI))
if 'RAI
QUIT
Begin DoDot:3
+23 SET RAX=$GET(^UTILITY($JOB,"W",DIWL,RAI,0))
+24 IF RAI=1
SET $PIECE(RAY," ",6)=""
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAY_RAX
+25 IF RAI'=1
SET $PIECE(RAY," ",24)=""
SET ^TMP($JOB,"RA AUTOE",$$INCR^RAUTL4(RAACNT))=RAY_RAX
+26 QUIT
End DoDot:3
+27 QUIT
End DoDot:2
+28 KILL ^UTILITY($JOB,"W")
+29 QUIT
End DoDot:1
SET RAREZON=1
+30 KILL RASTUDY
+31 QUIT
+32 ;
XAM() ; Return exam data information. Case number, exam status & procedure
+1 ; name build into one string. Assumes RAY3 is the 0 node for exam data
+2 ; no exam information present.
if $GET(RAY3)=""
QUIT ""
+3 NEW RAPROC,RAXAMSTR
SET RAXAMSTR=""
+4 NEW RASSAN,RACNDSP
SET RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
+5 SET RACNDSP=$SELECT((RASSAN'=""):RASSAN,1:+RAY3)
+6 IF $GET(RAMDIV)=""
SET RAMDIV=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,0)),"^",3)
+7 IF $GET(RALDIS)!('$ORDER(RAMEMARR(0)))!($ORDER(RAMEMARR(0))&($GET(RACDIS(RACNI))=1))
Begin DoDot:1
+8 IF $$USESSAN^RAHLRU1()
SET $EXTRACT(RAXAMSTR,1,5)="(Case"
SET $EXTRACT(RAXAMSTR,7,(7+$LENGTH(RACNDSP)))=RACNDSP
+9 IF '$$USESSAN^RAHLRU1()
SET $EXTRACT(RAXAMSTR,1,5)="(Case"
SET $EXTRACT(RAXAMSTR,7,(7+$LENGTH(+RAY3)))=+RAY3
+10 SET $EXTRACT(RAXAMSTR,$LENGTH(RAXAMSTR)+2,79)=$SELECT($DATA(^RA(72,+$PIECE(RAY3,"^",3),0)):$EXTRACT($PIECE(^(0),"^"),1,8)_")",1:"Unknown)")
+11 QUIT
End DoDot:1
+12 IF '$TEST
if $GET(RACDIS(RACNI))
SET $EXTRACT(RAXAMSTR,1)="("
SET $EXTRACT(RAXAMSTR,9,14)=RACDIS(RACNI)_"x"
SET $EXTRACT(RAXAMSTR,20)=")"
+13 SET RAPROC=$GET(^RAMIS(71,+$PIECE(RAY3,"^",2),0))
+14 IF $$USESSAN^RAHLRU1()
SET $EXTRACT(RAXAMSTR,32,65)=$SELECT($PIECE(RAPROC,"^")]"":$EXTRACT($PIECE(RAPROC,"^"),1,33),1:"Unknown")
+15 IF '$$USESSAN^RAHLRU1()
SET $EXTRACT(RAXAMSTR,22,54)=$SELECT($PIECE(RAPROC,"^")]"":$EXTRACT($PIECE(RAPROC,"^"),1,33),1:"Unknown")
+16 NEW RADISPLY
+17 ; set $ZR to 71 for prccpt^radd1, not call raprod since store result
SET RADISPLY=$GET(^RAMIS(71,+$PIECE($GET(^RADPT(+RADFN,"DT",+RADTI,"P",+RACNI,0)),U,2),0))
+18 SET RADISPLY=$$PRCCPT^RADD1()
+19 IF $$USESSAN^RAHLRU1()
SET $EXTRACT(RAXAMSTR,65,79)=RADISPLY
+20 IF '$$USESSAN^RAHLRU1()
SET $EXTRACT(RAXAMSTR,55,79)=RADISPLY
+21 QUIT RAXAMSTR
