PRCPRPC2 ;WISC/RFJ/DWA-patient distribution costs (print report) ;11 Mar 94
;;5.1;IFCAP;**32**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
PRINT ; print report
D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
S ORROOM=""
; show report variables selected
W !!?10,"*** R E P O R T V A R I A B L E S S E L E C T E D ***",!
W !,"SURGICAL SPECIALTY RANGE FROM : ",$S(PRCPSURS="":"FIRST",1:PRCPSURS),?60,"TO: ",$S(PRCPSURE="z":"LAST",1:PRCPSURE)
W !,"PATIENT NAME RANGE FROM : ",$S(PRCPPATS="":"FIRST",1:PRCPPATS),?60,"TO: ",$S(PRCPPATE="z":"LAST",1:PRCPPATE)
W !,"OPERATION/PROCEDURE CODE RANGE FROM: ",$S(PRCPOPCS="":"FIRST",1:PRCPOPCS),?60,"TO: ",$S(PRCPOPCE="z":"LAST",1:PRCPOPCE)
S Y=DATESTRT D DD^%DT W !,"DISTRIBUTION DATES FROM : ",Y S Y=DATEEND D DD^%DT W ?60,"TO: ",Y,!
W !,"PRINT SUMMARY ONLY : ",$S(PRCPSUMM=1:"YES",1:"NO")
W !,"PRINT ITEMS ON REPORT: ",$S($G(PRCPFITM)=1:"YES",1:"NO")
;
S DISTRNM="" F S DISTRNM=$O(^TMP($J,"PRCPRPCR",DISTRNM)) Q:DISTRNM=""!($G(PRCPFLAG)) S SURGSPEC="" F S SURGSPEC=$O(^TMP($J,"PRCPRPCR",DISTRNM,SURGSPEC)) Q:SURGSPEC=""!($G(PRCPFLAG)) D
. I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>" Q
. I $Y>(IOSL-8) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. I '$G(PRCPSUMM) W !!?5,"FROM Inventory Point: ",DISTRNM,?40,"TO Surgical Specialty: ",SURGSPEC
. S INOUTPAT="" F S INOUTPAT=$O(^TMP($J,"PRCPRPCR",DISTRNM,SURGSPEC,INOUTPAT)) Q:INOUTPAT=""!($G(PRCPFLAG)) D
. . S PATNAME="" F S PATNAME=$O(^TMP($J,"PRCPRPCR",DISTRNM,SURGSPEC,INOUTPAT,PATNAME)) Q:PATNAME=""!($G(PRCPFLAG)) D
. . . S OPCODE="" F S OPCODE=$O(^TMP($J,"PRCPRPCR",DISTRNM,SURGSPEC,INOUTPAT,PATNAME,OPCODE)) Q:OPCODE=""!($G(PRCPFLAG)) D
. . . . S DA=0 F S DA=$O(^TMP($J,"PRCPRPCR",DISTRNM,SURGSPEC,INOUTPAT,PATNAME,OPCODE,DA)) Q:'DA!($G(PRCPFLAG)) S DATA=^(DA) D
. . . . . S SURGEON=$E($$USER^PRCPUREP(+$P(DATA,"^",2)),1,15) I SURGEON="" S SURGEON=" "
. . . . . S TOTCOST=$P(DATA,"^",3)
. . . . . ; accumulate totals
. . . . . S %=$G(^TMP($J,"PRCPRPCRT",1,DISTRNM)),$P(%,"^")=$P(%,"^")+1,$P(%,"^",2)=$P(%,"^",2)+TOTCOST,^(DISTRNM)=%
. . . . . S %=$G(^TMP($J,"PRCPRPCRT",2,SURGSPEC)),$P(%,"^")=$P(%,"^")+1,$P(%,"^",2)=$P(%,"^",2)+TOTCOST,^(SURGSPEC)=%
. . . . . S %=$G(^TMP($J,"PRCPRPCRT",2,SURGSPEC,INOUTPAT)),$P(%,"^")=$P(%,"^")+1,$P(%,"^",2)=$P(%,"^",2)+TOTCOST,^(INOUTPAT)=%
. . . . . S %=$G(^TMP($J,"PRCPRPCRT",3,INOUTPAT)),$P(%,"^")=$P(%,"^")+1,$P(%,"^",2)=$P(%,"^",2)+TOTCOST,^(INOUTPAT)=%
. . . . . S %=$G(^TMP($J,"PRCPRPCRT",4,OPCODE)),$P(%,"^")=$P(%,"^")+1,$P(%,"^",2)=$P(%,"^",2)+TOTCOST,^(OPCODE)=%
. . . . . S %=$G(^TMP($J,"PRCPRPCRT",5,SURGEON)),$P(%,"^")=$P(%,"^")+1,$P(%,"^",2)=$P(%,"^",2)+TOTCOST,^(SURGEON)=%
. . . . . S %=$G(^TMP($J,"PRCPRPCRT",6)),$P(%,"^")=$P(%,"^")+1,$P(%,"^",2)=$P(%,"^",2)+TOTCOST,^(6)=%
. . . . . I $G(PRCPSUMM) Q
. . . . . ;
. . . . . S Y=DA D DD^%DT S DATE=$P(Y,",")
. . . . . I $P(DATA,"^")'="" S ORROOM=$E($P($G(^SC($P($G(^SRS(+$P(DATA,"^"),0)),"^"),0)),"^"),1,10)
. . . . . S:ORROOM="" ORROOM="N/A"
. . . . . W !,PATNAME,?12,INOUTPAT,?17,OPCODE,?26,DATE,?35,SURGEON,?52,ORROOM,?65,$J(TOTCOST,15,2) S ORROOM=""
. . . . . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. . . . . I $G(PRCPFITM)=1 S ITEMDA=0 F S ITEMDA=$O(^PRCP(446.1,DA,445,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) S DATA=$G(^(ITEMDA,0)) I DATA'="" D
. . . . . . W !?10,"IM# ",ITEMDA,?20,$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,25),?50,"QTY: ",+$P(DATA,"^",2),?65,$J(+$P(DATA,"^",3),15,2)
. . . . . . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
I $G(PRCPFLAG) Q
K ORROOM
;
; print report totals
D PRINTOTL^PRCPRPC3
Q
;
;
H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W $C(13),"PATIENT DISTRIBUTION COST REPORT FOR: ",$E(PRCP("IN"),1,20),?(80-$L(%)),%
S %="",$P(%,"-",81)=""
I $G(PRCPFTOT) W !,"*** R E P O R T T O T A L S ***",?46,$J("COUNT",10),$J("TOTAL COST",12),$J("AVERAGE",12),!,% Q
W !,"NAME-SSN",?11,"IO",?17,"OPCODE",?26,"DATE",?35,"SURGEON",?52,"OR ROOM",?70,"TOTAL COST",!,%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRPC2 4433 printed Dec 13, 2024@02:15:14 Page 2
PRCPRPC2 ;WISC/RFJ/DWA-patient distribution costs (print report) ;11 Mar 94
+1 ;;5.1;IFCAP;**32**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
PRINT ; print report
+1 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=Y
SET PAGE=1
SET SCREEN=$$SCRPAUSE^PRCPUREP
USE IO
DO H
+2 SET ORROOM=""
+3 ; show report variables selected
+4 WRITE !!?10,"*** R E P O R T V A R I A B L E S S E L E C T E D ***",!
+5 WRITE !,"SURGICAL SPECIALTY RANGE FROM : ",$SELECT(PRCPSURS="":"FIRST",1:PRCPSURS),?60,"TO: ",$SELECT(PRCPSURE="z":"LAST",1:PRCPSURE)
+6 WRITE !,"PATIENT NAME RANGE FROM : ",$SELECT(PRCPPATS="":"FIRST",1:PRCPPATS),?60,"TO: ",$SELECT(PRCPPATE="z":"LAST",1:PRCPPATE)
+7 WRITE !,"OPERATION/PROCEDURE CODE RANGE FROM: ",$SELECT(PRCPOPCS="":"FIRST",1:PRCPOPCS),?60,"TO: ",$SELECT(PRCPOPCE="z":"LAST",1:PRCPOPCE)
+8 SET Y=DATESTRT
DO DD^%DT
WRITE !,"DISTRIBUTION DATES FROM : ",Y
SET Y=DATEEND
DO DD^%DT
WRITE ?60,"TO: ",Y,!
+9 WRITE !,"PRINT SUMMARY ONLY : ",$SELECT(PRCPSUMM=1:"YES",1:"NO")
+10 WRITE !,"PRINT ITEMS ON REPORT: ",$SELECT($GET(PRCPFITM)=1:"YES",1:"NO")
+11 ;
+12 SET DISTRNM=""
FOR
SET DISTRNM=$ORDER(^TMP($JOB,"PRCPRPCR",DISTRNM))
if DISTRNM=""!($GET(PRCPFLAG))
QUIT
SET SURGSPEC=""
FOR
SET SURGSPEC=$ORDER(^TMP($JOB,"PRCPRPCR",DISTRNM,SURGSPEC))
if SURGSPEC=""!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+13 IF $GET(ZTQUEUED)
IF $$S^%ZTLOAD
SET PRCPFLAG=1
WRITE !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
QUIT
+14 IF $Y>(IOSL-8)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+15 IF '$GET(PRCPSUMM)
WRITE !!?5,"FROM Inventory Point: ",DISTRNM,?40,"TO Surgical Specialty: ",SURGSPEC
+16 SET INOUTPAT=""
FOR
SET INOUTPAT=$ORDER(^TMP($JOB,"PRCPRPCR",DISTRNM,SURGSPEC,INOUTPAT))
if INOUTPAT=""!($GET(PRCPFLAG))
QUIT
Begin DoDot:2
+17 SET PATNAME=""
FOR
SET PATNAME=$ORDER(^TMP($JOB,"PRCPRPCR",DISTRNM,SURGSPEC,INOUTPAT,PATNAME))
if PATNAME=""!($GET(PRCPFLAG))
QUIT
Begin DoDot:3
+18 SET OPCODE=""
FOR
SET OPCODE=$ORDER(^TMP($JOB,"PRCPRPCR",DISTRNM,SURGSPEC,INOUTPAT,PATNAME,OPCODE))
if OPCODE=""!($GET(PRCPFLAG))
QUIT
Begin DoDot:4
+19 SET DA=0
FOR
SET DA=$ORDER(^TMP($JOB,"PRCPRPCR",DISTRNM,SURGSPEC,INOUTPAT,PATNAME,OPCODE,DA))
if 'DA!($GET(PRCPFLAG))
QUIT
SET DATA=^(DA)
Begin DoDot:5
+20 SET SURGEON=$EXTRACT($$USER^PRCPUREP(+$PIECE(DATA,"^",2)),1,15)
IF SURGEON=""
SET SURGEON=" "
+21 SET TOTCOST=$PIECE(DATA,"^",3)
+22 ; accumulate totals
+23 SET %=$GET(^TMP($JOB,"PRCPRPCRT",1,DISTRNM))
SET $PIECE(%,"^")=$PIECE(%,"^")+1
SET $PIECE(%,"^",2)=$PIECE(%,"^",2)+TOTCOST
SET ^(DISTRNM)=%
+24 SET %=$GET(^TMP($JOB,"PRCPRPCRT",2,SURGSPEC))
SET $PIECE(%,"^")=$PIECE(%,"^")+1
SET $PIECE(%,"^",2)=$PIECE(%,"^",2)+TOTCOST
SET ^(SURGSPEC)=%
+25 SET %=$GET(^TMP($JOB,"PRCPRPCRT",2,SURGSPEC,INOUTPAT))
SET $PIECE(%,"^")=$PIECE(%,"^")+1
SET $PIECE(%,"^",2)=$PIECE(%,"^",2)+TOTCOST
SET ^(INOUTPAT)=%
+26 SET %=$GET(^TMP($JOB,"PRCPRPCRT",3,INOUTPAT))
SET $PIECE(%,"^")=$PIECE(%,"^")+1
SET $PIECE(%,"^",2)=$PIECE(%,"^",2)+TOTCOST
SET ^(INOUTPAT)=%
+27 SET %=$GET(^TMP($JOB,"PRCPRPCRT",4,OPCODE))
SET $PIECE(%,"^")=$PIECE(%,"^")+1
SET $PIECE(%,"^",2)=$PIECE(%,"^",2)+TOTCOST
SET ^(OPCODE)=%
+28 SET %=$GET(^TMP($JOB,"PRCPRPCRT",5,SURGEON))
SET $PIECE(%,"^")=$PIECE(%,"^")+1
SET $PIECE(%,"^",2)=$PIECE(%,"^",2)+TOTCOST
SET ^(SURGEON)=%
+29 SET %=$GET(^TMP($JOB,"PRCPRPCRT",6))
SET $PIECE(%,"^")=$PIECE(%,"^")+1
SET $PIECE(%,"^",2)=$PIECE(%,"^",2)+TOTCOST
SET ^(6)=%
+30 IF $GET(PRCPSUMM)
QUIT
+31 ;
+32 SET Y=DA
DO DD^%DT
SET DATE=$PIECE(Y,",")
+33 IF $PIECE(DATA,"^")'=""
SET ORROOM=$EXTRACT($PIECE($GET(^SC($PIECE($GET(^SRS(+$PIECE(DATA,"^"),0)),"^"),0)),"^"),1,10)
+34 if ORROOM=""
SET ORROOM="N/A"
+35 WRITE !,PATNAME,?12,INOUTPAT,?17,OPCODE,?26,DATE,?35,SURGEON,?52,ORROOM,?65,$JUSTIFY(TOTCOST,15,2)
SET ORROOM=""
+36 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+37 IF $GET(PRCPFITM)=1
SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^PRCP(446.1,DA,445,ITEMDA))
if 'ITEMDA!($GET(PRCPFLAG))
QUIT
SET DATA=$GET(^(ITEMDA,0))
IF DATA'=""
Begin DoDot:6
+38 WRITE !?10,"IM# ",ITEMDA,?20,$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,25),?50,"QTY: ",+$PIECE(DATA,"^",2),?65,$JUSTIFY(+$PIECE(DATA,"^",3),15,2)
+39 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+40 IF $GET(PRCPFLAG)
QUIT
+41 KILL ORROOM
+42 ;
+43 ; print report totals
+44 DO PRINTOTL^PRCPRPC3
+45 QUIT
+46 ;
+47 ;
H SET %=NOW_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+1 WRITE $CHAR(13),"PATIENT DISTRIBUTION COST REPORT FOR: ",$EXTRACT(PRCP("IN"),1,20),?(80-$LENGTH(%)),%
+2 SET %=""
SET $PIECE(%,"-",81)=""
+3 IF $GET(PRCPFTOT)
WRITE !,"*** R E P O R T T O T A L S ***",?46,$JUSTIFY("COUNT",10),$JUSTIFY("TOTAL COST",12),$JUSTIFY("AVERAGE",12),!,%
QUIT
+4 WRITE !,"NAME-SSN",?11,"IO",?17,"OPCODE",?26,"DATE",?35,"SURGEON",?52,"OR ROOM",?70,"TOTAL COST",!,%
+5 QUIT
