PRCHAM5 ;WISC/AKS,ID/RSD,SF-ISC/TKW-CONT. OF AMENDMENTS ;7-2-91/15:40
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
ENUI ; UPDATE FIELDS ON ITEM FILE THAT WERE CHANGED THROUGH AMENDMENT
W !! D W W %B,! F I=0:0 S I=$O(%B(I)) Q:'I W %B(I),!
D YN^PRCFYN Q:%'=1 S I=0 D UPI Q
UPI S I=$O(^PRC(442,PRCHPO,2,I)) Q:'I S Y=^(I,0) G:'$D(^PRC(441,+$P(Y,U,5),0)) UPI S Z=$O(^PRC(442,PRCHPO,2,I,1,0)) G:'$D(^(Z,0)) UPI I ^(0)'["*AMENDED*" G UPI
S:$P(Y,U,13)'="" $P(^PRC(441,+$P(Y,U,5),0),U,5)=$P(Y,U,13)
G:'$D(^PRC(441,+$P(Y,U,5),2,PRCHCV,0)) UPI S X=^(0)
S:$P(Y,U,3)'="" $P(X,U,7)=$P(Y,U,3) S:$P(Y,U,12) $P(X,U,8)=$P(Y,U,12) S:$P(Y,U,9) $P(X,U,2)=$P(Y,U,9),$P(X,U,6)=DT S:$P(Y,U,6)'="" $P(X,U,4)=$P(Y,U,6)
I $D(^PRC(442,PRCHPO,2,I,2)) S Z=$P(^(2),U,2) I Z]"",$D(^PRC(442,PRCHPO,1)) S $P(X,U,3)=$O(^PRC(440,+^(1),4,"B",Z,0)) S Z=$O(^PRC(440,PRCHCV,4,"B",Z,0)) I Z S $P(X,U,3)=Z
S ^PRC(441,+$P(Y,U,5),2,PRCHCV,0)=X
G UPI
EN7 ;PROMPT PAYMENT EDIT
S DIC="^PRC(442,PRCHPO,5,",DIC(0)="AEQZ" D ^DIC Q:Y<0 S PRCHP=Y,PRCHP0=Y(0),PRCHO=$P(Y(0),U,1)_"/"_$P(Y(0),U,2)
S %X="^PRC(442,PRCHPO,5,+PRCHP,",%Y="^PRC(443.6,PRCHPO,5,+PRCHP," D %XY^%RCR S ^PRC(443.6,PRCHPO,5,0)="^443.66A^"_$P(^PRC(442,PRCHPO,5,0),U,3,4)
S DR="[PRCHAMPPP]",DIE="^PRC(443.6,",DA=PRCHPO D ^DIE K DIE
S PRCHN=$S($D(^PRC(443.6,PRCHPO,5,+PRCHP,0)):$P(^(0),U,1)_"/"_$P(^(0),U,2),1:"@") Q:PRCHO=PRCHN
S PRCHT=0 S:PRCHN="@" PRCHL1="*",^TMP("PRCHW",$J,1)="Prompt Payment "_PRCHO_" has been cancelled" Q
PONO I $D(PRCHNRQ) S PRCHP("A")="REQUISITION NUMBER",PRCHP("T")=8,PRCHP("S")=1 D EN^PRCHPAT Q
I $D(PRCHIMP) S PRCHP("A")="IMPREST FUND P.O.NO.: ",PRCHP("T")=7,PRCHP("S")=3 D EN^PRCHPAT Q
D ENPO^PRCHUTL Q
DOCID S Z=$P(^PRC(443.6,PRCHPO,0),"-",2),$P(^PRC(443.6,PRCHPO,18),"^",3)=$S(Z:$E(Z,2,6),1:$E(Z)_$E(Z,3,6)) K Z Q
W S %B="You have the choice to let the system automatically update the Item Master",%B(1)="File with the amended data. If you choose to do this, the following",%B(2)="fields will be updated for ALL amended items on this order:"
S %B(3)=" National Stock No.",%B(6)=" Vendor Stock No.",%B(7)=" Unit of Purchase",%B(8)=" Packaging Multiple",%B(9)=" Actual Unit Cost",%B(10)=" Contract Number."
S %A="UPDATE ITEM FILE",%=2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHAM5 2295 printed Sep 23, 2025@19:41:45 Page 2
PRCHAM5 ;WISC/AKS,ID/RSD,SF-ISC/TKW-CONT. OF AMENDMENTS ;7-2-91/15:40
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
ENUI ; UPDATE FIELDS ON ITEM FILE THAT WERE CHANGED THROUGH AMENDMENT
+1 WRITE !!
DO W
WRITE %B,!
FOR I=0:0
SET I=$ORDER(%B(I))
if 'I
QUIT
WRITE %B(I),!
+2 DO YN^PRCFYN
if %'=1
QUIT
SET I=0
DO UPI
QUIT
UPI SET I=$ORDER(^PRC(442,PRCHPO,2,I))
if 'I
QUIT
SET Y=^(I,0)
if '$DATA(^PRC(441,+$PIECE(Y,U,5),0))
GOTO UPI
SET Z=$ORDER(^PRC(442,PRCHPO,2,I,1,0))
if '$DATA(^(Z,0))
GOTO UPI
IF ^(0)'["*AMENDED*"
GOTO UPI
+1 if $PIECE(Y,U,13)'=""
SET $PIECE(^PRC(441,+$PIECE(Y,U,5),0),U,5)=$PIECE(Y,U,13)
+2 if '$DATA(^PRC(441,+$PIECE(Y,U,5),2,PRCHCV,0))
GOTO UPI
SET X=^(0)
+3 if $PIECE(Y,U,3)'=""
SET $PIECE(X,U,7)=$PIECE(Y,U,3)
if $PIECE(Y,U,12)
SET $PIECE(X,U,8)=$PIECE(Y,U,12)
if $PIECE(Y,U,9)
SET $PIECE(X,U,2)=$PIECE(Y,U,9)
SET $PIECE(X,U,6)=DT
if $PIECE(Y,U,6)'=""
SET $PIECE(X,U,4)=$PIECE(Y,U,6)
+4 IF $DATA(^PRC(442,PRCHPO,2,I,2))
SET Z=$PIECE(^(2),U,2)
IF Z]""
IF $DATA(^PRC(442,PRCHPO,1))
SET $PIECE(X,U,3)=$ORDER(^PRC(440,+^(1),4,"B",Z,0))
SET Z=$ORDER(^PRC(440,PRCHCV,4,"B",Z,0))
IF Z
SET $PIECE(X,U,3)=Z
+5 SET ^PRC(441,+$PIECE(Y,U,5),2,PRCHCV,0)=X
+6 GOTO UPI
EN7 ;PROMPT PAYMENT EDIT
+1 SET DIC="^PRC(442,PRCHPO,5,"
SET DIC(0)="AEQZ"
DO ^DIC
if Y<0
QUIT
SET PRCHP=Y
SET PRCHP0=Y(0)
SET PRCHO=$PIECE(Y(0),U,1)_"/"_$PIECE(Y(0),U,2)
+2 SET %X="^PRC(442,PRCHPO,5,+PRCHP,"
SET %Y="^PRC(443.6,PRCHPO,5,+PRCHP,"
DO %XY^%RCR
SET ^PRC(443.6,PRCHPO,5,0)="^443.66A^"_$PIECE(^PRC(442,PRCHPO,5,0),U,3,4)
+3 SET DR="[PRCHAMPPP]"
SET DIE="^PRC(443.6,"
SET DA=PRCHPO
DO ^DIE
KILL DIE
+4 SET PRCHN=$SELECT($DATA(^PRC(443.6,PRCHPO,5,+PRCHP,0)):$PIECE(^(0),U,1)_"/"_$PIECE(^(0),U,2),1:"@")
if PRCHO=PRCHN
QUIT
+5 SET PRCHT=0
if PRCHN="@"
SET PRCHL1="*"
SET ^TMP("PRCHW",$JOB,1)="Prompt Payment "_PRCHO_" has been cancelled"
QUIT
PONO IF $DATA(PRCHNRQ)
SET PRCHP("A")="REQUISITION NUMBER"
SET PRCHP("T")=8
SET PRCHP("S")=1
DO EN^PRCHPAT
QUIT
+1 IF $DATA(PRCHIMP)
SET PRCHP("A")="IMPREST FUND P.O.NO.: "
SET PRCHP("T")=7
SET PRCHP("S")=3
DO EN^PRCHPAT
QUIT
+2 DO ENPO^PRCHUTL
QUIT
DOCID SET Z=$PIECE(^PRC(443.6,PRCHPO,0),"-",2)
SET $PIECE(^PRC(443.6,PRCHPO,18),"^",3)=$SELECT(Z:$EXTRACT(Z,2,6),1:$EXTRACT(Z)_$EXTRACT(Z,3,6))
KILL Z
QUIT
W SET %B="You have the choice to let the system automatically update the Item Master"
SET %B(1)="File with the amended data. If you choose to do this, the following"
SET %B(2)="fields will be updated for ALL amended items on this order:"
+1 SET %B(3)=" National Stock No."
SET %B(6)=" Vendor Stock No."
SET %B(7)=" Unit of Purchase"
SET %B(8)=" Packaging Multiple"
SET %B(9)=" Actual Unit Cost"
SET %B(10)=" Contract Number."
+2 SET %A="UPDATE ITEM FILE"
SET %=2
+3 QUIT
