PRCPAWR0 ;WISC/RFJ/BGJ-print register approval form ;9.9.97
;;5.1;IFCAP;**14**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D ^PRCPUSEL Q:'$G(PRCP("I"))
I PRCP("DPTYPE")'="W" W !,"ONLY THE WAREHOUSE CAN USE THIS OPTION." Q
N %,PRCPFALL,PRCPMULT,TOTAL,TRANID
;
; select list of adjustments
K ^TMP($J,"PRCPAWR0")
W !!,"To select ALL adjustments, press RETURN."
S TOTAL=0 F S TRANID=$$ADJUSTNO^PRCPAWAP Q:TRANID["^" S ^TMP($J,"PRCPAWR0",TRANID)="",TOTAL=TOTAL+1
I $O(^TMP($J,"PRCPAWR0",""))="" S XP="Do you want to select ALL adjustments",XH="Enter 'YES' to select ALL adjustments, 'NO' or '^' to exit." W ! S %=$$YN^PRCPUYN(1) Q:'% I %=1 S PRCPFALL=1
I '$G(PRCPFALL),$O(^TMP($J,"PRCPAWR0",""))="" Q
;
; if more than one adjustment is selected, ask to print one
; report or multiple reports.
S PRCPMULT=1
I $G(PRCPFALL)!(TOTAL>1) D I %<1 Q
. S XP="DO YOU WANT TO PRINT A SEPARATE REPORT FOR EACH ADJUSTMENT (THIS WILL",XP(1)="USE A LOT OF PAPER)"
. S XH="ENTER 'YES' TO PRINT EACH UNAPPROVED ADJUSTMENT ON A SINGLE PIECE OF PAPER,",XH(1)=" 'NO' TO PRINT ALL UNAPPROVED ADJUSTMENTS ON THE SAME REPORT."
. W !! S %=$$YN^PRCPUYN(2) I %=2 K PRCPMULT
;
S %ZIS="Q" W ! D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK D Q Q
. S ZTDESC="Adjustment Approval Form",ZTRTN="DQ^PRCPAWR0"
. S ZTSAVE("PRCP*")="",ZTSAVE("^TMP($J,""PRCPAWR0"",")="",ZTSAVE("ZTREQ")="@"
;
DQ ; queue starts here.
N %,%H,%I,ACCOUNT,ACCT,ADJDT,DA,DATA,INVPT,NOW,NSN,PAGE,PRCPFLAG,SCREEN,TOTAL,TRANID,VALUEINV,VALUESAL,VOUCHER,X,Y
; build adjustments from ^tmp($j,"prcpawr0",tranid)=""
D BUILD^PRCPAWR1
;
; start printing report.
D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=0,SCREEN=$$SCRPAUSE^PRCPUREP U IO
S TRANID="A" F S TRANID=$O(^TMP($J,"PRCPAWR0 DA",TRANID)) Q:$E(TRANID)'="A"!($D(PRCPFLAG)) K ADJDT,INVPT S DA=0 F S DA=$O(^TMP($J,"PRCPAWR0 DA",TRANID,DA)) Q:'DA!($D(PRCPFLAG)) D
. S DATA=$G(^PRCP(445.2,DA,0)) I DATA="" Q
. S VOUCHER=$P(DATA,"^",15)
. I $G(PRCPMULT),'$D(ADJDT) S Y=$P(DATA,"^",17) I +Y D DD^%DT S ADJDT=Y
. I $G(PRCPMULT),'$D(INVPT),$P(DATA,"^",18) S INVPT=$$INVNAME^PRCPUX1($P(DATA,"^",18))
. I PAGE=0 S PAGE=1 D H
. ;
. S NSN=$$NSN^PRCPUX1(+$P(DATA,"^",5)),ACCT=$$ACCT1^PRCPUX1($E(NSN,1,4))
. W !!,NSN,?19,$E($$DESCR^PRCPUX1(PRCP("I"),$P(DATA,"^",5)),1,28),?49,"#",$P(DATA,"^",5),?60,"ACCT: ",ACCT,?73,$J($$INITIALS^PRCPUREP($P(DATA,"^",16)),6)
. S VALUEINV=$J($P(DATA,"^",7)*$P(DATA,"^",8),0,2),VALUESAL=$J($P(DATA,"^",7)*$P(DATA,"^",9),0,2)
. I $P(DATA,"^",22)'="" S VALUEINV=$J($P(DATA,"^",22),0,2),VALUESAL=$J($P(DATA,"^",23),0,2)
. S ACCOUNT(ACCT)=$G(ACCOUNT(ACCT))+VALUEINV
. W !,$P(DATA,"^",2),?13,$P(DATA,"^",19),?33,$J($P(DATA,"^",6),8),$J($P(DATA,"^",7),11),$J(VALUESAL,14,2),$J(VALUEINV,14,2)
. I $D(^PRCP(445.2,DA,1)) W !,$P(^(1),"^")
. I $Y>(IOSL-7) D:$G(SCREEN) P^PRCPUREP Q:$D(PRCPFLAG) D H
. I '$D(PRCPFLAG),$G(PRCPMULT),'$O(^TMP($J,"PRCPAWR0 DA",TRANID,DA)) D END^PRCPAWR1 Q:$D(PRCPFLAG)
I $D(PRCPFLAG) S PRCPMULT=1
I '$D(PRCPMULT) D END^PRCPAWR1
Q D ^%ZISC K ^TMP($J,"PRCPAWR0"),^TMP($J,"PRCPAWR0 DA")
Q
;
;
H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W $C(13),"ADJUSTMENT APPROVAL FORM FROM ",PRCP("IN"),?(80-$L(%)),%
I $D(INVPT) W !?5,"DISTRIBUTION TO: ",INVPT
I $D(ADJDT) W !?5,"ADJUSTMENT DATE: ",ADJDT,?50,"VOUCHER: ",VOUCHER
W !,"NSN",?19,"DESCRIPTION",?49,"[#MI]",?60,"ACCT CODE",?72,"INITIALS"
S %="",$P(%,"-",81)="" W !,"TRANSID",?13,"TRANS./P.O.",?38,"U/I",?43,$J("QUANTITY",9),$J("SELL VALUE",14),$J("INV VALUE",14),!,%
Q
;
;
PRINFORM(TRANID) ; print adjustment approval form
N %,PRCPMULT
K ^TMP($J,"PRCPAWR0")
S ^TMP($J,"PRCPAWR0",TRANID)=""
S PRCPMULT=1
W !!,"Queueing Approval Form to Print on 'Fiscal (Receiving Reports)' Printer ..." S %=$O(^PRC(411,PRC("SITE"),2,"AC","FR",0))
FP I %="" W !?5,">> WARNING: DEVICE NOT FOUND IN SITE PARAMETERS FILE 411. >>",! S IOP="Q" D ^%ZIS S %=IO I '$G(IO("Q")) W !!,"MUST QUEUE OUTPUT",! S %="" G FP
E S ZTIO=%,ZTDTH=$H D D ^%ZTLOAD K IOP D ^%ZISC
. S ZTDESC="Adjustment Approval Form (Fiscal)",ZTRTN="DQ^PRCPAWR0"
. S ZTSAVE("PRCP*")="",ZTSAVE("^TMP($J,""PRCPAWR0"",")="",ZTSAVE("ZTREQ")="@"
;
W !,"Queueing Approval Form to Print on 'Supply (PPM)' Printer ..." S %=$O(^PRC(411,PRC("SITE"),2,"AC","S",0))
SP I %="" W !?5,">> WARNING: DEVICE NOT FOUND IN SITE PARAMETERS FILE 411. >>",! S IOP="Q" D ^%ZIS S %=IO I '$G(IO("Q")) W !!,"MUST QUEUE OUTPUT",! S %="" G SP
E S ZTIO=%,ZTDTH=$H D D ^%ZTLOAD K IOP D ^%ZISC
. S ZTDESC="Adjustment Approval Form (Supply)",ZTRTN="DQ^PRCPAWR0"
. S ZTSAVE("PRCP*")="",ZTSAVE("^TMP($J,""PRCPAWR0"",")="",ZTSAVE("ZTREQ")="@"
;
K ^TMP($J,"PRCPAWR0")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPAWR0 4837 printed Apr 09, 2024@21:02:29 Page 2
PRCPAWR0 ;WISC/RFJ/BGJ-print register approval form ;9.9.97
+1 ;;5.1;IFCAP;**14**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+4 IF PRCP("DPTYPE")'="W"
WRITE !,"ONLY THE WAREHOUSE CAN USE THIS OPTION."
QUIT
+5 NEW %,PRCPFALL,PRCPMULT,TOTAL,TRANID
+6 ;
+7 ; select list of adjustments
+8 KILL ^TMP($JOB,"PRCPAWR0")
+9 WRITE !!,"To select ALL adjustments, press RETURN."
+10 SET TOTAL=0
FOR
SET TRANID=$$ADJUSTNO^PRCPAWAP
if TRANID["^"
QUIT
SET ^TMP($JOB,"PRCPAWR0",TRANID)=""
SET TOTAL=TOTAL+1
+11 IF $ORDER(^TMP($JOB,"PRCPAWR0",""))=""
SET XP="Do you want to select ALL adjustments"
SET XH="Enter 'YES' to select ALL adjustments, 'NO' or '^' to exit."
WRITE !
SET %=$$YN^PRCPUYN(1)
if '%
QUIT
IF %=1
SET PRCPFALL=1
+12 IF '$GET(PRCPFALL)
IF $ORDER(^TMP($JOB,"PRCPAWR0",""))=""
QUIT
+13 ;
+14 ; if more than one adjustment is selected, ask to print one
+15 ; report or multiple reports.
+16 SET PRCPMULT=1
+17 IF $GET(PRCPFALL)!(TOTAL>1)
Begin DoDot:1
+18 SET XP="DO YOU WANT TO PRINT A SEPARATE REPORT FOR EACH ADJUSTMENT (THIS WILL"
SET XP(1)="USE A LOT OF PAPER)"
+19 SET XH="ENTER 'YES' TO PRINT EACH UNAPPROVED ADJUSTMENT ON A SINGLE PIECE OF PAPER,"
SET XH(1)=" 'NO' TO PRINT ALL UNAPPROVED ADJUSTMENTS ON THE SAME REPORT."
+20 WRITE !!
SET %=$$YN^PRCPUYN(2)
IF %=2
KILL PRCPMULT
End DoDot:1
IF %<1
QUIT
+21 ;
+22 SET %ZIS="Q"
WRITE !
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
Begin DoDot:1
+23 SET ZTDESC="Adjustment Approval Form"
SET ZTRTN="DQ^PRCPAWR0"
+24 SET ZTSAVE("PRCP*")=""
SET ZTSAVE("^TMP($J,""PRCPAWR0"",")=""
SET ZTSAVE("ZTREQ")="@"
End DoDot:1
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
DO Q
QUIT
+25 ;
DQ ; queue starts here.
+1 NEW %,%H,%I,ACCOUNT,ACCT,ADJDT,DA,DATA,INVPT,NOW,NSN,PAGE,PRCPFLAG,SCREEN,TOTAL,TRANID,VALUEINV,VALUESAL,VOUCHER,X,Y
+2 ; build adjustments from ^tmp($j,"prcpawr0",tranid)=""
+3 DO BUILD^PRCPAWR1
+4 ;
+5 ; start printing report.
+6 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=Y
SET PAGE=0
SET SCREEN=$$SCRPAUSE^PRCPUREP
USE IO
+7 SET TRANID="A"
FOR
SET TRANID=$ORDER(^TMP($JOB,"PRCPAWR0 DA",TRANID))
if $EXTRACT(TRANID)'="A"!($DATA(PRCPFLAG))
QUIT
KILL ADJDT,INVPT
SET DA=0
FOR
SET DA=$ORDER(^TMP($JOB,"PRCPAWR0 DA",TRANID,DA))
if 'DA!($DATA(PRCPFLAG))
QUIT
Begin DoDot:1
+8 SET DATA=$GET(^PRCP(445.2,DA,0))
IF DATA=""
QUIT
+9 SET VOUCHER=$PIECE(DATA,"^",15)
+10 IF $GET(PRCPMULT)
IF '$DATA(ADJDT)
SET Y=$PIECE(DATA,"^",17)
IF +Y
DO DD^%DT
SET ADJDT=Y
+11 IF $GET(PRCPMULT)
IF '$DATA(INVPT)
IF $PIECE(DATA,"^",18)
SET INVPT=$$INVNAME^PRCPUX1($PIECE(DATA,"^",18))
+12 IF PAGE=0
SET PAGE=1
DO H
+13 ;
+14 SET NSN=$$NSN^PRCPUX1(+$PIECE(DATA,"^",5))
SET ACCT=$$ACCT1^PRCPUX1($EXTRACT(NSN,1,4))
+15 WRITE !!,NSN,?19,$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),$PIECE(DATA,"^",5)),1,28),?49,"#",$PIECE(DATA,"^",5),?60,"ACCT: ",ACCT,?73,$JUSTIFY($$INITIALS^PRCPUREP($PIECE(DATA,"^",16)),6)
+16 SET VALUEINV=$JUSTIFY($PIECE(DATA,"^",7)*$PIECE(DATA,"^",8),0,2)
SET VALUESAL=$JUSTIFY($PIECE(DATA,"^",7)*$PIECE(DATA,"^",9),0,2)
+17 IF $PIECE(DATA,"^",22)'=""
SET VALUEINV=$JUSTIFY($PIECE(DATA,"^",22),0,2)
SET VALUESAL=$JUSTIFY($PIECE(DATA,"^",23),0,2)
+18 SET ACCOUNT(ACCT)=$GET(ACCOUNT(ACCT))+VALUEINV
+19 WRITE !,$PIECE(DATA,"^",2),?13,$PIECE(DATA,"^",19),?33,$JUSTIFY($PIECE(DATA,"^",6),8),$JUSTIFY($PIECE(DATA,"^",7),11),$JUSTIFY(VALUESAL,14,2),$JUSTIFY(VALUEINV,14,2)
+20 IF $DATA(^PRCP(445.2,DA,1))
WRITE !,$PIECE(^(1),"^")
+21 IF $Y>(IOSL-7)
if $GET(SCREEN)
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+22 IF '$DATA(PRCPFLAG)
IF $GET(PRCPMULT)
IF '$ORDER(^TMP($JOB,"PRCPAWR0 DA",TRANID,DA))
DO END^PRCPAWR1
if $DATA(PRCPFLAG)
QUIT
End DoDot:1
+23 IF $DATA(PRCPFLAG)
SET PRCPMULT=1
+24 IF '$DATA(PRCPMULT)
DO END^PRCPAWR1
Q DO ^%ZISC
KILL ^TMP($JOB,"PRCPAWR0"),^TMP($JOB,"PRCPAWR0 DA")
+1 QUIT
+2 ;
+3 ;
H SET %=NOW_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+1 WRITE $CHAR(13),"ADJUSTMENT APPROVAL FORM FROM ",PRCP("IN"),?(80-$LENGTH(%)),%
+2 IF $DATA(INVPT)
WRITE !?5,"DISTRIBUTION TO: ",INVPT
+3 IF $DATA(ADJDT)
WRITE !?5,"ADJUSTMENT DATE: ",ADJDT,?50,"VOUCHER: ",VOUCHER
+4 WRITE !,"NSN",?19,"DESCRIPTION",?49,"[#MI]",?60,"ACCT CODE",?72,"INITIALS"
+5 SET %=""
SET $PIECE(%,"-",81)=""
WRITE !,"TRANSID",?13,"TRANS./P.O.",?38,"U/I",?43,$JUSTIFY("QUANTITY",9),$JUSTIFY("SELL VALUE",14),$JUSTIFY("INV VALUE",14),!,%
+6 QUIT
+7 ;
+8 ;
PRINFORM(TRANID) ; print adjustment approval form
+1 NEW %,PRCPMULT
+2 KILL ^TMP($JOB,"PRCPAWR0")
+3 SET ^TMP($JOB,"PRCPAWR0",TRANID)=""
+4 SET PRCPMULT=1
+5 WRITE !!,"Queueing Approval Form to Print on 'Fiscal (Receiving Reports)' Printer ..."
SET %=$ORDER(^PRC(411,PRC("SITE"),2,"AC","FR",0))
FP IF %=""
WRITE !?5,">> WARNING: DEVICE NOT FOUND IN SITE PARAMETERS FILE 411. >>",!
SET IOP="Q"
DO ^%ZIS
SET %=IO
IF '$GET(IO("Q"))
WRITE !!,"MUST QUEUE OUTPUT",!
SET %=""
GOTO FP
+1 IF '$TEST
SET ZTIO=%
SET ZTDTH=$HOROLOG
Begin DoDot:1
+2 SET ZTDESC="Adjustment Approval Form (Fiscal)"
SET ZTRTN="DQ^PRCPAWR0"
+3 SET ZTSAVE("PRCP*")=""
SET ZTSAVE("^TMP($J,""PRCPAWR0"",")=""
SET ZTSAVE("ZTREQ")="@"
End DoDot:1
DO ^%ZTLOAD
KILL IOP
DO ^%ZISC
+4 ;
+5 WRITE !,"Queueing Approval Form to Print on 'Supply (PPM)' Printer ..."
SET %=$ORDER(^PRC(411,PRC("SITE"),2,"AC","S",0))
SP IF %=""
WRITE !?5,">> WARNING: DEVICE NOT FOUND IN SITE PARAMETERS FILE 411. >>",!
SET IOP="Q"
DO ^%ZIS
SET %=IO
IF '$GET(IO("Q"))
WRITE !!,"MUST QUEUE OUTPUT",!
SET %=""
GOTO SP
+1 IF '$TEST
SET ZTIO=%
SET ZTDTH=$HOROLOG
Begin DoDot:1
+2 SET ZTDESC="Adjustment Approval Form (Supply)"
SET ZTRTN="DQ^PRCPAWR0"
+3 SET ZTSAVE("PRCP*")=""
SET ZTSAVE("^TMP($J,""PRCPAWR0"",")=""
SET ZTSAVE("ZTREQ")="@"
End DoDot:1
DO ^%ZTLOAD
KILL IOP
DO ^%ZISC
+4 ;
+5 KILL ^TMP($JOB,"PRCPAWR0")
+6 QUIT
