RALWKL2 ;HISC/GJC-Workload Reports By Functional Area ;4/12/96 10:15
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
DIVCHK ; Output statistics within division.
N RA1,RAIMG,RASUM,RATTL0,RATTL1,RAWWU1
S (RA1,RAIMG,RADIVSUM)="",RASUM=1
S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
S RATTL0=$G(^TMP($J,"RA",RADIV)),RAWWU1=+$P(RATTL0,"^",5)
F I=1:1:4 S RATTL1=+$G(RATTL1)+(+$P(RATTL0,"^",I))
F S RA1=$O(^TMP($J,"RA1",RADIV,RA1)) Q:RA1']"" D Q:RAXIT
. I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
. S (RATTL2,RATTL3,RAWWU2)=0
. S RATTL2=$G(^TMP($J,"RA1",RADIV,RA1)),RAWWU2=$P(RATTL2,"^",5)
. F I=1:1:4 S RATTL3=+$G(RATTL3)+(+$P(RATTL2,"^",I))
. W !,$E(RA1,1,28),?30,$J(+$P(RATTL2,"^"),5)
. W ?36,$J(+$P(RATTL2,"^",2),5),?42,$J(+$P(RATTL2,"^",3),5)
. W ?48,$J(+$P(RATTL2,"^",4),5),?55,$J(RATTL3,5)
. W:$D(RAFL) ?62,$J($S(RATTL1:(100*RATTL3)/RATTL1,1:0),5,1)
. W ?68,$J(RAWWU2,5)
. W:$D(RAFL) ?75,$J($S(RAWWU1:(100*RAWWU2)/RAWWU1,1:0),5,1)
. Q
Q:RAXIT
I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
K RADIVSUM
W !,RALN,!!,"Division Total",?30,$J(+$P(RATTL0,"^"),5)
W ?36,$J(+$P(RATTL0,"^",2),5),?42,$J(+$P(RATTL0,"^",3),5)
W ?48,$J(+$P(RATTL0,"^",4),5),?55,$J(RATTL1,5) W:$D(RAFL) ?68,$J(RAWWU1,5)
I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
W !!?2,"Imaging Type(s): "
S RAITHLD=""
F S RAITHLD=$O(^TMP($J,"RA",RADIV,RAITHLD)) Q:RAXIT!(RAITHLD="") W:$X>(80-25) !?($X+$L("Imaging Type(s):")+3) D
.I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
.W $S($D(^RA(79.2,+$P(RAITHLD,"-",2),0)):$P(^(0),U,1),1:"UNKNOWN"),?($X+3)
K RAITHLD Q:RAXIT
W !!?3,"# of "_RATITLE_"s selected: "_$S(RAINPUT=1:"ALL",1:$G(RAFLDCNT))
S RA1=$O(^TMP($J,"RA",RADIV))
I RA1]"" N RADIV,RAIMG,RAFLD S RADIV=RA1,RASUM=0 D
. S RA11=$O(^TMP($J,"RA",RADIV,"")) S:RA11]"" RAIMG=RA11
. I $G(RAIMG)]"" S RA111=$O(^TMP($J,"RA",RADIV,RAIMG,"")) S:RA111]"" RAFLD=RA111 I $G(RAFLD)]"" S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1
. Q
Q
IMGCHK ; Check for EOS on I-Type
N RA1,RA11,RA111,RASUM,RATTL0,RATTL1,RATTL2,RATTL3,RAWWU1,RAWWU2
S (RA111,RAIMGSUM)="",RASUM=1
I RAPG S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
D:'RAPG HD^RALWKL1 Q:RAXIT
S RATTL0=$G(^TMP($J,"RA",RADIV,RAIMG)),RAWWU1=+$P(RATTL0,"^",5)
F I=1:1:4 S RATTL1=+$G(RATTL1)+(+$P(RATTL0,"^",I))
F S RA111=$O(^TMP($J,"RA",RADIV,RAIMG,RA111)) Q:RA111']"" D Q:RAXIT
. I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
. S (RATTL2,RATTL3,RAWWU2)=0
. S RATTL2=$G(^TMP($J,"RA",RADIV,RAIMG,RA111)),RAWWU2=+$P(RATTL2,"^",5)
. F I=1:1:4 S RATTL3=+$G(RATTL3)+(+$P(RATTL2,"^",I))
. W !,$E(RA111,1,28),?30,$J(+$P(RATTL2,"^"),5)
. W ?36,$J(+$P(RATTL2,"^",2),5),?42,$J(+$P(RATTL2,"^",3),5)
. W ?48,$J(+$P(RATTL2,"^",4),5),?55,$J(RATTL3,5)
. W:$D(RAFL) ?62,$J($S(RATTL1:(100*RATTL3)/RATTL1,1:0),5,1)
. W ?68,$J(RAWWU2,5)
. W:$D(RAFL) ?75,$J($S(RAWWU1:(100*RAWWU2)/RAWWU1,1:0),5,1)
. Q
I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1 Q:RAXIT
K RAIMGSUM
W !,RALN,!!,"Imaging Type Total",?30,$J(+$P(RATTL0,"^"),5)
W ?36,$J(+$P(RATTL0,"^",2),5),?42,$J(+$P(RATTL0,"^",3),5)
W ?48,$J(+$P(RATTL0,"^",4),5),?55,$J(RATTL1,5),?68,$J(RAWWU1,5)
W !!?3,"# of "_RATITLE_"s selected: "_$S(RAINPUT=1:"ALL",1:$G(RAFLDCNT))
S RA1=$O(^TMP($J,"RA",RADIV,RAIMG))
I RA1]"" N RAFLD,RAIMG S RAIMG=RA1,RASUM=0 D
. S RA11=$O(^TMP($J,"RA",RADIV,RAIMG,"")) Q:RA11']"" S RAFLD=RA11
. S RA111=$O(^TMP($J,"RA",RADIV,RAIMG,RAFLD,"")) Q:RA111']""
. S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD^RALWKL1
. Q
Q
PURGE ; Kill & Quit
K %DT,A,A1,B,B1,BEGDATE,C,DIROUT,DIRUT,DTOUT,DUOUT,ENDDATE,I,J,RA1,RA11
K RA111,RABEG,RACNI,RACRT,RAD0,RADFN,RADIV,RADIFLG
K RADIVNME,RADIVSUM,RADTE,RADTI,RAEND,RAFILE,RAFL,RAFL1,RAFLD,RAFLDCNT,RAIMG,RAIMGSUM
K RAINPUT,RALN,RALN1,RAMES,RAMIS,RANUM,RAP0,RAPCE,RAPG,RAPOP,RAPRC
K RAPRI,RAQI,RAQUIT,RASUM,RASV,RATDY,RATITLE,RATTL0,RATTL1,RATTL2
K RATTL3,RAWWU1,RAWWU2,RAXIT,X,Y,ZTDESC,ZTRTN,ZTSAVE
K ^TMP($J,"RA"),^TMP($J,"RA1"),^TMP($J,"RA D-TYPE"),^TMP($J,"RA I-TYPE")
K ^TMP($J,"RAFLD") K:$D(RAPSTX) RACCESS,RAPSTX D CLOSE^RAUTL K POP
Q
ZEROUT ; Zero out the data globals.
N A,A1,B,B1
S A="" F S A=$O(RACCESS(DUZ,"DIV-IMG",A)) Q:A']"" D
. Q:'$D(^TMP($J,"RA D-TYPE",A)) S A1=$O(^TMP($J,"RA D-TYPE",A,0)) Q:A1'>0 S RADIFLG(A1)=0
. S ^TMP($J,"RA",A1)="0^0^0^0^0",B=""
. F S B=$O(RACCESS(DUZ,"DIV-IMG",A,B)) Q:B']"" D
.. Q:'$D(^TMP($J,"RA I-TYPE",B)) D IT Q:B1'?3AP1"-".N S RADIFLG(A1)=RADIFLG(A1)+1
.. S ^TMP($J,"RA",A1,B1)="0^0^0^0^0"
.. Q
. Q
K RACCESS(DUZ,"DIV-IMG")
Q
IT ; calculate imaging type subscript
S B1=$O(^RA(79.2,"B",B,0)) Q:B1'>0
S B1=$E($P($G(^RA(79.2,+B1,0)),U,1),1,3)_"-"_B1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRALWKL2 4793 printed Apr 09, 2024@21:38:14 Page 2
RALWKL2 ;HISC/GJC-Workload Reports By Functional Area ;4/12/96 10:15
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
DIVCHK ; Output statistics within division.
+1 NEW RA1,RAIMG,RASUM,RATTL0,RATTL1,RAWWU1
+2 SET (RA1,RAIMG,RADIVSUM)=""
SET RASUM=1
+3 SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HD^RALWKL1
if RAXIT
QUIT
+4 SET RATTL0=$GET(^TMP($JOB,"RA",RADIV))
SET RAWWU1=+$PIECE(RATTL0,"^",5)
+5 FOR I=1:1:4
SET RATTL1=+$GET(RATTL1)+(+$PIECE(RATTL0,"^",I))
+6 FOR
SET RA1=$ORDER(^TMP($JOB,"RA1",RADIV,RA1))
if RA1']""
QUIT
Begin DoDot:1
+7 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HD^RALWKL1
if RAXIT
QUIT
+8 SET (RATTL2,RATTL3,RAWWU2)=0
+9 SET RATTL2=$GET(^TMP($JOB,"RA1",RADIV,RA1))
SET RAWWU2=$PIECE(RATTL2,"^",5)
+10 FOR I=1:1:4
SET RATTL3=+$GET(RATTL3)+(+$PIECE(RATTL2,"^",I))
+11 WRITE !,$EXTRACT(RA1,1,28),?30,$JUSTIFY(+$PIECE(RATTL2,"^"),5)
+12 WRITE ?36,$JUSTIFY(+$PIECE(RATTL2,"^",2),5),?42,$JUSTIFY(+$PIECE(RATTL2,"^",3),5)
+13 WRITE ?48,$JUSTIFY(+$PIECE(RATTL2,"^",4),5),?55,$JUSTIFY(RATTL3,5)
+14 if $DATA(RAFL)
WRITE ?62,$JUSTIFY($SELECT(RATTL1:(100*RATTL3)/RATTL1,1:0),5,1)
+15 WRITE ?68,$JUSTIFY(RAWWU2,5)
+16 if $DATA(RAFL)
WRITE ?75,$JUSTIFY($SELECT(RAWWU1:(100*RAWWU2)/RAWWU1,1:0),5,1)
+17 QUIT
End DoDot:1
if RAXIT
QUIT
+18 if RAXIT
QUIT
+19 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HD^RALWKL1
if RAXIT
QUIT
+20 KILL RADIVSUM
+21 WRITE !,RALN,!!,"Division Total",?30,$JUSTIFY(+$PIECE(RATTL0,"^"),5)
+22 WRITE ?36,$JUSTIFY(+$PIECE(RATTL0,"^",2),5),?42,$JUSTIFY(+$PIECE(RATTL0,"^",3),5)
+23 WRITE ?48,$JUSTIFY(+$PIECE(RATTL0,"^",4),5),?55,$JUSTIFY(RATTL1,5)
if $DATA(RAFL)
WRITE ?68,$JUSTIFY(RAWWU1,5)
+24 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HD^RALWKL1
if RAXIT
QUIT
+25 WRITE !!?2,"Imaging Type(s): "
+26 SET RAITHLD=""
+27 FOR
SET RAITHLD=$ORDER(^TMP($JOB,"RA",RADIV,RAITHLD))
if RAXIT!(RAITHLD="")
QUIT
if $X>(80-25)
WRITE !?($X+$LENGTH("Imaging Type(s):")+3)
Begin DoDot:1
+28 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HD^RALWKL1
if RAXIT
QUIT
+29 WRITE $SELECT($DATA(^RA(79.2,+$PIECE(RAITHLD,"-",2),0)):$PIECE(^(0),U,1),1:"UNKNOWN"),?($X+3)
End DoDot:1
+30 KILL RAITHLD
if RAXIT
QUIT
+31 WRITE !!?3,"# of "_RATITLE_"s selected: "_$SELECT(RAINPUT=1:"ALL",1:$GET(RAFLDCNT))
+32 SET RA1=$ORDER(^TMP($JOB,"RA",RADIV))
+33 IF RA1]""
NEW RADIV,RAIMG,RAFLD
SET RADIV=RA1
SET RASUM=0
Begin DoDot:1
+34 SET RA11=$ORDER(^TMP($JOB,"RA",RADIV,""))
if RA11]""
SET RAIMG=RA11
+35 IF $GET(RAIMG)]""
SET RA111=$ORDER(^TMP($JOB,"RA",RADIV,RAIMG,""))
if RA111]""
SET RAFLD=RA111
IF $GET(RAFLD)]""
SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HD^RALWKL1
+36 QUIT
End DoDot:1
+37 QUIT
IMGCHK ; Check for EOS on I-Type
+1 NEW RA1,RA11,RA111,RASUM,RATTL0,RATTL1,RATTL2,RATTL3,RAWWU1,RAWWU2
+2 SET (RA111,RAIMGSUM)=""
SET RASUM=1
+3 IF RAPG
SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HD^RALWKL1
if RAXIT
QUIT
+4 if 'RAPG
DO HD^RALWKL1
if RAXIT
QUIT
+5 SET RATTL0=$GET(^TMP($JOB,"RA",RADIV,RAIMG))
SET RAWWU1=+$PIECE(RATTL0,"^",5)
+6 FOR I=1:1:4
SET RATTL1=+$GET(RATTL1)+(+$PIECE(RATTL0,"^",I))
+7 FOR
SET RA111=$ORDER(^TMP($JOB,"RA",RADIV,RAIMG,RA111))
if RA111']""
QUIT
Begin DoDot:1
+8 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HD^RALWKL1
if RAXIT
QUIT
+9 SET (RATTL2,RATTL3,RAWWU2)=0
+10 SET RATTL2=$GET(^TMP($JOB,"RA",RADIV,RAIMG,RA111))
SET RAWWU2=+$PIECE(RATTL2,"^",5)
+11 FOR I=1:1:4
SET RATTL3=+$GET(RATTL3)+(+$PIECE(RATTL2,"^",I))
+12 WRITE !,$EXTRACT(RA111,1,28),?30,$JUSTIFY(+$PIECE(RATTL2,"^"),5)
+13 WRITE ?36,$JUSTIFY(+$PIECE(RATTL2,"^",2),5),?42,$JUSTIFY(+$PIECE(RATTL2,"^",3),5)
+14 WRITE ?48,$JUSTIFY(+$PIECE(RATTL2,"^",4),5),?55,$JUSTIFY(RATTL3,5)
+15 if $DATA(RAFL)
WRITE ?62,$JUSTIFY($SELECT(RATTL1:(100*RATTL3)/RATTL1,1:0),5,1)
+16 WRITE ?68,$JUSTIFY(RAWWU2,5)
+17 if $DATA(RAFL)
WRITE ?75,$JUSTIFY($SELECT(RAWWU1:(100*RAWWU2)/RAWWU1,1:0),5,1)
+18 QUIT
End DoDot:1
if RAXIT
QUIT
+19 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HD^RALWKL1
if RAXIT
QUIT
+20 KILL RAIMGSUM
+21 WRITE !,RALN,!!,"Imaging Type Total",?30,$JUSTIFY(+$PIECE(RATTL0,"^"),5)
+22 WRITE ?36,$JUSTIFY(+$PIECE(RATTL0,"^",2),5),?42,$JUSTIFY(+$PIECE(RATTL0,"^",3),5)
+23 WRITE ?48,$JUSTIFY(+$PIECE(RATTL0,"^",4),5),?55,$JUSTIFY(RATTL1,5),?68,$JUSTIFY(RAWWU1,5)
+24 WRITE !!?3,"# of "_RATITLE_"s selected: "_$SELECT(RAINPUT=1:"ALL",1:$GET(RAFLDCNT))
+25 SET RA1=$ORDER(^TMP($JOB,"RA",RADIV,RAIMG))
+26 IF RA1]""
NEW RAFLD,RAIMG
SET RAIMG=RA1
SET RASUM=0
Begin DoDot:1
+27 SET RA11=$ORDER(^TMP($JOB,"RA",RADIV,RAIMG,""))
if RA11']""
QUIT
SET RAFLD=RA11
+28 SET RA111=$ORDER(^TMP($JOB,"RA",RADIV,RAIMG,RAFLD,""))
if RA111']""
QUIT
+29 SET RAXIT=$$EOS^RAUTL5()
if 'RAXIT
DO HD^RALWKL1
+30 QUIT
End DoDot:1
+31 QUIT
PURGE ; Kill & Quit
+1 KILL %DT,A,A1,B,B1,BEGDATE,C,DIROUT,DIRUT,DTOUT,DUOUT,ENDDATE,I,J,RA1,RA11
+2 KILL RA111,RABEG,RACNI,RACRT,RAD0,RADFN,RADIV,RADIFLG
+3 KILL RADIVNME,RADIVSUM,RADTE,RADTI,RAEND,RAFILE,RAFL,RAFL1,RAFLD,RAFLDCNT,RAIMG,RAIMGSUM
+4 KILL RAINPUT,RALN,RALN1,RAMES,RAMIS,RANUM,RAP0,RAPCE,RAPG,RAPOP,RAPRC
+5 KILL RAPRI,RAQI,RAQUIT,RASUM,RASV,RATDY,RATITLE,RATTL0,RATTL1,RATTL2
+6 KILL RATTL3,RAWWU1,RAWWU2,RAXIT,X,Y,ZTDESC,ZTRTN,ZTSAVE
+7 KILL ^TMP($JOB,"RA"),^TMP($JOB,"RA1"),^TMP($JOB,"RA D-TYPE"),^TMP($JOB,"RA I-TYPE")
+8 KILL ^TMP($JOB,"RAFLD")
if $DATA(RAPSTX)
KILL RACCESS,RAPSTX
DO CLOSE^RAUTL
KILL POP
+9 QUIT
ZEROUT ; Zero out the data globals.
+1 NEW A,A1,B,B1
+2 SET A=""
FOR
SET A=$ORDER(RACCESS(DUZ,"DIV-IMG",A))
if A']""
QUIT
Begin DoDot:1
+3 if '$DATA(^TMP($JOB,"RA D-TYPE",A))
QUIT
SET A1=$ORDER(^TMP($JOB,"RA D-TYPE",A,0))
if A1'>0
QUIT
SET RADIFLG(A1)=0
+4 SET ^TMP($JOB,"RA",A1)="0^0^0^0^0"
SET B=""
+5 FOR
SET B=$ORDER(RACCESS(DUZ,"DIV-IMG",A,B))
if B']""
QUIT
Begin DoDot:2
+6 if '$DATA(^TMP($JOB,"RA I-TYPE",B))
QUIT
DO IT
if B1'?3AP1"-".N
QUIT
SET RADIFLG(A1)=RADIFLG(A1)+1
+7 SET ^TMP($JOB,"RA",A1,B1)="0^0^0^0^0"
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 KILL RACCESS(DUZ,"DIV-IMG")
+11 QUIT
IT ; calculate imaging type subscript
+1 SET B1=$ORDER(^RA(79.2,"B",B,0))
if B1'>0
QUIT
+2 SET B1=$EXTRACT($PIECE($GET(^RA(79.2,+B1,0)),U,1),1,3)_"-"_B1
+3 QUIT
