RAFLM2 ;HISC/FPT-Film Usage Rpt (cont.) ;4/17/96 09:30
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
; print report
S PAGE=0,RA80DASH=$$REPEAT^XLFSTR("-",80)
S Y=BEGDATE D D^RAUTL S BEGDATE=Y
S Y=ENDDATE D D^RAUTL S ENDDATE=Y
S X="NOW",%DT="T" D ^%DT K %DT D D^RAUTL S RARUNDTE=Y
F RADIV=0:0 S RADIV=$O(^TMP($J,"RA",RADIV)) Q:RAEOS!(RADIV'>0) S RAITYPE="" F S RAITYPE=$O(^TMP($J,"RA",RADIV,RAITYPE)) Q:RAEOS!(RAITYPE="") D START
Q ; kill variables & close device
K ^TMP($J,"RA"),^TMP($J,"RADIVFLD"),^TMP($J,"RAFILM"),^TMP($J,"RAFLM"),^TMP($J,"RA D-TYPE"),^TMP($J,"RA I-TYPE")
K A,BEGDATE,ENDDATE,EXAM,FILM,I,J,PAGE,POP,RA80DASH,RABEG,RACNI,RACPT,RACRT,RAD0,RADEXAM,RADFILM,RADFN,RADIV,RADPCT,RADRATIO,RADTE,RADTI,RAEND,RAEOS,RAEXAM,RAFILM,RAFL1,RAFL2,RAFLDCNT
K RAFLM,RAI,RAINPUT,RAITCNT,RAITEXAM,RAITFILM,RAITFLD,RAITHLD,RAITNDE,RAITNUM,RAITPCT,RAITRATO,RAITYPE,RALBL,RAMIS,RAMUL,RANUM,RAOR,RAP0,RAPCT,RAPIFN,RAPOP,RAPORT,RAPRC,RAPRI,RAQI,RAQUIT,RARATIO,RARUNDTE,RASTAT,RASUM,RASV
K RATITLE,RATIO,RATMPNDE,RAXIT,RAY,RAZ,X,Y,Z,ZZ,ZZZ
K DIROUT,DIRUT,DTOUT,DUOUT
K:$D(RAPSTX) RACCESS,RAPSTX
W ! D CLOSE^RAUTL
K RAMES,ZTDESC,ZTRTN,ZTSAVE
Q
START ;
S (FILM,EXAM,RATIO)=0
S RAZ=^TMP($J,"RA",RADIV,RAITYPE),RAY=$S($D(^DIC(4,RADIV,0)):$P(^(0),"^"),1:"UNKNOWN") D:$D(RAFL1) RAFLM Q:RAEOS S RASUM="",Z=RAZ,ZZ=")",ZZZ="RAFLM" D HD Q:RAEOS D PRT Q:RAEOS D TOT K RASUM Q:RAEOS
I $O(^TMP($J,"RA",RADIV,RAITYPE))="" D DIVTOT^RAFLM3
Q
;
RAFLM S RAFLM="" F J=0:0 S RAFLM=$O(^TMP($J,"RA",RADIV,RAITYPE,RAFLM)) Q:RAEOS!(RAFLM="") S Z=^(RAFLM) D HD Q:RAEOS D RAMIS
Q
;
RAMIS F RAMIS=0:0 S RAMIS=$O(^TMP($J,"RA",RADIV,RAITYPE,RAFLM,RAMIS)) D:RAMIS'>0 TOT Q:RAEOS!(RAMIS'>0) S ZZ=",RAMIS,RAPRC)",ZZZ="RAPRC" D:RAMIS<25!(RAMIS=99)!(RAMIS=27) PRT
Q
;
PRT I ($Y+6)>IOSL S RAEOS=$$EOS^RAUTL5() Q:RAEOS D HD Q:RAEOS
S EXAM=$P(Z,"^"),FILM=$P(Z,"^",2),RATIO=$S(EXAM:FILM/EXAM,1:0)
S @ZZZ="" F I=0:0 S @ZZZ=$O(@("^TMP($J,""RA"",RADIV,RAITYPE,RAFLM"_ZZ)) Q:RAEOS!(@ZZZ="") S Y=^(@ZZZ),RAEXAM=$P(Y,"^"),RAFILM=$P(Y,"^",2),RARATIO=$S(RAEXAM:RAFILM/RAEXAM,1:0),RAPCT=$S(FILM:(100*RAFILM)/FILM,1:0) D PRT1
Q
;
TOT ;
W !!?2,$S($D(RASUM):"Imaging Type",1:"Film Usage")," Total",?40,$J(FILM,5),?50,$J(EXAM,5),?60,$J(RATIO,5,1)
W !,RA80DASH
I ($Y+6)>IOSL S RAEOS=$$EOS^RAUTL5() Q:RAEOS Q:'$D(RASUM) D HD Q:RAEOS
I $D(RASUM) D
.W !!!,"* Cine data not included in imaging type totals.",!?2,"Percentages calculated on film data only."
.W !!?3,"# of Films selected: ",$S(RAINPUT=1:"ALL",1:$G(RAFLDCNT))
I $D(RASUM),$O(^TMP($J,"RA",RADIV))="",RAITCNT(RADIV)=1 Q
S RAEOS=$$EOS^RAUTL5()
Q
;
PRT1 I ($Y+6)>IOSL S RAEOS=$$EOS^RAUTL5() Q:RAEOS D HD Q:RAEOS
W !,@ZZZ,?40,$J(RAFILM,5),?50,$J(RAEXAM,5),?60,$J(RARATIO,5,1) Q:$D(RASUM)&($P(Y,"^",4)) W ?70,$J(RAPCT,5,1)
Q
;
HD S RALBL=$S($P(Z,"^",4):"Cine Ft",1:"Films") W:$Y>0 @IOF
W !?8,">>>>> Film Usage Report <<<<<"
S PAGE=PAGE+1 W ?70,"Page: ",PAGE
W !!?4,"Division: ",RAY,!,"Imaging Type: ",$S($D(^RA(79.2,+$P(RAITYPE,"-",2),0)):$P(^(0),U,1),1:"UNKNOWN"),?52,"For period: ",?64,BEGDATE,?76,"to"
W !?4,"Run Date: ",RARUNDTE,?64,ENDDATE
W !!?40,"Number",?50,"Number",?60,RALBL,?70,"Percentage"
W !?40," of ",?50," of ",?60," per ",?70," ",RALBL
W !?2,$S('$D(RASUM):"Procedure(CPT)",1:"Film Size"),?40,RALBL,$S($D(RASUM):"*",1:""),?50,"Exams",?60," Exam",?70," Used"
W !,RA80DASH
W:$D(RASUM) !?10,"(Imaging Type Summary)" W:'$D(RASUM) !?10,"Film Size: ",RAFLM
I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAEOS=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAFLM2 3556 printed Nov 22, 2024@17:45:10 Page 2
RAFLM2 ;HISC/FPT-Film Usage Rpt (cont.) ;4/17/96 09:30
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
+2 ; print report
+3 SET PAGE=0
SET RA80DASH=$$REPEAT^XLFSTR("-",80)
+4 SET Y=BEGDATE
DO D^RAUTL
SET BEGDATE=Y
+5 SET Y=ENDDATE
DO D^RAUTL
SET ENDDATE=Y
+6 SET X="NOW"
SET %DT="T"
DO ^%DT
KILL %DT
DO D^RAUTL
SET RARUNDTE=Y
+7 FOR RADIV=0:0
SET RADIV=$ORDER(^TMP($JOB,"RA",RADIV))
if RAEOS!(RADIV'>0)
QUIT
SET RAITYPE=""
FOR
SET RAITYPE=$ORDER(^TMP($JOB,"RA",RADIV,RAITYPE))
if RAEOS!(RAITYPE="")
QUIT
DO START
Q ; kill variables & close device
+1 KILL ^TMP($JOB,"RA"),^TMP($JOB,"RADIVFLD"),^TMP($JOB,"RAFILM"),^TMP($JOB,"RAFLM"),^TMP($JOB,"RA D-TYPE"),^TMP($JOB,"RA I-TYPE")
+2 KILL A,BEGDATE,ENDDATE,EXAM,FILM,I,J,PAGE,POP,RA80DASH,RABEG,RACNI,RACPT,RACRT,RAD0,RADEXAM,RADFILM,RADFN,RADIV,RADPCT,RADRATIO,RADTE,RADTI,RAEND,RAEOS,RAEXAM,RAFILM,RAFL1,RAFL2,RAFLDCNT
+3 KILL RAFLM,RAI,RAINPUT,RAITCNT,RAITEXAM,RAITFILM,RAITFLD,RAITHLD,RAITNDE,RAITNUM,RAITPCT,RAITRATO,RAITYPE,RALBL,RAMIS,RAMUL,RANUM,RAOR,RAP0,RAPCT,RAPIFN,RAPOP,RAPORT,RAPRC,RAPRI,RAQI,RAQUIT,RARATIO,RARUNDTE,RASTAT,RASUM,RASV
+4 KILL RATITLE,RATIO,RATMPNDE,RAXIT,RAY,RAZ,X,Y,Z,ZZ,ZZZ
+5 KILL DIROUT,DIRUT,DTOUT,DUOUT
+6 if $DATA(RAPSTX)
KILL RACCESS,RAPSTX
+7 WRITE !
DO CLOSE^RAUTL
+8 KILL RAMES,ZTDESC,ZTRTN,ZTSAVE
+9 QUIT
START ;
+1 SET (FILM,EXAM,RATIO)=0
+2 SET RAZ=^TMP($JOB,"RA",RADIV,RAITYPE)
SET RAY=$SELECT($DATA(^DIC(4,RADIV,0)):$PIECE(^(0),"^"),1:"UNKNOWN")
if $DATA(RAFL1)
DO RAFLM
if RAEOS
QUIT
SET RASUM=""
SET Z=RAZ
SET ZZ=")"
SET ZZZ="RAFLM"
DO HD
if RAEOS
QUIT
DO PRT
if RAEOS
QUIT
DO TOT
KILL RASUM
if RAEOS
QUIT
+3 IF $ORDER(^TMP($JOB,"RA",RADIV,RAITYPE))=""
DO DIVTOT^RAFLM3
+4 QUIT
+5 ;
RAFLM SET RAFLM=""
FOR J=0:0
SET RAFLM=$ORDER(^TMP($JOB,"RA",RADIV,RAITYPE,RAFLM))
if RAEOS!(RAFLM="")
QUIT
SET Z=^(RAFLM)
DO HD
if RAEOS
QUIT
DO RAMIS
+1 QUIT
+2 ;
RAMIS FOR RAMIS=0:0
SET RAMIS=$ORDER(^TMP($JOB,"RA",RADIV,RAITYPE,RAFLM,RAMIS))
if RAMIS'>0
DO TOT
if RAEOS!(RAMIS'>0)
QUIT
SET ZZ=",RAMIS,RAPRC)"
SET ZZZ="RAPRC"
if RAMIS<25!(RAMIS=99)!(RAMIS=27)
DO PRT
+1 QUIT
+2 ;
PRT IF ($Y+6)>IOSL
SET RAEOS=$$EOS^RAUTL5()
if RAEOS
QUIT
DO HD
if RAEOS
QUIT
+1 SET EXAM=$PIECE(Z,"^")
SET FILM=$PIECE(Z,"^",2)
SET RATIO=$SELECT(EXAM:FILM/EXAM,1:0)
+2 SET @ZZZ=""
FOR I=0:0
SET @ZZZ=$ORDER(@("^TMP($J,""RA"",RADIV,RAITYPE,RAFLM"_ZZ))
if RAEOS!(@ZZZ="")
QUIT
SET Y=^(@ZZZ)
SET RAEXAM=$PIECE(Y,"^")
SET RAFILM=$PIECE(Y,"^",2)
SET RARATIO=$SELECT(RAEXAM:RAFILM/RAEXAM,1:0)
SET RAPCT=$SELECT(FILM:(100*RAFILM)/FILM,1:0)
DO PRT1
+3 QUIT
+4 ;
TOT ;
+1 WRITE !!?2,$SELECT($DATA(RASUM):"Imaging Type",1:"Film Usage")," Total",?40,$JUSTIFY(FILM,5),?50,$JUSTIFY(EXAM,5),?60,$JUSTIFY(RATIO,5,1)
+2 WRITE !,RA80DASH
+3 IF ($Y+6)>IOSL
SET RAEOS=$$EOS^RAUTL5()
if RAEOS
QUIT
if '$DATA(RASUM)
QUIT
DO HD
if RAEOS
QUIT
+4 IF $DATA(RASUM)
Begin DoDot:1
+5 WRITE !!!,"* Cine data not included in imaging type totals.",!?2,"Percentages calculated on film data only."
+6 WRITE !!?3,"# of Films selected: ",$SELECT(RAINPUT=1:"ALL",1:$GET(RAFLDCNT))
End DoDot:1
+7 IF $DATA(RASUM)
IF $ORDER(^TMP($JOB,"RA",RADIV))=""
IF RAITCNT(RADIV)=1
QUIT
+8 SET RAEOS=$$EOS^RAUTL5()
+9 QUIT
+10 ;
PRT1 IF ($Y+6)>IOSL
SET RAEOS=$$EOS^RAUTL5()
if RAEOS
QUIT
DO HD
if RAEOS
QUIT
+1 WRITE !,@ZZZ,?40,$JUSTIFY(RAFILM,5),?50,$JUSTIFY(RAEXAM,5),?60,$JUSTIFY(RARATIO,5,1)
if $DATA(RASUM)&($PIECE(Y,"^",4))
QUIT
WRITE ?70,$JUSTIFY(RAPCT,5,1)
+2 QUIT
+3 ;
HD SET RALBL=$SELECT($PIECE(Z,"^",4):"Cine Ft",1:"Films")
if $Y>0
WRITE @IOF
+1 WRITE !?8,">>>>> Film Usage Report <<<<<"
+2 SET PAGE=PAGE+1
WRITE ?70,"Page: ",PAGE
+3 WRITE !!?4,"Division: ",RAY,!,"Imaging Type: ",$SELECT($DATA(^RA(79.2,+$PIECE(RAITYPE,"-",2),0)):$PIECE(^(0),U,1),1:"UNKNOWN"),?52,"For period: ",?64,BEGDATE,?76,"to"
+4 WRITE !?4,"Run Date: ",RARUNDTE,?64,ENDDATE
+5 WRITE !!?40,"Number",?50,"Number",?60,RALBL,?70,"Percentage"
+6 WRITE !?40," of ",?50," of ",?60," per ",?70," ",RALBL
+7 WRITE !?2,$SELECT('$DATA(RASUM):"Procedure(CPT)",1:"Film Size"),?40,RALBL,$SELECT($DATA(RASUM):"*",1:""),?50,"Exams",?60," Exam",?70," Used"
+8 WRITE !,RA80DASH
+9 if $DATA(RASUM)
WRITE !?10,"(Imaging Type Summary)"
if '$DATA(RASUM)
WRITE !?10,"Film Size: ",RAFLM
+10 IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
if $GET(ZTSTOP)=1
SET RAEOS=1
+11 QUIT
