- 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
- 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
