RADRPT1A ;HISC/GJC Radiation dosage report utility one A ;01 Aug 2017 1:26 PM
;;5.0;Radiology/Nuclear Medicine;**113,119**;Mar 16, 1998;Build 7
;
;--- IAs ---
;Call/File Number Type
;------------------------------------------------
;$$SS^%ZTLOAD 10063 S
;$$GET1^DIQ 2056 S
;GETS^DIQ 2056 S
;$$FMTE^XLFDT 10103 S
;$$NOW^XLFDT 10103 S
;$$CJ^XLFSTR 10104 S
;^DPT( 10035 S
;^VA(200, 10060 S
;where 'S'=Supported; 'C'=Controlled Subscription; 'P'=Private
;
EN ;entry point
; variables saved
;----------------
; ^TMP($J,"RAEX",n)=IEN 70.3 ^ RADFN ^ Exam Date ^ inv. Exam Date (IEN 70.02)
; ^ Case Number ^ IEN EXAMINATIONS (70.03) ^ Report (if none null)
S (RAI,RAP,RAQUIT)=0
S RANODT=$$FMTE^XLFDT($$NOW^XLFDT(),"1M")
S RATITLE=$$CJ^XLFSTR("Patient Profile With Radiation Dose Data",IOM)
;RAX = field numbers returned 70.03 level
S RAX=".01:4;6:8;9;9.5;12:16;19;125*" ;*** see DD map of 70.03 ***
S $P(RABORDR,"=",(IOM+1))="",$P(RALINE,"-",(IOM+1))=""
S RATAB(1)=2,RATAB(2)=14,RATAB(3)=38,RATAB(4)=49
S RATAB(5)=16,RATAB(6)=38,RATAB(7)=51
;
K RAZDFN D GETS^DIQ(2,RADFN_",",".01;.09","E","RAZDFN")
S RA("NAME")=$E(RAZDFN(2,RADFN_",",".01","E"),1,30)
S X=RAZDFN(2,RADFN_",",".09","E"),RA("PID")=X
;RA("PID") is the full SSN just like VA("PID")
S X1=$E(X,($L(X)-3),$L(X))
;RA("BID") is the last four of the SSN just like VA("BID")
S RA("BID")=X1 K RAZDFN,X,X1
;
K ^TMP($J,"RA DISCLAIMER") D DISCLAIM^RADRPT2A
;
F S RAI=$O(^TMP($J,"RAEX",RAI)) Q:'RAI D Q:RAQUIT
.S Y=$G(^TMP($J,"RAEX",RAI))
.F I=1:1:7 S @$P("RARAD^RADFN^RADTE^RADTI^RACN^RACNI^RARPT","^",I)=$P(Y,"^",I)
.;RARAD = IEN file 70.3; RARPT = IEN of the report for this study
.S RAY2=$G(^RADPT(RADFN,"DT",RADTI,0)) Q:RAY2=""
.S RAY3=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) Q:RAY3=""
.S RAORD(0)=$G(^RAO(75.1,+$P(RAY3,U,11),0))
.;fluoro data on 0 node
.S RARAD(0)=$G(^RAD(RARAD,0)) Q:RARAD(0)=""
.S RAIEN=RADTI_","_RADFN_"," K RAY2A,RAY3A
.D GETS^DIQ(70.02,RAIEN,".01:4","E","RAY2A")
.S RAIENS=RACNI_","_RADTI_","_RADFN_","
.D GETS^DIQ(70.03,RAIENS,RAX,"E","RAY3A")
.S RA("RACN")=$$CN() ; case # accession #
.;
.;--- header for first page only ---
.S RAPG=1 W @IOF,!,RATITLE
.W !,"Date: ",RANODT,?69,"Page: ",RAPG
.W !,RABORDR
.;
.;--- name and SSN (last four) ---
.W !?RATAB(1),"Name",?RATAB(2),": ",RA("NAME")," ",RA("BID")
.;
.W !?RATAB(1),"Division",?RATAB(2),": ",$E(RAY2A(70.02,RAIEN,"3","E"),1,21)
.W ?RATAB(3),"Category",?RATAB(4),": ",$E(RAY3A(70.03,RAIENS,"4","E"),1,27)
.W !?RATAB(1),"Location",?RATAB(2),": ",$E(RAY2A(70.02,RAIEN,"4","E"),1,21)
.W ?RATAB(3),"Ward",?RATAB(4),": ",$E(RAY3A(70.03,RAIENS,"6","E"),1,27)
.W !?RATAB(1),"Exam Date",?RATAB(2),": ",$E(RAY2A(70.02,RAIEN,".01","E"),1,21)
.W ?RATAB(3),"Service",?RATAB(4),": ",$E(RAY3A(70.03,RAIENS,"7","E"),1,27)
.W !?RATAB(1),"Case No.",?RATAB(2),": ",$$CN() ;16 digits max
.W ?RATAB(3),"Bedsection",?RATAB(4),": ",$E(RAY3A(70.03,RAIENS,"19","E"),1,27)
.W !?RATAB(3),"Clinic",?RATAB(4),": ",$E(RAY3A(70.03,RAIENS,"8","E"),1,27)
.W:$E(RAY3A(70.03,RAIENS,"4","E"),1)="C" !?RATAB(3),"Contract",?RATAB(4),": ",$E(RAY3A(70.03,RAIENS,"9","E"),1,27)
.W:$E(RAY3A(70.03,RAIENS,"4","E"),1)="S" !?RATAB(3),"Sharing",?RATAB(4),": ",$E(RAY3A(70.03,RAIENS,"9","E"),1,27)
.W:$E(RAY3A(70.03,RAIENS,"4","E"),1)="R" !?RATAB(3),"Research",?RATAB(4),": ",$E(RAY3A(70.03,RAIENS,"9.5","E"),1,27)
.W !,RALINE ;spacer
.S RAOPRC=$$GET1^DIQ(71,+$P(RAORD(0),U,2)_",",.01) ;name of ordered proc.
.S RAPRC=$$GET1^DIQ(71,+$P(RAY3,U,2)_",",.01) ;name of registered proc.
.W !?RATAB(1),"Registered",?RATAB(2),": ",$E(RAPRC,1,30),?RATAB(4),$$PRC(+$P(RAY3,U,2))
.W:RAPRC'=RAOPRC !?RATAB(1),"Requested",?RATAB(2),": ",$E(RAOPRC,1,60)
.S RA("PHYS")=$$GET1^DIQ(200,+$P(RAY3,U,14)_",",.01) ;name of requesting physician
.S RA("EXS")=$P($G(^RA(72,+$P(RAY3,U,3),0)),U) ;exam status
.S RA("PIR")=$$GET1^DIQ(200,+$P(RAY3,U,12)_",",.01) ;name of primary interpreting resident
.I $P(RAY3,U,17)>0 D
..S RA("RPT")=$$GET1^DIQ(74,+$P(RAY3,U,17)_",",5)
..S RA("RPT")=$S($G(RA("RPT"))'="":RA("RPT"),1:"No Report")
..S RA("PREVFIER")=+$P($G(^RARPT(+$P(RAY3,U,17),0)),U,13) ;13th piece fld #15
..S RA("PREVFIER")=$$GET1^DIQ(200,+RA("PREVFIER")_",",.01) ;name of requesting physician
..S RA("PREVFIED")=$S(RA("PREVFIER")'="":RA("PREVFIER"),1:"No") K RA("PREVFIER")
..Q
.S RA("CAM")=$S(+$P(RAY3,U,18)>0:$P($G(^RA(78.6,+$P(RAY3,U,18),0)),U),1:"") ;cam/eq/rm
.S RA("PIS")=$$GET1^DIQ(200,+$P(RAY3,U,15)_",",.01) ;name of primary interpreting staff
.S RA("DX")=$S(+$P(RAY3,U,13)>0:$P($G(^RA(78.3,+$P(RAY3,U,13),0)),U),1:"")
.S RA("TECH")=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0))
.I RA("TECH") D
..S RA("T")=+$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",RA("TECH"),0)),U)
..S RA("TECH")=$$GET1^DIQ(200,RA("T")_",",.01) ;name of technologist
..K RA("T")
..QUIT
.S RA("CMP")=$E(RAY3A(70.03,RAIENS,"16","E"),1,27)
.W !?RATAB(1),"Requesting Phy",?RATAB(5),": ",$E(RA("PHYS"),1,18)
.W ?RATAB(6),"Exam Status",?RATAB(7),": ",$E(RA("EXS"),1,27)
.W !?RATAB(1),"Int'g Resident",?RATAB(5),": ",$E(RA("PIR"),1,18)
.W ?RATAB(6),"Report Status",?RATAB(7),": ",$E($G(RA("RPT")),1,27)
.W !?RATAB(1),"Pre-Verified",?RATAB(5),": ",$E($G(RA("PREVFIED")),1,18)
.W ?RATAB(6),"Cam/Equip/Rm",?RATAB(7),": ",$E(RA("CAM"),1,27)
.W !?RATAB(1),"Int'g Staff",?RATAB(5),": ",$E(RA("PIS"),1,18)
.W ?RATAB(6),"Diagnosis",?RATAB(7),": ",$E(RA("DX"),1,27)
.W !?RATAB(1),"Technologist",?RATAB(5),": ",$E($G(RA("TECH")),1,18)
.W ?RATAB(6),"Complication",?RATAB(7),": ",$E(RA("CMP"),1,27)
.I $P(RAORD(0),U,13)'="" W !?RATAB(1),"Pregnant at time of order entry: "_$$GET1^DIQ(75.1,+$P(RAY3,U,11)_",",13)
.;
.;--------- get procedure modifiers/CPT Modifiers ---------------
.S RALBL="Modifiers",RAHDR=$$CJ^XLFSTR(RALBL,IOM,"-")
.W !,RAHDR,!?RATAB(1),RALBL,?RATAB(5),": "
.I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",0)) D K RAL,RAS
..S RAL=$O(RAY3A("70.1",$C(126)),-1)
..S RAS="" F S RAS=$O(RAY3A("70.1",RAS)) Q:RAS="" D Q:RAQUIT
...I $Y>(IOSL-4) D HDR Q:RAQUIT
...W ?18,$E($G(RAY3A("70.1",RAS,.01,"E")),1,30)
...W:RAL'=RAS ! ;more data
...Q
..Q
.E W "None"
.Q:RAQUIT
.S RALBL="CPT Modifiers" W !?RATAB(1),RALBL,?RATAB(5),": "
.I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",0)) D K RACPT,RAL,RALBL,RAS,RAX99,Y
..;EX: - RACPT("70.3135","1,1,6889176.8884,76,",".01","I")=4
..D GETS^DIQ(70.03,RAIENS,"135*","I","RACPT")
..S RAL=$O(RACPT("70.3135",$C(126)),-1)
..S RAS="" F S RAS=$O(RACPT("70.3135",RAS)) Q:RAS="" D Q:RAQUIT
...I $Y>(IOSL-4) D HDR Q:RAQUIT
...;EX - RAX99="4^23^UNUSUAL ANESTHESIA^09923^C^2930101^1^^2930101^"
...S Y=$G(RACPT("70.3135",RAS,.01,"I")),RAX99=""
...S:Y RAX99=$$BASICMOD^RACPTMSC(Y,RADTE)
...W ?18,$P(RAX99,U,2)," ",$P(RAX99,U,3)
...W:RAL'=RAS !
...Q
..Q
.E W "None"
.Q:RAQUIT
.;
.;-------------------- get Contrast Media --------------------------
.I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",0)) D K RACM,RAL,RALBL,RAS
..S RALBL="Contrast Media",RAHDR=$$CJ^XLFSTR(RALBL,IOM,"-")
..W !,RAHDR,!?RATAB(1),RALBL,?RATAB(5),": "
..D GETS^DIQ(70.03,RAIENS,"225*","E","RACM")
..S RAL=$O(RACM("70.3225",$C(126)),-1)
..S RAS="" F S RAS=$O(RACM("70.3225",RAS)) Q:RAS="" D Q:RAQUIT
...I $Y>(IOSL-4) D HDR Q:RAQUIT
...W ?18,$E($G(RACM("70.3225",RAS,.01,"E")),1,30)
...W:RAL'=RAS ! ;more data
...Q
..Q
.Q:RAQUIT
.;
.;----------------------- get Medications ------------------------------
.I $O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0)) D K RAS,RAMED
..S RAHDR=$$CJ^XLFSTR("Medications",IOM,"-") W !,RAHDR
..K RAMED D GETS^DIQ(70.03,RAIENS,"200*","E","RAMED")
..S RAL=$O(RAMED("70.15",$C(126)),-1)
..S RAS="" F S RAS=$O(RAMED("70.15",RAS)) Q:RAS="" D Q:RAQUIT
...I $Y>(IOSL-4) D HDR Q:RAQUIT
...W !?RATAB(1),"Med: ",$E($G(RAMED("70.15",RAS,.01,"E")),1,28)
...W ?RATAB(3),"Dose Adm'd: ",$E($G(RAMED("70.15",RAS,2,"E")),1,25)
...W !?RATAB(1),"Adm'd by: ",$E($G(RAMED("70.15",RAS,3,"E")),1,24)
...W ?RATAB(3),"Date Adm'd: ",$E($G(RAMED("70.15",RAS,4,"E")),1,20)
...W:RAS'=RAL ! ;more data
...Q
..Q
.Q:RAQUIT
.;
.;----------------------- get Radiopharms ------------------------------
.I $P(RAY3,U,28)>0 D K RADA,RADIO,RAS,RAU
..;#500 NUCLEAR MED DATA
..S RADA=$P(RAY3,U,28)_",",RAHDR=$$CJ^XLFSTR("Radiopharmaceuticals",IOM,"-")
..W !,RAHDR K RADIO S RAS=""
..D GETS^DIQ(70.2,RADA_",","100*","E","RADIO")
..S RAL=$O(RADIO("70.21",$C(126)),-1)
..F S RAS=$O(RADIO("70.21",RAS)) Q:RAS="" D Q:RAQUIT
...I $Y>(IOSL-4) D HDR Q:RAQUIT
...S RAU=0 F S RAU=$O(RADIO("70.21",RAS,RAU)) Q:RAU'>0 D Q:RAQUIT
....I $Y>(IOSL-4) D HDR Q:RAQUIT
....S RAU(0)=$$TRN1^RAPROD2(RAU)_$G(RADIO("70.21",RAS,RAU,"E"))
....S RAU(0)=RAU(0)_$S(RAU=2:" mCi",RAU=4:" mCi",RAU=7:" mCi",1:"")
....W !?RATAB(1),$E(RAU(0),1,28)
....S RAU=$O(RADIO("70.21",RAS,RAU))
....S:RAU'>0 RAU=$C(32) Q:RAU=$C(32)
....S RAU(1)=$$TRN1^RAPROD2(RAU)_$G(RADIO("70.21",RAS,RAU,"E"))
....S RAU(1)=RAU(1)_$S(RAU=2:" mCi",RAU=4:" mCi",RAU=7:" mCi",1:"")
....W ?RATAB(4),$E(RAU(1),1,27)
....Q
...W:RAS'=RAL ! ;more data
...Q
..Q
.Q:RAQUIT
.;
.;----------------------- get Rad Dose (fluoro) --------------------
.I $P(RARAD(0),U,5)'=""!($P(RARAD(0),U,6)'="") D ;air kerma OR air kerma area product
..S RAHDR=$$CJ^XLFSTR("Rad Dose",IOM,"-"),RAZFL=""
..S RACOL(1)="Air Kerma (mGy)"
..S RACOL(2)="Air Kerma Area Product (Gy-cm2)"
..S RACOL(3)="Fluoro Time (min)" ;note: data is in seconds
..W !,RAHDR
..I $Y>(IOSL-4) D HDR Q:RAQUIT
..W !?RATAB(1),RACOL(1),?24,RACOL(2),?60,RACOL(3)
..S $P(XRA,"-",($L(RACOL(1))+1))="" W !?RATAB(1),XRA
..K XRA S $P(XRA,"-",($L(RACOL(2))+1))="" W ?24,XRA
..K XRA S $P(XRA,"-",($L(RACOL(3))+1))="" W ?60,XRA
..W !?RATAB(1),$J($P(RARAD(0),U,5),8,2),?24,$J(+$P(RARAD(0),U,6),8,2)
..W ?60,$J(($P(RARAD(0),U,7))/60,1,1) ;to mins to tenths
..K RACOL,XRA
..Q
.Q:RAQUIT
.;
.;----------------------- get Rad Dose (CT SCAN) -------------------
.I $O(^RAD(RARAD,"II",0)) S RAZCT="" D CT^RADRPT1 ;if CT Scan data
.Q:RAQUIT
.S RAP=RAP+1
.I $D(ZTQUEUED) S:RAP#500=0 (RAQUIT,ZTSTOP)=$$S^%ZTLOAD()
.; --- disclaimer ---
.K RALBL D HDR Q:RAQUIT
.F RAII=1:1:5 D Q:RAQUIT
..I ($D(RAZFL)#2)=1,(($D(RAZCT)#2)=0) Q:RAII=3!(RAII=4)
..I ($D(RAZFL)#2)=0,(($D(RAZCT)#2)=1) Q:RAII=5
..S RAYY=0
..F S RAYY=$O(^TMP($J,"RA DISCLAIMER",RAII,RAYY)) Q:RAYY'>0 D Q:RAQUIT
...I $Y>(IOSL-4) D HDR Q:RAQUIT
...W !,$G(^TMP($J,"RA DISCLAIMER",RAII,RAYY))
...Q
..Q
.S DX=0,DY=IOSL X ^%ZOSF("XY")
.K DX,DY,RAIEN,RAIENS,RAII,RAY2A,RAY3A,RAYY,RAZCT,RAZFL,RTFL,Y,Z
.Q
D XIT
Q
;
CN() ;return case # in the form of the accession # (SSAN aware)
N X S X=$P(RAY3,U,31) ;SITE ACCESSION NUMBER (SSAN)
S:X="" X=$E(RADTE,4,5)_$E(RADTE,6,7)_$E(RADTE,2,3)_"-"_$P(RAY3,U)
Q X
;
HDR ;header/end of screen logic
;RAHDR: is dynamic; its value is based on the section
;HDR^RADRPT1A is called from.
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
S RAPG=RAPG+1 W @IOF,!,RATITLE
W !,"Date: ",RANODT,?69,"Page: ",RAPG
W !,RABORDR
W !?RATAB(1),"Name: ",$E(RA("NAME"),1,27)_" "_RA("BID")
W ?RATAB(4),"Exam Date: ",$E(RAY2A(70.02,RAIEN,".01","E"),1,21)
W !?RATAB(1),"Procedure: ",$E(RAPRC,1,30)
W ?RATAB(4),"Case Number: ",RA("RACN")
W !,RAHDR W:$D(RALBL)#2 !?RATAB(1),RALBL,": "
Q
;
XIT ;kill variables set ZTREQ then exit
K %,%H,%I,N,RA,RABORDR,RACN,RACNI,RADA,RADFN,RADTE,RADPT,RADTI,RAHDR
K RAI,RAIEN,RAIENS,RAL,RALBL,RALINE,RAM,RAMED,RANODT,RAOPRC,RAORD,RAP,RAPG
K RAPRC,RAQUIT,RARAD,RARPT,RARX,RAS,RATAB,RATITLE,RAU,RAX,RAY,RAY2,RAY2A
K RAY3,RAY3A,RAZCT,RAZFL
K ^TMP($J,"RAEX"),^TMP($J,"RA DISCLAIMER")
S:$D(ZTQUEUED) ZTREQ="@"
Q
;
PRC(Y) ;print procedure data (file #71)
;Input: Y = IEN file 71
;Output: imaging type abbreviation - procdure type or inactive - CPT code
; (if not a Parent or Broad procedure)
;ex: (NM Parent)
; (MAM Inactive) Note: may be broad or parent type
; (CT Inactive) CPT:76361
; (VAS Detailed) CPT:93619
N X
S X(0)=$G(^RAMIS(71,Y,0)),X("I")=$G(^RAMIS(71,Y,"I"))
S X("IN")=$S(X("I")="":0,DT'>X("I"):0,1:1)
S X=$P(X(0),U,6),X("CPT")=""
S X("PT")=$S(X="B":"Broad",X="D":"Detailed",X="P":"Parent",X="S":"Series",1:"Unknown")
S X=+$P(X(0),U,12) S X("IT")=$S(X=0:"Unknown",1:$P(^RA(79.2,X,0),U,3)) ;required identifier
I $E(X("PT"),1)'="B",$E(X("PT"),1)'="P" S X("CPT")="CPT:"_$P($$NAMCODE^RACPTMSC(+$P(X(0),U,9),DT),U)
S X="("_X("IT")_" "_$S(X("IN"):"Inactive",1:X("PT"))_") "_X("CPT")
Q X
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRADRPT1A 12933 printed Sep 23, 2025@20:10:52 Page 2
RADRPT1A ;HISC/GJC Radiation dosage report utility one A ;01 Aug 2017 1:26 PM
+1 ;;5.0;Radiology/Nuclear Medicine;**113,119**;Mar 16, 1998;Build 7
+2 ;
+3 ;--- IAs ---
+4 ;Call/File Number Type
+5 ;------------------------------------------------
+6 ;$$SS^%ZTLOAD 10063 S
+7 ;$$GET1^DIQ 2056 S
+8 ;GETS^DIQ 2056 S
+9 ;$$FMTE^XLFDT 10103 S
+10 ;$$NOW^XLFDT 10103 S
+11 ;$$CJ^XLFSTR 10104 S
+12 ;^DPT( 10035 S
+13 ;^VA(200, 10060 S
+14 ;where 'S'=Supported; 'C'=Controlled Subscription; 'P'=Private
+15 ;
EN ;entry point
+1 ; variables saved
+2 ;----------------
+3 ; ^TMP($J,"RAEX",n)=IEN 70.3 ^ RADFN ^ Exam Date ^ inv. Exam Date (IEN 70.02)
+4 ; ^ Case Number ^ IEN EXAMINATIONS (70.03) ^ Report (if none null)
+5 SET (RAI,RAP,RAQUIT)=0
+6 SET RANODT=$$FMTE^XLFDT($$NOW^XLFDT(),"1M")
+7 SET RATITLE=$$CJ^XLFSTR("Patient Profile With Radiation Dose Data",IOM)
+8 ;RAX = field numbers returned 70.03 level
+9 ;*** see DD map of 70.03 ***
SET RAX=".01:4;6:8;9;9.5;12:16;19;125*"
+10 SET $PIECE(RABORDR,"=",(IOM+1))=""
SET $PIECE(RALINE,"-",(IOM+1))=""
+11 SET RATAB(1)=2
SET RATAB(2)=14
SET RATAB(3)=38
SET RATAB(4)=49
+12 SET RATAB(5)=16
SET RATAB(6)=38
SET RATAB(7)=51
+13 ;
+14 KILL RAZDFN
DO GETS^DIQ(2,RADFN_",",".01;.09","E","RAZDFN")
+15 SET RA("NAME")=$EXTRACT(RAZDFN(2,RADFN_",",".01","E"),1,30)
+16 SET X=RAZDFN(2,RADFN_",",".09","E")
SET RA("PID")=X
+17 ;RA("PID") is the full SSN just like VA("PID")
+18 SET X1=$EXTRACT(X,($LENGTH(X)-3),$LENGTH(X))
+19 ;RA("BID") is the last four of the SSN just like VA("BID")
+20 SET RA("BID")=X1
KILL RAZDFN,X,X1
+21 ;
+22 KILL ^TMP($JOB,"RA DISCLAIMER")
DO DISCLAIM^RADRPT2A
+23 ;
+24 FOR
SET RAI=$ORDER(^TMP($JOB,"RAEX",RAI))
if 'RAI
QUIT
Begin DoDot:1
+25 SET Y=$GET(^TMP($JOB,"RAEX",RAI))
+26 FOR I=1:1:7
SET @$PIECE("RARAD^RADFN^RADTE^RADTI^RACN^RACNI^RARPT","^",I)=$PIECE(Y,"^",I)
+27 ;RARAD = IEN file 70.3; RARPT = IEN of the report for this study
+28 SET RAY2=$GET(^RADPT(RADFN,"DT",RADTI,0))
if RAY2=""
QUIT
+29 SET RAY3=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
if RAY3=""
QUIT
+30 SET RAORD(0)=$GET(^RAO(75.1,+$PIECE(RAY3,U,11),0))
+31 ;fluoro data on 0 node
+32 SET RARAD(0)=$GET(^RAD(RARAD,0))
if RARAD(0)=""
QUIT
+33 SET RAIEN=RADTI_","_RADFN_","
KILL RAY2A,RAY3A
+34 DO GETS^DIQ(70.02,RAIEN,".01:4","E","RAY2A")
+35 SET RAIENS=RACNI_","_RADTI_","_RADFN_","
+36 DO GETS^DIQ(70.03,RAIENS,RAX,"E","RAY3A")
+37 ; case # accession #
SET RA("RACN")=$$CN()
+38 ;
+39 ;--- header for first page only ---
+40 SET RAPG=1
WRITE @IOF,!,RATITLE
+41 WRITE !,"Date: ",RANODT,?69,"Page: ",RAPG
+42 WRITE !,RABORDR
+43 ;
+44 ;--- name and SSN (last four) ---
+45 WRITE !?RATAB(1),"Name",?RATAB(2),": ",RA("NAME")," ",RA("BID")
+46 ;
+47 WRITE !?RATAB(1),"Division",?RATAB(2),": ",$EXTRACT(RAY2A(70.02,RAIEN,"3","E"),1,21)
+48 WRITE ?RATAB(3),"Category",?RATAB(4),": ",$EXTRACT(RAY3A(70.03,RAIENS,"4","E"),1,27)
+49 WRITE !?RATAB(1),"Location",?RATAB(2),": ",$EXTRACT(RAY2A(70.02,RAIEN,"4","E"),1,21)
+50 WRITE ?RATAB(3),"Ward",?RATAB(4),": ",$EXTRACT(RAY3A(70.03,RAIENS,"6","E"),1,27)
+51 WRITE !?RATAB(1),"Exam Date",?RATAB(2),": ",$EXTRACT(RAY2A(70.02,RAIEN,".01","E"),1,21)
+52 WRITE ?RATAB(3),"Service",?RATAB(4),": ",$EXTRACT(RAY3A(70.03,RAIENS,"7","E"),1,27)
+53 ;16 digits max
WRITE !?RATAB(1),"Case No.",?RATAB(2),": ",$$CN()
+54 WRITE ?RATAB(3),"Bedsection",?RATAB(4),": ",$EXTRACT(RAY3A(70.03,RAIENS,"19","E"),1,27)
+55 WRITE !?RATAB(3),"Clinic",?RATAB(4),": ",$EXTRACT(RAY3A(70.03,RAIENS,"8","E"),1,27)
+56 if $EXTRACT(RAY3A(70.03,RAIENS,"4","E"),1)="C"
WRITE !?RATAB(3),"Contract",?RATAB(4),": ",$EXTRACT(RAY3A(70.03,RAIENS,"9","E"),1,27)
+57 if $EXTRACT(RAY3A(70.03,RAIENS,"4","E"),1)="S"
WRITE !?RATAB(3),"Sharing",?RATAB(4),": ",$EXTRACT(RAY3A(70.03,RAIENS,"9","E"),1,27)
+58 if $EXTRACT(RAY3A(70.03,RAIENS,"4","E"),1)="R"
WRITE !?RATAB(3),"Research",?RATAB(4),": ",$EXTRACT(RAY3A(70.03,RAIENS,"9.5","E"),1,27)
+59 ;spacer
WRITE !,RALINE
+60 ;name of ordered proc.
SET RAOPRC=$$GET1^DIQ(71,+$PIECE(RAORD(0),U,2)_",",.01)
+61 ;name of registered proc.
SET RAPRC=$$GET1^DIQ(71,+$PIECE(RAY3,U,2)_",",.01)
+62 WRITE !?RATAB(1),"Registered",?RATAB(2),": ",$EXTRACT(RAPRC,1,30),?RATAB(4),$$PRC(+$PIECE(RAY3,U,2))
+63 if RAPRC'=RAOPRC
WRITE !?RATAB(1),"Requested",?RATAB(2),": ",$EXTRACT(RAOPRC,1,60)
+64 ;name of requesting physician
SET RA("PHYS")=$$GET1^DIQ(200,+$PIECE(RAY3,U,14)_",",.01)
+65 ;exam status
SET RA("EXS")=$PIECE($GET(^RA(72,+$PIECE(RAY3,U,3),0)),U)
+66 ;name of primary interpreting resident
SET RA("PIR")=$$GET1^DIQ(200,+$PIECE(RAY3,U,12)_",",.01)
+67 IF $PIECE(RAY3,U,17)>0
Begin DoDot:2
+68 SET RA("RPT")=$$GET1^DIQ(74,+$PIECE(RAY3,U,17)_",",5)
+69 SET RA("RPT")=$SELECT($GET(RA("RPT"))'="":RA("RPT"),1:"No Report")
+70 ;13th piece fld #15
SET RA("PREVFIER")=+$PIECE($GET(^RARPT(+$PIECE(RAY3,U,17),0)),U,13)
+71 ;name of requesting physician
SET RA("PREVFIER")=$$GET1^DIQ(200,+RA("PREVFIER")_",",.01)
+72 SET RA("PREVFIED")=$SELECT(RA("PREVFIER")'="":RA("PREVFIER"),1:"No")
KILL RA("PREVFIER")
+73 QUIT
End DoDot:2
+74 ;cam/eq/rm
SET RA("CAM")=$SELECT(+$PIECE(RAY3,U,18)>0:$PIECE($GET(^RA(78.6,+$PIECE(RAY3,U,18),0)),U),1:"")
+75 ;name of primary interpreting staff
SET RA("PIS")=$$GET1^DIQ(200,+$PIECE(RAY3,U,15)_",",.01)
+76 SET RA("DX")=$SELECT(+$PIECE(RAY3,U,13)>0:$PIECE($GET(^RA(78.3,+$PIECE(RAY3,U,13),0)),U),1:"")
+77 SET RA("TECH")=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",0))
+78 IF RA("TECH")
Begin DoDot:2
+79 SET RA("T")=+$PIECE($GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"TC",RA("TECH"),0)),U)
+80 ;name of technologist
SET RA("TECH")=$$GET1^DIQ(200,RA("T")_",",.01)
+81 KILL RA("T")
+82 QUIT
End DoDot:2
+83 SET RA("CMP")=$EXTRACT(RAY3A(70.03,RAIENS,"16","E"),1,27)
+84 WRITE !?RATAB(1),"Requesting Phy",?RATAB(5),": ",$EXTRACT(RA("PHYS"),1,18)
+85 WRITE ?RATAB(6),"Exam Status",?RATAB(7),": ",$EXTRACT(RA("EXS"),1,27)
+86 WRITE !?RATAB(1),"Int'g Resident",?RATAB(5),": ",$EXTRACT(RA("PIR"),1,18)
+87 WRITE ?RATAB(6),"Report Status",?RATAB(7),": ",$EXTRACT($GET(RA("RPT")),1,27)
+88 WRITE !?RATAB(1),"Pre-Verified",?RATAB(5),": ",$EXTRACT($GET(RA("PREVFIED")),1,18)
+89 WRITE ?RATAB(6),"Cam/Equip/Rm",?RATAB(7),": ",$EXTRACT(RA("CAM"),1,27)
+90 WRITE !?RATAB(1),"Int'g Staff",?RATAB(5),": ",$EXTRACT(RA("PIS"),1,18)
+91 WRITE ?RATAB(6),"Diagnosis",?RATAB(7),": ",$EXTRACT(RA("DX"),1,27)
+92 WRITE !?RATAB(1),"Technologist",?RATAB(5),": ",$EXTRACT($GET(RA("TECH")),1,18)
+93 WRITE ?RATAB(6),"Complication",?RATAB(7),": ",$EXTRACT(RA("CMP"),1,27)
+94 IF $PIECE(RAORD(0),U,13)'=""
WRITE !?RATAB(1),"Pregnant at time of order entry: "_$$GET1^DIQ(75.1,+$PIECE(RAY3,U,11)_",",13)
+95 ;
+96 ;--------- get procedure modifiers/CPT Modifiers ---------------
+97 SET RALBL="Modifiers"
SET RAHDR=$$CJ^XLFSTR(RALBL,IOM,"-")
+98 WRITE !,RAHDR,!?RATAB(1),RALBL,?RATAB(5),": "
+99 IF $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"M",0))
Begin DoDot:2
+100 SET RAL=$ORDER(RAY3A("70.1",$CHAR(126)),-1)
+101 SET RAS=""
FOR
SET RAS=$ORDER(RAY3A("70.1",RAS))
if RAS=""
QUIT
Begin DoDot:3
+102 IF $Y>(IOSL-4)
DO HDR
if RAQUIT
QUIT
+103 WRITE ?18,$EXTRACT($GET(RAY3A("70.1",RAS,.01,"E")),1,30)
+104 ;more data
if RAL'=RAS
WRITE !
+105 QUIT
End DoDot:3
if RAQUIT
QUIT
+106 QUIT
End DoDot:2
KILL RAL,RAS
+107 IF '$TEST
WRITE "None"
+108 if RAQUIT
QUIT
+109 SET RALBL="CPT Modifiers"
WRITE !?RATAB(1),RALBL,?RATAB(5),": "
+110 IF $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",0))
Begin DoDot:2
+111 ;EX: - RACPT("70.3135","1,1,6889176.8884,76,",".01","I")=4
+112 DO GETS^DIQ(70.03,RAIENS,"135*","I","RACPT")
+113 SET RAL=$ORDER(RACPT("70.3135",$CHAR(126)),-1)
+114 SET RAS=""
FOR
SET RAS=$ORDER(RACPT("70.3135",RAS))
if RAS=""
QUIT
Begin DoDot:3
+115 IF $Y>(IOSL-4)
DO HDR
if RAQUIT
QUIT
+116 ;EX - RAX99="4^23^UNUSUAL ANESTHESIA^09923^C^2930101^1^^2930101^"
+117 SET Y=$GET(RACPT("70.3135",RAS,.01,"I"))
SET RAX99=""
+118 if Y
SET RAX99=$$BASICMOD^RACPTMSC(Y,RADTE)
+119 WRITE ?18,$PIECE(RAX99,U,2)," ",$PIECE(RAX99,U,3)
+120 if RAL'=RAS
WRITE !
+121 QUIT
End DoDot:3
if RAQUIT
QUIT
+122 QUIT
End DoDot:2
KILL RACPT,RAL,RALBL,RAS,RAX99,Y
+123 IF '$TEST
WRITE "None"
+124 if RAQUIT
QUIT
+125 ;
+126 ;-------------------- get Contrast Media --------------------------
+127 IF $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",0))
Begin DoDot:2
+128 SET RALBL="Contrast Media"
SET RAHDR=$$CJ^XLFSTR(RALBL,IOM,"-")
+129 WRITE !,RAHDR,!?RATAB(1),RALBL,?RATAB(5),": "
+130 DO GETS^DIQ(70.03,RAIENS,"225*","E","RACM")
+131 SET RAL=$ORDER(RACM("70.3225",$CHAR(126)),-1)
+132 SET RAS=""
FOR
SET RAS=$ORDER(RACM("70.3225",RAS))
if RAS=""
QUIT
Begin DoDot:3
+133 IF $Y>(IOSL-4)
DO HDR
if RAQUIT
QUIT
+134 WRITE ?18,$EXTRACT($GET(RACM("70.3225",RAS,.01,"E")),1,30)
+135 ;more data
if RAL'=RAS
WRITE !
+136 QUIT
End DoDot:3
if RAQUIT
QUIT
+137 QUIT
End DoDot:2
KILL RACM,RAL,RALBL,RAS
+138 if RAQUIT
QUIT
+139 ;
+140 ;----------------------- get Medications ------------------------------
+141 IF $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"RX",0))
Begin DoDot:2
+142 SET RAHDR=$$CJ^XLFSTR("Medications",IOM,"-")
WRITE !,RAHDR
+143 KILL RAMED
DO GETS^DIQ(70.03,RAIENS,"200*","E","RAMED")
+144 SET RAL=$ORDER(RAMED("70.15",$CHAR(126)),-1)
+145 SET RAS=""
FOR
SET RAS=$ORDER(RAMED("70.15",RAS))
if RAS=""
QUIT
Begin DoDot:3
+146 IF $Y>(IOSL-4)
DO HDR
if RAQUIT
QUIT
+147 WRITE !?RATAB(1),"Med: ",$EXTRACT($GET(RAMED("70.15",RAS,.01,"E")),1,28)
+148 WRITE ?RATAB(3),"Dose Adm'd: ",$EXTRACT($GET(RAMED("70.15",RAS,2,"E")),1,25)
+149 WRITE !?RATAB(1),"Adm'd by: ",$EXTRACT($GET(RAMED("70.15",RAS,3,"E")),1,24)
+150 WRITE ?RATAB(3),"Date Adm'd: ",$EXTRACT($GET(RAMED("70.15",RAS,4,"E")),1,20)
+151 ;more data
if RAS'=RAL
WRITE !
+152 QUIT
End DoDot:3
if RAQUIT
QUIT
+153 QUIT
End DoDot:2
KILL RAS,RAMED
+154 if RAQUIT
QUIT
+155 ;
+156 ;----------------------- get Radiopharms ------------------------------
+157 IF $PIECE(RAY3,U,28)>0
Begin DoDot:2
+158 ;#500 NUCLEAR MED DATA
+159 SET RADA=$PIECE(RAY3,U,28)_","
SET RAHDR=$$CJ^XLFSTR("Radiopharmaceuticals",IOM,"-")
+160 WRITE !,RAHDR
KILL RADIO
SET RAS=""
+161 DO GETS^DIQ(70.2,RADA_",","100*","E","RADIO")
+162 SET RAL=$ORDER(RADIO("70.21",$CHAR(126)),-1)
+163 FOR
SET RAS=$ORDER(RADIO("70.21",RAS))
if RAS=""
QUIT
Begin DoDot:3
+164 IF $Y>(IOSL-4)
DO HDR
if RAQUIT
QUIT
+165 SET RAU=0
FOR
SET RAU=$ORDER(RADIO("70.21",RAS,RAU))
if RAU'>0
QUIT
Begin DoDot:4
+166 IF $Y>(IOSL-4)
DO HDR
if RAQUIT
QUIT
+167 SET RAU(0)=$$TRN1^RAPROD2(RAU)_$GET(RADIO("70.21",RAS,RAU,"E"))
+168 SET RAU(0)=RAU(0)_$SELECT(RAU=2:" mCi",RAU=4:" mCi",RAU=7:" mCi",1:"")
+169 WRITE !?RATAB(1),$EXTRACT(RAU(0),1,28)
+170 SET RAU=$ORDER(RADIO("70.21",RAS,RAU))
+171 if RAU'>0
SET RAU=$CHAR(32)
if RAU=$CHAR(32)
QUIT
+172 SET RAU(1)=$$TRN1^RAPROD2(RAU)_$GET(RADIO("70.21",RAS,RAU,"E"))
+173 SET RAU(1)=RAU(1)_$SELECT(RAU=2:" mCi",RAU=4:" mCi",RAU=7:" mCi",1:"")
+174 WRITE ?RATAB(4),$EXTRACT(RAU(1),1,27)
+175 QUIT
End DoDot:4
if RAQUIT
QUIT
+176 ;more data
if RAS'=RAL
WRITE !
+177 QUIT
End DoDot:3
if RAQUIT
QUIT
+178 QUIT
End DoDot:2
KILL RADA,RADIO,RAS,RAU
+179 if RAQUIT
QUIT
+180 ;
+181 ;----------------------- get Rad Dose (fluoro) --------------------
+182 ;air kerma OR air kerma area product
IF $PIECE(RARAD(0),U,5)'=""!($PIECE(RARAD(0),U,6)'="")
Begin DoDot:2
+183 SET RAHDR=$$CJ^XLFSTR("Rad Dose",IOM,"-")
SET RAZFL=""
+184 SET RACOL(1)="Air Kerma (mGy)"
+185 SET RACOL(2)="Air Kerma Area Product (Gy-cm2)"
+186 ;note: data is in seconds
SET RACOL(3)="Fluoro Time (min)"
+187 WRITE !,RAHDR
+188 IF $Y>(IOSL-4)
DO HDR
if RAQUIT
QUIT
+189 WRITE !?RATAB(1),RACOL(1),?24,RACOL(2),?60,RACOL(3)
+190 SET $PIECE(XRA,"-",($LENGTH(RACOL(1))+1))=""
WRITE !?RATAB(1),XRA
+191 KILL XRA
SET $PIECE(XRA,"-",($LENGTH(RACOL(2))+1))=""
WRITE ?24,XRA
+192 KILL XRA
SET $PIECE(XRA,"-",($LENGTH(RACOL(3))+1))=""
WRITE ?60,XRA
+193 WRITE !?RATAB(1),$JUSTIFY($PIECE(RARAD(0),U,5),8,2),?24,$JUSTIFY(+$PIECE(RARAD(0),U,6),8,2)
+194 ;to mins to tenths
WRITE ?60,$JUSTIFY(($PIECE(RARAD(0),U,7))/60,1,1)
+195 KILL RACOL,XRA
+196 QUIT
End DoDot:2
+197 if RAQUIT
QUIT
+198 ;
+199 ;----------------------- get Rad Dose (CT SCAN) -------------------
+200 ;if CT Scan data
IF $ORDER(^RAD(RARAD,"II",0))
SET RAZCT=""
DO CT^RADRPT1
+201 if RAQUIT
QUIT
+202 SET RAP=RAP+1
+203 IF $DATA(ZTQUEUED)
if RAP#500=0
SET (RAQUIT,ZTSTOP)=$$S^%ZTLOAD()
+204 ; --- disclaimer ---
+205 KILL RALBL
DO HDR
if RAQUIT
QUIT
+206 FOR RAII=1:1:5
Begin DoDot:2
+207 IF ($DATA(RAZFL)#2)=1
IF (($DATA(RAZCT)#2)=0)
if RAII=3!(RAII=4)
QUIT
+208 IF ($DATA(RAZFL)#2)=0
IF (($DATA(RAZCT)#2)=1)
if RAII=5
QUIT
+209 SET RAYY=0
+210 FOR
SET RAYY=$ORDER(^TMP($JOB,"RA DISCLAIMER",RAII,RAYY))
if RAYY'>0
QUIT
Begin DoDot:3
+211 IF $Y>(IOSL-4)
DO HDR
if RAQUIT
QUIT
+212 WRITE !,$GET(^TMP($JOB,"RA DISCLAIMER",RAII,RAYY))
+213 QUIT
End DoDot:3
if RAQUIT
QUIT
+214 QUIT
End DoDot:2
if RAQUIT
QUIT
+215 SET DX=0
SET DY=IOSL
XECUTE ^%ZOSF("XY")
+216 KILL DX,DY,RAIEN,RAIENS,RAII,RAY2A,RAY3A,RAYY,RAZCT,RAZFL,RTFL,Y,Z
+217 QUIT
End DoDot:1
if RAQUIT
QUIT
+218 DO XIT
+219 QUIT
+220 ;
CN() ;return case # in the form of the accession # (SSAN aware)
+1 ;SITE ACCESSION NUMBER (SSAN)
NEW X
SET X=$PIECE(RAY3,U,31)
+2 if X=""
SET X=$EXTRACT(RADTE,4,5)_$EXTRACT(RADTE,6,7)_$EXTRACT(RADTE,2,3)_"-"_$PIECE(RAY3,U)
+3 QUIT X
+4 ;
HDR ;header/end of screen logic
+1 ;RAHDR: is dynamic; its value is based on the section
+2 ;HDR^RADRPT1A is called from.
+3 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+4 WRITE !,"Press RETURN to continue or '^' to exit: "
READ X:DTIME
+5 SET RAQUIT='$TEST!(X["^")
KILL X
+6 QUIT
End DoDot:1
if RAQUIT
QUIT
+7 SET RAPG=RAPG+1
WRITE @IOF,!,RATITLE
+8 WRITE !,"Date: ",RANODT,?69,"Page: ",RAPG
+9 WRITE !,RABORDR
+10 WRITE !?RATAB(1),"Name: ",$EXTRACT(RA("NAME"),1,27)_" "_RA("BID")
+11 WRITE ?RATAB(4),"Exam Date: ",$EXTRACT(RAY2A(70.02,RAIEN,".01","E"),1,21)
+12 WRITE !?RATAB(1),"Procedure: ",$EXTRACT(RAPRC,1,30)
+13 WRITE ?RATAB(4),"Case Number: ",RA("RACN")
+14 WRITE !,RAHDR
if $DATA(RALBL)#2
WRITE !?RATAB(1),RALBL,": "
+15 QUIT
+16 ;
XIT ;kill variables set ZTREQ then exit
+1 KILL %,%H,%I,N,RA,RABORDR,RACN,RACNI,RADA,RADFN,RADTE,RADPT,RADTI,RAHDR
+2 KILL RAI,RAIEN,RAIENS,RAL,RALBL,RALINE,RAM,RAMED,RANODT,RAOPRC,RAORD,RAP,RAPG
+3 KILL RAPRC,RAQUIT,RARAD,RARPT,RARX,RAS,RATAB,RATITLE,RAU,RAX,RAY,RAY2,RAY2A
+4 KILL RAY3,RAY3A,RAZCT,RAZFL
+5 KILL ^TMP($JOB,"RAEX"),^TMP($JOB,"RA DISCLAIMER")
+6 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+7 QUIT
+8 ;
PRC(Y) ;print procedure data (file #71)
+1 ;Input: Y = IEN file 71
+2 ;Output: imaging type abbreviation - procdure type or inactive - CPT code
+3 ; (if not a Parent or Broad procedure)
+4 ;ex: (NM Parent)
+5 ; (MAM Inactive) Note: may be broad or parent type
+6 ; (CT Inactive) CPT:76361
+7 ; (VAS Detailed) CPT:93619
+8 NEW X
+9 SET X(0)=$GET(^RAMIS(71,Y,0))
SET X("I")=$GET(^RAMIS(71,Y,"I"))
+10 SET X("IN")=$SELECT(X("I")="":0,DT'>X("I"):0,1:1)
+11 SET X=$PIECE(X(0),U,6)
SET X("CPT")=""
+12 SET X("PT")=$SELECT(X="B":"Broad",X="D":"Detailed",X="P":"Parent",X="S":"Series",1:"Unknown")
+13 ;required identifier
SET X=+$PIECE(X(0),U,12)
SET X("IT")=$SELECT(X=0:"Unknown",1:$PIECE(^RA(79.2,X,0),U,3))
+14 IF $EXTRACT(X("PT"),1)'="B"
IF $EXTRACT(X("PT"),1)'="P"
SET X("CPT")="CPT:"_$PIECE($$NAMCODE^RACPTMSC(+$PIECE(X(0),U,9),DT),U)
+15 SET X="("_X("IT")_" "_$SELECT(X("IN"):"Inactive",1:X("PT"))_") "_X("CPT")
+16 QUIT X
+17 ;
