PRCPRPC3 ;WISC/RFJ-patient distribution costs (print report totals) ;11 Mar 94
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
PRINTOTL ; print report totals
D:SCREEN P^PRCPUREP I $G(PRCPFLAG) Q
S PRCPFTOT=1 D H^PRCPRPC2
S DISTRNM="" F S DISTRNM=$O(^TMP($J,"PRCPRPCRT",1,DISTRNM)) Q:DISTRNM=""!($G(PRCPFLAG)) W !,"TOTALS BY DISTRIBUTION POINT: ",DISTRNM D TOTAL(^(DISTRNM))
I $G(PRCPFLAG) Q
W !
S SURGSPEC="" F S SURGSPEC=$O(^TMP($J,"PRCPRPCRT",2,SURGSPEC)) Q:SURGSPEC=""!($G(PRCPFLAG)) D
. W !,"TOTALS BY SURGICAL SPECIALTY: ",SURGSPEC D TOTAL($G(^TMP($J,"PRCPRPCRT",2,SURGSPEC)))
. I $G(PRCPFLAG) Q
. S INOUTPAT="" F S INOUTPAT=$O(^TMP($J,"PRCPRPCRT",2,SURGSPEC,INOUTPAT)) Q:INOUTPAT=""!($G(PRCPFLAG)) W !,$J($S(INOUTPAT="I":"INPATIENT",INOUTPAT="O":"OUTPATIENT",1:"UNKNOWN"),28),":" D TOTAL(^(INOUTPAT))
I $G(PRCPFLAG) Q
W !
S INOUTPAT="" F S INOUTPAT=$O(^TMP($J,"PRCPRPCRT",3,INOUTPAT)) Q:INOUTPAT=""!($G(PRCPFLAG)) W !,"TOTALS BY INPATIENT/OUTPATIENT: ",$S(INOUTPAT="I":"INPATIENT",INOUTPAT="O":"OUTPATIENT",1:"UNKNOWN") D TOTAL(^(INOUTPAT))
I $G(PRCPFLAG) Q
W !
S OPCODE="" F S OPCODE=$O(^TMP($J,"PRCPRPCRT",4,OPCODE)) Q:OPCODE=""!($G(PRCPFLAG)) W !,"TOTALS BY OPERATION/PROCEDURE CODE: ",OPCODE D TOTAL(^(OPCODE))
I $G(PRCPFLAG) Q
W !
S SURGEON="" F S SURGEON=$O(^TMP($J,"PRCPRPCRT",5,SURGEON)) Q:SURGEON=""!($G(PRCPFLAG)) W !,"TOTALS BY SURGEON: ",SURGEON D TOTAL(^(SURGEON))
I $G(PRCPFLAG) Q
W !!,"TOTALS BY REPORT: " D TOTAL($G(^TMP($J,"PRCPRPCRT",6)))
;
D END^PRCPUREP
Q
;
;
TOTAL(VALUES) ; show totals where value = count ^ cost
S AVERAGE=$S('$P(VALUES,"^"):"",1:$P(VALUES,"^",2)/$P(VALUES,"^"))
W ?46,$J(+$P(VALUES,"^"),10),$J($P(VALUES,"^",2),12,2),$J(AVERAGE,12,2)
I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H^PRCPRPC2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRPC3 1892 printed Oct 16, 2024@18:15:59 Page 2
PRCPRPC3 ;WISC/RFJ-patient distribution costs (print report totals) ;11 Mar 94
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
PRINTOTL ; print report totals
+1 if SCREEN
DO P^PRCPUREP
IF $GET(PRCPFLAG)
QUIT
+2 SET PRCPFTOT=1
DO H^PRCPRPC2
+3 SET DISTRNM=""
FOR
SET DISTRNM=$ORDER(^TMP($JOB,"PRCPRPCRT",1,DISTRNM))
if DISTRNM=""!($GET(PRCPFLAG))
QUIT
WRITE !,"TOTALS BY DISTRIBUTION POINT: ",DISTRNM
DO TOTAL(^(DISTRNM))
+4 IF $GET(PRCPFLAG)
QUIT
+5 WRITE !
+6 SET SURGSPEC=""
FOR
SET SURGSPEC=$ORDER(^TMP($JOB,"PRCPRPCRT",2,SURGSPEC))
if SURGSPEC=""!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+7 WRITE !,"TOTALS BY SURGICAL SPECIALTY: ",SURGSPEC
DO TOTAL($GET(^TMP($JOB,"PRCPRPCRT",2,SURGSPEC)))
+8 IF $GET(PRCPFLAG)
QUIT
+9 SET INOUTPAT=""
FOR
SET INOUTPAT=$ORDER(^TMP($JOB,"PRCPRPCRT",2,SURGSPEC,INOUTPAT))
if INOUTPAT=""!($GET(PRCPFLAG))
QUIT
WRITE !,$JUSTIFY($SELECT(INOUTPAT="I":"INPATIENT",INOUTPAT="O":"OUTPATIENT",1:"UNKNOWN"),28),":"
DO TOTAL(^(INOUTPAT))
End DoDot:1
+10 IF $GET(PRCPFLAG)
QUIT
+11 WRITE !
+12 SET INOUTPAT=""
FOR
SET INOUTPAT=$ORDER(^TMP($JOB,"PRCPRPCRT",3,INOUTPAT))
if INOUTPAT=""!($GET(PRCPFLAG))
QUIT
WRITE !,"TOTALS BY INPATIENT/OUTPATIENT: ",$SELECT(INOUTPAT="I":"INPATIENT",INOUTPAT="O":"OUTPATIENT",1:"UNKNOWN")
DO TOTAL(^(INOUTPAT))
+13 IF $GET(PRCPFLAG)
QUIT
+14 WRITE !
+15 SET OPCODE=""
FOR
SET OPCODE=$ORDER(^TMP($JOB,"PRCPRPCRT",4,OPCODE))
if OPCODE=""!($GET(PRCPFLAG))
QUIT
WRITE !,"TOTALS BY OPERATION/PROCEDURE CODE: ",OPCODE
DO TOTAL(^(OPCODE))
+16 IF $GET(PRCPFLAG)
QUIT
+17 WRITE !
+18 SET SURGEON=""
FOR
SET SURGEON=$ORDER(^TMP($JOB,"PRCPRPCRT",5,SURGEON))
if SURGEON=""!($GET(PRCPFLAG))
QUIT
WRITE !,"TOTALS BY SURGEON: ",SURGEON
DO TOTAL(^(SURGEON))
+19 IF $GET(PRCPFLAG)
QUIT
+20 WRITE !!,"TOTALS BY REPORT: "
DO TOTAL($GET(^TMP($JOB,"PRCPRPCRT",6)))
+21 ;
+22 DO END^PRCPUREP
+23 QUIT
+24 ;
+25 ;
TOTAL(VALUES) ; show totals where value = count ^ cost
+1 SET AVERAGE=$SELECT('$PIECE(VALUES,"^"):"",1:$PIECE(VALUES,"^",2)/$PIECE(VALUES,"^"))
+2 WRITE ?46,$JUSTIFY(+$PIECE(VALUES,"^"),10),$JUSTIFY($PIECE(VALUES,"^",2),12,2),$JUSTIFY(AVERAGE,12,2)
+3 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H^PRCPRPC2
+4 QUIT
