PRCPAWR1 ;WISC/DWA,RFJ-print register approval form (end of report) ;11 Mar 94
;;5.1;IFCAP;**4**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
BUILD ; build tmp global for printing the report
N DA,DATA,TRANID
K ^TMP($J,"PRCPAWR0 DA")
; build selected adjustements only
I $O(^TMP($J,"PRCPAWR0",""))'="" D Q
. S TRANID="" F S TRANID=$O(^TMP($J,"PRCPAWR0",TRANID)) Q:$E(TRANID)'="A" D BUILD1
; build all adjustments
S TRANID="A" F S TRANID=$O(^PRCP(445.2,"T",PRCP("I"),TRANID)) Q:$E(TRANID)'="A" D BUILD1
Q
;
;
BUILD1 ; build tmp global with adjustment data
S DA=0 F S DA=$O(^PRCP(445.2,"T",PRCP("I"),TRANID,DA)) Q:'DA S DATA=$G(^PRCP(445.2,DA,0)) I DATA'="" D
. I $P(DATA,"^",20)="" S ^TMP($J,"PRCPAWR0 DA",TRANID,DA)=""
Q
;
;
END ; print end of report information
W !!,"----------- S U M M A R Y O F I T E M A C C O U N T C O D E S ----------"
S TOTAL=0,ACCT=0 F S ACCT=$O(ACCOUNT(ACCT)) Q:ACCT=""!$G(PRCPFLAG) S DATA=ACCOUNT(ACCT) D
. I $X>40 W !
. E W ?40
. W "ACCT: ",ACCT,?($S($X<10:10,1:50)),"INV AMOUNT: ",$J(DATA,12,2) S TOTAL=TOTAL+DATA
. I $Y>(IOSL-2),$X>40,$O(^TMP($J,"ACCT",ACCT))'="" D:$G(SCREEN) P^PRCPUREP Q:$D(PRCPFLAG) D H^PRCPAWR0
K ACCOUNT
I $D(PRCPFLAG) Q
W !!,"TOTAL DOLLAR AMOUNT OF INVENTORY VALUE ADJUSTMENT (UNAPPROVED): ",$J(TOTAL,0,2)
I $D(PRCPMSG) W !!,PRCPMSG
I '$G(PRCPMULT) Q ;all adjustments printed on same report
K DATA F %=1:1 S DATA=$P($T(DATA+%),";",3,99) Q:DATA="" S DATA(%)=DATA
I $Y>(IOSL-%-2) D:$G(SCREEN) P^PRCPUREP Q:$D(PRCPFLAG) D H^PRCPAWR0
W ! S %=0 F S %=$O(DATA(%)) Q:'% W !,DATA(%)
I $O(^TMP($J,"PRCPAWR0 DA",TRANID))'="" D:$G(SCREEN) P^PRCPUREP W @IOF
S PAGE=0
Q
;
;
DATA ;print signature at bottom of report
;;CERTIFICATION -- THE SUPPLIES LISTED ON THIS REQUEST HAVE BEEN PROPERLY
;;ADJUSTED BY QUANTITY AND VALUE.
;;
;;ITEM NUMBERS APPROVED [#MI]:__________________________________________________
;;
;;SIGNATURE ACCOUNTABLE OFFICER:________________________________________________
;;
;;SIGNATURE APPROVING OFFICIAL:_________________________________________________
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPAWR1 2204 printed Sep 23, 2025@19:49 Page 2
PRCPAWR1 ;WISC/DWA,RFJ-print register approval form (end of report) ;11 Mar 94
+1 ;;5.1;IFCAP;**4**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
BUILD ; build tmp global for printing the report
+1 NEW DA,DATA,TRANID
+2 KILL ^TMP($JOB,"PRCPAWR0 DA")
+3 ; build selected adjustements only
+4 IF $ORDER(^TMP($JOB,"PRCPAWR0",""))'=""
Begin DoDot:1
+5 SET TRANID=""
FOR
SET TRANID=$ORDER(^TMP($JOB,"PRCPAWR0",TRANID))
if $EXTRACT(TRANID)'="A"
QUIT
DO BUILD1
End DoDot:1
QUIT
+6 ; build all adjustments
+7 SET TRANID="A"
FOR
SET TRANID=$ORDER(^PRCP(445.2,"T",PRCP("I"),TRANID))
if $EXTRACT(TRANID)'="A"
QUIT
DO BUILD1
+8 QUIT
+9 ;
+10 ;
BUILD1 ; build tmp global with adjustment data
+1 SET DA=0
FOR
SET DA=$ORDER(^PRCP(445.2,"T",PRCP("I"),TRANID,DA))
if 'DA
QUIT
SET DATA=$GET(^PRCP(445.2,DA,0))
IF DATA'=""
Begin DoDot:1
+2 IF $PIECE(DATA,"^",20)=""
SET ^TMP($JOB,"PRCPAWR0 DA",TRANID,DA)=""
End DoDot:1
+3 QUIT
+4 ;
+5 ;
END ; print end of report information
+1 WRITE !!,"----------- S U M M A R Y O F I T E M A C C O U N T C O D E S ----------"
+2 SET TOTAL=0
SET ACCT=0
FOR
SET ACCT=$ORDER(ACCOUNT(ACCT))
if ACCT=""!$GET(PRCPFLAG)
QUIT
SET DATA=ACCOUNT(ACCT)
Begin DoDot:1
+3 IF $X>40
WRITE !
+4 IF '$TEST
WRITE ?40
+5 WRITE "ACCT: ",ACCT,?($SELECT($X<10:10,1:50)),"INV AMOUNT: ",$JUSTIFY(DATA,12,2)
SET TOTAL=TOTAL+DATA
+6 IF $Y>(IOSL-2)
IF $X>40
IF $ORDER(^TMP($JOB,"ACCT",ACCT))'=""
if $GET(SCREEN)
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H^PRCPAWR0
End DoDot:1
+7 KILL ACCOUNT
+8 IF $DATA(PRCPFLAG)
QUIT
+9 WRITE !!,"TOTAL DOLLAR AMOUNT OF INVENTORY VALUE ADJUSTMENT (UNAPPROVED): ",$JUSTIFY(TOTAL,0,2)
+10 IF $DATA(PRCPMSG)
WRITE !!,PRCPMSG
+11 ;all adjustments printed on same report
IF '$GET(PRCPMULT)
QUIT
+12 KILL DATA
FOR %=1:1
SET DATA=$PIECE($TEXT(DATA+%),";",3,99)
if DATA=""
QUIT
SET DATA(%)=DATA
+13 IF $Y>(IOSL-%-2)
if $GET(SCREEN)
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H^PRCPAWR0
+14 WRITE !
SET %=0
FOR
SET %=$ORDER(DATA(%))
if '%
QUIT
WRITE !,DATA(%)
+15 IF $ORDER(^TMP($JOB,"PRCPAWR0 DA",TRANID))'=""
if $GET(SCREEN)
DO P^PRCPUREP
WRITE @IOF
+16 SET PAGE=0
+17 QUIT
+18 ;
+19 ;
DATA ;print signature at bottom of report
+1 ;;CERTIFICATION -- THE SUPPLIES LISTED ON THIS REQUEST HAVE BEEN PROPERLY
+2 ;;ADJUSTED BY QUANTITY AND VALUE.
+3 ;;
+4 ;;ITEM NUMBERS APPROVED [#MI]:__________________________________________________
+5 ;;
+6 ;;SIGNATURE ACCOUNTABLE OFFICER:________________________________________________
+7 ;;
+8 ;;SIGNATURE APPROVING OFFICIAL:_________________________________________________
