RAWFR3 ;HISC/GJC-'Wasted Film Report' (3 of 4) ;4/15/96 07:12
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
;
COMP ; Compilation for 'Non-Summary' data
N RACINE,RAF0,RAHDRFG,RATIO,RAUSED,X2,X3,X4,Y0,Y1,Y2,Y3
S RAHDRFG=0,X2="" ; 'X2' is the division
F S X2=$O(^TMP($J,"RA WFR","NS",X2)) Q:X2']""!(RAXIT) D
. S Y0=$G(^TMP($J,"RA WFR","NS",X2)) ; 'Y0' total # of all films
. S X3="" ; 'X3' is the imaging location
. F S X3=$O(^TMP($J,"RA WFR","NS",X2,"I",X3)) Q:X3']""!(RAXIT) D
.. Q:'$D(^TMP($J,"RA WFR","NS",X2,"I",X3,"WF"))
.. I RAHDRFG S RAXIT=$$EOS^RAUTL5 Q:RAXIT
.. S RADIV=X2,RAIMG=X3,(Y0,Y3)=0 D HDR
.. ; films for a particular imaging type
.. S X4="" ; wasted film type if 'X1' is "F", tech if 'X1' is "T"
.. F S X4=$O(^TMP($J,"RA WFR","NS",X2,"I",X3,"WF",X4)) Q:X4']""!(RAXIT) D
... S RAUSED=+$O(^RA(78.4,"B",X4,0)) Q:'RAUSED
... S RAUSED=+$P(^RA(78.4,RAUSED,0),U,5) Q:'RAUSED
... S RAF0=$G(^RA(78.4,RAUSED,0))
... S RAUSED=$P(RAF0,U),RACINE=$S($P(RAF0,U,2)="Y":1,1:0)
... ;Q:'$D(^TMP($J,"RA WFR","NS",X2,"I",X3,"F",RAUSED))
... S Y2=$G(^TMP($J,"RA WFR","NS",X2,"I",X3,"F",RAUSED))
... S Y1=$G(^TMP($J,"RA WFR","NS",X2,"I",X3,"WF",X4))
... I 'RACINE S Y0=Y0+Y1,Y3=Y3+Y2 ; add to subtotals if not cine type
... ; 'Y3' is used for the division summary
... S RATIO=$S((Y1+Y2)>0:$J((Y1/(Y1+Y2))*100,5,1),1:0)
... W !,X4,?$S(IOM=132:60,1:35),Y2,?$S(IOM=132:75,1:45),Y1
... W ?$S(IOM=132:100,1:60),RATIO
... I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5 Q:RAXIT D HDR
... Q
.. Q:RAXIT W !!?$S(IOM=132:10,1:5),"Subtotals:"
.. W ?$S(IOM=132:60,1:35),$S('Y3:"",1:Y3)
.. W ?$S(IOM=132:75,1:45),Y0
.. W ?$S(IOM=132:100,1:60),$S((Y0+Y3)>0:$J((Y0/(Y0+Y3))*100,5,1),1:0)
.. S RAHDRFG=1 W !,RALINE
.. I $Y>(IOSL-4) S RAXIT=$$EOS^RAUTL5 Q:RAXIT D HDR
.. W !!?5,"* Cine data not included in totals."
.. Q
. Q:RAXIT
. I RATOT>1 D
.. N X S X=X2 N RASYN,RATIO,RAUSED,X1,X2,X3,X4,Y0,Y1,Y2,Y3
.. S RASYN=1 D SUMMARY^RAWFR2(X)
.. Q
. Q
Q
KILL ; Kill and quit
K %,%CHK,%RET,%Z,DIROUT,DIRUT,DTOUT,DUOUT,I,RABGDTI,RABGDTX,RACCESS
K RADATE,RADFN,RADIV,RADT,RADTI,RAENDTI,RAENDTX,RAEXST,RAEX,RAEX0
K RAEXS,RAFLM0,RAFLMNUM,RAFLMS,RAHEAD,RAIBGDT,RAIENDT,RAIMG,RALINE
K RAMBGDT,RAMENDT,RAMES,RAPG,RAPOP,RAQUIT,RARP0,RASYN,RATAG,RATDAY
K RATECH,RATOT,RAWFR,RAXIT,X,Y,Z,ZTDESC,ZTRTN,ZTSAVE,POP
K ^TMP($J,"RA D-TYPE"),^TMP($J,"RA I-TYPE")
K ^TMP($J,"RA WFR") K:$D(RAPSTX) RACCESS,RAPSTX
Q
HDR ; Display/Print the header for the report
W:$E(IOST,1,2)="C-" @IOF,!
W:$E(IOST,1,2)'="C-"&(+$G(RAPG)>0) @IOF,!
S RAPG=+$G(RAPG)+1
W !?(IOM-$L(RAHEAD)\2),RAHEAD,?$S(IOM=132:122,1:69),"Page: ",RAPG,!
I RASYN D
. W !?$S(IOM=132:10,1:5),"Division: ",$G(RADIV)
. W ?$S(IOM=132:85,1:50),"For Period: ",RABGDTX_" to"
. W !?$S(IOM=132:10,1:5),"Run Date: ",RATDAY
. W ?$S(IOM=132:97,1:62),RAENDTX_"."
E D
. W !?$S(IOM=132:10,1:5),"Division: ",$G(RADIV)
. W ?$S(IOM=132:85,1:50),"For Period: ",RABGDTX_" to"
. W !?$S(IOM=132:10,1:5),"Imaging Type: ",$G(RAIMG)
. W ?$S(IOM=132:97,1:62),RAENDTX_"."
. W !?$S(IOM=132:10,1:5),"Run Date: ",RATDAY
W !!?$S(IOM=132:60,1:35),"Units",?$S(IOM=132:75,1:45),"Units"
W ?$S(IOM=132:100,1:60),"Percentage"
W !?$S(IOM=132:60,1:35),"Of Used",?$S(IOM=132:75,1:45),"Of Wasted"
W ?$S(IOM=132:100,1:60),"Of Wasted"
W !,"Film Size",?$S(IOM=132:60,1:35),"Films"
W ?$S(IOM=132:75,1:45),"Films"
W ?$S(IOM=132:100,1:60),"Film"
W !,RALINE
W:RASYN !?$S(IOM=132:10,1:5),"(Division Summary)"
I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAXIT=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAWFR3 3586 printed Dec 13, 2024@02:40:38 Page 2
RAWFR3 ;HISC/GJC-'Wasted Film Report' (3 of 4) ;4/15/96 07:12
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
+2 ;
COMP ; Compilation for 'Non-Summary' data
+1 NEW RACINE,RAF0,RAHDRFG,RATIO,RAUSED,X2,X3,X4,Y0,Y1,Y2,Y3
+2 ; 'X2' is the division
SET RAHDRFG=0
SET X2=""
+3 FOR
SET X2=$ORDER(^TMP($JOB,"RA WFR","NS",X2))
if X2']""!(RAXIT)
QUIT
Begin DoDot:1
+4 ; 'Y0' total # of all films
SET Y0=$GET(^TMP($JOB,"RA WFR","NS",X2))
+5 ; 'X3' is the imaging location
SET X3=""
+6 FOR
SET X3=$ORDER(^TMP($JOB,"RA WFR","NS",X2,"I",X3))
if X3']""!(RAXIT)
QUIT
Begin DoDot:2
+7 if '$DATA(^TMP($JOB,"RA WFR","NS",X2,"I",X3,"WF"))
QUIT
+8 IF RAHDRFG
SET RAXIT=$$EOS^RAUTL5
if RAXIT
QUIT
+9 SET RADIV=X2
SET RAIMG=X3
SET (Y0,Y3)=0
DO HDR
+10 ; films for a particular imaging type
+11 ; wasted film type if 'X1' is "F", tech if 'X1' is "T"
SET X4=""
+12 FOR
SET X4=$ORDER(^TMP($JOB,"RA WFR","NS",X2,"I",X3,"WF",X4))
if X4']""!(RAXIT)
QUIT
Begin DoDot:3
+13 SET RAUSED=+$ORDER(^RA(78.4,"B",X4,0))
if 'RAUSED
QUIT
+14 SET RAUSED=+$PIECE(^RA(78.4,RAUSED,0),U,5)
if 'RAUSED
QUIT
+15 SET RAF0=$GET(^RA(78.4,RAUSED,0))
+16 SET RAUSED=$PIECE(RAF0,U)
SET RACINE=$SELECT($PIECE(RAF0,U,2)="Y":1,1:0)
+17 ;Q:'$D(^TMP($J,"RA WFR","NS",X2,"I",X3,"F",RAUSED))
+18 SET Y2=$GET(^TMP($JOB,"RA WFR","NS",X2,"I",X3,"F",RAUSED))
+19 SET Y1=$GET(^TMP($JOB,"RA WFR","NS",X2,"I",X3,"WF",X4))
+20 ; add to subtotals if not cine type
IF 'RACINE
SET Y0=Y0+Y1
SET Y3=Y3+Y2
+21 ; 'Y3' is used for the division summary
+22 SET RATIO=$SELECT((Y1+Y2)>0:$JUSTIFY((Y1/(Y1+Y2))*100,5,1),1:0)
+23 WRITE !,X4,?$SELECT(IOM=132:60,1:35),Y2,?$SELECT(IOM=132:75,1:45),Y1
+24 WRITE ?$SELECT(IOM=132:100,1:60),RATIO
+25 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5
if RAXIT
QUIT
DO HDR
+26 QUIT
End DoDot:3
+27 if RAXIT
QUIT
WRITE !!?$SELECT(IOM=132:10,1:5),"Subtotals:"
+28 WRITE ?$SELECT(IOM=132:60,1:35),$SELECT('Y3:"",1:Y3)
+29 WRITE ?$SELECT(IOM=132:75,1:45),Y0
+30 WRITE ?$SELECT(IOM=132:100,1:60),$SELECT((Y0+Y3)>0:$JUSTIFY((Y0/(Y0+Y3))*100,5,1),1:0)
+31 SET RAHDRFG=1
WRITE !,RALINE
+32 IF $Y>(IOSL-4)
SET RAXIT=$$EOS^RAUTL5
if RAXIT
QUIT
DO HDR
+33 WRITE !!?5,"* Cine data not included in totals."
+34 QUIT
End DoDot:2
+35 if RAXIT
QUIT
+36 IF RATOT>1
Begin DoDot:2
+37 NEW X
SET X=X2
NEW RASYN,RATIO,RAUSED,X1,X2,X3,X4,Y0,Y1,Y2,Y3
+38 SET RASYN=1
DO SUMMARY^RAWFR2(X)
+39 QUIT
End DoDot:2
+40 QUIT
End DoDot:1
+41 QUIT
KILL ; Kill and quit
+1 KILL %,%CHK,%RET,%Z,DIROUT,DIRUT,DTOUT,DUOUT,I,RABGDTI,RABGDTX,RACCESS
+2 KILL RADATE,RADFN,RADIV,RADT,RADTI,RAENDTI,RAENDTX,RAEXST,RAEX,RAEX0
+3 KILL RAEXS,RAFLM0,RAFLMNUM,RAFLMS,RAHEAD,RAIBGDT,RAIENDT,RAIMG,RALINE
+4 KILL RAMBGDT,RAMENDT,RAMES,RAPG,RAPOP,RAQUIT,RARP0,RASYN,RATAG,RATDAY
+5 KILL RATECH,RATOT,RAWFR,RAXIT,X,Y,Z,ZTDESC,ZTRTN,ZTSAVE,POP
+6 KILL ^TMP($JOB,"RA D-TYPE"),^TMP($JOB,"RA I-TYPE")
+7 KILL ^TMP($JOB,"RA WFR")
if $DATA(RAPSTX)
KILL RACCESS,RAPSTX
+8 QUIT
HDR ; Display/Print the header for the report
+1 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF,!
+2 if $EXTRACT(IOST,1,2)'="C-"&(+$GET(RAPG)>0)
WRITE @IOF,!
+3 SET RAPG=+$GET(RAPG)+1
+4 WRITE !?(IOM-$LENGTH(RAHEAD)\2),RAHEAD,?$SELECT(IOM=132:122,1:69),"Page: ",RAPG,!
+5 IF RASYN
Begin DoDot:1
+6 WRITE !?$SELECT(IOM=132:10,1:5),"Division: ",$GET(RADIV)
+7 WRITE ?$SELECT(IOM=132:85,1:50),"For Period: ",RABGDTX_" to"
+8 WRITE !?$SELECT(IOM=132:10,1:5),"Run Date: ",RATDAY
+9 WRITE ?$SELECT(IOM=132:97,1:62),RAENDTX_"."
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 WRITE !?$SELECT(IOM=132:10,1:5),"Division: ",$GET(RADIV)
+12 WRITE ?$SELECT(IOM=132:85,1:50),"For Period: ",RABGDTX_" to"
+13 WRITE !?$SELECT(IOM=132:10,1:5),"Imaging Type: ",$GET(RAIMG)
+14 WRITE ?$SELECT(IOM=132:97,1:62),RAENDTX_"."
+15 WRITE !?$SELECT(IOM=132:10,1:5),"Run Date: ",RATDAY
End DoDot:1
+16 WRITE !!?$SELECT(IOM=132:60,1:35),"Units",?$SELECT(IOM=132:75,1:45),"Units"
+17 WRITE ?$SELECT(IOM=132:100,1:60),"Percentage"
+18 WRITE !?$SELECT(IOM=132:60,1:35),"Of Used",?$SELECT(IOM=132:75,1:45),"Of Wasted"
+19 WRITE ?$SELECT(IOM=132:100,1:60),"Of Wasted"
+20 WRITE !,"Film Size",?$SELECT(IOM=132:60,1:35),"Films"
+21 WRITE ?$SELECT(IOM=132:75,1:45),"Films"
+22 WRITE ?$SELECT(IOM=132:100,1:60),"Film"
+23 WRITE !,RALINE
+24 if RASYN
WRITE !?$SELECT(IOM=132:10,1:5),"(Division Summary)"
+25 IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
if $GET(ZTSTOP)=1
SET RAXIT=1
+26 QUIT
