RADLY ;HISC/GJC AISC/MJK,RMO-Rad Daily Log Report ;7/17/97 12:35
;;5.0;Radiology/Nuclear Medicine;**15,47**;Mar 16, 1998;Build 21
; setup raccess(duz,"LOC" raccess(duz,"DIV" raccess(duz,"IMG"
I $O(RACCESS(DUZ,""))="" S RAPSTX="" D SETVARS^RAPSET1(0)
; Check access and
; setup raccess(duz,"DIV-IMG","chicago (ws),"general radiology"
S RAXIT=$$SETUPDI^RAUTL7() G:RAXIT CLEAN
; Select Div
; setup ^tmp($j,"RA D-TYPE"
D SELDIV^RAUTL7
I '$D(^TMP($J,"RA D-TYPE"))!(RAQUIT) K RACCESS(DUZ,"DIV-IMG") S RAXIT=1 G CLEAN
; Set imaging types as allowed by division(s) picked
N X,X1,RACHK1 S X=0
; setup ^tmp($j,"DIV-IMG"
D SETUP^RAUTL7A
; setup ^tmp($j,"RA I-TYPE"
F S X=$O(^TMP($J,"DIV-IMG",X)) Q:X'=+X I $D(RACCESS(DUZ,"IMG",X)) S ^TMP($J,"RA I-TYPE",$P($G(^RA(79.2,+X,0)),U),X)=""
; Select Img Loc
; setup ^tmp($j,"DIV-ITYP-ILOC" ^tmp($j,"RA LOC-TYPE"
D SELLOC^RAUTL7
I '$D(^TMP($J,"RA LOC-TYPE"))!(RAQUIT) K RACESS(DUZ,"DIV-IMG"),^TMP($J,"DIV-ITYP-ILOC") S RAXIT=1
CLEAN K ^TMP($J,"DIV-IMG")
;
I RAXIT K RAXIT K:$D(RAPSTX) RACCESS,RAPSTX,I,POP,RAQUIT Q
; loop thru raccess(duz,"DIV-IMG" to setup ^tmp($j,"RADLY",
; matching on ^tmp($j,"RA D-TYPE" and ^tmp($j,"RA I-TYPE"
; use new code in rtn radly1, instead of rtn radlq3
D ZEROUT^RADLY1 K RACCESS(DUZ,"DIV-IMG") W !
ASKLOG ; Ask log date
W ! K %DT
S %DT="PATEX",%DT("A")="Select Log Date: "
S %DT("B")="T-1" D ^%DT K %DT
I Y<0 D KILL^RADLY1 Q
S RALDTI=Y\1 S RALDTX=$$FMTE^XLFDT(Y\1,1)
S ZTDESC="Rad/Nuc Med Daily Log Rpt"
S ZTRTN="START^RADLY",ZTSAVE("RALDT*")=""
S ZTSAVE("^TMP($J,""RADLY"",")="",ZTSAVE("^TMP($J,""RA D-TYPE"",")=""
S ZTSAVE("^TMP($J,""RA I-TYPE"",")=""
S ZTSAVE("^TMP($J,""RA LOC-TYPE"",")=""
D ZIS^RAUTL
I RAPOP D KILL^RADLY1 Q
START ; Start the process
U IO D NOW^%DTC
S:$D(ZTQUEUED) ZTREQ="@"
S RATDY=$$FMTE^XLFDT(%\1,1),(RAPG,RAXIT)=0
S $P(RALN,"-",(IOM+1))="",RAHEAD="Daily Log Report For: "_RALDTX
S RATAB(1)=$S(IOM=132:8,1:5),RATAB(2)=$S(IOM=132:25,1:8)
S RATAB(3)=$S(IOM=132:42,1:25),RATAB(4)=$S(IOM=132:52,1:32)
S RATAB(5)=$S(IOM=132:72,1:38),RATAB(6)=$S(IOM=132:95,1:43)
S RATAB(7)=$S(IOM=132:114,1:60),RATAB(8)=$S(IOM=132:122,1:62)
S RATAB(9)=$S(IOM=132:102,1:62)
;
F RADTE=RALDTI:0 S RADTE=$O(^RADPT("AR",RADTE)) Q:'RADTE D Q:RAXIT
. Q:RADTE>(RALDTI+.9999)
. F RADFN=0:0 S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:'RADFN D Q:RAXIT
.. S RADTI=9999999.9999-RADTE
.. D:$D(^RADPT(RADFN,"DT",RADTI,0)) SORT^RADLY1
.. Q
. Q
I RAXIT D CLOSE^RAUTL,KILL^RADLY1 Q
;
; eliminate "RADLY" nodes that are outside the user-selected img locs
N A,B,C S A=""
CLN1 S A=$O(^TMP($J,"RADLY",A)) G:A']"" PREP S B=""
CLN2 S B=$O(^TMP($J,"RADLY",A,B)) G:B']"" CLN1 S C=""
CLN3 S C=$O(^TMP($J,"RADLY",A,B,C)) G:C']"" CLN2
K:$O(^TMP($J,"RA LOC-TYPE",C,0))="" ^TMP($J,"RADLY",A,B,C)
K:$O(^TMP($J,"RA I-TYPE",B,0))="" ^TMP($J,"RADLY",A,B)
K:$O(^TMP($J,"RADLY",A,""))="" ^TMP($J,"RADLY",A)
G CLN3
PREP G:'$D(^TMP($J,"RADLY")) OUT
S X=+$O(^TMP($J,"RADLY","")),Y=$O(^TMP($J,"RADLY",X,""))
S RADIV=$P($G(^DIC(4,X,0)),"^"),RAITYPE=Y
S RAILOC=$O(^TMP($J,"RADLY",X,Y,""))
; save current values
S RADIV0=RADIV,RAITYPE0=RAITYPE,RAILOC0=RAILOC
D HD^RADLY1
I RAXIT D CLOSE^RAUTL,KILL^RADLY1 Q
I $D(^TMP($J,"RADLY")) D
. D PRINT^RADLY1 ; Print out data
. I 'RAXIT D
.. S RADIVNM=$$DIVTOT^RACMP("RADLY") Q:'RADIVNM
.. S (RADIV,RAFLG,RAITYPE)="",RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RADLY1
.. D:'RAXIT SYNOP
.. Q
. Q
OUT D CLOSE^RAUTL,KILL^RADLY1
Q
SET ; Set ^TMP global
S RAEX(0)=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
S RACN=$P(RAEX(0),"^"),RAPRC=+$P(RAEX(0),"^",2)
S RAPRC=$G(^RAMIS(71,RAPRC,0)),RAST=+$P(RAEX(0),"^",3)
S RAPRC=$E($S(RAPRC]"":$P(RAPRC,"^"),1:"Unknown"),1,19)
S RAST=$G(^RA(72,RAST,0)),RA6=+$P(RAEX(0),"^",6)
S RA8=+$P(RAEX(0),"^",8),RA9=+$P(RAEX(0),"^",9)
S RAST=$E($S(RAST]"":$P(RAST,"^"),1:"Unknown"),1,20)
S X=RADTE D TIME^RAUTL1 S RATME=X
S:$D(^DIC(42,RA6,0)) RAWHE=$P(^DIC(42,RA6,0),"^")
S:$D(^SC(RA8,0)) RAWHE=$P(^SC(RA8,0),"^")
S:$D(^DIC(34,RA9,0)) RAWHE=$P(^DIC(34,RA9,0),"^")
S:$D(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"R")) RAWHE=$P(^("R"),"^")
S RAWHE=$E($S($G(RAWHE)]"":RAWHE,1:"Unknown"),1,20)
S RARPT=+$P(RAEX(0),"^",17)
S RARPT=$S($O(^RARPT(RARPT,"R",0)):"Yes",1:"No")
I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1 Q:RAXIT
S ^TMP($J,"RADLY",RADIV)=+$G(^TMP($J,"RADLY",RADIV))+1
S ^TMP($J,"RADLY",RADIV,RAITYPE)=+$G(^TMP($J,"RADLY",RADIV,RAITYPE))+1
S ^TMP($J,"RADLY",RADIV,RAITYPE,RAILOC)=+$G(^TMP($J,"RADLY",RADIV,RAITYPE,RAILOC))+1
S RADIVTY=+$G(RADIVTY)+1
N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN)
I $$USESSAN^RAHLRU1() S ^TMP($J,"RADLY",RADIV,RAITYPE,RAILOC,RANME,RADTE,RACNI)=RACNDSP_"^"_RAPRC_"^"_RAST_"^"_RATME_"^"_RAWHE_"^"_RARPT_"^"_RASSN
I '$$USESSAN^RAHLRU1() S ^TMP($J,"RADLY",RADIV,RAITYPE,RAILOC,RANME,RADTE,RACNI)=RACN_"^"_RAPRC_"^"_RAST_"^"_RATME_"^"_RAWHE_"^"_RARPT_"^"_RASSN
Q
SYNOP ; Synopsis of data presented to the user.
S A=""
W !?RATAB(2),"Division",!?RATAB(2)+3,"Imaging Type",!?RATAB(2)+6,"Imaging Location(s)",!
SYN1 S A=$O(^TMP($J,"RADLY",A)) Q:A']""
I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RADLY1 Q:RAXIT
W !!?RATAB(2),$P($G(^DIC(4,A,0)),"^") S B=""
SYN2 S B=$O(^TMP($J,"RADLY",A,B)) G:B']"" SYN1
I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RADLY1 Q:RAXIT
W !?RATAB(2)+3,B,!?RATAB(2)+6 S C=""
SYN3 S C=$O(^TMP($J,"RADLY",A,B,C)) G:C']"" SYN2
I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RADLY1 Q:RAXIT
W:$X>(IOM-30) !?RATAB(2)+6
W C,?($X+3)
G SYN3
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRADLY 5681 printed Oct 16, 2024@18:35:23 Page 2
RADLY ;HISC/GJC AISC/MJK,RMO-Rad Daily Log Report ;7/17/97 12:35
+1 ;;5.0;Radiology/Nuclear Medicine;**15,47**;Mar 16, 1998;Build 21
+2 ; setup raccess(duz,"LOC" raccess(duz,"DIV" raccess(duz,"IMG"
+3 IF $ORDER(RACCESS(DUZ,""))=""
SET RAPSTX=""
DO SETVARS^RAPSET1(0)
+4 ; Check access and
+5 ; setup raccess(duz,"DIV-IMG","chicago (ws),"general radiology"
+6 SET RAXIT=$$SETUPDI^RAUTL7()
if RAXIT
GOTO CLEAN
+7 ; Select Div
+8 ; setup ^tmp($j,"RA D-TYPE"
+9 DO SELDIV^RAUTL7
+10 IF '$DATA(^TMP($JOB,"RA D-TYPE"))!(RAQUIT)
KILL RACCESS(DUZ,"DIV-IMG")
SET RAXIT=1
GOTO CLEAN
+11 ; Set imaging types as allowed by division(s) picked
+12 NEW X,X1,RACHK1
SET X=0
+13 ; setup ^tmp($j,"DIV-IMG"
+14 DO SETUP^RAUTL7A
+15 ; setup ^tmp($j,"RA I-TYPE"
+16 FOR
SET X=$ORDER(^TMP($JOB,"DIV-IMG",X))
if X'=+X
QUIT
IF $DATA(RACCESS(DUZ,"IMG",X))
SET ^TMP($JOB,"RA I-TYPE",$PIECE($GET(^RA(79.2,+X,0)),U),X)=""
+17 ; Select Img Loc
+18 ; setup ^tmp($j,"DIV-ITYP-ILOC" ^tmp($j,"RA LOC-TYPE"
+19 DO SELLOC^RAUTL7
+20 IF '$DATA(^TMP($JOB,"RA LOC-TYPE"))!(RAQUIT)
KILL RACESS(DUZ,"DIV-IMG"),^TMP($JOB,"DIV-ITYP-ILOC")
SET RAXIT=1
CLEAN KILL ^TMP($JOB,"DIV-IMG")
+1 ;
+2 IF RAXIT
KILL RAXIT
if $DATA(RAPSTX)
KILL RACCESS,RAPSTX,I,POP,RAQUIT
QUIT
+3 ; loop thru raccess(duz,"DIV-IMG" to setup ^tmp($j,"RADLY",
+4 ; matching on ^tmp($j,"RA D-TYPE" and ^tmp($j,"RA I-TYPE"
+5 ; use new code in rtn radly1, instead of rtn radlq3
+6 DO ZEROUT^RADLY1
KILL RACCESS(DUZ,"DIV-IMG")
WRITE !
ASKLOG ; Ask log date
+1 WRITE !
KILL %DT
+2 SET %DT="PATEX"
SET %DT("A")="Select Log Date: "
+3 SET %DT("B")="T-1"
DO ^%DT
KILL %DT
+4 IF Y<0
DO KILL^RADLY1
QUIT
+5 SET RALDTI=Y\1
SET RALDTX=$$FMTE^XLFDT(Y\1,1)
+6 SET ZTDESC="Rad/Nuc Med Daily Log Rpt"
+7 SET ZTRTN="START^RADLY"
SET ZTSAVE("RALDT*")=""
+8 SET ZTSAVE("^TMP($J,""RADLY"",")=""
SET ZTSAVE("^TMP($J,""RA D-TYPE"",")=""
+9 SET ZTSAVE("^TMP($J,""RA I-TYPE"",")=""
+10 SET ZTSAVE("^TMP($J,""RA LOC-TYPE"",")=""
+11 DO ZIS^RAUTL
+12 IF RAPOP
DO KILL^RADLY1
QUIT
START ; Start the process
+1 USE IO
DO NOW^%DTC
+2 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 SET RATDY=$$FMTE^XLFDT(%\1,1)
SET (RAPG,RAXIT)=0
+4 SET $PIECE(RALN,"-",(IOM+1))=""
SET RAHEAD="Daily Log Report For: "_RALDTX
+5 SET RATAB(1)=$SELECT(IOM=132:8,1:5)
SET RATAB(2)=$SELECT(IOM=132:25,1:8)
+6 SET RATAB(3)=$SELECT(IOM=132:42,1:25)
SET RATAB(4)=$SELECT(IOM=132:52,1:32)
+7 SET RATAB(5)=$SELECT(IOM=132:72,1:38)
SET RATAB(6)=$SELECT(IOM=132:95,1:43)
+8 SET RATAB(7)=$SELECT(IOM=132:114,1:60)
SET RATAB(8)=$SELECT(IOM=132:122,1:62)
+9 SET RATAB(9)=$SELECT(IOM=132:102,1:62)
+10 ;
+11 FOR RADTE=RALDTI:0
SET RADTE=$ORDER(^RADPT("AR",RADTE))
if 'RADTE
QUIT
Begin DoDot:1
+12 if RADTE>(RALDTI+.9999)
QUIT
+13 FOR RADFN=0:0
SET RADFN=$ORDER(^RADPT("AR",RADTE,RADFN))
if 'RADFN
QUIT
Begin DoDot:2
+14 SET RADTI=9999999.9999-RADTE
+15 if $DATA(^RADPT(RADFN,"DT",RADTI,0))
DO SORT^RADLY1
+16 QUIT
End DoDot:2
if RAXIT
QUIT
+17 QUIT
End DoDot:1
if RAXIT
QUIT
+18 IF RAXIT
DO CLOSE^RAUTL
DO KILL^RADLY1
QUIT
+19 ;
+20 ; eliminate "RADLY" nodes that are outside the user-selected img locs
+21 NEW A,B,C
SET A=""
CLN1 SET A=$ORDER(^TMP($JOB,"RADLY",A))
if A']""
GOTO PREP
SET B=""
CLN2 SET B=$ORDER(^TMP($JOB,"RADLY",A,B))
if B']""
GOTO CLN1
SET C=""
CLN3 SET C=$ORDER(^TMP($JOB,"RADLY",A,B,C))
if C']""
GOTO CLN2
+1 if $ORDER(^TMP($JOB,"RA LOC-TYPE",C,0))=""
KILL ^TMP($JOB,"RADLY",A,B,C)
+2 if $ORDER(^TMP($JOB,"RA I-TYPE",B,0))=""
KILL ^TMP($JOB,"RADLY",A,B)
+3 if $ORDER(^TMP($JOB,"RADLY",A,""))=""
KILL ^TMP($JOB,"RADLY",A)
+4 GOTO CLN3
PREP if '$DATA(^TMP($JOB,"RADLY"))
GOTO OUT
+1 SET X=+$ORDER(^TMP($JOB,"RADLY",""))
SET Y=$ORDER(^TMP($JOB,"RADLY",X,""))
+2 SET RADIV=$PIECE($GET(^DIC(4,X,0)),"^")
SET RAITYPE=Y
+3 SET RAILOC=$ORDER(^TMP($JOB,"RADLY",X,Y,""))
+4 ; save current values
+5 SET RADIV0=RADIV
SET RAITYPE0=RAITYPE
SET RAILOC0=RAILOC
+6 DO HD^RADLY1
+7 IF RAXIT
DO CLOSE^RAUTL
DO KILL^RADLY1
QUIT
+8 IF $DATA(^TMP($JOB,"RADLY"))
Begin DoDot:1
+9 ; Print out data
DO PRINT^RADLY1
+10 IF 'RAXIT
Begin DoDot:2
+11 SET RADIVNM=$$DIVTOT^RACMP("RADLY")
if 'RADIVNM
QUIT
+12 SET (RADIV,RAFLG,RAITYPE)=""
SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HD^RADLY1
+13 if 'RAXIT
DO SYNOP
+14 QUIT
End DoDot:2
+15 QUIT
End DoDot:1
OUT DO CLOSE^RAUTL
DO KILL^RADLY1
+1 QUIT
SET ; Set ^TMP global
+1 SET RAEX(0)=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+2 SET RACN=$PIECE(RAEX(0),"^")
SET RAPRC=+$PIECE(RAEX(0),"^",2)
+3 SET RAPRC=$GET(^RAMIS(71,RAPRC,0))
SET RAST=+$PIECE(RAEX(0),"^",3)
+4 SET RAPRC=$EXTRACT($SELECT(RAPRC]"":$PIECE(RAPRC,"^"),1:"Unknown"),1,19)
+5 SET RAST=$GET(^RA(72,RAST,0))
SET RA6=+$PIECE(RAEX(0),"^",6)
+6 SET RA8=+$PIECE(RAEX(0),"^",8)
SET RA9=+$PIECE(RAEX(0),"^",9)
+7 SET RAST=$EXTRACT($SELECT(RAST]"":$PIECE(RAST,"^"),1:"Unknown"),1,20)
+8 SET X=RADTE
DO TIME^RAUTL1
SET RATME=X
+9 if $DATA(^DIC(42,RA6,0))
SET RAWHE=$PIECE(^DIC(42,RA6,0),"^")
+10 if $DATA(^SC(RA8,0))
SET RAWHE=$PIECE(^SC(RA8,0),"^")
+11 if $DATA(^DIC(34,RA9,0))
SET RAWHE=$PIECE(^DIC(34,RA9,0),"^")
+12 if $DATA(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"R"))
SET RAWHE=$PIECE(^("R"),"^")
+13 SET RAWHE=$EXTRACT($SELECT($GET(RAWHE)]"":RAWHE,1:"Unknown"),1,20)
+14 SET RARPT=+$PIECE(RAEX(0),"^",17)
+15 SET RARPT=$SELECT($ORDER(^RARPT(RARPT,"R",0)):"Yes",1:"No")
+16 IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
if $GET(ZTSTOP)=1
SET RAXIT=1
if RAXIT
QUIT
+17 SET ^TMP($JOB,"RADLY",RADIV)=+$GET(^TMP($JOB,"RADLY",RADIV))+1
+18 SET ^TMP($JOB,"RADLY",RADIV,RAITYPE)=+$GET(^TMP($JOB,"RADLY",RADIV,RAITYPE))+1
+19 SET ^TMP($JOB,"RADLY",RADIV,RAITYPE,RAILOC)=+$GET(^TMP($JOB,"RADLY",RADIV,RAITYPE,RAILOC))+1
+20 SET RADIVTY=+$GET(RADIVTY)+1
+21 NEW RASSAN,RACNDSP
SET RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
+22 SET RACNDSP=$SELECT((RASSAN'=""):RASSAN,1:RACN)
+23 IF $$USESSAN^RAHLRU1()
SET ^TMP($JOB,"RADLY",RADIV,RAITYPE,RAILOC,RANME,RADTE,RACNI)=RACNDSP_"^"_RAPRC_"^"_RAST_"^"_RATME_"^"_RAWHE_"^"_RARPT_"^"_RASSN
+24 IF '$$USESSAN^RAHLRU1()
SET ^TMP($JOB,"RADLY",RADIV,RAITYPE,RAILOC,RANME,RADTE,RACNI)=RACN_"^"_RAPRC_"^"_RAST_"^"_RATME_"^"_RAWHE_"^"_RARPT_"^"_RASSN
+25 QUIT
SYNOP ; Synopsis of data presented to the user.
+1 SET A=""
+2 WRITE !?RATAB(2),"Division",!?RATAB(2)+3,"Imaging Type",!?RATAB(2)+6,"Imaging Location(s)",!
SYN1 SET A=$ORDER(^TMP($JOB,"RADLY",A))
if A']""
QUIT
+1 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HD^RADLY1
if RAXIT
QUIT
+2 WRITE !!?RATAB(2),$PIECE($GET(^DIC(4,A,0)),"^")
SET B=""
SYN2 SET B=$ORDER(^TMP($JOB,"RADLY",A,B))
if B']""
GOTO SYN1
+1 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HD^RADLY1
if RAXIT
QUIT
+2 WRITE !?RATAB(2)+3,B,!?RATAB(2)+6
SET C=""
SYN3 SET C=$ORDER(^TMP($JOB,"RADLY",A,B,C))
if C']""
GOTO SYN2
+1 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HD^RADLY1
if RAXIT
QUIT
+2 if $X>(IOM-30)
WRITE !?RATAB(2)+6
+3 WRITE C,?($X+3)
+4 GOTO SYN3
