- 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 23, 2025@18:30:13 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
