PRCPRVS0 ;WISC/RFJ-voucher summary (continued) ;15 Jun 92
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
PRINT ; print report
N %,ACCT,ACCTBAL,CC,D,DATE,MONTH,NOW,OPENBAL,P,PAGE,PRCPFLAG,REFNO,SCREEN,TACCISS,TACCISSA,TACCOTH,TACCREC,TACCRECA,TACCT,TRANSID,TRANSNO,TSUPISS,TSUPISSA,TSUPOTH,TSUPREC,TSUPRECA,X,Y
S Y=DATESTRT D DD^%DT S MONTH=Y
S SCREEN=$$SCRPAUSE^PRCPUREP,PAGE=1 D NOW^%DTC S Y=% D DD^%DT S NOW=Y U IO
S (TSUPISS,TSUPISSA,TSUPOTH,TSUPREC,TSUPRECA,ACCT,ACCTBAL,OPENBAL)=""
F S ACCT=$O(OPEN(ACCT)) Q:'ACCT!($G(PRCPFLAG)) D H D
. S (TACCISS,TACCISSA,TACCOTH,TACCREC,TACCRECA)=""
. S $P(OPENBAL,"^")=$P(OPENBAL,"^")+$P(OPEN(ACCT),"^"),$P(OPENBAL,"^",2)=$P(OPENBAL,"^",2)+$P(OPEN(ACCT),"^",2)
. S REFNO="" F S REFNO=$O(^TMP($J,"PRCPRVSR",ACCT,REFNO)) Q:REFNO=""!($G(PRCPFLAG)) S DATE="" F S DATE=$O(^TMP($J,"PRCPRVSR",ACCT,REFNO,DATE)) Q:'DATE!($G(PRCPFLAG)) D
. . S TRANSID=0 F S TRANSID=$O(^TMP($J,"PRCPRVSR",ACCT,REFNO,DATE,TRANSID)) Q:(TRANSID)=""!($G(PRCPFLAG)) S D=^(TRANSID) D
. . . S CC=$E($P(D,"^",3),1,4) I CC'="" S CC=CC_"/"_$P(D,"^",4)
. . . W !,REFNO,?8,$E(DATE,6,7),?13,$P(D,"^"),?27,$P(D,"^",2),?37,CC,?49,$J($FN($P(D,"^",5),"T+"),9),$$SHOWVALU($P(D,"^",6)),$$SHOWVALU($P(D,"^",7))
. . . S TRANSNO=$P(D,"^") I TRANSNO="OTHER" D SETVAR("TACCOTH")
. . . ; set totals for receipts
. . . I +TRANSNO,$P(TRANSNO,"-",2)="" D
. . . . I $E($P(D,"^",2))="R" D SETVAR("TACCREC") Q
. . . . D SETVAR("TACCRECA")
. . . ; set totals for issues
. . . I +TRANSNO,$P(TRANSNO,"-",2)'="" D
. . . . I $E($P(D,"^",2))="R" D SETVAR("TACCISS") Q
. . . . D SETVAR("TACCISSA")
. . . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
. . I '$G(PRCPFLAG),$Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
. . I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
. I $G(PRCPFLAG) Q
. I $Y>(IOSL-11) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
. W !!?4,"TOTAL ACCT CODE ISSUES:",?49,$$SHOWTOTL("TACCISS")
. W !?4,"TOTAL ACCT CODE ISSUE ADJ:",?49,$$SHOWTOTL("TACCISSA")
. W !?4,"TOTAL ACCT CODE RECEIPTS:",?49,$$SHOWTOTL("TACCREC")
. W !?4,"TOTAL ACCT CODE RECEIPT ADJ:",?49,$$SHOWTOTL("TACCRECA")
. W !?4,"TOTAL ACCT CODE OTHER ADJ:",?49,$$SHOWTOTL("TACCOTH")
. S TACCT="" F %="TACCISS","TACCISSA","TACCOTH","TACCREC","TACCRECA" F P=1:1:3 S $P(TACCT,"^",P)=$P(TACCT,"^",P)+$P(@%,"^",P),X="TSUP"_$E(%,5,8),$P(@X,"^",P)=$P(@X,"^",P)+$P(@%,"^",P)
. W !!?4,"OPEN BALANCE FOR ACCT CODE '",ACCT,"':",?49,$J($FN($P($G(OPEN(ACCT)),"^"),"T+"),9),$$SHOWVALU($P($G(OPEN(ACCT)),"^",2))
. W !?4,"TOTALS FOR ACCT CODE '",ACCT,"':",?49,$$SHOWTOTL("TACCT")
. S %="",$P(%,"^")=$P($G(OPEN(ACCT)),"^")+$P(TACCT,"^"),$P(%,"^",2)=$P($G(OPEN(ACCT)),"^",2)+$P(TACCT,"^",2)
. S $P(ACCTBAL,"^")=$P(ACCTBAL,"^")+$P(%,"^"),$P(ACCTBAL,"^",2)=$P(ACCTBAL,"^",2)+$P(%,"^",2)
. W !?4,"CLOSING BALANCE FOR ACCT CODE '",ACCT,"':",?49,$J($FN($P(%,"^"),"T+"),9),$$SHOWVALU($P(%,"^",2))
. I $O(^TMP($J,"PRCPRVSR",ACCT)) D:SCREEN P^PRCPUREP
I $G(PRCPFLAG) D Q Q
I $Y>(IOSL-12) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) S ACCT="END OF REPORT" D H
W !!,"** TOTAL SUPPLY ISSUES:",?49,$$SHOWTOTL("TSUPISS")
W !,"** TOTAL SUPPLY ISSUE ADJ:",?49,$$SHOWTOTL("TSUPISSA")
W !,"** TOTAL SUPPLY RECEIPTS:",?49,$$SHOWTOTL("TSUPREC")
W !,"** TOTAL SUPPLY RECEIPT ADJ:",?49,$$SHOWTOTL("TSUPRECA")
W !,"** TOTAL OTHER ADJ:",?49,$$SHOWTOTL("TSUPOTH")
S TACCT="" F %="TSUPISS","TSUPISSA","TSUPOTH","TSUPREC","TSUPRECA" F P=1:1:3 S $P(TACCT,"^",P)=$P(TACCT,"^",P)+$P(@%,"^",P)
W !!,"** TOTALS FOR SUPPLY:",?49,$$SHOWTOTL("TACCT")
W !!,"** OPENING BALANCE FOR SUPPLY:",?49,$J($FN($P(OPENBAL,"^"),"T+"),9),$$SHOWVALU($P(OPENBAL,"^",2))
W !,"** CLOSING BALANCE FOR SUPPLY:",?49,$J($FN($P(ACCTBAL,"^"),"T+"),9),$$SHOWVALU($P(ACCTBAL,"^",2))
D END^PRCPUREP
Q D ^%ZISC K ^TMP($J,"PRCPRVSR") Q
;
;
SETVAR(V1) ;set total variable v1
F %=1:1:3 S $P(@V1,"^",%)=$P(@V1,"^",%)+$P(D,"^",%+4)
Q
;
;
SHOWTOTL(V1) ;print totals for variable v1
Q $J($FN($P(@V1,"^"),"T+"),9)_$$SHOWVALU($P(@V1,"^",2))_$$SHOWVALU($P(@V1,"^",3))
;
;
SHOWVALU(V1) ;show value
N % S %="+" S:+V1=0 %=" " I V1<0 S V1=-V1,%="-"
Q $J(V1,10,2)_%
;
;
H ;heading
S %=NOW_" PAGE: "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W $C(13),"VOUCHER SUMMARY REPORT FOR: ",$E(PRCP("IN"),1,20),?(80-$L(%)),%
W !?5,"TRANSACTIONS FOR THE MONTH-YEAR: ",MONTH
W !?4,"ACCOUNT CODE: ",ACCT,?30,"STA-INVENTORY POINT: ",PRC("SITE"),"-",PRCP("IN")
W !,"REF #",?8,"DT",?13,"STA-FCP-2237",?27,"TRANSID",?37," CC/SA",?54,"QTY",?63,"INV $",?73,"SELL $"
S %="",$P(%,"-",81)="" W !,%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRVS0 4857 printed Sep 23, 2025@19:51:46 Page 2
PRCPRVS0 ;WISC/RFJ-voucher summary (continued) ;15 Jun 92
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
PRINT ; print report
+1 NEW %,ACCT,ACCTBAL,CC,D,DATE,MONTH,NOW,OPENBAL,P,PAGE,PRCPFLAG,REFNO,SCREEN,TACCISS,TACCISSA,TACCOTH,TACCREC,TACCRECA,TACCT,TRANSID,TRANSNO,TSUPISS,TSUPISSA,TSUPOTH,TSUPREC,TSUPRECA,X,Y
+2 SET Y=DATESTRT
DO DD^%DT
SET MONTH=Y
+3 SET SCREEN=$$SCRPAUSE^PRCPUREP
SET PAGE=1
DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=Y
USE IO
+4 SET (TSUPISS,TSUPISSA,TSUPOTH,TSUPREC,TSUPRECA,ACCT,ACCTBAL,OPENBAL)=""
+5 FOR
SET ACCT=$ORDER(OPEN(ACCT))
if 'ACCT!($GET(PRCPFLAG))
QUIT
DO H
Begin DoDot:1
+6 SET (TACCISS,TACCISSA,TACCOTH,TACCREC,TACCRECA)=""
+7 SET $PIECE(OPENBAL,"^")=$PIECE(OPENBAL,"^")+$PIECE(OPEN(ACCT),"^")
SET $PIECE(OPENBAL,"^",2)=$PIECE(OPENBAL,"^",2)+$PIECE(OPEN(ACCT),"^",2)
+8 SET REFNO=""
FOR
SET REFNO=$ORDER(^TMP($JOB,"PRCPRVSR",ACCT,REFNO))
if REFNO=""!($GET(PRCPFLAG))
QUIT
SET DATE=""
FOR
SET DATE=$ORDER(^TMP($JOB,"PRCPRVSR",ACCT,REFNO,DATE))
if 'DATE!($GET(PRCPFLAG))
QUIT
Begin DoDot:2
+9 SET TRANSID=0
FOR
SET TRANSID=$ORDER(^TMP($JOB,"PRCPRVSR",ACCT,REFNO,DATE,TRANSID))
if (TRANSID)=""!($GET(PRCPFLAG))
QUIT
SET D=^(TRANSID)
Begin DoDot:3
+10 SET CC=$EXTRACT($PIECE(D,"^",3),1,4)
IF CC'=""
SET CC=CC_"/"_$PIECE(D,"^",4)
+11 WRITE !,REFNO,?8,$EXTRACT(DATE,6,7),?13,$PIECE(D,"^"),?27,$PIECE(D,"^",2),?37,CC,?49,$JUSTIFY($FNUMBER($PIECE(D,"^",5),"T+"),9),$$SHOWVALU($PIECE(D,"^",6)),$$SHOWVALU($PIECE(D,"^",7))
+12 SET TRANSNO=$PIECE(D,"^")
IF TRANSNO="OTHER"
DO SETVAR("TACCOTH")
+13 ; set totals for receipts
+14 IF +TRANSNO
IF $PIECE(TRANSNO,"-",2)=""
Begin DoDot:4
+15 IF $EXTRACT($PIECE(D,"^",2))="R"
DO SETVAR("TACCREC")
QUIT
+16 DO SETVAR("TACCRECA")
End DoDot:4
+17 ; set totals for issues
+18 IF +TRANSNO
IF $PIECE(TRANSNO,"-",2)'=""
Begin DoDot:4
+19 IF $EXTRACT($PIECE(D,"^",2))="R"
DO SETVAR("TACCISS")
QUIT
+20 DO SETVAR("TACCISSA")
End DoDot:4
+21 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
DO H
End DoDot:3
+22 IF '$GET(PRCPFLAG)
IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
DO H
+23 IF $GET(ZTQUEUED)
IF $$S^%ZTLOAD
SET PRCPFLAG=1
WRITE !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
End DoDot:2
+24 IF $GET(PRCPFLAG)
QUIT
+25 IF $Y>(IOSL-11)
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
DO H
+26 WRITE !!?4,"TOTAL ACCT CODE ISSUES:",?49,$$SHOWTOTL("TACCISS")
+27 WRITE !?4,"TOTAL ACCT CODE ISSUE ADJ:",?49,$$SHOWTOTL("TACCISSA")
+28 WRITE !?4,"TOTAL ACCT CODE RECEIPTS:",?49,$$SHOWTOTL("TACCREC")
+29 WRITE !?4,"TOTAL ACCT CODE RECEIPT ADJ:",?49,$$SHOWTOTL("TACCRECA")
+30 WRITE !?4,"TOTAL ACCT CODE OTHER ADJ:",?49,$$SHOWTOTL("TACCOTH")
+31 SET TACCT=""
FOR %="TACCISS","TACCISSA","TACCOTH","TACCREC","TACCRECA"
FOR P=1:1:3
SET $PIECE(TACCT,"^",P)=$PIECE(TACCT,"^",P)+$PIECE(@%,"^",P)
SET X="TSUP"_$EXTRACT(%,5,8)
SET $PIECE(@X,"^",P)=$PIECE(@X,"^",P)+$PIECE(@%,"^",P)
+32 WRITE !!?4,"OPEN BALANCE FOR ACCT CODE '",ACCT,"':",?49,$JUSTIFY($FNUMBER($PIECE($GET(OPEN(ACCT)),"^"),"T+"),9),$$SHOWVALU($PIECE($GET(OPEN(ACCT)),"^",2))
+33 WRITE !?4,"TOTALS FOR ACCT CODE '",ACCT,"':",?49,$$SHOWTOTL("TACCT")
+34 SET %=""
SET $PIECE(%,"^")=$PIECE($GET(OPEN(ACCT)),"^")+$PIECE(TACCT,"^")
SET $PIECE(%,"^",2)=$PIECE($GET(OPEN(ACCT)),"^",2)+$PIECE(TACCT,"^",2)
+35 SET $PIECE(ACCTBAL,"^")=$PIECE(ACCTBAL,"^")+$PIECE(%,"^")
SET $PIECE(ACCTBAL,"^",2)=$PIECE(ACCTBAL,"^",2)+$PIECE(%,"^",2)
+36 WRITE !?4,"CLOSING BALANCE FOR ACCT CODE '",ACCT,"':",?49,$JUSTIFY($FNUMBER($PIECE(%,"^"),"T+"),9),$$SHOWVALU($PIECE(%,"^",2))
+37 IF $ORDER(^TMP($JOB,"PRCPRVSR",ACCT))
if SCREEN
DO P^PRCPUREP
End DoDot:1
+38 IF $GET(PRCPFLAG)
DO Q
QUIT
+39 IF $Y>(IOSL-12)
if SCREEN
DO P^PRCPUREP
if $GET(PRCPFLAG)
QUIT
SET ACCT="END OF REPORT"
DO H
+40 WRITE !!,"** TOTAL SUPPLY ISSUES:",?49,$$SHOWTOTL("TSUPISS")
+41 WRITE !,"** TOTAL SUPPLY ISSUE ADJ:",?49,$$SHOWTOTL("TSUPISSA")
+42 WRITE !,"** TOTAL SUPPLY RECEIPTS:",?49,$$SHOWTOTL("TSUPREC")
+43 WRITE !,"** TOTAL SUPPLY RECEIPT ADJ:",?49,$$SHOWTOTL("TSUPRECA")
+44 WRITE !,"** TOTAL OTHER ADJ:",?49,$$SHOWTOTL("TSUPOTH")
+45 SET TACCT=""
FOR %="TSUPISS","TSUPISSA","TSUPOTH","TSUPREC","TSUPRECA"
FOR P=1:1:3
SET $PIECE(TACCT,"^",P)=$PIECE(TACCT,"^",P)+$PIECE(@%,"^",P)
+46 WRITE !!,"** TOTALS FOR SUPPLY:",?49,$$SHOWTOTL("TACCT")
+47 WRITE !!,"** OPENING BALANCE FOR SUPPLY:",?49,$JUSTIFY($FNUMBER($PIECE(OPENBAL,"^"),"T+"),9),$$SHOWVALU($PIECE(OPENBAL,"^",2))
+48 WRITE !,"** CLOSING BALANCE FOR SUPPLY:",?49,$JUSTIFY($FNUMBER($PIECE(ACCTBAL,"^"),"T+"),9),$$SHOWVALU($PIECE(ACCTBAL,"^",2))
+49 DO END^PRCPUREP
Q DO ^%ZISC
KILL ^TMP($JOB,"PRCPRVSR")
QUIT
+1 ;
+2 ;
SETVAR(V1) ;set total variable v1
+1 FOR %=1:1:3
SET $PIECE(@V1,"^",%)=$PIECE(@V1,"^",%)+$PIECE(D,"^",%+4)
+2 QUIT
+3 ;
+4 ;
SHOWTOTL(V1) ;print totals for variable v1
+1 QUIT $JUSTIFY($FNUMBER($PIECE(@V1,"^"),"T+"),9)_$$SHOWVALU($PIECE(@V1,"^",2))_$$SHOWVALU($PIECE(@V1,"^",3))
+2 ;
+3 ;
SHOWVALU(V1) ;show value
+1 NEW %
SET %="+"
if +V1=0
SET %=" "
IF V1<0
SET V1=-V1
SET %="-"
+2 QUIT $JUSTIFY(V1,10,2)_%
+3 ;
+4 ;
H ;heading
+1 SET %=NOW_" PAGE: "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+2 WRITE $CHAR(13),"VOUCHER SUMMARY REPORT FOR: ",$EXTRACT(PRCP("IN"),1,20),?(80-$LENGTH(%)),%
+3 WRITE !?5,"TRANSACTIONS FOR THE MONTH-YEAR: ",MONTH
+4 WRITE !?4,"ACCOUNT CODE: ",ACCT,?30,"STA-INVENTORY POINT: ",PRC("SITE"),"-",PRCP("IN")
+5 WRITE !,"REF #",?8,"DT",?13,"STA-FCP-2237",?27,"TRANSID",?37," CC/SA",?54,"QTY",?63,"INV $",?73,"SELL $"
+6 SET %=""
SET $PIECE(%,"-",81)=""
WRITE !,%
+7 QUIT
