- 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 Feb 18, 2025@23:39:18 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:_________________________________________________
