- 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 Feb 19, 2025@00:01:04 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