- 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 Feb 18, 2025@23:41:37 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