PRCHAM4 ;WISC/AKS,ID/RSD,SF-ISC/TKW-ADJUSTMENT VOUCHER ;6/8/96 13:06
V ;;5.1;IFCAP;**124**;Oct 20, 2000;Build 2
;Per VHA Directive 2004-038, this routine should not be modified.
EN ;ADJUSTMENT VOUCHER
I $D(^PRC(443.6,PRCHPO)) D Q
.W !!,"There is a pending amendment against this purchase order." Q
S PRCHAV="" D ENAV^PRCHAM Q:'$D(PRCHPO)
PAR S DIC="^PRC(442,PRCHPO,11,",DIC(0)="QEANZ"
S DIC("S")="I $P(^PRC(442,PRCHPO,11,+Y,0),U,12)'<0" D ^DIC K DIC
;I $G(PRCHAUTH)=1 S DIC("S")="I $P(^PRC(442,PRCHPO,11,+Y,0),U,12)'<0,$P(^PRC(442,PRCHPO,23),U,11)=""P"""
;I $G(PRCHAUTH)=2 S DIC("S")="I $P(^PRC(442,PRCHPO,11,+Y,0),U,12)'<0,$P(^PRC(442,PRCHPO,23),U,11)=""D"""
G:Y<0 Q^PRCHAM
I $P(^PRC(442,PRCHPO,11,+Y,0),U,6)="",$P($G(^PRC(442,PRCHPO,0)),U,2)'=25,'$G(PRCHAUTH) W !,"This Receiving Report has not been processed in Fiscal Service." G PAR
S (PRCHRPTO,PRCHRPT)=+Y,PRCHAV0=Y(0),PRCHRD=$P(Y(0),U)
S (PRCHRTT,PRCHRT)=0
S:$D(^PRC(442,PRCHPO,11,PRCHRPTO,1)) PRCHAV1=^(1),$P(PRCHAV1,U,16)=PRCHRPTO
S PRCHSAM1=$P(PRCHAV0,U,3),PRCHSAM2=$P(PRCHAV0,U,5)
D NOW^%DTC
I X>($P(^PRC(442,PRCHPO,11,PRCHRPTO,0),U)+30) D I %'=1 G Q^PRCHAM
.W !!,?10,"This partial receipt is more than 30 days old."
.W !,?10,"Please check payment status with Fiscal.",!," "
.S %="",%A=" Would you like to continue? ",%B="" D ^PRCFYN
S ^TMP("PRCHW",$J,1)="Adjustment Voucher for Purchase Order "_$P(PRCH(0),U)
S (PRCHII,PRCHNN)=0 F S PRCHNN=$O(^PRC(442,PRCHPO,11,PRCHNN)) Q:'PRCHNN S PRCHII=PRCHII+1
S PRCHRPTN=PRCHII+1,PRCHATOT=0
S PRCHJ=3,PRCHL1="*",(PRCHO,PRCHN,PRCHL2)="" D EN^PRCHAM
ITEM S DIC("S")="I $O(^PRC(443.6,PRCHPO,2,""AB"",PRCHRD,+Y,0))"
K PRCHI,^TMP("PRCHW",$J) D MV^PRCHAM2,EN^PRCHAM2 K DIC
I '$D(PRCHNFLG) G Q^PRCHAM
G LST:Y<0,ITEM:'$D(^PRC(443.6,PRCHPO,2,+PRCHI,2))
S PRCHI(0)=^PRC(443.6,PRCHPO,2,+PRCHI,0),PRCHI(2)=^(2),I=PRCHJ
D MES^PRCHAM2 S PRCHAV=+$O(^PRC(443.6,PRCHPO,2,"AB",PRCHRD,+PRCHI,0))
G:'$D(^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHAV,0)) ITEM S (PRCHITR,Y)=^(0)
;S PRCHO=$S($P(Y,U,7):$P(Y,U,7),1:$P(Y,U,2)),PRCHAMT1=$P(Y,U,3)
S PRCHO=$P(Y,U,2),PRCHAMT1=$P(Y,U,3)
I $P(Y,U,7)]"" S PRCHO=$P(Y,U,7),PRCHAMT1=$P(Y,U,8)
S PRCHDA=$P(Y,U,5),PRCHK=K+1
S ^TMP("PRCHW",$J,PRCHK)=" ORIGINALLY QTY RECEIVED = "_PRCHO_" ,COST = $ "_PRCHAMT1
S PRCHK=PRCHK+1 D EN2^PRCHAM44 G ITEM:'$D(X)
S PRCHN=PRCHXX G:PRCHO=+PRCHN ITEM
S PRCHADAM=$S($P(PRCHITR,U,8):$P(PRCHITR,U,8),1:$P(PRCHITR,U,3))+PRCHAMT1
S $P(^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHAVLD,0),U,8)=PRCHADAM
S ^TMP("PRCHW",$J,PRCHK)=" will now read: QTY RECEIVED="_PRCHQTY_", COST=$"_PRCHADAM
S PRCHJ=PRCHK+1,PRCHL1="*",PRCHL2="",PRCHJ=1 D EN^PRCHAM S PRCHATOT=PRCHATOT+1 G ITEM
LST S (PRCHAMT1,PRCHDA)=0,PRCHAVA=$P(PRCHAV0,U,3)+$P(PRCHAV0,U,5)
I 'PRCHCHK!(PRCHATOT=0) D Q G Q^PRCHAM
S I=0 F S I=$O(^PRC(443.6,PRCHPO,2,"AB",PRCHRD,I)) Q:'I D
.S J=0 F S J=$O(^PRC(443.6,PRCHPO,2,"AB",PRCHRD,I,J)) Q:'J D
..S PRCHAV=J I $D(^PRC(443.6,PRCHPO,2,I,0)),$D(^(2)) S PRCHRS=$P(^(2),U,7) I $D(^(3,PRCHAV,0)) S (PRCHITSB,Y)=^(0) D SUB
D TM^PRCHREC2,EN2^PRCHREC S K=1
S ^TMP("PRCHW",$J,K)=" Vendor: "_$P(^PRC(440,$P(^PRC(442,PRCHPO,1),U),0),U),K=K+1
S ^TMP("PRCHW",$J,K)=" APPROPRIATION: "_$P(^PRC(442,PRCHPO,0),U,4),K=K+1
S ^TMP("PRCHW",$J,K)=" This Receiving Report will now read: ",K=K+1
I PRCHDA D
.S ^TMP("PRCHW",$J,K)=" Discounted Amount: "_PRCHDA,K=K+1
S ^TMP("PRCHW",$J,K)=" Total Amount: "_PRCHRAM
I PRCHRT S PRCHRTT=PRCHRAM*PRCHRT D
.S ^TMP("PRCHW",$J,K+1)=" Term Discount Amount: "_$J(PRCHRTT,8,2)
.S ^TMP("PRCHW",$J,K+2)=" Net Amount: "_$J(PRCHRAMN,10,2)
S (PRCHAMT1,PRCHDA)=0,PRCHAVA=$P(PRCHAV0,U,3)+$P(PRCHAV0,U,5) K PRCHR
;I 'PRCHCHK D Q G Q^PRCHAM
S I=0 F S I=$O(^PRC(443.6,PRCHPO,2,"AB",PRCHRD,I)) Q:'I D
.S J=0 F S J=$O(^PRC(443.6,PRCHPO,2,"AB",PRCHRD,I,J)) Q:'J D
..I '$D(^PRC(442,PRCHPO,11,J)) S PRCHAV=J I $D(^PRC(443.6,PRCHPO,2,I,0)),$D(^(2)) S PRCHRS=$P(^(2),U,7) I $D(^(3,PRCHAV,0)) S (PRCHITSB,Y)=^(0) D SUB
D TM^PRCHREC2,EN2^PRCHREC S K=1
S $P(PRCHAV0,U,2,5)=PRCHR(1)_U_PRCHR(2)
S X=$P(PRCHAV0,U,9) S:X]""&($D(PRCHAF)) $P(PRCHAV0,U,9)=""
S $P(PRCHAV0,U,19)=""
S $P(PRCHAV0,U,10)=$S($D(PRCHROV):"Y",1:""),$P(PRCHAV0,U,12)=PRCHRAM
S X=$P(^PRC(443.6,PRCHPO,0),U,17),X=X-PRCHAVA,$P(^(0),U,17)=X
S $P(PRCHAV0,U,6)="",$P(PRCHAV0,U,9)=""
S ^PRC(443.6,PRCHPO,11,PRCHRPT,0)=PRCHAV0,PRCHL1="*"
S:$D(PRCHAV1) ^PRC(443.6,PRCHPO,11,PRCHRPT,1)=PRCHAV1
S (PRCHO,PRCHN,PRCHL2)="" D EN^PRCHAM,Q G EN2^PRCHAM
SUB S PRCHDA=PRCHDA+$P(Y,U,5) S:PRCHRS="" PRCHRS="**"
S:'$D(PRCHR("SA",PRCHRS)) PRCHR("SA",PRCHRS)=0
S PRCHR("SA",PRCHRS)=PRCHR("SA",PRCHRS)+$P(Y,U,3)-$P(Y,U,5) Q
SETC ;IF ESTIMATED ORDER, PARTIAL ORDER RECEIVED, RESET 'C' X-REF ON ALL ITEMS
Q:'$D(^PRC(442,PRCHPO,7)) Q:$P(^(7),U,3)'="Y" Q:$P(^(7),U,2)'=26
F I=0:0 S I=$O(^PRC(442,PRCHPO,2,I)) Q:'I I $D(^(I,0)) D
.S X=+^(0),PRCHX(X,X)="^PRC(442,PRCHPO,2,""C"",X,"_I_")"
Q
W1 W:$E(X)'="?" " ??",$C(7)
W !,"Enter the quantity (a number between 0 & 999,999 with up to two decimal places)" Q
Q K PRCHAMT1,PRCHDA,PRCHRD,PRCHR,PRCHRPT,PRCHRES,PRCHRAM,PRCHRAMN,PRCHRT,PRCHATOT
K PRCHRT2,PRCHRS,PRCHRQ,PRCHRQ1,PRCHROV,PRCHAV0,PRCHAVA,PRCHAF,PRCHRTT
QUIT
EN2Q K X
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHAM4 5275 printed Sep 23, 2025@19:41:43 Page 2
PRCHAM4 ;WISC/AKS,ID/RSD,SF-ISC/TKW-ADJUSTMENT VOUCHER ;6/8/96 13:06
V ;;5.1;IFCAP;**124**;Oct 20, 2000;Build 2
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
EN ;ADJUSTMENT VOUCHER
+1 IF $DATA(^PRC(443.6,PRCHPO))
Begin DoDot:1
+2 WRITE !!,"There is a pending amendment against this purchase order."
QUIT
End DoDot:1
QUIT
+3 SET PRCHAV=""
DO ENAV^PRCHAM
if '$DATA(PRCHPO)
QUIT
PAR SET DIC="^PRC(442,PRCHPO,11,"
SET DIC(0)="QEANZ"
+1 SET DIC("S")="I $P(^PRC(442,PRCHPO,11,+Y,0),U,12)'<0"
DO ^DIC
KILL DIC
+2 ;I $G(PRCHAUTH)=1 S DIC("S")="I $P(^PRC(442,PRCHPO,11,+Y,0),U,12)'<0,$P(^PRC(442,PRCHPO,23),U,11)=""P"""
+3 ;I $G(PRCHAUTH)=2 S DIC("S")="I $P(^PRC(442,PRCHPO,11,+Y,0),U,12)'<0,$P(^PRC(442,PRCHPO,23),U,11)=""D"""
+4 if Y<0
GOTO Q^PRCHAM
+5 IF $PIECE(^PRC(442,PRCHPO,11,+Y,0),U,6)=""
IF $PIECE($GET(^PRC(442,PRCHPO,0)),U,2)'=25
IF '$GET(PRCHAUTH)
WRITE !,"This Receiving Report has not been processed in Fiscal Service."
GOTO PAR
+6 SET (PRCHRPTO,PRCHRPT)=+Y
SET PRCHAV0=Y(0)
SET PRCHRD=$PIECE(Y(0),U)
+7 SET (PRCHRTT,PRCHRT)=0
+8 if $DATA(^PRC(442,PRCHPO,11,PRCHRPTO,1))
SET PRCHAV1=^(1)
SET $PIECE(PRCHAV1,U,16)=PRCHRPTO
+9 SET PRCHSAM1=$PIECE(PRCHAV0,U,3)
SET PRCHSAM2=$PIECE(PRCHAV0,U,5)
+10 DO NOW^%DTC
+11 IF X>($PIECE(^PRC(442,PRCHPO,11,PRCHRPTO,0),U)+30)
Begin DoDot:1
+12 WRITE !!,?10,"This partial receipt is more than 30 days old."
+13 WRITE !,?10,"Please check payment status with Fiscal.",!," "
+14 SET %=""
SET %A=" Would you like to continue? "
SET %B=""
DO ^PRCFYN
End DoDot:1
IF %'=1
GOTO Q^PRCHAM
+15 SET ^TMP("PRCHW",$JOB,1)="Adjustment Voucher for Purchase Order "_$PIECE(PRCH(0),U)
+16 SET (PRCHII,PRCHNN)=0
FOR
SET PRCHNN=$ORDER(^PRC(442,PRCHPO,11,PRCHNN))
if 'PRCHNN
QUIT
SET PRCHII=PRCHII+1
+17 SET PRCHRPTN=PRCHII+1
SET PRCHATOT=0
+18 SET PRCHJ=3
SET PRCHL1="*"
SET (PRCHO,PRCHN,PRCHL2)=""
DO EN^PRCHAM
ITEM SET DIC("S")="I $O(^PRC(443.6,PRCHPO,2,""AB"",PRCHRD,+Y,0))"
+1 KILL PRCHI,^TMP("PRCHW",$JOB)
DO MV^PRCHAM2
DO EN^PRCHAM2
KILL DIC
+2 IF '$DATA(PRCHNFLG)
GOTO Q^PRCHAM
+3 if Y<0
GOTO LST
if '$DATA(^PRC(443.6,PRCHPO,2,+PRCHI,2))
GOTO ITEM
+4 SET PRCHI(0)=^PRC(443.6,PRCHPO,2,+PRCHI,0)
SET PRCHI(2)=^(2)
SET I=PRCHJ
+5 DO MES^PRCHAM2
SET PRCHAV=+$ORDER(^PRC(443.6,PRCHPO,2,"AB",PRCHRD,+PRCHI,0))
+6 if '$DATA(^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHAV,0))
GOTO ITEM
SET (PRCHITR,Y)=^(0)
+7 ;S PRCHO=$S($P(Y,U,7):$P(Y,U,7),1:$P(Y,U,2)),PRCHAMT1=$P(Y,U,3)
+8 SET PRCHO=$PIECE(Y,U,2)
SET PRCHAMT1=$PIECE(Y,U,3)
+9 IF $PIECE(Y,U,7)]""
SET PRCHO=$PIECE(Y,U,7)
SET PRCHAMT1=$PIECE(Y,U,8)
+10 SET PRCHDA=$PIECE(Y,U,5)
SET PRCHK=K+1
+11 SET ^TMP("PRCHW",$JOB,PRCHK)=" ORIGINALLY QTY RECEIVED = "_PRCHO_" ,COST = $ "_PRCHAMT1
+12 SET PRCHK=PRCHK+1
DO EN2^PRCHAM44
if '$DATA(X)
GOTO ITEM
+13 SET PRCHN=PRCHXX
if PRCHO=+PRCHN
GOTO ITEM
+14 SET PRCHADAM=$SELECT($PIECE(PRCHITR,U,8):$PIECE(PRCHITR,U,8),1:$PIECE(PRCHITR,U,3))+PRCHAMT1
+15 SET $PIECE(^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHAVLD,0),U,8)=PRCHADAM
+16 SET ^TMP("PRCHW",$JOB,PRCHK)=" will now read: QTY RECEIVED="_PRCHQTY_", COST=$"_PRCHADAM
+17 SET PRCHJ=PRCHK+1
SET PRCHL1="*"
SET PRCHL2=""
SET PRCHJ=1
DO EN^PRCHAM
SET PRCHATOT=PRCHATOT+1
GOTO ITEM
LST SET (PRCHAMT1,PRCHDA)=0
SET PRCHAVA=$PIECE(PRCHAV0,U,3)+$PIECE(PRCHAV0,U,5)
+1 IF 'PRCHCHK!(PRCHATOT=0)
DO Q
GOTO Q^PRCHAM
+2 SET I=0
FOR
SET I=$ORDER(^PRC(443.6,PRCHPO,2,"AB",PRCHRD,I))
if 'I
QUIT
Begin DoDot:1
+3 SET J=0
FOR
SET J=$ORDER(^PRC(443.6,PRCHPO,2,"AB",PRCHRD,I,J))
if 'J
QUIT
Begin DoDot:2
+4 SET PRCHAV=J
IF $DATA(^PRC(443.6,PRCHPO,2,I,0))
IF $DATA(^(2))
SET PRCHRS=$PIECE(^(2),U,7)
IF $DATA(^(3,PRCHAV,0))
SET (PRCHITSB,Y)=^(0)
DO SUB
End DoDot:2
End DoDot:1
+5 DO TM^PRCHREC2
DO EN2^PRCHREC
SET K=1
+6 SET ^TMP("PRCHW",$JOB,K)=" Vendor: "_$PIECE(^PRC(440,$PIECE(^PRC(442,PRCHPO,1),U),0),U)
SET K=K+1
+7 SET ^TMP("PRCHW",$JOB,K)=" APPROPRIATION: "_$PIECE(^PRC(442,PRCHPO,0),U,4)
SET K=K+1
+8 SET ^TMP("PRCHW",$JOB,K)=" This Receiving Report will now read: "
SET K=K+1
+9 IF PRCHDA
Begin DoDot:1
+10 SET ^TMP("PRCHW",$JOB,K)=" Discounted Amount: "_PRCHDA
SET K=K+1
End DoDot:1
+11 SET ^TMP("PRCHW",$JOB,K)=" Total Amount: "_PRCHRAM
+12 IF PRCHRT
SET PRCHRTT=PRCHRAM*PRCHRT
Begin DoDot:1
+13 SET ^TMP("PRCHW",$JOB,K+1)=" Term Discount Amount: "_$JUSTIFY(PRCHRTT,8,2)
+14 SET ^TMP("PRCHW",$JOB,K+2)=" Net Amount: "_$JUSTIFY(PRCHRAMN,10,2)
End DoDot:1
+15 SET (PRCHAMT1,PRCHDA)=0
SET PRCHAVA=$PIECE(PRCHAV0,U,3)+$PIECE(PRCHAV0,U,5)
KILL PRCHR
+16 ;I 'PRCHCHK D Q G Q^PRCHAM
+17 SET I=0
FOR
SET I=$ORDER(^PRC(443.6,PRCHPO,2,"AB",PRCHRD,I))
if 'I
QUIT
Begin DoDot:1
+18 SET J=0
FOR
SET J=$ORDER(^PRC(443.6,PRCHPO,2,"AB",PRCHRD,I,J))
if 'J
QUIT
Begin DoDot:2
+19 IF '$DATA(^PRC(442,PRCHPO,11,J))
SET PRCHAV=J
IF $DATA(^PRC(443.6,PRCHPO,2,I,0))
IF $DATA(^(2))
SET PRCHRS=$PIECE(^(2),U,7)
IF $DATA(^(3,PRCHAV,0))
SET (PRCHITSB,Y)=^(0)
DO SUB
End DoDot:2
End DoDot:1
+20 DO TM^PRCHREC2
DO EN2^PRCHREC
SET K=1
+21 SET $PIECE(PRCHAV0,U,2,5)=PRCHR(1)_U_PRCHR(2)
+22 SET X=$PIECE(PRCHAV0,U,9)
if X]""&($DATA(PRCHAF))
SET $PIECE(PRCHAV0,U,9)=""
+23 SET $PIECE(PRCHAV0,U,19)=""
+24 SET $PIECE(PRCHAV0,U,10)=$SELECT($DATA(PRCHROV):"Y",1:"")
SET $PIECE(PRCHAV0,U,12)=PRCHRAM
+25 SET X=$PIECE(^PRC(443.6,PRCHPO,0),U,17)
SET X=X-PRCHAVA
SET $PIECE(^(0),U,17)=X
+26 SET $PIECE(PRCHAV0,U,6)=""
SET $PIECE(PRCHAV0,U,9)=""
+27 SET ^PRC(443.6,PRCHPO,11,PRCHRPT,0)=PRCHAV0
SET PRCHL1="*"
+28 if $DATA(PRCHAV1)
SET ^PRC(443.6,PRCHPO,11,PRCHRPT,1)=PRCHAV1
+29 SET (PRCHO,PRCHN,PRCHL2)=""
DO EN^PRCHAM
DO Q
GOTO EN2^PRCHAM
SUB SET PRCHDA=PRCHDA+$PIECE(Y,U,5)
if PRCHRS=""
SET PRCHRS="**"
+1 if '$DATA(PRCHR("SA",PRCHRS))
SET PRCHR("SA",PRCHRS)=0
+2 SET PRCHR("SA",PRCHRS)=PRCHR("SA",PRCHRS)+$PIECE(Y,U,3)-$PIECE(Y,U,5)
QUIT
SETC ;IF ESTIMATED ORDER, PARTIAL ORDER RECEIVED, RESET 'C' X-REF ON ALL ITEMS
+1 if '$DATA(^PRC(442,PRCHPO,7))
QUIT
if $PIECE(^(7),U,3)'="Y"
QUIT
if $PIECE(^(7),U,2)'=26
QUIT
+2 FOR I=0:0
SET I=$ORDER(^PRC(442,PRCHPO,2,I))
if 'I
QUIT
IF $DATA(^(I,0))
Begin DoDot:1
+3 SET X=+^(0)
SET PRCHX(X,X)="^PRC(442,PRCHPO,2,""C"",X,"_I_")"
End DoDot:1
+4 QUIT
W1 if $EXTRACT(X)'="?"
WRITE " ??",$CHAR(7)
+1 WRITE !,"Enter the quantity (a number between 0 & 999,999 with up to two decimal places)"
QUIT
Q KILL PRCHAMT1,PRCHDA,PRCHRD,PRCHR,PRCHRPT,PRCHRES,PRCHRAM,PRCHRAMN,PRCHRT,PRCHATOT
+1 KILL PRCHRT2,PRCHRS,PRCHRQ,PRCHRQ1,PRCHROV,PRCHAV0,PRCHAVA,PRCHAF,PRCHRTT
+2 QUIT
EN2Q KILL X
+1 QUIT
