RADLY1 ;HISC/GJC-Rad Daily Log Report ;5/7/97 13:50
;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21
PRINT ; Output subroutine part one
S RA1=""
P1 S RA1=$O(^TMP($J,"RADLY",RA1)) Q:RA1']"" S RA2=""
S RADIV=$P($G(^DIC(4,RA1,0)),"^") D CKCHANGE Q:RAXIT
P2 S RA2=$O(^TMP($J,"RADLY",RA1,RA2)) I RA2']"" D DIVCHK Q:RAXIT G P1
S RAITYPE=RA2,RA3="" D CKCHANGE Q:RAXIT
P3 S RA3=$O(^TMP($J,"RADLY",RA1,RA2,RA3)) I RA3']"" D IMGCHK Q:RAXIT G P2
S RAILOC=RA3,RA4="" D CKCHANGE Q:RAXIT
P4 S RA4=$O(^TMP($J,"RADLY",RA1,RA2,RA3,RA4)) I RA4']"" D LOCCHK Q:RAXIT G P3
S RA5=""
P5 S RA5=$O(^TMP($J,"RADLY",RA1,RA2,RA3,RA4,RA5)) G:RA5']"" P4 S RA6=""
P6 S RA6=$O(^TMP($J,"RADLY",RA1,RA2,RA3,RA4,RA5,RA6)) G:RA6']"" P5 S RA0=$G(^(RA6))
D:RA0]"" PRT1 Q:RAXIT
G P6
HD ; Header
W:RAPG!($E(IOST,1,2)="C-") @IOF
S RAPG=RAPG+1 W !?(IOM-$L(RAHEAD)\2-5),RAHEAD,?RATAB(9),"Page: ",RAPG
; raflg gets set after all records are printed,=1 if more than 1 div.
W:'$D(RAFLG) !,"Division : ",$S(RADIV]"":RADIV,1:"Unknown")
W:$D(RAFLG) !,"Division : "
W ?RATAB(9),"Date: ",RATDY
N RA12
S RA12=$S(RAILOC]"":RAILOC,1:"Unknown")
S:IOM<132 RA12=$E(RA12,1,30)
W:'$D(RAFLG) !,"Imaging Location : ",RA12," ("
W:$D(RAFLG) !,"Imaging Location :"
S RA12=$S(RAITYPE]"":RAITYPE,1:"Unknown")
S:IOM<132 RA12=$E(RA12,1,30)
W:'$D(RAFLG) RA12,")"
I IOM=132 D ; If 132 column
. I $$USESSAN^RAHLRU1() D
.. W !,"Name",?RATAB(2),"Pt ID",?RATAB(3)-2,"Time",?RATAB(4)-2
.. W "Ward/Clinic",?RATAB(5)-1,"Procedure",?RATAB(6)-2,"Exam Status"
.. W ?RATAB(7)-4,"Case#",?RATAB(8)+6,"Rptd",!,RALN
. I '$$USESSAN^RAHLRU1() D
.. W !,"Name",?RATAB(2),"Pt ID",?RATAB(3),"Time",?RATAB(4),"Ward/Clinic"
.. W ?RATAB(5),"Procedure",?RATAB(6),"Exam Status",?RATAB(7),"Case#"
.. W ?RATAB(8),"Reported",!,RALN
. Q
E D ; default to 80 column format
. I $$USESSAN^RAHLRU1() D
.. W !,"Name",?RATAB(3),"Pt ID",?RATAB(5),"Ward/Clinic"
.. W ?RATAB(7),"Procedure",!,?RATAB(2),"Exam Status",?RATAB(4),"Case #"
.. W ?RATAB(6)+9,"Time",?RATAB(8)+8,"Reported",!,RALN
. I '$$USESSAN^RAHLRU1() D
.. W !,"Name",?RATAB(3),"Pt ID",?RATAB(5),"Ward/Clinic"
.. W ?RATAB(7),"Procedure",!,?RATAB(2),"Exam Status",?RATAB(4),"Case #"
.. W ?RATAB(6),"Time",?RATAB(8),"Reported",!,RALN
. Q
I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1
Q
PRT1 ; Output subroutine two
F I=1:1:7 D
. S @$P("RACN^RAPRC^RAST^RATME^RAWHE^RARPT^RASSN","^",I)=$P(RA0,"^",I)
. Q
I $Y>(IOSL-4) D Q:RAXIT
. S:$E(IOST,1,2)="C-" RAXIT=$$EOS^RAUTL5() D:'RAXIT HD
. Q
I IOM=132 D ; default to 132 column format
. I $$USESSAN^RAHLRU1() D
.. W !,RA4,?RATAB(2),RASSN,?RATAB(3)-2,RATME,?RATAB(4)-2,RAWHE
.. W ?RATAB(5)-1,RAPRC,?RATAB(6)-2,$E(RAST,1,14),?RATAB(7)-4,RACN
.. W ?RATAB(8)+6,RARPT
. I '$$USESSAN^RAHLRU1() D
.. W !,RA4,?RATAB(2),RASSN,?RATAB(3),RATME,?RATAB(4),RAWHE
.. W ?RATAB(5),RAPRC,?RATAB(6),RAST,?RATAB(7),RACN,?RATAB(8),RARPT
. Q
E D ; If 80 column
. I $$USESSAN^RAHLRU1() D
.. W !,RA4,?RATAB(3),RASSN,?RATAB(5),RAWHE,?RATAB(7),RAPRC,!?RATAB(2)
.. W RAST,?RATAB(4),RACN,?RATAB(6)+9,RATME,?RATAB(8)+8,RARPT
. I '$$USESSAN^RAHLRU1() D
.. W !,RA4,?RATAB(3),RASSN,?RATAB(5),RAWHE,?RATAB(7),RAPRC
.. W !?RATAB(2),RAST,?RATAB(4),RACN,?RATAB(6),RATME,?RATAB(8),RARPT
. Q
Q
KILL ; Kill variables
K %,%I,%X,%Y,DIC,I,RA0,RA1,RA2,RA3,RA4,RA5,RA6,RA7,RA8,RA9,RA10,RA11
K RACN,RACNI,RADFN,RADIV,RADIVNM,RADIVTY,RADTE,RADTI,RAEX,RAFLG,RAHEAD
K RAIMGTY,RAITYPE,RALDTI,RALDTX,RALN,RAMES,RANME,RAPG,RAPOP,RAPRC,RAPT
K RAQUIT,RARE,RARPT,RASSN,RAST,RATAB,RATDY,RATME,RAWHE,RAXIT,X,Y,ZTDESC
K RAILOC,RADIV0,RAITYPE0,RAILOC0
K ZTRTN,ZTSAVE K:$D(RAPSTX) RACCESS,RAPSTX,POP,DUOUT
K ^TMP($J,"RA D-TYPE"),^TMP($J,"RA I-TYPE"),^TMP($J,"RADLY")
K ^TMP($J,"RA LOC-TYPE"),^TMP($J,"DIV-ITYP-ILOC")
Q
DIVCHK ; Output statistics within division.
N RA7 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD Q:RAXIT
W !?RATAB(2),"Division Total '"_RADIV_"': ",+$G(^TMP($J,"RADLY",RA1))
Q
IMGCHK ; Check for EOS on I-Type
N RA10 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD Q:RAXIT
W !?RATAB(2),"Imaging Type Total '"_RAITYPE_"': ",+$G(^TMP($J,"RADLY",RA1,RAITYPE))
Q
LOCCHK ; Check for EOS on Loc-Type
N RA9 I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD Q:RAXIT
W !?RATAB(2),"Imaging Location Total '"_RAILOC_"': ",+$G(^TMP($J,"RADLY",RA1,RAITYPE,RAILOC))
Q
CKCHANGE ; Check for change in div/img-type/img-loc, for header
N A,RAPRTHD
S RAPRTHD=0 ;whether to print page header or not, 1=yes
S A=$P($G(^DIC(4,+RA1,0)),"^")
I $G(RA2)]"",$G(RA3)]"" S:A'=RADIV0 RAPRTHD=1
I $G(RA2)]"",$G(RA3)]"",RADIV0=A S:RA2'=RAITYPE0 RAPRTHD=1
I $G(RA3)]"",RAITYPE0=RA2 S:RA3'=RAILOC0 RAPRTHD=1
S RADIV0=A S:$G(RA2)]"" RAITYPE0=RA2 S:$G(RA3)]"" RAILOC0=RA3
Q:'RAPRTHD&($Y<(IOSL-5))
S:$E(IOST,1,2)="C-" RAXIT=$$EOS^RAUTL5()
D:'RAXIT HD
Q
SORT ; Gather/sort data
S RARE(0)=$G(^RADPT(RADFN,"DT",RADTI,0))
S RADIV=+$P(RARE(0),"^",3),RADIV("I")=+$P($G(^RA(79,RADIV,0)),"^")
S RADIV=$P($G(^DIC(4,RADIV("I"),0)),"^")
I RADIV']""!('$D(^TMP($J,"RA D-TYPE",RADIV))) Q ; no div
S RADIV=RADIV("I") K RADIV("I")
S RAITYPE=+$P(RARE(0),"^",2) Q:RAITYPE'>0
S RAITYPE=$P($G(^RA(79.2,RAITYPE,0)),"^")
Q:'$D(^TMP($J,"RA I-TYPE",RAITYPE)) ; no img type
S RAILOC=+$P(RARE(0),"^",4) Q:RAILOC'>0
S RAILOC=$P($G(^RA(79.1,RAILOC,0)),"^"),RAILOC=$P($G(^SC(+RAILOC,0)),"^")
Q:'$D(^TMP($J,"RA LOC-TYPE",RAILOC)) ;no img loc
S (RANME,RASSN)="Unknown",RAPT(0)=$G(^DPT(RADFN,0))
S RANME=$S($P(RAPT(0),"^")]"":$P(RAPT(0),"^"),1:RANME)
S RASSN=$$SSN^RAUTL,RANME=$E(RANME,1,23)
F RACNI=0:0 S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI D Q:RAXIT
. D:$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)) SET^RADLY
. Q
Q
ZEROUT ; zero out the ^tmp($j,"RADLY"
; loop throu raccess(duz,"DIV,ITYP-ILOC",divname,imgtypename,imglocname)
; THIS SECTION REPLACES THE ORIGINAL CALL TO ZEROUT^RADLQ3("RADLY")
; so to ensure that locations not assigned to the user will be
; zeroed out, if those locations share the same imaging types that
; his assigned locations have
N X,Y,Z,X1
S X=""
ZER1 S X=$O(RACCESS(DUZ,"DIV-ITYP-ILOC",X)) Q:X="" ;eg. "cgo (ws)"
S Y="",X1=$O(^DIC(4,"B",X,0)) ; eg. 639
ZER2 S Y=$O(RACCESS(DUZ,"DIV-ITYP-ILOC",X,Y)) G:Y="" ZER1 S Z="" ;eg. "gen rad"
ZER3 S Z=$O(RACCESS(DUZ,"DIV-ITYP-ILOC",X,Y,Z)) G:Z="" ZER2 ;eg. "x-ray"
S ^TMP($J,"RADLY",X1,Y,Z)=0
G ZER3
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRADLY1 6495 printed Sep 23, 2025@20:10:48 Page 2
RADLY1 ;HISC/GJC-Rad Daily Log Report ;5/7/97 13:50
+1 ;;5.0;Radiology/Nuclear Medicine;**47**;Mar 16, 1998;Build 21
PRINT ; Output subroutine part one
+1 SET RA1=""
P1 SET RA1=$ORDER(^TMP($JOB,"RADLY",RA1))
if RA1']""
QUIT
SET RA2=""
+1 SET RADIV=$PIECE($GET(^DIC(4,RA1,0)),"^")
DO CKCHANGE
if RAXIT
QUIT
P2 SET RA2=$ORDER(^TMP($JOB,"RADLY",RA1,RA2))
IF RA2']""
DO DIVCHK
if RAXIT
QUIT
GOTO P1
+1 SET RAITYPE=RA2
SET RA3=""
DO CKCHANGE
if RAXIT
QUIT
P3 SET RA3=$ORDER(^TMP($JOB,"RADLY",RA1,RA2,RA3))
IF RA3']""
DO IMGCHK
if RAXIT
QUIT
GOTO P2
+1 SET RAILOC=RA3
SET RA4=""
DO CKCHANGE
if RAXIT
QUIT
P4 SET RA4=$ORDER(^TMP($JOB,"RADLY",RA1,RA2,RA3,RA4))
IF RA4']""
DO LOCCHK
if RAXIT
QUIT
GOTO P3
+1 SET RA5=""
P5 SET RA5=$ORDER(^TMP($JOB,"RADLY",RA1,RA2,RA3,RA4,RA5))
if RA5']""
GOTO P4
SET RA6=""
P6 SET RA6=$ORDER(^TMP($JOB,"RADLY",RA1,RA2,RA3,RA4,RA5,RA6))
if RA6']""
GOTO P5
SET RA0=$GET(^(RA6))
+1 if RA0]""
DO PRT1
if RAXIT
QUIT
+2 GOTO P6
HD ; Header
+1 if RAPG!($EXTRACT(IOST,1,2)="C-")
WRITE @IOF
+2 SET RAPG=RAPG+1
WRITE !?(IOM-$LENGTH(RAHEAD)\2-5),RAHEAD,?RATAB(9),"Page: ",RAPG
+3 ; raflg gets set after all records are printed,=1 if more than 1 div.
+4 if '$DATA(RAFLG)
WRITE !,"Division : ",$SELECT(RADIV]"":RADIV,1:"Unknown")
+5 if $DATA(RAFLG)
WRITE !,"Division : "
+6 WRITE ?RATAB(9),"Date: ",RATDY
+7 NEW RA12
+8 SET RA12=$SELECT(RAILOC]"":RAILOC,1:"Unknown")
+9 if IOM<132
SET RA12=$EXTRACT(RA12,1,30)
+10 if '$DATA(RAFLG)
WRITE !,"Imaging Location : ",RA12," ("
+11 if $DATA(RAFLG)
WRITE !,"Imaging Location :"
+12 SET RA12=$SELECT(RAITYPE]"":RAITYPE,1:"Unknown")
+13 if IOM<132
SET RA12=$EXTRACT(RA12,1,30)
+14 if '$DATA(RAFLG)
WRITE RA12,")"
+15 ; If 132 column
IF IOM=132
Begin DoDot:1
+16 IF $$USESSAN^RAHLRU1()
Begin DoDot:2
+17 WRITE !,"Name",?RATAB(2),"Pt ID",?RATAB(3)-2,"Time",?RATAB(4)-2
+18 WRITE "Ward/Clinic",?RATAB(5)-1,"Procedure",?RATAB(6)-2,"Exam Status"
+19 WRITE ?RATAB(7)-4,"Case#",?RATAB(8)+6,"Rptd",!,RALN
End DoDot:2
+20 IF '$$USESSAN^RAHLRU1()
Begin DoDot:2
+21 WRITE !,"Name",?RATAB(2),"Pt ID",?RATAB(3),"Time",?RATAB(4),"Ward/Clinic"
+22 WRITE ?RATAB(5),"Procedure",?RATAB(6),"Exam Status",?RATAB(7),"Case#"
+23 WRITE ?RATAB(8),"Reported",!,RALN
End DoDot:2
+24 QUIT
End DoDot:1
+25 ; default to 80 column format
IF '$TEST
Begin DoDot:1
+26 IF $$USESSAN^RAHLRU1()
Begin DoDot:2
+27 WRITE !,"Name",?RATAB(3),"Pt ID",?RATAB(5),"Ward/Clinic"
+28 WRITE ?RATAB(7),"Procedure",!,?RATAB(2),"Exam Status",?RATAB(4),"Case #"
+29 WRITE ?RATAB(6)+9,"Time",?RATAB(8)+8,"Reported",!,RALN
End DoDot:2
+30 IF '$$USESSAN^RAHLRU1()
Begin DoDot:2
+31 WRITE !,"Name",?RATAB(3),"Pt ID",?RATAB(5),"Ward/Clinic"
+32 WRITE ?RATAB(7),"Procedure",!,?RATAB(2),"Exam Status",?RATAB(4),"Case #"
+33 WRITE ?RATAB(6),"Time",?RATAB(8),"Reported",!,RALN
End DoDot:2
+34 QUIT
End DoDot:1
+35 IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
if $GET(ZTSTOP)=1
SET RAXIT=1
+36 QUIT
PRT1 ; Output subroutine two
+1 FOR I=1:1:7
Begin DoDot:1
+2 SET @$PIECE("RACN^RAPRC^RAST^RATME^RAWHE^RARPT^RASSN","^",I)=$PIECE(RA0,"^",I)
+3 QUIT
End DoDot:1
+4 IF $Y>(IOSL-4)
Begin DoDot:1
+5 if $EXTRACT(IOST,1,2)="C-"
SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HD
+6 QUIT
End DoDot:1
if RAXIT
QUIT
+7 ; default to 132 column format
IF IOM=132
Begin DoDot:1
+8 IF $$USESSAN^RAHLRU1()
Begin DoDot:2
+9 WRITE !,RA4,?RATAB(2),RASSN,?RATAB(3)-2,RATME,?RATAB(4)-2,RAWHE
+10 WRITE ?RATAB(5)-1,RAPRC,?RATAB(6)-2,$EXTRACT(RAST,1,14),?RATAB(7)-4,RACN
+11 WRITE ?RATAB(8)+6,RARPT
End DoDot:2
+12 IF '$$USESSAN^RAHLRU1()
Begin DoDot:2
+13 WRITE !,RA4,?RATAB(2),RASSN,?RATAB(3),RATME,?RATAB(4),RAWHE
+14 WRITE ?RATAB(5),RAPRC,?RATAB(6),RAST,?RATAB(7),RACN,?RATAB(8),RARPT
End DoDot:2
+15 QUIT
End DoDot:1
+16 ; If 80 column
IF '$TEST
Begin DoDot:1
+17 IF $$USESSAN^RAHLRU1()
Begin DoDot:2
+18 WRITE !,RA4,?RATAB(3),RASSN,?RATAB(5),RAWHE,?RATAB(7),RAPRC,!?RATAB(2)
+19 WRITE RAST,?RATAB(4),RACN,?RATAB(6)+9,RATME,?RATAB(8)+8,RARPT
End DoDot:2
+20 IF '$$USESSAN^RAHLRU1()
Begin DoDot:2
+21 WRITE !,RA4,?RATAB(3),RASSN,?RATAB(5),RAWHE,?RATAB(7),RAPRC
+22 WRITE !?RATAB(2),RAST,?RATAB(4),RACN,?RATAB(6),RATME,?RATAB(8),RARPT
End DoDot:2
+23 QUIT
End DoDot:1
+24 QUIT
KILL ; Kill variables
+1 KILL %,%I,%X,%Y,DIC,I,RA0,RA1,RA2,RA3,RA4,RA5,RA6,RA7,RA8,RA9,RA10,RA11
+2 KILL RACN,RACNI,RADFN,RADIV,RADIVNM,RADIVTY,RADTE,RADTI,RAEX,RAFLG,RAHEAD
+3 KILL RAIMGTY,RAITYPE,RALDTI,RALDTX,RALN,RAMES,RANME,RAPG,RAPOP,RAPRC,RAPT
+4 KILL RAQUIT,RARE,RARPT,RASSN,RAST,RATAB,RATDY,RATME,RAWHE,RAXIT,X,Y,ZTDESC
+5 KILL RAILOC,RADIV0,RAITYPE0,RAILOC0
+6 KILL ZTRTN,ZTSAVE
if $DATA(RAPSTX)
KILL RACCESS,RAPSTX,POP,DUOUT
+7 KILL ^TMP($JOB,"RA D-TYPE"),^TMP($JOB,"RA I-TYPE"),^TMP($JOB,"RADLY")
+8 KILL ^TMP($JOB,"RA LOC-TYPE"),^TMP($JOB,"DIV-ITYP-ILOC")
+9 QUIT
DIVCHK ; Output statistics within division.
+1 NEW RA7
IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HD
if RAXIT
QUIT
+2 WRITE !?RATAB(2),"Division Total '"_RADIV_"': ",+$GET(^TMP($JOB,"RADLY",RA1))
+3 QUIT
IMGCHK ; Check for EOS on I-Type
+1 NEW RA10
IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HD
if RAXIT
QUIT
+2 WRITE !?RATAB(2),"Imaging Type Total '"_RAITYPE_"': ",+$GET(^TMP($JOB,"RADLY",RA1,RAITYPE))
+3 QUIT
LOCCHK ; Check for EOS on Loc-Type
+1 NEW RA9
IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HD
if RAXIT
QUIT
+2 WRITE !?RATAB(2),"Imaging Location Total '"_RAILOC_"': ",+$GET(^TMP($JOB,"RADLY",RA1,RAITYPE,RAILOC))
+3 QUIT
CKCHANGE ; Check for change in div/img-type/img-loc, for header
+1 NEW A,RAPRTHD
+2 ;whether to print page header or not, 1=yes
SET RAPRTHD=0
+3 SET A=$PIECE($GET(^DIC(4,+RA1,0)),"^")
+4 IF $GET(RA2)]""
IF $GET(RA3)]""
if A'=RADIV0
SET RAPRTHD=1
+5 IF $GET(RA2)]""
IF $GET(RA3)]""
IF RADIV0=A
if RA2'=RAITYPE0
SET RAPRTHD=1
+6 IF $GET(RA3)]""
IF RAITYPE0=RA2
if RA3'=RAILOC0
SET RAPRTHD=1
+7 SET RADIV0=A
if $GET(RA2)]""
SET RAITYPE0=RA2
if $GET(RA3)]""
SET RAILOC0=RA3
+8 if 'RAPRTHD&($Y<(IOSL-5))
QUIT
+9 if $EXTRACT(IOST,1,2)="C-"
SET RAXIT=$$EOS^RAUTL5()
+10 if 'RAXIT
DO HD
+11 QUIT
SORT ; Gather/sort data
+1 SET RARE(0)=$GET(^RADPT(RADFN,"DT",RADTI,0))
+2 SET RADIV=+$PIECE(RARE(0),"^",3)
SET RADIV("I")=+$PIECE($GET(^RA(79,RADIV,0)),"^")
+3 SET RADIV=$PIECE($GET(^DIC(4,RADIV("I"),0)),"^")
+4 ; no div
IF RADIV']""!('$DATA(^TMP($JOB,"RA D-TYPE",RADIV)))
QUIT
+5 SET RADIV=RADIV("I")
KILL RADIV("I")
+6 SET RAITYPE=+$PIECE(RARE(0),"^",2)
if RAITYPE'>0
QUIT
+7 SET RAITYPE=$PIECE($GET(^RA(79.2,RAITYPE,0)),"^")
+8 ; no img type
if '$DATA(^TMP($JOB,"RA I-TYPE",RAITYPE))
QUIT
+9 SET RAILOC=+$PIECE(RARE(0),"^",4)
if RAILOC'>0
QUIT
+10 SET RAILOC=$PIECE($GET(^RA(79.1,RAILOC,0)),"^")
SET RAILOC=$PIECE($GET(^SC(+RAILOC,0)),"^")
+11 ;no img loc
if '$DATA(^TMP($JOB,"RA LOC-TYPE",RAILOC))
QUIT
+12 SET (RANME,RASSN)="Unknown"
SET RAPT(0)=$GET(^DPT(RADFN,0))
+13 SET RANME=$SELECT($PIECE(RAPT(0),"^")]"":$PIECE(RAPT(0),"^"),1:RANME)
+14 SET RASSN=$$SSN^RAUTL
SET RANME=$EXTRACT(RANME,1,23)
+15 FOR RACNI=0:0
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
if 'RACNI
QUIT
Begin DoDot:1
+16 if $DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
DO SET^RADLY
+17 QUIT
End DoDot:1
if RAXIT
QUIT
+18 QUIT
ZEROUT ; zero out the ^tmp($j,"RADLY"
+1 ; loop throu raccess(duz,"DIV,ITYP-ILOC",divname,imgtypename,imglocname)
+2 ; THIS SECTION REPLACES THE ORIGINAL CALL TO ZEROUT^RADLQ3("RADLY")
+3 ; so to ensure that locations not assigned to the user will be
+4 ; zeroed out, if those locations share the same imaging types that
+5 ; his assigned locations have
+6 NEW X,Y,Z,X1
+7 SET X=""
ZER1 ;eg. "cgo (ws)"
SET X=$ORDER(RACCESS(DUZ,"DIV-ITYP-ILOC",X))
if X=""
QUIT
+1 ; eg. 639
SET Y=""
SET X1=$ORDER(^DIC(4,"B",X,0))
ZER2 ;eg. "gen rad"
SET Y=$ORDER(RACCESS(DUZ,"DIV-ITYP-ILOC",X,Y))
if Y=""
GOTO ZER1
SET Z=""
ZER3 ;eg. "x-ray"
SET Z=$ORDER(RACCESS(DUZ,"DIV-ITYP-ILOC",X,Y,Z))
if Z=""
GOTO ZER2
+1 SET ^TMP($JOB,"RADLY",X1,Y,Z)=0
+2 GOTO ZER3
