RALWKL1 ;HISC/GJC-Workload Reports By Functional Area ;4/12/96 10:18
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
EN1 ; Entry point
S X="NOW",%DT="T" D ^%DT K %DT D D^RAUTL S RATDY=Y,$P(RALN,"-",81)=""
S BEGDATE("X")=$$FMTE^XLFDT(BEGDATE,1)
S ENDDATE("X")=$$FMTE^XLFDT(ENDDATE,1),RAPG=0 W:$Y>0 @IOF
I RASUM D EN1^RALWKL4 Q ; Do summary report quit.
S RADIV=$O(^TMP($J,"RA","")),RAIMG=$O(^TMP($J,"RA",RADIV,""))
S RADIV="" F S RADIV=$O(^TMP($J,"RA",RADIV)) Q:RADIV']"" D Q:RAXIT
. S RAIMG="" F S RAIMG=$O(^TMP($J,"RA",RADIV,RAIMG)) Q:RAIMG']"" D Q:RAXIT
.. S RAFLD=""
.. F S RAFLD=$O(^TMP($J,"RA",RADIV,RAIMG,RAFLD)) Q:RAFLD']"" D Q:RAXIT
... S RATTL0=$G(^TMP($J,"RA",RADIV,RAIMG,RAFLD)),RAWWU1=$P(RATTL0,"^",5)
... S RATTL1=0 F I=1:1:4 S RATTL1=RATTL1+$P(RATTL0,"^",I)
... S RAMIS=0
... F S RAMIS=$O(^TMP($J,"RA",RADIV,RAIMG,RAFLD,RAMIS)) Q:RAMIS'>0 D Q:RAXIT
.... Q:RAMIS'<25&(RAMIS'=27)&(RAMIS'=99) S RAPRC=""
.... F S RAPRC=$O(^TMP($J,"RA",RADIV,RAIMG,RAFLD,RAMIS,RAPRC)) Q:RAPRC']"" D Q:RAXIT
..... D PRT1
..... Q
.... Q
... D:'RAXIT TOT
... Q
.. D:'RAXIT IMGCHK^RALWKL2
.. Q
. D:'RAXIT&(RADIFLG(RADIV)>1) DIVCHK^RALWKL2
. Q
Q
PRT1 ; Tabulate the data for non summary report, output the data.
S RATTL2=$G(^TMP($J,"RA",RADIV,RAIMG,RAFLD,RAMIS,RAPRC))
S RAWWU2=$P(RATTL2,"^",5),RATTL3=0 ; Total up the first four pieces.
F I=1:1:4 S RATTL3=RATTL3+$P(RATTL2,"^",I)
D:'RAPG HD Q:RAXIT
I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD Q:RAXIT
W !,$E(RAPRC,1,28),?30,$J(+$P(RATTL2,"^"),5),?36,$J(+$P(RATTL2,"^",2),5)
W ?42,$J(+$P(RATTL2,"^",3),5),?48,$J(+$P(RATTL2,"^",4),5)
W ?55,$J(RATTL3,5),?62,$J($S(RATTL1:(100*RATTL3)/RATTL1,1:0),5,1)
I $D(RAFL) D
. W ?68,$J(RAWWU2,5),?75,$J($S(RAWWU1:(RAWWU2*100)/RAWWU1,1:0),5,1)
. Q
Q
TOT ; Total within Service, Ward, Clinic, etc.
I 'RATTL1,('RAWWU1) Q
I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() D:'RAXIT HD Q:RAXIT
W !!,$G(RATITLE)_" Total"
W ?30,$J(+$P(RATTL0,"^"),5),?36,$J(+$P(RATTL0,"^",2),5)
W ?42,$J(+$P(RATTL0,"^",3),5),?48,$J(+$P(RATTL0,"^",4),5)
W ?55,$J(RATTL1,5)
W:$D(RAFL) ?68,$J(RAWWU1,5)
W !,RALN N RA1 S RA1=$O(^TMP($J,"RA",RADIV,RAIMG,RAFLD))
I RA1]"" N RAFLD S RAFLD=RA1,RAXIT=$$EOS^RAUTL5() D:'RAXIT HD
Q
HD ; Header
I RAPG!($E(IOST,1,2)="C-") W:$Y>0 @IOF
S RAPG=RAPG+1
W !?5,">>> "_RATITLE_" Workload Report <<<"
W ?70,"Page: ",RAPG
W !!?4,"Division: ",$S($D(^DIC(4,+RADIV,0)):$P(^(0),U,1),1:"UNKNOWN")
W:'$D(RADIVSUM) !,"Imaging Type: ",$S($D(^RA(79.2,+$P(RAIMG,"-",2),0)):$P(^(0),U,1),1:"UNKNOWN")
W ?52,"For period: ",?64,BEGDATE("X"),?77,"to"
W !?4,"Run Date: ",RATDY,?64,ENDDATE("X")
W !!?32,"-------Examinations------",!?62,"% of" W:$D(RAFL) ?75," % of"
W !,$S('RASUM:"Procedure",1:RATITLE),?30," Inpt",?36," Opt"
W ?42," Res",?48,"Other",?55,"Total",?62,"Exams"
W:$D(RAFL) ?68," WWU",?75," WWU"
W !,RALN
W:$D(RADIVSUM) !?10,"(Division Summary)" ; set in DIVCHK^RALWKL2
W:$D(RAIMGSUM) !?10,"(Imaging Type Summary)" ; set in IMGCHK^RALWKL2
W:'$D(RADIVSUM)&('$D(RAIMGSUM))&('RASUM) !?10,RATITLE,": ",$G(RAFLD)
I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1
Q
DISPXAM(A) ; Display Examination Statuses which meet certain criteria.
; 'A' is the equivalent of the variable 'RACRT'. This code is related
; to the 'CRIT^RAUTL1' subroutine. This sets up the RACRT local array
; according to I-Type.
N RA,RAHD,UNDRLN,X,Y,Z
S RAHD(0)="The entries printed for this report will be based only"
S RAHD(1)="on exams that are in one of the following statuses:"
W !!?(IOM-$L(RAHD(0))\2),RAHD(0),!?(IOM-$L(RAHD(1))\2),RAHD(1)
S X="" F S X=$O(^TMP($J,"RA I-TYPE",X)) Q:X']"" D Q:RAXIT
. I $D(^RA(72,"AA",X)) K UNDRLN S Y="" D
.. I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT W @IOF
.. S $P(UNDRLN,"-",($L(X)+1))="" W !!?10,X,!?10,UNDRLN
.. F S Y=$O(^RA(72,"AA",X,Y)) Q:Y']"" D Q:RAXIT
... S Z=0 F S Z=$O(^RA(72,"AA",X,Y,Z)) Q:'Z D Q:RAXIT
.... S RA(0)=$G(^RA(72,Z,0)),RA(.3)=$G(^RA(72,Z,.3))
.... S RA(.3,A)=$P(RA(.3),"^",A)
.... I RA(0)]"",(RA(.3)]""),(RA(.3,A)]""),("Yy"[RA(.3,A)) D
..... S RACRT(Z)=X ; Where 'X' is the I-Type
..... I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D
...... W @IOF,!?10,X,!?10,UNDRLN
...... Q
..... W !?15,$P(RA(0),"^")
..... Q
.... Q
... Q
.. Q
. Q
Q
RALWKL1 ;HISC/GJC-Workload Reports By Functional Area ;4/12/96 10:18
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
EN1 ; Entry point
+1 SET X="NOW"
SET %DT="T"
DO ^%DT
KILL %DT
DO D^RAUTL
SET RATDY=Y
SET $PIECE(RALN,"-",81)=""
+2 SET BEGDATE("X")=$$FMTE^XLFDT(BEGDATE,1)
+3 SET ENDDATE("X")=$$FMTE^XLFDT(ENDDATE,1)
SET RAPG=0
IF $Y>0
WRITE @IOF
+4 ; Do summary report quit.
IF RASUM
DO EN1^RALWKL4
QUIT
+5 SET RADIV=$ORDER(^TMP($JOB,"RA",""))
SET RAIMG=$ORDER(^TMP($JOB,"RA",RADIV,""))
+6 SET RADIV=""
FOR
SET RADIV=$ORDER(^TMP($JOB,"RA",RADIV))
IF RADIV']""
QUIT
Begin DoDot:1
+7 SET RAIMG=""
FOR
SET RAIMG=$ORDER(^TMP($JOB,"RA",RADIV,RAIMG))
IF RAIMG']""
QUIT
Begin DoDot:2
+8 SET RAFLD=""
+9 FOR
SET RAFLD=$ORDER(^TMP($JOB,"RA",RADIV,RAIMG,RAFLD))
IF RAFLD']""
QUIT
Begin DoDot:3
+10 SET RATTL0=$GET(^TMP($JOB,"RA",RADIV,RAIMG,RAFLD))
SET RAWWU1=$PIECE(RATTL0,"^",5)
+11 SET RATTL1=0
FOR I=1:1:4
SET RATTL1=RATTL1+$PIECE(RATTL0,"^",I)
+12 SET RAMIS=0
+13 FOR
SET RAMIS=$ORDER(^TMP($JOB,"RA",RADIV,RAIMG,RAFLD,RAMIS))
IF RAMIS'>0
QUIT
Begin DoDot:4
+14 IF RAMIS'<25&(RAMIS'=27)&(RAMIS'=99)
QUIT
SET RAPRC=""
+15 FOR
SET RAPRC=$ORDER(^TMP($JOB,"RA",RADIV,RAIMG,RAFLD,RAMIS,RAPRC))
IF RAPRC']""
QUIT
Begin DoDot:5
+16 DO PRT1
+17 QUIT
End DoDot:5
IF RAXIT
QUIT
+18 QUIT
End DoDot:4
IF RAXIT
QUIT
+19 IF 'RAXIT
DO TOT
+20 QUIT
End DoDot:3
IF RAXIT
QUIT
+21 IF 'RAXIT
DO IMGCHK^RALWKL2
+22 QUIT
End DoDot:2
IF RAXIT
QUIT
+23 IF 'RAXIT&(RADIFLG(RADIV)>1)
DO DIVCHK^RALWKL2
+24 QUIT
End DoDot:1
IF RAXIT
QUIT
+25 QUIT
PRT1 ; Tabulate the data for non summary report, output the data.
+1 SET RATTL2=$GET(^TMP($JOB,"RA",RADIV,RAIMG,RAFLD,RAMIS,RAPRC))
+2 ; Total up the first four pieces.
SET RAWWU2=$PIECE(RATTL2,"^",5)
SET RATTL3=0
+3 FOR I=1:1:4
SET RATTL3=RATTL3+$PIECE(RATTL2,"^",I)
+4 IF 'RAPG
DO HD
IF RAXIT
QUIT
+5 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
IF 'RAXIT
DO HD
IF RAXIT
QUIT
+6 WRITE !,$EXTRACT(RAPRC,1,28),?30,$JUSTIFY(+$PIECE(RATTL2,"^"),5),?36,$JUSTIFY(+$PIECE(RATTL2,"^",2),5)
+7 WRITE ?42,$JUSTIFY(+$PIECE(RATTL2,"^",3),5),?48,$JUSTIFY(+$PIECE(RATTL2,"^",4),5)
+8 WRITE ?55,$JUSTIFY(RATTL3,5),?62,$JUSTIFY($SELECT(RATTL1:(100*RATTL3)/RATTL1,1:0),5,1)
+9 IF $DATA(RAFL)
Begin DoDot:1
+10 WRITE ?68,$JUSTIFY(RAWWU2,5),?75,$JUSTIFY($SELECT(RAWWU1:(RAWWU2*100)/RAWWU1,1:0),5,1)
+11 QUIT
End DoDot:1
+12 QUIT
TOT ; Total within Service, Ward, Clinic, etc.
+1 IF 'RATTL1
IF ('RAWWU1)
QUIT
+2 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
IF 'RAXIT
DO HD
IF RAXIT
QUIT
+3 WRITE !!,$GET(RATITLE)_" Total"
+4 WRITE ?30,$JUSTIFY(+$PIECE(RATTL0,"^"),5),?36,$JUSTIFY(+$PIECE(RATTL0,"^",2),5)
+5 WRITE ?42,$JUSTIFY(+$PIECE(RATTL0,"^",3),5),?48,$JUSTIFY(+$PIECE(RATTL0,"^",4),5)
+6 WRITE ?55,$JUSTIFY(RATTL1,5)
+7 IF $DATA(RAFL)
WRITE ?68,$JUSTIFY(RAWWU1,5)
+8 WRITE !,RALN
NEW RA1
SET RA1=$ORDER(^TMP($JOB,"RA",RADIV,RAIMG,RAFLD))
+9 IF RA1]""
NEW RAFLD
SET RAFLD=RA1
SET RAXIT=$$EOS^RAUTL5()
IF 'RAXIT
DO HD
+10 QUIT
HD ; Header
+1 IF RAPG!($EXTRACT(IOST,1,2)="C-")
IF $Y>0
WRITE @IOF
+2 SET RAPG=RAPG+1
+3 WRITE !?5,">>> "_RATITLE_" Workload Report <<<"
+4 WRITE ?70,"Page: ",RAPG
+5 WRITE !!?4,"Division: ",$SELECT($DATA(^DIC(4,+RADIV,0)):$PIECE(^(0),U,1),1:"UNKNOWN")
+6 IF '$DATA(RADIVSUM)
WRITE !,"Imaging Type: ",$SELECT($DATA(^RA(79.2,+$PIECE(RAIMG,"-",2),0)):$PIECE(^(0),U,1),1:"UNKNOWN")
+7 WRITE ?52,"For period: ",?64,BEGDATE("X"),?77,"to"
+8 WRITE !?4,"Run Date: ",RATDY,?64,ENDDATE("X")
+9 WRITE !!?32,"-------Examinations------",!?62,"% of"
IF $DATA(RAFL)
WRITE ?75," % of"
+10 WRITE !,$SELECT('RASUM:"Procedure",1:RATITLE),?30," Inpt",?36," Opt"
+11 WRITE ?42," Res",?48,"Other",?55,"Total",?62,"Exams"
+12 IF $DATA(RAFL)
WRITE ?68," WWU",?75," WWU"
+13 WRITE !,RALN
+14 ; set in DIVCHK^RALWKL2
IF $DATA(RADIVSUM)
WRITE !?10,"(Division Summary)"
+15 ; set in IMGCHK^RALWKL2
IF $DATA(RAIMGSUM)
WRITE !?10,"(Imaging Type Summary)"
+16 IF '$DATA(RADIVSUM)&('$DATA(RAIMGSUM))&('RASUM)
WRITE !?10,RATITLE,": ",$GET(RAFLD)
+17 IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
IF $GET(ZTSTOP)=1
SET RAXIT=1
+18 QUIT
DISPXAM(A) ; Display Examination Statuses which meet certain criteria.
+1 ; 'A' is the equivalent of the variable 'RACRT'. This code is related
+2 ; to the 'CRIT^RAUTL1' subroutine. This sets up the RACRT local array
+3 ; according to I-Type.
+4 NEW RA,RAHD,UNDRLN,X,Y,Z
+5 SET RAHD(0)="The entries printed for this report will be based only"
+6 SET RAHD(1)="on exams that are in one of the following statuses:"
+7 WRITE !!?(IOM-$LENGTH(RAHD(0))\2),RAHD(0),!?(IOM-$LENGTH(RAHD(1))\2),RAHD(1)
+8 SET X=""
FOR
SET X=$ORDER(^TMP($JOB,"RA I-TYPE",X))
IF X']""
QUIT
Begin DoDot:1
+9 IF $DATA(^RA(72,"AA",X))
KILL UNDRLN
SET Y=""
Begin DoDot:2
+10 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
IF RAXIT
QUIT
WRITE @IOF
+11 SET $PIECE(UNDRLN,"-",($LENGTH(X)+1))=""
WRITE !!?10,X,!?10,UNDRLN
+12 FOR
SET Y=$ORDER(^RA(72,"AA",X,Y))
IF Y']""
QUIT
Begin DoDot:3
+13 SET Z=0
FOR
SET Z=$ORDER(^RA(72,"AA",X,Y,Z))
IF 'Z
QUIT
Begin DoDot:4
+14 SET RA(0)=$GET(^RA(72,Z,0))
SET RA(.3)=$GET(^RA(72,Z,.3))
+15 SET RA(.3,A)=$PIECE(RA(.3),"^",A)
+16 IF RA(0)]""
IF (RA(.3)]"")
IF (RA(.3,A)]"")
IF ("Yy"[RA(.3,A))
Begin DoDot:5
+17 ; Where 'X' is the I-Type
SET RACRT(Z)=X
+18 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
IF RAXIT
QUIT
Begin DoDot:6
+19 WRITE @IOF,!?10,X,!?10,UNDRLN
+20 QUIT
End DoDot:6
+21 WRITE !?15,$PIECE(RA(0),"^")
+22 QUIT
End DoDot:5
+23 QUIT
End DoDot:4
IF RAXIT
QUIT
+24 QUIT
End DoDot:3
IF RAXIT
QUIT
+25 QUIT
End DoDot:2
+26 QUIT
End DoDot:1
IF RAXIT
QUIT
+27 QUIT
