RART3 ;HISC/GJC,SWM-Reporting Menu (Part 2) ;05/22/09 09:20
;;5.0;Radiology/Nuclear Medicine;**8,10,18,27,35,45,75,99**;Mar 16, 1998;Build 5
; continue from RART1
; last modif by SS for P18
; p99 changed the Staff Phys title to Staff Imaging Phys
;Supported IA #10103 reference to ^XLFDT
;
QRPT ; Queue the report to run
N X K IOP,%ZIS S %ZIS="Q",%ZIS("B")=""
S %ZIS("S")="I $E($P($G(^%ZIS(2,+$P($G(^(""SUBTYPE"")),""^""),0)),""^""),1,2)=""P-"""
W ! D ^%ZIS
I POP D Q6^RART1 Q
I $E(IOST,1,2)="P-",('$D(IO("Q"))) D
. D PRT^RARTR
. Q
I $D(IO("Q")) D
. K RANME,RAPRC,Y S U="^",DT=$S($G(DT)]"":DT,1:$$DT^XLFDT())
. S ZTDESC="Rad/Nuc Med Abnormal Report Alert",ZTRTN="PRT^RARTR"
. S:$D(RARTMES) ZTSAVE("RARTMES")=""
. F I="DT","RARPT","U" S ZTSAVE(I)=""
. D ^%ZTLOAD W:$D(ZTSK) " Task # ",ZTSK
. K IO("Q"),ZTDESC,ZTRTN,ZTSAVE
. Q
W ! D ^%ZISC,HOME^%ZIS
D Q6^RART1,EXIT^RART
Q
PHYS N RA2ND,R1,R2,RASTR
S (R1,R2)=0 F S R2=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",R2)) Q:'R2 S:+$G(^(R2,0)) R1=R1+1,RA2ND("SRR",R1)=+^(0),RA2ND("SRR",R1)=$E($P($G(^VA(200,RA2ND("SRR",R1),0)),"^"),1,20)
S (R1,R2)=0 F S R2=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",R2)) Q:'R2 S:+$G(^(R2,0)) R1=R1+1,RA2ND("SSR",R1)=+^(0),RA2ND("SSR",R1)=$E($P($G(^VA(200,RA2ND("SSR",R1),0)),"^"),1,20)
S R1=$E($P($G(^VA(200,+$P(R3,"^",15),0)),"^"),1,15)
S RASTR="Staff Imaging Phys: "_R1 S:R1]"" RASTR=RASTR_" (P)"
PHYS1 I '$O(RA2ND("SSR",0)) W !,RASTR G PHYS2
S R1=0
PHYS11 S R1=$O(RA2ND("SSR",R1)) G:R1="" PHYS19
I $L(RASTR)+$L(RA2ND("SSR",R1))>79 W !,RASTR,";" S RASTR=" "
S:RASTR]" " RASTR=RASTR_"; " S RASTR=RASTR_RA2ND("SSR",R1) G PHYS11
PHYS19 W:RASTR]"" !,RASTR
PHYS2 S R1=$E($P($G(^VA(200,+$P(R3,"^",12),0)),"^"),1,15)
S RASTR="Residents : "_R1 S:R1]"" RASTR=RASTR_" (P)"
I '$O(RA2ND("SRR",0)) W !,RASTR Q
S R1=0
PHYS21 S R1=$O(RA2ND("SRR",R1)) G:R1="" PHYS29
I $L(RASTR)+$L(RA2ND("SRR",R1))>79 W !,RASTR,";" S RASTR=" "
S:RASTR]" " RASTR=RASTR_"; " S RASTR=RASTR_RA2ND("SRR",R1) G PHYS21
PHYS29 W:RASTR]"" !,RASTR
Q
MODSET ; print modifiers of all cases of print set
N RACDIS,RALDIS,RACNISAV,RAMEMARR,R1
D EN2^RAUTL20(.RAMEMARR) Q:'$O(RAMEMARR(0))
S RACNISAV=RACNI,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 Q:$L($G(X)) I $G(RAXIT) S X="^" Q
. S R1=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
. D MODS^RAUTL2
. ; If printing page at a time we need to check the length - RA*5*8
. I $Y>(IOSL-6),'$D(RARTVERF) S RAP="" D WAIT^RART1 I X="^"!(X="P")!(X="T") Q
. K X
. D OUT1 S RAREZON=1
. S:+$P(R1,"^",28) X=$$RDIO1^RARTUTL1(+$P(R1,"^",28)) Q:$L($G(X))
. S:+$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) X=$$PHARM1^RARTUTL(RACNI_","_RADTI_","_RADFN_",")
. W:$O(RAMEMARR(RACNI)) !
. Q
S RACNI=RACNISAV
W ! K RAREZON
Q
OUT1 ; print Procedure name, CPT code, Procedure modifier, and CPT Modifiers
; $O(RAMEMARR(0)) may be defined, if previously called MODSET^RART3
; 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
; If printset, skip if not long format or case not marked for cond.displ
I $O(RAMEMARR(0)),'$G(RALDIS),'$D(RACDIS(RACNI)) Q
N I,J,RACRF S RACRF=1
N RA18RET S RA18RET=0 ;P18
S R1=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
S RASTUDY=$P($G(^RAO(75.1,+$P(R1,U,11),.1)),U) ;Convey 'Reason for Study' P75
; Check if cancelled and not part of this report
I $P(^RA(72,+$P(R1,"^",3),0),"^",3)=0,($P(R1,"^",17)="") Q
I $P(^RA(72,+$P(R1,"^",3),0),"^",3)=0 D
.W !,$S($G(RALDIS):"",'$D(RACDIS):"",$G(RACDIS(RACNI))=1:"",1:RACDIS(RACNI)_"x"),?4,$E($P($G(^RAMIS(71,+$P(R1,"^",2),0)),"^"),1,42)_" (cancelled)"
E W !,$S($G(RALDIS):"",'$D(RACDIS):"",$G(RACDIS(RACNI))=1:"",1:RACDIS(RACNI)_"x"),?4,$P($G(^RAMIS(71,+$P(R1,"^",2),0)),"^")
D PRCCPT^RAPROD ;disp proc. abbr, proc type, & CPT
;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 '$D(RARTVERF),$Y>(IOSL-5) S RAXIT=$$EOS^RAUTL5() S:RAXIT RA18RET=-1 Q:RAXIT W @IOF W !
..Q
.K RAIZ
.QUIT
K RACMDATA Q:RA18RET=-1 ;P18
W:Y'="None" !?5,"Proc Modifiers : ",Y
W:Y(1)'="None" !?5,"CPT Modifiers :"
I Y(1)'="None" S RACRF=0 D
.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 '$D(RARTVERF),$Y>(IOSL-5) S RAXIT=$$EOS^RAUTL5() S:RAXIT RA18RET=-1 Q:RAXIT W @IOF W !
Q:RA18RET=-1
I $L(RASTUDY),$G(RAREZON,0)=0 W:RACRF ! S RACRF=0 D DIWP^RAUTL5(5,68,"Reason for Study: "_RASTUDY) ;P75
K RASTUDY
;RATECHCO is defined in OPTION FILE's ENTRY/EXIT ACTION
I $D(RATECHCO) W:RACRF ! S RA18RET=$$PUTTCOM^RAUTL11(RADFN,RADTI,RACNI," Tech.Comment : ",22,70,7,0,0,2,0) S:RA18RET=-1 RAXIT=1 Q:RA18RET=-1 ;P18
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRART3 5218 printed Sep 23, 2025@20:15:21 Page 2
RART3 ;HISC/GJC,SWM-Reporting Menu (Part 2) ;05/22/09 09:20
+1 ;;5.0;Radiology/Nuclear Medicine;**8,10,18,27,35,45,75,99**;Mar 16, 1998;Build 5
+2 ; continue from RART1
+3 ; last modif by SS for P18
+4 ; p99 changed the Staff Phys title to Staff Imaging Phys
+5 ;Supported IA #10103 reference to ^XLFDT
+6 ;
QRPT ; Queue the report to run
+1 NEW X
KILL IOP,%ZIS
SET %ZIS="Q"
SET %ZIS("B")=""
+2 SET %ZIS("S")="I $E($P($G(^%ZIS(2,+$P($G(^(""SUBTYPE"")),""^""),0)),""^""),1,2)=""P-"""
+3 WRITE !
DO ^%ZIS
+4 IF POP
DO Q6^RART1
QUIT
+5 IF $EXTRACT(IOST,1,2)="P-"
IF ('$DATA(IO("Q")))
Begin DoDot:1
+6 DO PRT^RARTR
+7 QUIT
End DoDot:1
+8 IF $DATA(IO("Q"))
Begin DoDot:1
+9 KILL RANME,RAPRC,Y
SET U="^"
SET DT=$SELECT($GET(DT)]"":DT,1:$$DT^XLFDT())
+10 SET ZTDESC="Rad/Nuc Med Abnormal Report Alert"
SET ZTRTN="PRT^RARTR"
+11 if $DATA(RARTMES)
SET ZTSAVE("RARTMES")=""
+12 FOR I="DT","RARPT","U"
SET ZTSAVE(I)=""
+13 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE " Task # ",ZTSK
+14 KILL IO("Q"),ZTDESC,ZTRTN,ZTSAVE
+15 QUIT
End DoDot:1
+16 WRITE !
DO ^%ZISC
DO HOME^%ZIS
+17 DO Q6^RART1
DO EXIT^RART
+18 QUIT
PHYS NEW RA2ND,R1,R2,RASTR
+1 SET (R1,R2)=0
FOR
SET R2=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SRR",R2))
if 'R2
QUIT
if +$GET(^(R2,0))
SET R1=R1+1
SET RA2ND("SRR",R1)=+^(0)
SET RA2ND("SRR",R1)=$EXTRACT($PIECE($GET(^VA(200,RA2ND("SRR",R1),0)),"^"),1,20)
+2 SET (R1,R2)=0
FOR
SET R2=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"SSR",R2))
if 'R2
QUIT
if +$GET(^(R2,0))
SET R1=R1+1
SET RA2ND("SSR",R1)=+^(0)
SET RA2ND("SSR",R1)=$EXTRACT($PIECE($GET(^VA(200,RA2ND("SSR",R1),0)),"^"),1,20)
+3 SET R1=$EXTRACT($PIECE($GET(^VA(200,+$PIECE(R3,"^",15),0)),"^"),1,15)
+4 SET RASTR="Staff Imaging Phys: "_R1
if R1]""
SET RASTR=RASTR_" (P)"
PHYS1 IF '$ORDER(RA2ND("SSR",0))
WRITE !,RASTR
GOTO PHYS2
+1 SET R1=0
PHYS11 SET R1=$ORDER(RA2ND("SSR",R1))
if R1=""
GOTO PHYS19
+1 IF $LENGTH(RASTR)+$LENGTH(RA2ND("SSR",R1))>79
WRITE !,RASTR,";"
SET RASTR=" "
+2 if RASTR]" "
SET RASTR=RASTR_"; "
SET RASTR=RASTR_RA2ND("SSR",R1)
GOTO PHYS11
PHYS19 if RASTR]""
WRITE !,RASTR
PHYS2 SET R1=$EXTRACT($PIECE($GET(^VA(200,+$PIECE(R3,"^",12),0)),"^"),1,15)
+1 SET RASTR="Residents : "_R1
if R1]""
SET RASTR=RASTR_" (P)"
+2 IF '$ORDER(RA2ND("SRR",0))
WRITE !,RASTR
QUIT
+3 SET R1=0
PHYS21 SET R1=$ORDER(RA2ND("SRR",R1))
if R1=""
GOTO PHYS29
+1 IF $LENGTH(RASTR)+$LENGTH(RA2ND("SRR",R1))>79
WRITE !,RASTR,";"
SET RASTR=" "
+2 if RASTR]" "
SET RASTR=RASTR_"; "
SET RASTR=RASTR_RA2ND("SRR",R1)
GOTO PHYS21
PHYS29 if RASTR]""
WRITE !,RASTR
+1 QUIT
MODSET ; print modifiers of all cases of print set
+1 NEW RACDIS,RALDIS,RACNISAV,RAMEMARR,R1
+2 DO EN2^RAUTL20(.RAMEMARR)
if '$ORDER(RAMEMARR(0))
QUIT
+3 SET RACNISAV=RACNI
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 R1=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+9 DO MODS^RAUTL2
+10 ; If printing page at a time we need to check the length - RA*5*8
+11 IF $Y>(IOSL-6)
IF '$DATA(RARTVERF)
SET RAP=""
DO WAIT^RART1
IF X="^"!(X="P")!(X="T")
QUIT
+12 KILL X
+13 DO OUT1
SET RAREZON=1
+14 if +$PIECE(R1,"^",28)
SET X=$$RDIO1^RARTUTL1(+$PIECE(R1,"^",28))
if $LENGTH($GET(X))
QUIT
+15 if +$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0))
SET X=$$PHARM1^RARTUTL(RACNI_","_RADTI_","_RADFN_",")
+16 if $ORDER(RAMEMARR(RACNI))
WRITE !
+17 QUIT
End DoDot:1
if $LENGTH($GET(X))
QUIT
IF $GET(RAXIT)
SET X="^"
QUIT
+18 SET RACNI=RACNISAV
+19 WRITE !
KILL RAREZON
+20 QUIT
OUT1 ; print Procedure name, CPT code, Procedure modifier, and CPT Modifiers
+1 ; $O(RAMEMARR(0)) may be defined, if previously called MODSET^RART3
+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 printset, skip if not long format or case not marked for cond.displ
+6 IF $ORDER(RAMEMARR(0))
IF '$GET(RALDIS)
IF '$DATA(RACDIS(RACNI))
QUIT
+7 NEW I,J,RACRF
SET RACRF=1
+8 ;P18
NEW RA18RET
SET RA18RET=0
+9 SET R1=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+10 ;Convey 'Reason for Study' P75
SET RASTUDY=$PIECE($GET(^RAO(75.1,+$PIECE(R1,U,11),.1)),U)
+11 ; Check if cancelled and not part of this report
+12 IF $PIECE(^RA(72,+$PIECE(R1,"^",3),0),"^",3)=0
IF ($PIECE(R1,"^",17)="")
QUIT
+13 IF $PIECE(^RA(72,+$PIECE(R1,"^",3),0),"^",3)=0
Begin DoDot:1
+14 WRITE !,$SELECT($GET(RALDIS):"",'$DATA(RACDIS):"",$GET(RACDIS(RACNI))=1:"",1:RACDIS(RACNI)_"x"),?4,$EXTRACT($PIECE($GET(^RAMIS(71,+$PIECE(R1,"^",2),0)),"^"),1,42)_" (cancelled)"
End DoDot:1
+15 IF '$TEST
WRITE !,$SELECT($GET(RALDIS):"",'$DATA(RACDIS):"",$GET(RACDIS(RACNI))=1:"",1:RACDIS(RACNI)_"x"),?4,$PIECE($GET(^RAMIS(71,+$PIECE(R1,"^",2),0)),"^")
+16 ;disp proc. abbr, proc type, & CPT
DO PRCCPT^RAPROD
+17 ;check for contrast media; display if CM data exists (patch 45)
+18 SET RACMDATA=$$CMEDIA^RAUTL8(RADFN,RADTI,RACNI)
+19 IF $LENGTH(RACMDATA)
Begin DoDot:1
+20 WRITE !?5,"Contrast Media :"
+21 FOR RAIZ=1:1
if $PIECE(RACMDATA,", ",RAIZ)=""
QUIT
Begin DoDot:2
+22 WRITE ?22,$PIECE(RACMDATA,", ",RAIZ)
if $PIECE(RACMDATA,", ",RAIZ+1)'=""
WRITE !
+23 IF '$DATA(RARTVERF)
IF $Y>(IOSL-5)
SET RAXIT=$$EOS^RAUTL5()
if RAXIT
SET RA18RET=-1
if RAXIT
QUIT
WRITE @IOF
WRITE !
+24 QUIT
End DoDot:2
+25 KILL RAIZ
+26 QUIT
End DoDot:1
+27 ;P18
KILL RACMDATA
if RA18RET=-1
QUIT
+28 if Y'="None"
WRITE !?5,"Proc Modifiers : ",Y
+29 if Y(1)'="None"
WRITE !?5,"CPT Modifiers :"
+30 IF Y(1)'="None"
SET RACRF=0
Begin DoDot:1
+31 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 '$DATA(RARTVERF)
IF $Y>(IOSL-5)
SET RAXIT=$$EOS^RAUTL5()
if RAXIT
SET RA18RET=-1
if RAXIT
QUIT
WRITE @IOF
WRITE !
End DoDot:1
+32 if RA18RET=-1
QUIT
+33 ;P75
IF $LENGTH(RASTUDY)
IF $GET(RAREZON,0)=0
if RACRF
WRITE !
SET RACRF=0
DO DIWP^RAUTL5(5,68,"Reason for Study: "_RASTUDY)
+34 KILL RASTUDY
+35 ;RATECHCO is defined in OPTION FILE's ENTRY/EXIT ACTION
+36 ;P18
IF $DATA(RATECHCO)
if RACRF
WRITE !
SET RA18RET=$$PUTTCOM^RAUTL11(RADFN,RADTI,RACNI," Tech.Comment : ",22,70,7,0,0,2,0)
if RA18RET=-1
SET RAXIT=1
if RA18RET=-1
QUIT
+37 QUIT
