RACDR1 ;HISC/FPT-Continuation of routine RACDR, CDR report ;4/16/96 08:48
;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
;Print CDR report
S (RADIV,X)=""
F S RADIV=$O(^TMP($J,"RACDR",RADIV)) Q:RAEOS!(RADIV="") D DIVNME,DIVTOT K RAFLG D Q:RAEOS I RAITCNT(RADIV)>1 D DIVSUM K RADIVSUM
.S RAIMAGE="" F S RAIMAGE=$O(^TMP($J,"RACDR",RADIV,RAIMAGE)) Q:RAEOS!(RAIMAGE="") K RAFLG D Q:RAEOS D IMGTOT,ITSUM K RAFLG
..S RACDR="" F S RACDR=$O(^TMP($J,"RACDR",RADIV,RAIMAGE,RACDR)) Q:RAEOS!(RACDR']"") S RAT=^TMP($J,"RACDR",RADIV,RAIMAGE,RACDR),RATA=$P(RAT,"^")+$P(RAT,"^",2)+$P(RAT,"^",3)+$P(RAT,"^",4) D HED Q:RAEOS D Q:RAEOS
...S RAPROCN="" F S RAPROCN=$O(^TMP($J,"RACDR",RADIV,RAIMAGE,RACDR,RAPROCN)) Q:RAEOS!(RAPROCN="") D Q:RAEOS
....S RAPROC="" F S RAPROC=$O(^TMP($J,"RACDR",RADIV,RAIMAGE,RACDR,RAPROCN,RAPROC)) Q:RAEOS!(RAPROC']"") S RAX=^(RAPROC) D Q:RAEOS
.....I ($Y+5)>IOSL S RAEOS=$$EOS^RAUTL5() Q:RAEOS D HED Q:RAEOS
.....S RATP=0 W !,$E(RAPROCN,1,38),?41 F RAJ=1:1:4 W ?($X+1),$J($P(RAX,"^",RAJ),5) S RATP=RATP+$P(RAX,"^",RAJ)
.....W ?68,$J(RATP,4) S Y=$S(RATA=0:0,1:(RATP/RATA*100)) W ?74,$J(Y,5,1)
.....I $O(^TMP($J,"RACDR",RADIV,RAIMAGE,RACDR,RAPROCN))="" D W
Q
W S RATP=0 W !!?32,"Total",?41
F RAJ=1:1:4 D
.W ?($X+1),$J($P(RAT,"^",RAJ),5)
.S RATP=RATP+$P(RAT,"^",RAJ)
.Q
W ?68,$J(RATP,4) S Y=$S(RATA=0:0,1:(RATP/RATA*100)) W ?74,$J(Y,5,1),!?30,"Percent",?41 F RAJ=1:1:4 W ?$X,$J($S(RATA=0:0,1:($P(RAT,"^",RAJ)/RATA*100)),6,1)
S RAEOS=$$EOS^RAUTL5()
Q
ITSUM ; imaging type summary
S RAFLG="" D HED Q:RAEOS
W !?10,"(Imaging Type Summary)"
S RACDR=0 F S RACDR=$O(^TMP($J,"RACDR",RADIV,RAIMAGE,RACDR)) Q:RAEOS!(RACDR'>0) S RATP=0,RAT=^(RACDR) W !?2,$S(RACDR>0:RACDR,1:"")," ",$P(RAT,"^",5),?41 D
.F RAJ=1:1:4 W ?($X+1),$J($P(RAT,"^",RAJ),5) S RATP=RATP+$P(RAT,"^",RAJ)
.W ?68,$J(RATP,4) S Y=$S(RAIMGTOT=0:0,1:(RATP/RAIMGTOT*100)) W ?74,$J(Y,5,1)
.I ($Y+5)>IOSL S RAEOS=$$EOS^RAUTL5() Q:RAEOS D HED
.Q
Q:RAEOS
S RAIMGTOT(0)=0
W !!?32,"Total",?41
F RAJ=1:1:4 W ?($X+1),$J($P(RAIMGNDE,"^",RAJ),5) S RAIMGTOT(0)=RAIMGTOT(0)+$P(RAIMGNDE,U,RAJ)
W ?68,$J(RAIMGTOT,4) S Y=$S(RAIMGTOT=0:0,1:(RAIMGTOT(0)/RAIMGTOT*100))
W ?74,$J(Y,5,1),!?30,"Percent",?41
F RAJ=1:1:4 W ?$X,$J($S(RAIMGTOT=0:0,1:($P(RAIMGNDE,"^",RAJ)/RAIMGTOT*100)),6,1)
I $O(^TMP($J,"RACDR",RADIV))="",RAITCNT(RADIV)=1 Q
S RAEOS=$$EOS^RAUTL5()
Q
HED ; header
W:$Y>0 @IOF S RAPG=RAPG+1
W !?20,">>>>> COST DISTRIBUTION REPORT <<<<<"
W ?71,"Page: ",RAPG
W !!,?4,"Division: ",RADIVNME
W:'$D(RADIVSUM) !,"Imaging Type: ",$S($D(^RA(79.2,+$P(RAIMAGE,"-",2),0)):$P(^(0),U,1),1:"Unknown")
W ?52,"For Period: ",?64,RABDT," to",!?4,"Run Date: ",RARDT,?64,RAEDT
W !!,?74,"% of",!,$S('$D(RAFLG):"Procedure",1:"Cost Distribution Center"),?43,"Inpt Opt Res Oth Total Exams",!,RAQ
W:'$D(RAFLG) !?10,"Cost Distribution Center: ",$S(RACDR=0:"",1:RACDR)," ",$P(RAT,"^",5),!
I $D(ZTQUEUED) D STOPCHK^RAUTL9 S:$G(ZTSTOP)=1 RAEOS=1
Q
DIVSUM ; division summary
S (RADIVSUM,RAFLG)="" D HED Q:RAEOS
W !?10,"(Division Summary)"
S RACDR="" F S RACDR=$O(^TMP($J,"RA DIVTOT",RADIV,RACDR)) Q:RAEOS!(RACDR="") S RATP=0,RAT=^(RACDR) W !?2,$S(RACDR]"":RACDR,1:"")," ",$P(RAT,"^",5),?41 D
.F RAJ=1:1:4 W ?($X+1),$J($P(RAT,"^",RAJ),5) S RATP=RATP+$P(RAT,"^",RAJ)
.W ?68,$J(RATP,4) S Y=$S(RADIVTOT=0:0,1:(RATP/RADIVTOT*100)) W ?74,$J(Y,5,1)
.I ($Y+5)>IOSL S RAEOS=$$EOS^RAUTL5() Q:RAEOS D HED
.Q
Q:RAEOS
S RADIVTOT(0)=0
W !!?32,"Total",?41
F RAJ=1:1:4 W ?($X+1),$J($P(RADIVNDE,"^",RAJ),5) S RADIVTOT(0)=RADIVTOT(0)+$P(RADIVNDE,U,RAJ)
W ?68,$J(RADIVTOT,4) S Y=$S(RADIVTOT=0:0,1:(RADIVTOT(0)/RADIVTOT*100))
W ?74,$J(Y,5,1),!?30,"Percent",?41
F RAJ=1:1:4 W ?$X,$J($S(RADIVTOT=0:0,1:($P(RADIVNDE,"^",RAJ)/RADIVTOT*100)),6,1)
; show imaging types
I ($Y+(RAITCNT(RADIV)\2)+3)>IOSL S RAEOS=$$EOS^RAUTL5 Q:RAEOS D HED Q:RAEOS
W !!?2,"Imaging Type(s): "
S RAITHLD=""
F S RAITHLD=$O(^TMP($J,"RACDR",RADIV,RAITHLD)) Q:RAEOS!(RAITHLD="") W:$X>(80-25) !?($X+$L("Imaging Type(s):")+3) D
.I ($Y+4)>IOSL S RAEOS=$$EOS^RAUTL5 Q:RAEOS D HED W !?19
.W $S($D(^RA(79.2,+$P(RAITHLD,"-",2),0)):$P(^(0),U,1),1:"UNKNOWN"),?($X+3)
I $O(^TMP($J,"RACDR",RADIV))]"" S RAEOS=$$EOS^RAUTL5()
Q
DIVNME ;
S RADIVNME=$S($D(^DIC(4,+RADIV,0)):$P(^(0),"^"),1:"Unknown")
Q
DIVTOT ;
S RADIVTOT=0,RADIVNDE=$G(^TMP($J,"RACDR",RADIV))
F RAJ=1:1:4 S RADIVTOT=RADIVTOT+$P(RADIVNDE,U,RAJ)
Q
IMGTOT ;
S RAIMGTOT=0,RAIMGNDE=$G(^TMP($J,"RACDR",RADIV,RAIMAGE))
F RAJ=1:1:4 S RAIMGTOT=RAIMGTOT+$P(RAIMGNDE,U,RAJ)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRACDR1 4592 printed Apr 09, 2024@21:38:42 Page 2
RACDR1 ;HISC/FPT-Continuation of routine RACDR, CDR report ;4/16/96 08:48
+1 ;;5.0;Radiology/Nuclear Medicine;;Mar 16, 1998
+2 ;Print CDR report
+3 SET (RADIV,X)=""
+4 FOR
SET RADIV=$ORDER(^TMP($JOB,"RACDR",RADIV))
if RAEOS!(RADIV="")
QUIT
DO DIVNME
DO DIVTOT
KILL RAFLG
Begin DoDot:1
+5 SET RAIMAGE=""
FOR
SET RAIMAGE=$ORDER(^TMP($JOB,"RACDR",RADIV,RAIMAGE))
if RAEOS!(RAIMAGE="")
QUIT
KILL RAFLG
Begin DoDot:2
+6 SET RACDR=""
FOR
SET RACDR=$ORDER(^TMP($JOB,"RACDR",RADIV,RAIMAGE,RACDR))
if RAEOS!(RACDR']"")
QUIT
SET RAT=^TMP($JOB,"RACDR",RADIV,RAIMAGE,RACDR)
SET RATA=$PIECE(RAT,"^")+$PIECE(RAT,"^",2)+$PIECE(RAT,"^",3)+$PIECE(RAT,"^",4)
DO HED
if RAEOS
QUIT
Begin DoDot:3
+7 SET RAPROCN=""
FOR
SET RAPROCN=$ORDER(^TMP($JOB,"RACDR",RADIV,RAIMAGE,RACDR,RAPROCN))
if RAEOS!(RAPROCN="")
QUIT
Begin DoDot:4
+8 SET RAPROC=""
FOR
SET RAPROC=$ORDER(^TMP($JOB,"RACDR",RADIV,RAIMAGE,RACDR,RAPROCN,RAPROC))
if RAEOS!(RAPROC']"")
QUIT
SET RAX=^(RAPROC)
Begin DoDot:5
+9 IF ($Y+5)>IOSL
SET RAEOS=$$EOS^RAUTL5()
if RAEOS
QUIT
DO HED
if RAEOS
QUIT
+10 SET RATP=0
WRITE !,$EXTRACT(RAPROCN,1,38),?41
FOR RAJ=1:1:4
WRITE ?($X+1),$JUSTIFY($PIECE(RAX,"^",RAJ),5)
SET RATP=RATP+$PIECE(RAX,"^",RAJ)
+11 WRITE ?68,$JUSTIFY(RATP,4)
SET Y=$SELECT(RATA=0:0,1:(RATP/RATA*100))
WRITE ?74,$JUSTIFY(Y,5,1)
+12 IF $ORDER(^TMP($JOB,"RACDR",RADIV,RAIMAGE,RACDR,RAPROCN))=""
DO W
End DoDot:5
if RAEOS
QUIT
End DoDot:4
if RAEOS
QUIT
End DoDot:3
if RAEOS
QUIT
End DoDot:2
if RAEOS
QUIT
DO IMGTOT
DO ITSUM
KILL RAFLG
End DoDot:1
if RAEOS
QUIT
IF RAITCNT(RADIV)>1
DO DIVSUM
KILL RADIVSUM
+13 QUIT
W SET RATP=0
WRITE !!?32,"Total",?41
+1 FOR RAJ=1:1:4
Begin DoDot:1
+2 WRITE ?($X+1),$JUSTIFY($PIECE(RAT,"^",RAJ),5)
+3 SET RATP=RATP+$PIECE(RAT,"^",RAJ)
+4 QUIT
End DoDot:1
+5 WRITE ?68,$JUSTIFY(RATP,4)
SET Y=$SELECT(RATA=0:0,1:(RATP/RATA*100))
WRITE ?74,$JUSTIFY(Y,5,1),!?30,"Percent",?41
FOR RAJ=1:1:4
WRITE ?$X,$JUSTIFY($SELECT(RATA=0:0,1:($PIECE(RAT,"^",RAJ)/RATA*100)),6,1)
+6 SET RAEOS=$$EOS^RAUTL5()
+7 QUIT
ITSUM ; imaging type summary
+1 SET RAFLG=""
DO HED
if RAEOS
QUIT
+2 WRITE !?10,"(Imaging Type Summary)"
+3 SET RACDR=0
FOR
SET RACDR=$ORDER(^TMP($JOB,"RACDR",RADIV,RAIMAGE,RACDR))
if RAEOS!(RACDR'>0)
QUIT
SET RATP=0
SET RAT=^(RACDR)
WRITE !?2,$SELECT(RACDR>0:RACDR,1:"")," ",$PIECE(RAT,"^",5),?41
Begin DoDot:1
+4 FOR RAJ=1:1:4
WRITE ?($X+1),$JUSTIFY($PIECE(RAT,"^",RAJ),5)
SET RATP=RATP+$PIECE(RAT,"^",RAJ)
+5 WRITE ?68,$JUSTIFY(RATP,4)
SET Y=$SELECT(RAIMGTOT=0:0,1:(RATP/RAIMGTOT*100))
WRITE ?74,$JUSTIFY(Y,5,1)
+6 IF ($Y+5)>IOSL
SET RAEOS=$$EOS^RAUTL5()
if RAEOS
QUIT
DO HED
+7 QUIT
End DoDot:1
+8 if RAEOS
QUIT
+9 SET RAIMGTOT(0)=0
+10 WRITE !!?32,"Total",?41
+11 FOR RAJ=1:1:4
WRITE ?($X+1),$JUSTIFY($PIECE(RAIMGNDE,"^",RAJ),5)
SET RAIMGTOT(0)=RAIMGTOT(0)+$PIECE(RAIMGNDE,U,RAJ)
+12 WRITE ?68,$JUSTIFY(RAIMGTOT,4)
SET Y=$SELECT(RAIMGTOT=0:0,1:(RAIMGTOT(0)/RAIMGTOT*100))
+13 WRITE ?74,$JUSTIFY(Y,5,1),!?30,"Percent",?41
+14 FOR RAJ=1:1:4
WRITE ?$X,$JUSTIFY($SELECT(RAIMGTOT=0:0,1:($PIECE(RAIMGNDE,"^",RAJ)/RAIMGTOT*100)),6,1)
+15 IF $ORDER(^TMP($JOB,"RACDR",RADIV))=""
IF RAITCNT(RADIV)=1
QUIT
+16 SET RAEOS=$$EOS^RAUTL5()
+17 QUIT
HED ; header
+1 if $Y>0
WRITE @IOF
SET RAPG=RAPG+1
+2 WRITE !?20,">>>>> COST DISTRIBUTION REPORT <<<<<"
+3 WRITE ?71,"Page: ",RAPG
+4 WRITE !!,?4,"Division: ",RADIVNME
+5 if '$DATA(RADIVSUM)
WRITE !,"Imaging Type: ",$SELECT($DATA(^RA(79.2,+$PIECE(RAIMAGE,"-",2),0)):$PIECE(^(0),U,1),1:"Unknown")
+6 WRITE ?52,"For Period: ",?64,RABDT," to",!?4,"Run Date: ",RARDT,?64,RAEDT
+7 WRITE !!,?74,"% of",!,$SELECT('$DATA(RAFLG):"Procedure",1:"Cost Distribution Center"),?43,"Inpt Opt Res Oth Total Exams",!,RAQ
+8 if '$DATA(RAFLG)
WRITE !?10,"Cost Distribution Center: ",$SELECT(RACDR=0:"",1:RACDR)," ",$PIECE(RAT,"^",5),!
+9 IF $DATA(ZTQUEUED)
DO STOPCHK^RAUTL9
if $GET(ZTSTOP)=1
SET RAEOS=1
+10 QUIT
DIVSUM ; division summary
+1 SET (RADIVSUM,RAFLG)=""
DO HED
if RAEOS
QUIT
+2 WRITE !?10,"(Division Summary)"
+3 SET RACDR=""
FOR
SET RACDR=$ORDER(^TMP($JOB,"RA DIVTOT",RADIV,RACDR))
if RAEOS!(RACDR="")
QUIT
SET RATP=0
SET RAT=^(RACDR)
WRITE !?2,$SELECT(RACDR]"":RACDR,1:"")," ",$PIECE(RAT,"^",5),?41
Begin DoDot:1
+4 FOR RAJ=1:1:4
WRITE ?($X+1),$JUSTIFY($PIECE(RAT,"^",RAJ),5)
SET RATP=RATP+$PIECE(RAT,"^",RAJ)
+5 WRITE ?68,$JUSTIFY(RATP,4)
SET Y=$SELECT(RADIVTOT=0:0,1:(RATP/RADIVTOT*100))
WRITE ?74,$JUSTIFY(Y,5,1)
+6 IF ($Y+5)>IOSL
SET RAEOS=$$EOS^RAUTL5()
if RAEOS
QUIT
DO HED
+7 QUIT
End DoDot:1
+8 if RAEOS
QUIT
+9 SET RADIVTOT(0)=0
+10 WRITE !!?32,"Total",?41
+11 FOR RAJ=1:1:4
WRITE ?($X+1),$JUSTIFY($PIECE(RADIVNDE,"^",RAJ),5)
SET RADIVTOT(0)=RADIVTOT(0)+$PIECE(RADIVNDE,U,RAJ)
+12 WRITE ?68,$JUSTIFY(RADIVTOT,4)
SET Y=$SELECT(RADIVTOT=0:0,1:(RADIVTOT(0)/RADIVTOT*100))
+13 WRITE ?74,$JUSTIFY(Y,5,1),!?30,"Percent",?41
+14 FOR RAJ=1:1:4
WRITE ?$X,$JUSTIFY($SELECT(RADIVTOT=0:0,1:($PIECE(RADIVNDE,"^",RAJ)/RADIVTOT*100)),6,1)
+15 ; show imaging types
+16 IF ($Y+(RAITCNT(RADIV)\2)+3)>IOSL
SET RAEOS=$$EOS^RAUTL5
if RAEOS
QUIT
DO HED
if RAEOS
QUIT
+17 WRITE !!?2,"Imaging Type(s): "
+18 SET RAITHLD=""
+19 FOR
SET RAITHLD=$ORDER(^TMP($JOB,"RACDR",RADIV,RAITHLD))
if RAEOS!(RAITHLD="")
QUIT
if $X>(80-25)
WRITE !?($X+$LENGTH("Imaging Type(s):")+3)
Begin DoDot:1
+20 IF ($Y+4)>IOSL
SET RAEOS=$$EOS^RAUTL5
if RAEOS
QUIT
DO HED
WRITE !?19
+21 WRITE $SELECT($DATA(^RA(79.2,+$PIECE(RAITHLD,"-",2),0)):$PIECE(^(0),U,1),1:"UNKNOWN"),?($X+3)
End DoDot:1
+22 IF $ORDER(^TMP($JOB,"RACDR",RADIV))]""
SET RAEOS=$$EOS^RAUTL5()
+23 QUIT
DIVNME ;
+1 SET RADIVNME=$SELECT($DATA(^DIC(4,+RADIV,0)):$PIECE(^(0),"^"),1:"Unknown")
+2 QUIT
DIVTOT ;
+1 SET RADIVTOT=0
SET RADIVNDE=$GET(^TMP($JOB,"RACDR",RADIV))
+2 FOR RAJ=1:1:4
SET RADIVTOT=RADIVTOT+$PIECE(RADIVNDE,U,RAJ)
+3 QUIT
IMGTOT ;
+1 SET RAIMGTOT=0
SET RAIMGNDE=$GET(^TMP($JOB,"RACDR",RADIV,RAIMAGE))
+2 FOR RAJ=1:1:4
SET RAIMGTOT=RAIMGTOT+$PIECE(RAIMGNDE,U,RAJ)
+3 QUIT
