PRCPRVSR ;WISC/RFJ-voucher summary (option, whse) ;9.9.97
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D ^PRCPUSEL Q:'$D(PRCP("I"))
N %,%H,%I,DATESTRT,X,Y
K X S X(1)="The Voucher Summary Report will print a listing of all issues, receipts, and adjustments. It will display the opening and closing balances by account codes."
D DISPLAY^PRCPUX2(40,79,.X)
K X S X(1)="Enter the date (month-year) for the Voucher Summary Report." D DISPLAY^PRCPUX2(2,40,.X)
D NOW^%DTC S Y=$E(X,1,5)_"00" S %DT(0)=-Y D DD^%DT S %DT="AEP",%DT("B")=Y,%DT("A")="Print Voucher Summary for MONTH and YEAR: " D ^%DT K %DT I Y<1 Q
S DATESTRT=$E(Y,1,5)_"00"
W ! S %ZIS="Q" D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
. S ZTDESC="Voucher Summary Report",ZTRTN="DQ^PRCPRVSR"
. S ZTSAVE("PRC*")="",ZTSAVE("DATESTRT")="",ZTSAVE("ZTREQ")="@"
W !!,"<*> please wait <*>"
DQ ; queue starts here
N ACCT,CC,D,DA,DATE,INVVAL,ISSUE,ITEMDA,OPEN,REFNO,SA,SELLVAL,TRANSID,TRANSNO,TYPE,X,Y
K OPEN
S ITEMDA=0 F S ITEMDA=$O(^PRCP(445.1,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S X=$$GETOPEN^PRCPUBAL(PRCP("I"),ITEMDA,$E(DATESTRT,1,5)) I X'="" D
. S ACCT=$$ACCT1^PRCPUX1($E($$NSN^PRCPUX1(ITEMDA),1,4))
. S $P(OPEN(ACCT),"^")=$P($G(OPEN(ACCT)),"^")+$P(X,"^",2)+$P(X,"^",3)
. S $P(OPEN(ACCT),"^",2)=$P($G(OPEN(ACCT)),"^",2)+$P(X,"^",8)
K ^TMP($J,"PRCPRVSR")
S DATE=DATESTRT F S DATE=$O(^PRCP(445.2,"AX",PRCP("I"),DATE)) Q:$E(DATE,1,5)'=$E(DATESTRT,1,5) S TYPE="" F S TYPE=$O(^PRCP(445.2,"AX",PRCP("I"),DATE,TYPE)) Q:TYPE="" D
. S DA=0 F S DA=$O(^PRCP(445.2,"AX",PRCP("I"),DATE,TYPE,DA)) Q:'DA D
. . S D=$G(^PRCP(445.2,DA,0)) I '$P(D,"^",5) Q
. . ; non-issuable
. . I $P(D,"^",11)'="" Q
. . S ACCT=$$ACCT1^PRCPUX1($P($$NSN^PRCPUX1($P(D,"^",5)),"-"))
. . S REFNO=$P(D,"^",15),TRANSNO=$P(D,"^",19),TRANSID=$P(D,"^",2),(ISSUE,CC,SA)=""
. . S INVVAL=$P(D,"^",7)*$P(D,"^",8),SELLVAL=$P(D,"^",7)*$P(D,"^",9)
. . I $P(D,"^",22)'="" S INVVAL=$P(D,"^",22),SELLVAL=$P(D,"^",23)
. . ; other adjustments
. . I $P(TRANSNO,"-",2)="" S TRANSNO="OTHER"
. . ; purchase order
. . I +TRANSNO,$P(TRANSNO,"-",3)="" S REFNO=$P($P(D,"^",19),"-",2),TRANSNO=$P(TRANSNO,"-"),SELLVAL=INVVAL
. . ; issue
. . I +TRANSNO,$P(TRANSNO,"-",3)'="" D
. . . S CC=$P($G(^PRCS(410,+$O(^PRCS(410,"B",TRANSNO,0)),3)),"^",3),CC=+$S($D(^PRCD(420.1,+CC,0)):$P(^(0),"^"),1:CC),SA=$$SUBACCT^PRCPU441(+$P(D,"^",5)),TRANSNO=$P(TRANSNO,"-")_"-"_$P(TRANSNO,"-",4,5)
. . S:REFNO="" REFNO="?????"
. . I $D(^TMP($J,"PRCPRVSR",ACCT,REFNO,$E($P(D,"^",3),1,7),TRANSID)) S %=^(TRANSID) I $P(%,"^",3)=CC S $P(%,"^",5)=$P(%,"^",5)+$P(D,"^",7),$P(%,"^",6)=$P(%,"^",6)+INVVAL,$P(%,"^",7)=$P(%,"^",7)+SELLVAL,^(TRANSID)=% Q
. . S ^TMP($J,"PRCPRVSR",ACCT,REFNO,$E($P(D,"^",3),1,7),$P(D,"^",2))=TRANSNO_"^"_$P(D,"^",2)_"^"_CC_"^"_SA_"^"_$P(D,"^",7)_"^"_INVVAL_"^"_SELLVAL
D PRINT^PRCPRVS0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRVSR 3009 printed Apr 09, 2024@21:00:26 Page 2
PRCPRVSR ;WISC/RFJ-voucher summary (option, whse) ;9.9.97
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO ^PRCPUSEL
if '$DATA(PRCP("I"))
QUIT
+4 NEW %,%H,%I,DATESTRT,X,Y
+5 KILL X
SET X(1)="The Voucher Summary Report will print a listing of all issues, receipts, and adjustments. It will display the opening and closing balances by account codes."
+6 DO DISPLAY^PRCPUX2(40,79,.X)
+7 KILL X
SET X(1)="Enter the date (month-year) for the Voucher Summary Report."
DO DISPLAY^PRCPUX2(2,40,.X)
+8 DO NOW^%DTC
SET Y=$EXTRACT(X,1,5)_"00"
SET %DT(0)=-Y
DO DD^%DT
SET %DT="AEP"
SET %DT("B")=Y
SET %DT("A")="Print Voucher Summary for MONTH and YEAR: "
DO ^%DT
KILL %DT
IF Y<1
QUIT
+9 SET DATESTRT=$EXTRACT(Y,1,5)_"00"
+10 WRITE !
SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
Begin DoDot:1
+11 SET ZTDESC="Voucher Summary Report"
SET ZTRTN="DQ^PRCPRVSR"
+12 SET ZTSAVE("PRC*")=""
SET ZTSAVE("DATESTRT")=""
SET ZTSAVE("ZTREQ")="@"
End DoDot:1
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
QUIT
+13 WRITE !!,"<*> please wait <*>"
DQ ; queue starts here
+1 NEW ACCT,CC,D,DA,DATE,INVVAL,ISSUE,ITEMDA,OPEN,REFNO,SA,SELLVAL,TRANSID,TRANSNO,TYPE,X,Y
+2 KILL OPEN
+3 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^PRCP(445.1,PRCP("I"),1,ITEMDA))
if 'ITEMDA
QUIT
SET X=$$GETOPEN^PRCPUBAL(PRCP("I"),ITEMDA,$EXTRACT(DATESTRT,1,5))
IF X'=""
Begin DoDot:1
+4 SET ACCT=$$ACCT1^PRCPUX1($EXTRACT($$NSN^PRCPUX1(ITEMDA),1,4))
+5 SET $PIECE(OPEN(ACCT),"^")=$PIECE($GET(OPEN(ACCT)),"^")+$PIECE(X,"^",2)+$PIECE(X,"^",3)
+6 SET $PIECE(OPEN(ACCT),"^",2)=$PIECE($GET(OPEN(ACCT)),"^",2)+$PIECE(X,"^",8)
End DoDot:1
+7 KILL ^TMP($JOB,"PRCPRVSR")
+8 SET DATE=DATESTRT
FOR
SET DATE=$ORDER(^PRCP(445.2,"AX",PRCP("I"),DATE))
if $EXTRACT(DATE,1,5)'=$EXTRACT(DATESTRT,1,5)
QUIT
SET TYPE=""
FOR
SET TYPE=$ORDER(^PRCP(445.2,"AX",PRCP("I"),DATE,TYPE))
if TYPE=""
QUIT
Begin DoDot:1
+9 SET DA=0
FOR
SET DA=$ORDER(^PRCP(445.2,"AX",PRCP("I"),DATE,TYPE,DA))
if 'DA
QUIT
Begin DoDot:2
+10 SET D=$GET(^PRCP(445.2,DA,0))
IF '$PIECE(D,"^",5)
QUIT
+11 ; non-issuable
+12 IF $PIECE(D,"^",11)'=""
QUIT
+13 SET ACCT=$$ACCT1^PRCPUX1($PIECE($$NSN^PRCPUX1($PIECE(D,"^",5)),"-"))
+14 SET REFNO=$PIECE(D,"^",15)
SET TRANSNO=$PIECE(D,"^",19)
SET TRANSID=$PIECE(D,"^",2)
SET (ISSUE,CC,SA)=""
+15 SET INVVAL=$PIECE(D,"^",7)*$PIECE(D,"^",8)
SET SELLVAL=$PIECE(D,"^",7)*$PIECE(D,"^",9)
+16 IF $PIECE(D,"^",22)'=""
SET INVVAL=$PIECE(D,"^",22)
SET SELLVAL=$PIECE(D,"^",23)
+17 ; other adjustments
+18 IF $PIECE(TRANSNO,"-",2)=""
SET TRANSNO="OTHER"
+19 ; purchase order
+20 IF +TRANSNO
IF $PIECE(TRANSNO,"-",3)=""
SET REFNO=$PIECE($PIECE(D,"^",19),"-",2)
SET TRANSNO=$PIECE(TRANSNO,"-")
SET SELLVAL=INVVAL
+21 ; issue
+22 IF +TRANSNO
IF $PIECE(TRANSNO,"-",3)'=""
Begin DoDot:3
+23 SET CC=$PIECE($GET(^PRCS(410,+$ORDER(^PRCS(410,"B",TRANSNO,0)),3)),"^",3)
SET CC=+$SELECT($DATA(^PRCD(420.1,+CC,0)):$PIECE(^(0),"^"),1:CC)
SET SA=$$SUBACCT^PRCPU441(+$PIECE(D,"^",5))
SET TRANSNO=$PIECE(TRANSNO,"-")_"-"_$PIECE(TRANSNO,"-",4,5)
End DoDot:3
+24 if REFNO=""
SET REFNO="?????"
+25 IF $DATA(^TMP($JOB,"PRCPRVSR",ACCT,REFNO,$EXTRACT($PIECE(D,"^",3),1,7),TRANSID))
SET %=^(TRANSID)
IF $PIECE(%,"^",3)=CC
SET $PIECE(%,"^",5)=$PIECE(%,"^",5)+$PIECE(D,"^",7)
SET $PIECE(%,"^",6)=$PIECE(%,"^",6)+INVVAL
SET $PIECE(%,"^",7)=$PIECE(%,"^",7)+SELLVAL
SET ^(TRANSID)=%
QUIT
+26 SET ^TMP($JOB,"PRCPRVSR",ACCT,REFNO,$EXTRACT($PIECE(D,"^",3),1,7),$PIECE(D,"^",2))=TRANSNO_"^"_$PIECE(D,"^",2)_"^"_CC_"^"_SA_"^"_$PIECE(D,"^",7)_"^"_INVVAL_"^"_SELLVAL
End DoDot:2
End DoDot:1
+27 DO PRINT^PRCPRVS0
+28 QUIT
