RAWFR4 ;HISC/GJC-'Wasted Film Report' (4 of 4) ;10/7/94 14:28
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
DISPLAY(A) ; Outputs the I-Types associated with a division
; The division name is passed in as a parameter.
N B,RATAB S B="",RATAB=3
W !!,"Division: ",A,!?RATAB,"Imaging Type(s): "
F S B=$O(RACCESS(DUZ,"DIV-IMG",A,B)) Q:B']"" D Q:RAXIT
. I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5() Q:RAXIT D HDR^RAWFR3
. W:$X>(IOM-30) !?($X+RATAB+$L("Imaging Type(s): "))
. W B,?($X+RATAB)
. Q
Q
DISPXAM(A) ; Display Examination Statuses which meet certain criteria.
; 'A' is the equivalent of the variable 'RAWFR'. This code is related
; to the 'CRIT^RAUTL1' subroutine. This sets up the RAWFR 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 RAWFR(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
ZEROUT ; Zero out global array totals for division/i-type
N X,Y,Z S RATOT=0,X="",Z=$S(RASYN=1:"S",1:"NS")
F S X=$O(RACCESS(DUZ,"DIV-IMG",X)) Q:X']"" D
. Q:'$D(^TMP($J,"RA D-TYPE",X))
. S RATOT=RATOT+1,^TMP($J,"RA WFR",Z,X)=0,Y=""
. F S Y=$O(RACCESS(DUZ,"DIV-IMG",X,Y)) Q:Y']"" D
.. Q:'$D(^TMP($J,"RA I-TYPE",Y))
.. S ^TMP($J,"RA WFR",Z,X,"I",Y)=0
.. S ^TMP($J,"RA WFR",Z,X,"I",Y,"F"," ")=0
.. S ^TMP($J,"RA WFR",Z,X,"I",Y,"WF"," ")=0
.. Q
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAWFR4 2159 printed Dec 13, 2024@02:40:39 Page 2
RAWFR4 ;HISC/GJC-'Wasted Film Report' (4 of 4) ;10/7/94 14:28
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
DISPLAY(A) ; Outputs the I-Types associated with a division
+1 ; The division name is passed in as a parameter.
+2 NEW B,RATAB
SET B=""
SET RATAB=3
+3 WRITE !!,"Division: ",A,!?RATAB,"Imaging Type(s): "
+4 FOR
SET B=$ORDER(RACCESS(DUZ,"DIV-IMG",A,B))
if B']""
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5()
if RAXIT
QUIT
DO HDR^RAWFR3
+6 if $X>(IOM-30)
WRITE !?($X+RATAB+$LENGTH("Imaging Type(s): "))
+7 WRITE B,?($X+RATAB)
+8 QUIT
End DoDot:1
if RAXIT
QUIT
+9 QUIT
DISPXAM(A) ; Display Examination Statuses which meet certain criteria.
+1 ; 'A' is the equivalent of the variable 'RAWFR'. This code is related
+2 ; to the 'CRIT^RAUTL1' subroutine. This sets up the RAWFR 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 RAWFR(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
ZEROUT ; Zero out global array totals for division/i-type
+1 NEW X,Y,Z
SET RATOT=0
SET X=""
SET Z=$SELECT(RASYN=1:"S",1:"NS")
+2 FOR
SET X=$ORDER(RACCESS(DUZ,"DIV-IMG",X))
if X']""
QUIT
Begin DoDot:1
+3 if '$DATA(^TMP($JOB,"RA D-TYPE",X))
QUIT
+4 SET RATOT=RATOT+1
SET ^TMP($JOB,"RA WFR",Z,X)=0
SET Y=""
+5 FOR
SET Y=$ORDER(RACCESS(DUZ,"DIV-IMG",X,Y))
if Y']""
QUIT
Begin DoDot:2
+6 if '$DATA(^TMP($JOB,"RA I-TYPE",Y))
QUIT
+7 SET ^TMP($JOB,"RA WFR",Z,X,"I",Y)=0
+8 SET ^TMP($JOB,"RA WFR",Z,X,"I",Y,"F"," ")=0
+9 SET ^TMP($JOB,"RA WFR",Z,X,"I",Y,"WF"," ")=0
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
