RADRPT2A ;HISC/GJC Radiation dosage report utility two ;01 Aug 2017 1:28 PM
;;5.0;Radiology/Nuclear Medicine;**113,119**;Mar 16, 1998;Build 7
;
;--- IAs ---
;Call Number Type
;------------------------------------------------
;$$SS^%ZTLOAD 10063 S
;$$GET1^DIQ 2056 S
;GETS^DIQ 2056 S
;$$FMTE^XLFDT 10103 S
;$$CJ^XLFSTR 10104 S
;^DPT( 10035 S
;^DIC(4, 10060 S
;^VA(200, 10090 S
;where 'S'=Supported; 'C'=Controlled Subscription; 'P'=Private
;
DISPLAY ; display data
;
; Where the data for the report is stored:
; ----------------------------------------------------------------------------
; ^TMP($J,"RA SORT",RADTE,RASORT,RADFN,RACNI,"F") = Air Kerma ^ Air kerma Area Product ^ Total Fluoro time (min)
;
; ^TMP($J,"RA SORT",RADTE,RASORT,RADFN,RACNI,"S") = CTDIvol (total) ^ DLP (total)
;
; ^TMP($J,"RA SORT",RADTE,RASORT,RADFN,RACNI,n) = Phantom ptr (#2005.6362) ^ CTDIvol ^ DLP
; ----------------------------------------------------------------------------
;
;RARPTYPE=F:Fluoroscopy;D:Detailed;S:Summary
;RAFILTR=C:CPT Code;P:Patient;R:Radiologist
;
S $P(RABORDER,"=",(IOM+1))=""
S RAHDRBY=$S(RAFILTR="C":"CPT Code",RAFILTR="P":"Patient",1:"Radiologist")
S:RARPTYPE="S" RAHDRTY="CT Totals (ONLY) Radiation Dose Summary Report by "_RAHDRBY
S:RARPTYPE="D" RAHDRTY="CT by Series Radiation Dose Summary Report by "_RAHDRBY
S:RARPTYPE="F" RAHDRTY="Fluoro Radiation Dose Summary Report by "_RAHDRBY
S $P(RALINE,"-",(IOM+1))=""
S RAC=9999999.9999,(RAPG,RAQUIT,RAZTSTOP)=0
;
I ($D(^TMP($J,"RA SORT"))\10)=0 D D XIT Q
.D HDR S X="There are no Radiology exam records of file for the selected filter criteria."
.W !,$$CJ^XLFSTR(X,(IOM+1))
.Q
;
K ^TMP($J,"RA DISCLAIMER") D DISCLAIM
;
S RADTE("X")=$O(^TMP($J,"RA SORT",$C(32)),-1) ;last date/time subscript value
S RADTE=0 D HDR
F S RADTE=$O(^TMP($J,"RA SORT",RADTE)) Q:RADTE'>0 D Q:RAQUIT
.;RAXY("X") is the last ascending second level subscript value
.S RAXY="",RAXY("X")=$O(^TMP($J,"RA SORT",RADTE,$C(126)),-1)
.F S RAXY=$O(^TMP($J,"RA SORT",RADTE,RAXY)) Q:RAXY="" D Q:RAQUIT
..S RADFN=0,RADFN("X")=$O(^TMP($J,"RA SORT",RADTE,RAXY,$C(32)),-1)
..F S RADFN=$O(^TMP($J,"RA SORT",RADTE,RAXY,RADFN)) Q:RADFN'>0 D Q:RAQUIT
...;get patient demographics name & SSN
...D GETDEM S RACNI=0
...S RACNI("X")=$O(^TMP($J,"RA SORT",RADTE,RAXY,RADFN,$C(32)),-1)
...F S RACNI=$O(^TMP($J,"RA SORT",RADTE,RAXY,RADFN,RACNI)) Q:RACNI'>0 D Q:RAQUIT
....S RADTI=(RAC-RADTE),RAY2=$G(^RADPT(RADFN,"DT",RADTI,0))
....S RAY3=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
....;get exam/study based data
....D GETXAM
....;print by Fluoroscopy
....D:RARPTYPE="F" PRTFL Q:RAQUIT
....;print by CT summary
....D:RARPTYPE="S" CTDATA Q:RAQUIT
....;print by CT detail
....D:RARPTYPE="D" CTDATA Q:RAQUIT
....I $Y>(IOSL-4),(RACNI'=RACNI("X")) D EOS
....Q
...Q:RAQUIT I $Y>(IOSL-4),(RADFN'=RADFN("X")) D EOS
...Q
..Q:RAQUIT I $Y>(IOSL-4),(RAXY'=RAXY("X")) D EOS
..Q
.; RAP used as timing mechanism to check if the job was stopped
.Q:RAQUIT S RAZTSTOP=RAZTSTOP+1
.I $D(ZTQUEUED) S:RAZTSTOP#500=0 (RAQUIT,ZTSTOP)=$$S^%ZTLOAD()
.I $Y>(IOSL-4),(RADTE'=RADTE("X")) D EOS
.Q
;
I RAQUIT D XIT Q
S RADISCLM=""
D:$Y>(IOSL-4) EOS Q:RAQUIT
W ! F RAI=1:1:5 D Q:RAQUIT
.I RARPTYPE="F" Q:RAI=3!(RAI=4)
.I RARPTYPE="S" Q:RAI=3!(RAI=5)
.I RARPTYPE="D" Q:RAI=5
.S RAY=0
.F S RAY=$O(^TMP($J,"RA DISCLAIMER",RAI,RAY)) Q:RAY'>0 D Q:RAQUIT
..D:$Y>(IOSL-4) EOS Q:RAQUIT
..W !,$G(^TMP($J,"RA DISCLAIMER",RAI,RAY))
..Q
.Q:RAQUIT W ! ;break between disclaimers
.Q
D XIT
Q
;
XIT ;kill variables and exit...
K ^TMP($J,"RA DISCLAIMER"),RA71,RABORDER,RAC,RACN,RACNI,RACPT,RACTDI,RADATE
K RADFN,RADIEN,RADISCLM,RADLP,RADTE,RADTI,RAF,RAFAC,RAFILTR,RAFLMIN,RAFLSEC
K RAHDRBY,RAHDRTY,RAHDS,RAI,RAK,RAKAP,RAL,RALINE,RANAME,RANGE,RAPG,RAPHNTOM
K RAPRC,RAQUIT,RAR,RARPTYPE,RARUNDT,RASSN,RASTF,RASTNUM,RATMP,RAXY,RAY,RAY2
K RAY3,RAZTSTOP,X,Y S:$D(ZTQUEUED) ZTREQ="@"
Q
;
CTDATA ;print CT detailed series data or print summary totals
;
; ^TMP($J,"RA SORT",RADTE,RASORT,RADFN,RACNI,"S") = CTDIvol (total) ^ DLP (total)
;
; ^TMP($J,"RA SORT",RADTE,RASORT,RADFN,RACNI,RAI) = Phantom ptr (#2005.6362) ^ CTDIvol ^ DLP
;
N RACTDI,RADLP,RAF,RAHDS,RAI,RAPHNTOM,X
I RARPTYPE="D" D Q:RAQUIT
.S RAHDS=0 ;print the 'high 5'
.F S RAHDS=$O(^TMP($J,"RA SORT",RADTE,RAXY,RADFN,RACNI,RAHDS)) Q:RAHDS'>0 D Q:RAQUIT
..S RAF=$G(^TMP($J,"RA SORT",RADTE,RAXY,RADFN,RACNI,RAHDS))
..S RAPHNTOM=$$GET1^DIQ(2005.6362,+$P(RAF,U,1)_",",2)
..S RACTDI=$P(RAF,U,2),RADLP=$P(RAF,U,3)
..D PRTCTD I $Y>(IOSL-4) D EOS Q:RAQUIT
..Q
.;print totals for the detailed report
.Q:RAQUIT
.S X=$G(^TMP($J,"RA SORT",RADTE,RAXY,RADFN,RACNI,"S"))
.S RAHDS="Total",RACTDI=$P(X,U,1),RADLP=$P(X,U,2)
.S RAPHNTOM="" D PRTCTD
.Q
I RARPTYPE="S" D Q:RAQUIT
.S X=$G(^TMP($J,"RA SORT",RADTE,RAXY,RADFN,RACNI,"S"))
.S RACTDI=$P(X,U,1),RADLP=$P(X,U,2)
.D PRTCTS I $Y>(IOSL-4) D EOS Q:RAQUIT
.Q
Q
;
GETDEM ;get patient demographics name & SSN
K RATMP,X D GETS^DIQ(2,RADFN_",",".01;.09","E","RATMP")
S RANAME=RATMP(2,RADFN_",",".01","E")
S (RASSN("PID"),X)=RATMP(2,RADFN_",",".09","E")
S RASSN("BID")=$E(X,($L(X)-3),$L(X)) K RATMP,X
Q
;
GETXAM ;get exam/study based data
S RASTF=$$GET1^DIQ(200,+$P(RAY3,U,15)_",",.01)
S RA71(0)=$G(^RAMIS(71,+$P(RAY3,U,2),0))
S RAPRC=$P(RA71(0),U,1),RA71(9)=+$P(RA71(0),U,9)
;Example: 73000^X-RAY EXAM OF COLLAR BONE
S RACPT=$P($$NAMCODE^RACPTMSC(RA71(9),RADTE),U,1)
S RADATE=$$FMTE^XLFDT(RADTE,"2DZ")
Q
;
PRTCTS ;print CT summary data
W !,$E(RANAME,1,27),?29,RASSN("BID"),?35,RADATE,?45,RACPT,?52,$E(RAPRC,1,27),?81,$E(RASTF,1,27)
W ?110,$J(RACTDI,9,2),?121,$J(RADLP,9,2)
Q
;
PRTCTD ;print CT series/detailed data
W !,$E(RANAME,1,23),?25,RASSN("BID"),?31,RADATE,?41,RACPT,?48,$E(RAPRC,1,23),?73,$E(RASTF,1,23)
W ?98,RAHDS,?107,$J(RACTDI,9,2),?118,$J(RADLP,9,2)
Q
;
PRTFL ;print fluoroscopy data
S X=$G(^TMP($J,"RA SORT",RADTE,RAXY,RADFN,RACNI,"F"))
S RAK=$P(X,U,1),RAKAP=$P(X,U,2),RAFLMIN=$P(X,U,3)
W !,$E(RANAME,1,18),?25,RASSN("BID"),?31,RADATE,?41,RACPT,?48,$E(RAPRC,1,25),?75,$E(RASTF,1,23)
W ?99,$J(RAK,10,2),?112,$J(RAKAP,9,2),?125,RAFLMIN K X
Q
;
EOS ;end of screen - Note: EOS falls through to HDR!
I $E(IOST,1,2)="C-" D Q:RAQUIT
.W !,"Press RETURN to continue or '^' to exit: " R X:DTIME
.S RAQUIT='$T!(X["^") K X
.Q
HDR ;header
S RAPG=RAPG+1
W @IOF,!,"Facility",?20,": ",RAFAC,?120,"Page: ",RAPG
W !,"Station",?20,": ",RASTNUM
W !,"Report Date Range",?20,": ",RANGE
W !,"Report Run Date/Time",?20,": ",RARUNDT
W !,RABORDER D:('$D(RADISCLM)#2) @$S(RARPTYPE="F":"HDRFL",RARPTYPE="D":"HDRCTD",1:"HDRCTS")
Q
;
HDRCTD ;header for CT detailed
W !,RAHDRTY ;note: RAHDRTY is set at top of the routine
W !!?98,"Highest",!?98,"Dose",?107,"CTDIvol",?118,"DLP"
W !,"Patient",?25,"SSN",?31,"Date",?41,"CPT",?48,"Procedure Name",?73,"Radiologist",?98,"Series",?107,"mGy",?118,"mGy-cm"
W !,RALINE
Q
;
HDRCTS ;header for CT summary
W !,RAHDRTY
W !!?110,"Sum of",?121,"Sum of",!,?110,"all CDTI",?121,"all DLP"
W !,"Patient",?29,"SSN",?35,"Date",?45,"CPT",?52,"Procedure Name",?81,"Radiologist",?110,"vol mGy",?121,"mGy-cm"
W !,RALINE
Q
;
HDRFL ;header for fluoroscopy
W !,RAHDRTY
W !?100,"Air",?112,"Air Kerma",?125,"Fluoro",!?100,"Kerma",?112,"Area Product",?125,"Time"
W !,"Patient",?25,"SSN",?31,"Date",?41,"CPT",?48,"Procedure Name",?75,"Radiologist",?100,"mGy",?112,"Gy-cm2",?125,"min"
W !,RALINE
Q
;
DISCLAIM ;set up the disclaimer statements in an array
S ^TMP($J,"RA DISCLAIMER",1,1)="1. The purpose of this report is to facilitate tracking of procedure doses to"
S ^TMP($J,"RA DISCLAIMER",1,2)=" identify opportunities for improvement. It is not intended to provide a"
S ^TMP($J,"RA DISCLAIMER",1,3)=" complete record of patient dose. Doses resulting from plain films and"
S ^TMP($J,"RA DISCLAIMER",1,4)=" radiopharmaceuticals are not supported."
;(1,5)=""
S ^TMP($J,"RA DISCLAIMER",2,1)="2. Only procedures for which dose data has been received are listed. Data may"
S ^TMP($J,"RA DISCLAIMER",2,2)=" be missing if the modality does not support DICOM structured dose reporting,"
S ^TMP($J,"RA DISCLAIMER",2,3)=" if the dose report was not sent to VistA Imaging, if the radiology report was"
S ^TMP($J,"RA DISCLAIMER",2,4)=" was not verified, or if the procedure was performed/imported before patches"
S ^TMP($J,"RA DISCLAIMER",2,5)=" MAG*3*137 and RA*5*113 were installed."
;(2,6)=""
S ^TMP($J,"RA DISCLAIMER",3,1)="3. Only the five highest dose CT series are listed. The total dose refers"
S ^TMP($J,"RA DISCLAIMER",3,2)=" to the sum of all series and so may be larger than the sum of the five"
S ^TMP($J,"RA DISCLAIMER",3,3)=" displayed doses. This report may include CT localizer radiograph(s)"
S ^TMP($J,"RA DISCLAIMER",3,4)=" values as a series and/or included in the total depending on the CT"
S ^TMP($J,"RA DISCLAIMER",3,5)=" manufacturer."
;(3,6)=""
S ^TMP($J,"RA DISCLAIMER",4,1)="4. Radiology set workflow may show the total rad dose for a patient care event"
S ^TMP($J,"RA DISCLAIMER",4,2)=" under one CPT. If separate exposure instances during a CT examination were"
S ^TMP($J,"RA DISCLAIMER",4,3)=" of different body parts, the total CTDIvol stated here may exceed the actual"
S ^TMP($J,"RA DISCLAIMER",4,4)=" CTDIvol for any body part. More detailed dose information is available on the"
S ^TMP($J,"RA DISCLAIMER",4,5)=" modality (until it is deleted) or in the DICOM Radiation Dose Structured"
S ^TMP($J,"RA DISCLAIMER",4,6)=" Report (RDSR) file stored in VistA Imaging. Viewing the RDSR file is not yet"
S ^TMP($J,"RA DISCLAIMER",4,7)=" supported."
;(4,8)=""
S ^TMP($J,"RA DISCLAIMER",5,1)="5. Radiology set workflow may show the total rad dose for a patient care event"
S ^TMP($J,"RA DISCLAIMER",5,2)=" under one CPT. Air Kerma Area Product is also called the Dose Area Product."
S ^TMP($J,"RA DISCLAIMER",5,3)=" If fluoroscopy was performed using more than one projection, the total air"
S ^TMP($J,"RA DISCLAIMER",5,4)=" kerma stated here may exceed the air kerma to any single projection. More"
S ^TMP($J,"RA DISCLAIMER",5,5)=" detailed dose information is available on the modality (until it is deleted)"
S ^TMP($J,"RA DISCLAIMER",5,6)=" or in the DICOM Radiation Dose Structured Report (RDSR) file stored in VistA"
S ^TMP($J,"RA DISCLAIMER",5,7)=" Imaging. Viewing the RDSR file is not yet supported."
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRADRPT2A 10849 printed Sep 23, 2025@20:10:54 Page 2
RADRPT2A ;HISC/GJC Radiation dosage report utility two ;01 Aug 2017 1:28 PM
+1 ;;5.0;Radiology/Nuclear Medicine;**113,119**;Mar 16, 1998;Build 7
+2 ;
+3 ;--- IAs ---
+4 ;Call Number Type
+5 ;------------------------------------------------
+6 ;$$SS^%ZTLOAD 10063 S
+7 ;$$GET1^DIQ 2056 S
+8 ;GETS^DIQ 2056 S
+9 ;$$FMTE^XLFDT 10103 S
+10 ;$$CJ^XLFSTR 10104 S
+11 ;^DPT( 10035 S
+12 ;^DIC(4, 10060 S
+13 ;^VA(200, 10090 S
+14 ;where 'S'=Supported; 'C'=Controlled Subscription; 'P'=Private
+15 ;
DISPLAY ; display data
+1 ;
+2 ; Where the data for the report is stored:
+3 ; ----------------------------------------------------------------------------
+4 ; ^TMP($J,"RA SORT",RADTE,RASORT,RADFN,RACNI,"F") = Air Kerma ^ Air kerma Area Product ^ Total Fluoro time (min)
+5 ;
+6 ; ^TMP($J,"RA SORT",RADTE,RASORT,RADFN,RACNI,"S") = CTDIvol (total) ^ DLP (total)
+7 ;
+8 ; ^TMP($J,"RA SORT",RADTE,RASORT,RADFN,RACNI,n) = Phantom ptr (#2005.6362) ^ CTDIvol ^ DLP
+9 ; ----------------------------------------------------------------------------
+10 ;
+11 ;RARPTYPE=F:Fluoroscopy;D:Detailed;S:Summary
+12 ;RAFILTR=C:CPT Code;P:Patient;R:Radiologist
+13 ;
+14 SET $PIECE(RABORDER,"=",(IOM+1))=""
+15 SET RAHDRBY=$SELECT(RAFILTR="C":"CPT Code",RAFILTR="P":"Patient",1:"Radiologist")
+16 if RARPTYPE="S"
SET RAHDRTY="CT Totals (ONLY) Radiation Dose Summary Report by "_RAHDRBY
+17 if RARPTYPE="D"
SET RAHDRTY="CT by Series Radiation Dose Summary Report by "_RAHDRBY
+18 if RARPTYPE="F"
SET RAHDRTY="Fluoro Radiation Dose Summary Report by "_RAHDRBY
+19 SET $PIECE(RALINE,"-",(IOM+1))=""
+20 SET RAC=9999999.9999
SET (RAPG,RAQUIT,RAZTSTOP)=0
+21 ;
+22 IF ($DATA(^TMP($JOB,"RA SORT"))\10)=0
Begin DoDot:1
+23 DO HDR
SET X="There are no Radiology exam records of file for the selected filter criteria."
+24 WRITE !,$$CJ^XLFSTR(X,(IOM+1))
+25 QUIT
End DoDot:1
DO XIT
QUIT
+26 ;
+27 KILL ^TMP($JOB,"RA DISCLAIMER")
DO DISCLAIM
+28 ;
+29 ;last date/time subscript value
SET RADTE("X")=$ORDER(^TMP($JOB,"RA SORT",$CHAR(32)),-1)
+30 SET RADTE=0
DO HDR
+31 FOR
SET RADTE=$ORDER(^TMP($JOB,"RA SORT",RADTE))
if RADTE'>0
QUIT
Begin DoDot:1
+32 ;RAXY("X") is the last ascending second level subscript value
+33 SET RAXY=""
SET RAXY("X")=$ORDER(^TMP($JOB,"RA SORT",RADTE,$CHAR(126)),-1)
+34 FOR
SET RAXY=$ORDER(^TMP($JOB,"RA SORT",RADTE,RAXY))
if RAXY=""
QUIT
Begin DoDot:2
+35 SET RADFN=0
SET RADFN("X")=$ORDER(^TMP($JOB,"RA SORT",RADTE,RAXY,$CHAR(32)),-1)
+36 FOR
SET RADFN=$ORDER(^TMP($JOB,"RA SORT",RADTE,RAXY,RADFN))
if RADFN'>0
QUIT
Begin DoDot:3
+37 ;get patient demographics name & SSN
+38 DO GETDEM
SET RACNI=0
+39 SET RACNI("X")=$ORDER(^TMP($JOB,"RA SORT",RADTE,RAXY,RADFN,$CHAR(32)),-1)
+40 FOR
SET RACNI=$ORDER(^TMP($JOB,"RA SORT",RADTE,RAXY,RADFN,RACNI))
if RACNI'>0
QUIT
Begin DoDot:4
+41 SET RADTI=(RAC-RADTE)
SET RAY2=$GET(^RADPT(RADFN,"DT",RADTI,0))
+42 SET RAY3=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+43 ;get exam/study based data
+44 DO GETXAM
+45 ;print by Fluoroscopy
+46 if RARPTYPE="F"
DO PRTFL
if RAQUIT
QUIT
+47 ;print by CT summary
+48 if RARPTYPE="S"
DO CTDATA
if RAQUIT
QUIT
+49 ;print by CT detail
+50 if RARPTYPE="D"
DO CTDATA
if RAQUIT
QUIT
+51 IF $Y>(IOSL-4)
IF (RACNI'=RACNI("X"))
DO EOS
+52 QUIT
End DoDot:4
if RAQUIT
QUIT
+53 if RAQUIT
QUIT
IF $Y>(IOSL-4)
IF (RADFN'=RADFN("X"))
DO EOS
+54 QUIT
End DoDot:3
if RAQUIT
QUIT
+55 if RAQUIT
QUIT
IF $Y>(IOSL-4)
IF (RAXY'=RAXY("X"))
DO EOS
+56 QUIT
End DoDot:2
if RAQUIT
QUIT
+57 ; RAP used as timing mechanism to check if the job was stopped
+58 if RAQUIT
QUIT
SET RAZTSTOP=RAZTSTOP+1
+59 IF $DATA(ZTQUEUED)
if RAZTSTOP#500=0
SET (RAQUIT,ZTSTOP)=$$S^%ZTLOAD()
+60 IF $Y>(IOSL-4)
IF (RADTE'=RADTE("X"))
DO EOS
+61 QUIT
End DoDot:1
if RAQUIT
QUIT
+62 ;
+63 IF RAQUIT
DO XIT
QUIT
+64 SET RADISCLM=""
+65 if $Y>(IOSL-4)
DO EOS
if RAQUIT
QUIT
+66 WRITE !
FOR RAI=1:1:5
Begin DoDot:1
+67 IF RARPTYPE="F"
if RAI=3!(RAI=4)
QUIT
+68 IF RARPTYPE="S"
if RAI=3!(RAI=5)
QUIT
+69 IF RARPTYPE="D"
if RAI=5
QUIT
+70 SET RAY=0
+71 FOR
SET RAY=$ORDER(^TMP($JOB,"RA DISCLAIMER",RAI,RAY))
if RAY'>0
QUIT
Begin DoDot:2
+72 if $Y>(IOSL-4)
DO EOS
if RAQUIT
QUIT
+73 WRITE !,$GET(^TMP($JOB,"RA DISCLAIMER",RAI,RAY))
+74 QUIT
End DoDot:2
if RAQUIT
QUIT
+75 ;break between disclaimers
if RAQUIT
QUIT
WRITE !
+76 QUIT
End DoDot:1
if RAQUIT
QUIT
+77 DO XIT
+78 QUIT
+79 ;
XIT ;kill variables and exit...
+1 KILL ^TMP($JOB,"RA DISCLAIMER"),RA71,RABORDER,RAC,RACN,RACNI,RACPT,RACTDI,RADATE
+2 KILL RADFN,RADIEN,RADISCLM,RADLP,RADTE,RADTI,RAF,RAFAC,RAFILTR,RAFLMIN,RAFLSEC
+3 KILL RAHDRBY,RAHDRTY,RAHDS,RAI,RAK,RAKAP,RAL,RALINE,RANAME,RANGE,RAPG,RAPHNTOM
+4 KILL RAPRC,RAQUIT,RAR,RARPTYPE,RARUNDT,RASSN,RASTF,RASTNUM,RATMP,RAXY,RAY,RAY2
+5 KILL RAY3,RAZTSTOP,X,Y
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+6 QUIT
+7 ;
CTDATA ;print CT detailed series data or print summary totals
+1 ;
+2 ; ^TMP($J,"RA SORT",RADTE,RASORT,RADFN,RACNI,"S") = CTDIvol (total) ^ DLP (total)
+3 ;
+4 ; ^TMP($J,"RA SORT",RADTE,RASORT,RADFN,RACNI,RAI) = Phantom ptr (#2005.6362) ^ CTDIvol ^ DLP
+5 ;
+6 NEW RACTDI,RADLP,RAF,RAHDS,RAI,RAPHNTOM,X
+7 IF RARPTYPE="D"
Begin DoDot:1
+8 ;print the 'high 5'
SET RAHDS=0
+9 FOR
SET RAHDS=$ORDER(^TMP($JOB,"RA SORT",RADTE,RAXY,RADFN,RACNI,RAHDS))
if RAHDS'>0
QUIT
Begin DoDot:2
+10 SET RAF=$GET(^TMP($JOB,"RA SORT",RADTE,RAXY,RADFN,RACNI,RAHDS))
+11 SET RAPHNTOM=$$GET1^DIQ(2005.6362,+$PIECE(RAF,U,1)_",",2)
+12 SET RACTDI=$PIECE(RAF,U,2)
SET RADLP=$PIECE(RAF,U,3)
+13 DO PRTCTD
IF $Y>(IOSL-4)
DO EOS
if RAQUIT
QUIT
+14 QUIT
End DoDot:2
if RAQUIT
QUIT
+15 ;print totals for the detailed report
+16 if RAQUIT
QUIT
+17 SET X=$GET(^TMP($JOB,"RA SORT",RADTE,RAXY,RADFN,RACNI,"S"))
+18 SET RAHDS="Total"
SET RACTDI=$PIECE(X,U,1)
SET RADLP=$PIECE(X,U,2)
+19 SET RAPHNTOM=""
DO PRTCTD
+20 QUIT
End DoDot:1
if RAQUIT
QUIT
+21 IF RARPTYPE="S"
Begin DoDot:1
+22 SET X=$GET(^TMP($JOB,"RA SORT",RADTE,RAXY,RADFN,RACNI,"S"))
+23 SET RACTDI=$PIECE(X,U,1)
SET RADLP=$PIECE(X,U,2)
+24 DO PRTCTS
IF $Y>(IOSL-4)
DO EOS
if RAQUIT
QUIT
+25 QUIT
End DoDot:1
if RAQUIT
QUIT
+26 QUIT
+27 ;
GETDEM ;get patient demographics name & SSN
+1 KILL RATMP,X
DO GETS^DIQ(2,RADFN_",",".01;.09","E","RATMP")
+2 SET RANAME=RATMP(2,RADFN_",",".01","E")
+3 SET (RASSN("PID"),X)=RATMP(2,RADFN_",",".09","E")
+4 SET RASSN("BID")=$EXTRACT(X,($LENGTH(X)-3),$LENGTH(X))
KILL RATMP,X
+5 QUIT
+6 ;
GETXAM ;get exam/study based data
+1 SET RASTF=$$GET1^DIQ(200,+$PIECE(RAY3,U,15)_",",.01)
+2 SET RA71(0)=$GET(^RAMIS(71,+$PIECE(RAY3,U,2),0))
+3 SET RAPRC=$PIECE(RA71(0),U,1)
SET RA71(9)=+$PIECE(RA71(0),U,9)
+4 ;Example: 73000^X-RAY EXAM OF COLLAR BONE
+5 SET RACPT=$PIECE($$NAMCODE^RACPTMSC(RA71(9),RADTE),U,1)
+6 SET RADATE=$$FMTE^XLFDT(RADTE,"2DZ")
+7 QUIT
+8 ;
PRTCTS ;print CT summary data
+1 WRITE !,$EXTRACT(RANAME,1,27),?29,RASSN("BID"),?35,RADATE,?45,RACPT,?52,$EXTRACT(RAPRC,1,27),?81,$EXTRACT(RASTF,1,27)
+2 WRITE ?110,$JUSTIFY(RACTDI,9,2),?121,$JUSTIFY(RADLP,9,2)
+3 QUIT
+4 ;
PRTCTD ;print CT series/detailed data
+1 WRITE !,$EXTRACT(RANAME,1,23),?25,RASSN("BID"),?31,RADATE,?41,RACPT,?48,$EXTRACT(RAPRC,1,23),?73,$EXTRACT(RASTF,1,23)
+2 WRITE ?98,RAHDS,?107,$JUSTIFY(RACTDI,9,2),?118,$JUSTIFY(RADLP,9,2)
+3 QUIT
+4 ;
PRTFL ;print fluoroscopy data
+1 SET X=$GET(^TMP($JOB,"RA SORT",RADTE,RAXY,RADFN,RACNI,"F"))
+2 SET RAK=$PIECE(X,U,1)
SET RAKAP=$PIECE(X,U,2)
SET RAFLMIN=$PIECE(X,U,3)
+3 WRITE !,$EXTRACT(RANAME,1,18),?25,RASSN("BID"),?31,RADATE,?41,RACPT,?48,$EXTRACT(RAPRC,1,25),?75,$EXTRACT(RASTF,1,23)
+4 WRITE ?99,$JUSTIFY(RAK,10,2),?112,$JUSTIFY(RAKAP,9,2),?125,RAFLMIN
KILL X
+5 QUIT
+6 ;
EOS ;end of screen - Note: EOS falls through to HDR!
+1 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+2 WRITE !,"Press RETURN to continue or '^' to exit: "
READ X:DTIME
+3 SET RAQUIT='$TEST!(X["^")
KILL X
+4 QUIT
End DoDot:1
if RAQUIT
QUIT
HDR ;header
+1 SET RAPG=RAPG+1
+2 WRITE @IOF,!,"Facility",?20,": ",RAFAC,?120,"Page: ",RAPG
+3 WRITE !,"Station",?20,": ",RASTNUM
+4 WRITE !,"Report Date Range",?20,": ",RANGE
+5 WRITE !,"Report Run Date/Time",?20,": ",RARUNDT
+6 WRITE !,RABORDER
if ('$DATA(RADISCLM)#2)
DO @$SELECT(RARPTYPE="F":"HDRFL",RARPTYPE="D":"HDRCTD",1:"HDRCTS")
+7 QUIT
+8 ;
HDRCTD ;header for CT detailed
+1 ;note: RAHDRTY is set at top of the routine
WRITE !,RAHDRTY
+2 WRITE !!?98,"Highest",!?98,"Dose",?107,"CTDIvol",?118,"DLP"
+3 WRITE !,"Patient",?25,"SSN",?31,"Date",?41,"CPT",?48,"Procedure Name",?73,"Radiologist",?98,"Series",?107,"mGy",?118,"mGy-cm"
+4 WRITE !,RALINE
+5 QUIT
+6 ;
HDRCTS ;header for CT summary
+1 WRITE !,RAHDRTY
+2 WRITE !!?110,"Sum of",?121,"Sum of",!,?110,"all CDTI",?121,"all DLP"
+3 WRITE !,"Patient",?29,"SSN",?35,"Date",?45,"CPT",?52,"Procedure Name",?81,"Radiologist",?110,"vol mGy",?121,"mGy-cm"
+4 WRITE !,RALINE
+5 QUIT
+6 ;
HDRFL ;header for fluoroscopy
+1 WRITE !,RAHDRTY
+2 WRITE !?100,"Air",?112,"Air Kerma",?125,"Fluoro",!?100,"Kerma",?112,"Area Product",?125,"Time"
+3 WRITE !,"Patient",?25,"SSN",?31,"Date",?41,"CPT",?48,"Procedure Name",?75,"Radiologist",?100,"mGy",?112,"Gy-cm2",?125,"min"
+4 WRITE !,RALINE
+5 QUIT
+6 ;
DISCLAIM ;set up the disclaimer statements in an array
+1 SET ^TMP($JOB,"RA DISCLAIMER",1,1)="1. The purpose of this report is to facilitate tracking of procedure doses to"
+2 SET ^TMP($JOB,"RA DISCLAIMER",1,2)=" identify opportunities for improvement. It is not intended to provide a"
+3 SET ^TMP($JOB,"RA DISCLAIMER",1,3)=" complete record of patient dose. Doses resulting from plain films and"
+4 SET ^TMP($JOB,"RA DISCLAIMER",1,4)=" radiopharmaceuticals are not supported."
+5 ;(1,5)=""
+6 SET ^TMP($JOB,"RA DISCLAIMER",2,1)="2. Only procedures for which dose data has been received are listed. Data may"
+7 SET ^TMP($JOB,"RA DISCLAIMER",2,2)=" be missing if the modality does not support DICOM structured dose reporting,"
+8 SET ^TMP($JOB,"RA DISCLAIMER",2,3)=" if the dose report was not sent to VistA Imaging, if the radiology report was"
+9 SET ^TMP($JOB,"RA DISCLAIMER",2,4)=" was not verified, or if the procedure was performed/imported before patches"
+10 SET ^TMP($JOB,"RA DISCLAIMER",2,5)=" MAG*3*137 and RA*5*113 were installed."
+11 ;(2,6)=""
+12 SET ^TMP($JOB,"RA DISCLAIMER",3,1)="3. Only the five highest dose CT series are listed. The total dose refers"
+13 SET ^TMP($JOB,"RA DISCLAIMER",3,2)=" to the sum of all series and so may be larger than the sum of the five"
+14 SET ^TMP($JOB,"RA DISCLAIMER",3,3)=" displayed doses. This report may include CT localizer radiograph(s)"
+15 SET ^TMP($JOB,"RA DISCLAIMER",3,4)=" values as a series and/or included in the total depending on the CT"
+16 SET ^TMP($JOB,"RA DISCLAIMER",3,5)=" manufacturer."
+17 ;(3,6)=""
+18 SET ^TMP($JOB,"RA DISCLAIMER",4,1)="4. Radiology set workflow may show the total rad dose for a patient care event"
+19 SET ^TMP($JOB,"RA DISCLAIMER",4,2)=" under one CPT. If separate exposure instances during a CT examination were"
+20 SET ^TMP($JOB,"RA DISCLAIMER",4,3)=" of different body parts, the total CTDIvol stated here may exceed the actual"
+21 SET ^TMP($JOB,"RA DISCLAIMER",4,4)=" CTDIvol for any body part. More detailed dose information is available on the"
+22 SET ^TMP($JOB,"RA DISCLAIMER",4,5)=" modality (until it is deleted) or in the DICOM Radiation Dose Structured"
+23 SET ^TMP($JOB,"RA DISCLAIMER",4,6)=" Report (RDSR) file stored in VistA Imaging. Viewing the RDSR file is not yet"
+24 SET ^TMP($JOB,"RA DISCLAIMER",4,7)=" supported."
+25 ;(4,8)=""
+26 SET ^TMP($JOB,"RA DISCLAIMER",5,1)="5. Radiology set workflow may show the total rad dose for a patient care event"
+27 SET ^TMP($JOB,"RA DISCLAIMER",5,2)=" under one CPT. Air Kerma Area Product is also called the Dose Area Product."
+28 SET ^TMP($JOB,"RA DISCLAIMER",5,3)=" If fluoroscopy was performed using more than one projection, the total air"
+29 SET ^TMP($JOB,"RA DISCLAIMER",5,4)=" kerma stated here may exceed the air kerma to any single projection. More"
+30 SET ^TMP($JOB,"RA DISCLAIMER",5,5)=" detailed dose information is available on the modality (until it is deleted)"
+31 SET ^TMP($JOB,"RA DISCLAIMER",5,6)=" or in the DICOM Radiation Dose Structured Report (RDSR) file stored in VistA"
+32 SET ^TMP($JOB,"RA DISCLAIMER",5,7)=" Imaging. Viewing the RDSR file is not yet supported."
+33 QUIT
+34 ;
