Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCPRPC3

PRCPRPC3.m

Go to the documentation of this file.
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