PRCHAM3 ;WISC/AKS,ID/RSD,SF-ISC/TKW-CONT. OF AMENDMENTS ;4/20/94 11:13 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
RECAL D REST S (K,PRCH)=0 F I=0:0 S PRCH=$O(^PRC(443.6,PRCHPO,3,PRCH)) Q:'PRCH S PRCHAC=$P(^(PRCH,0),U,1),PRCHACT=$P(^(0),U,4),PRCHP=$P(^(0),U,2),PRCHO=$P(^(0),U,3) D PCTQ,MDIS
Q
PCTQ I PRCHAC="Q" S PRCHACT=$P(^PRC(443.6,PRCHPO,2,0),U,4),PRCHAC="1:1:"_PRCHLC G PCT
I PRCHAC[":" S PRCHAC=$P(PRCHAC,":",1)_":1:"_$P(PRCHAC,":",2)
PCT S PRCHDAM=0,Y="F J="_PRCHAC_" S PRCHN=J D PCT1" X Y
S PRCHDAM=PRCHDAM*100+.5\1/100,$P(^PRC(443.6,PRCHPO,3,PRCH,0),U,3)=PRCHDAM Q
PCT1 S PRCHN=$O(^PRC(443.6,PRCHPO,2,"B",PRCHN,0)) Q:'PRCHN S PRCHD=$S($D(^PRC(443.6,PRCHPO,2,PRCHN,2)):$P(^(2),U,1),1:0)
I $E(PRCHP,1)="$" S PRCHDA=$P(PRCHP,"$",2)/PRCHACT
E S:+$P(^PRC(443.6,PRCHPO,2,PRCHN,2),U,6)>0 PRCHD=PRCHD-$P(^(2),U,6) S PRCHDA=$J(PRCHD*(PRCHP/100),0,3)
S PRCHDAM=PRCHDAM+PRCHDA,$P(^PRC(443.6,PRCHPO,2,PRCHN,2),U,6)=$P(^PRC(443.6,PRCHPO,2,PRCHN,2),U,6)+PRCHDA Q
REST D MV^PRCHAM2,MVDIS^PRCHAM2 F I=0:0 S I=$O(^PRC(443.6,PRCHPO,2,I)) Q:'I S:$D(^(I,2)) $P(^(2),U,6)=""
Q
MDIS S PRCHN=$P(^PRC(443.6,PRCHPO,3,PRCH,0),U,3) I PRCHO'=PRCHN S PRCHAMT=PRCHAMT+(PRCHO-PRCHN) S:K ^TMP("PRCHW",$J,K)=" " S K=K+1 D MDIS^PRCHAM2 Q
Q
DIE S DIE="^PRC(443.6,",DA=PRCHPO D ^DIE K DIE Q
UPDT ;UPDATE DELIVERY DATE/ORIGINAL DELIVERY DATE
S PRCHDT=$P(^PRC(442,PRCHPO,0),U,10),DR=7 D DIE^PRCHAM1 I PRCHDT,$P(^PRC(442,PRCHPO,0),U,20)="",$P(^PRC(443.6,PRCHPO,0),U,10)'=PRCHDT S $P(^(0),U,20)=PRCHDT
K PRCHDT Q
EN8 ;AMEND ESTIMATED SHIPPING/HANDLING
S PRCHO=$P(PRCH(0),U,13),DR=13 D DIE S PRCHN=$P(^PRC(443.6,PRCHPO,0),U,13) Q:PRCHO=PRCHN
S PRCHT=0,PRCHAMT=PRCHAMT+(PRCHN-PRCHO),PRCHDL=1
S:+PRCHO=0 PRCHL1="*",^TMP("PRCHW",$J,1)="Add estimated shipping and/or handling charge of "_PRCHN_" dollars" S:'$P(^PRC(443.6,PRCHPO,0),U,18) PRCHLC=PRCHLC+1,$P(^(0),U,18)=PRCHLC
S:+PRCHN=0 PRCHL1="*",^TMP("PRCHW",$J,1)="Estimated shipping and/or handling charge of "_PRCHO_" dollars has been deleted",$P(^PRC(443.6,PRCHPO,0),U,13)=""
Q
EN14 D MVDIS^PRCHAM2 S J=$P(^PRC(443.6,PRCHPO,3,0),U,4)+1,PRCHD=J_"^"_(PRCHLC+1),J=PRCHLC+1
S %=2,%A=" ADD ITEM DISCOUNT AS LINE ITEM NUMBER: "_J,%B="" D ^PRCFYN I %'=1 W ?40,"<NOTHING ADDED>" Q
S DIC="^PRC(443.6,PRCHPO,3,",DIC(0)="QEALZ",DLAYGO=443.6 D ^DIC G EX14:Y<0!($P(Y,U,3)="") S $P(^(0),U,4)=PRCHJ,$P(^(0),U,6)=$P(PRCHD,U,2),PRCHD=+Y,PRCHD0=Y(0)
S DR="[PRCHAMDISCNT]" D DIE G EX14:'$D(^PRC(443.6,PRCHPO,3,+PRCHD)) S PRCHLC=PRCHLC+1,PRCH=+PRCHD,PRCHAC=$P(^(PRCH,0),U,1),PRCHACT=$P(^(0),U,4),PRCHP=$P(^(0),U,2)
D PCTQ S PRCHAMT=PRCHAMT-$P(^PRC(443.6,PRCHPO,3,PRCH,0),U,3),PRCHT=0,^TMP("PRCHW",$J,1)=" *ADDED THROUGH AMENDMENT*",K=2 D MDIS^PRCHAM2 S (PRCHO,PRCHN)=""
EX14 K DLAYGO Q
EN15 D MVDIS^PRCHAM2 S DIC="^PRC(443.6,PRCHPO,3,",DIC(0)="QAEMZ" D ^DIC Q:Y<0 S PRCHD=+Y,%=2,%A=" SURE YOU WANT TO DELETE ",%B="" D ^PRCFYN I %'=1 W ?40,"<NOTHING DELETED>" Q
S $P(^PRC(443.6,PRCHPO,3,PRCHD,0),U,2)=0,PRCHAREC=1,PRCHT=0,(PRCHO,PRCHN)="" Q
EN16 D MVDIS^PRCHAM2 S DIC="^PRC(443.6,PRCHPO,3,",DIC(0)="QAEZ" D ^DIC Q:Y<0 S PRCHD=+Y,PRCHD0=Y(0),DR="[PRCHAMDISCNT]" D DIE S PRCHAREC=1,PRCHT=0,(PRCHO,PRCHN)="" Q
Q
DIS S (PRCHJ,X1)="" Q:X="Q" F I=1:1 S X2=$P(X,",",I) Q:X2="" S:X2=+X2 X1=X1_X2_",",X2="" I X2]"" K:X2'[":"!($P(X2,":",1)'?1N.N)!($P(X2,":",2)'?1N.N)!(+X2'<$P(X2,":",2)) X Q:'$D(X) S X1=X1_+X2_":1:"_$P(X2,":",2)_","
Q:'$D(X) S X1=$E(X1,1,($L(X1)-1)),J=0 X "F I="_X1_" S J=J+1 I '$D(^PRC(443.6,PRCHPO,2,""B"",I)) W "" ??"",$C(7),!,""**ITEM "",I,"" IS NOT A VALID LINE ITEM**"" K X Q"
Q:'$D(X) K:X?.E1P X Q:'$D(X) S PRCHJ=J Q
LCK L ^PRC(442,PRCHPO):1 I '$T W !?5,"P.O. is being edited by another user " Q
I '$D(^PRC(442,PRCHPO,0))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHAM3 3783 printed Sep 23, 2025@19:41:42 Page 2
PRCHAM3 ;WISC/AKS,ID/RSD,SF-ISC/TKW-CONT. OF AMENDMENTS ;4/20/94 11:13 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
RECAL DO REST
SET (K,PRCH)=0
FOR I=0:0
SET PRCH=$ORDER(^PRC(443.6,PRCHPO,3,PRCH))
if 'PRCH
QUIT
SET PRCHAC=$PIECE(^(PRCH,0),U,1)
SET PRCHACT=$PIECE(^(0),U,4)
SET PRCHP=$PIECE(^(0),U,2)
SET PRCHO=$PIECE(^(0),U,3)
DO PCTQ
DO MDIS
+1 QUIT
PCTQ IF PRCHAC="Q"
SET PRCHACT=$PIECE(^PRC(443.6,PRCHPO,2,0),U,4)
SET PRCHAC="1:1:"_PRCHLC
GOTO PCT
+1 IF PRCHAC[":"
SET PRCHAC=$PIECE(PRCHAC,":",1)_":1:"_$PIECE(PRCHAC,":",2)
PCT SET PRCHDAM=0
SET Y="F J="_PRCHAC_" S PRCHN=J D PCT1"
XECUTE Y
+1 SET PRCHDAM=PRCHDAM*100+.5\1/100
SET $PIECE(^PRC(443.6,PRCHPO,3,PRCH,0),U,3)=PRCHDAM
QUIT
PCT1 SET PRCHN=$ORDER(^PRC(443.6,PRCHPO,2,"B",PRCHN,0))
if 'PRCHN
QUIT
SET PRCHD=$SELECT($DATA(^PRC(443.6,PRCHPO,2,PRCHN,2)):$PIECE(^(2),U,1),1:0)
+1 IF $EXTRACT(PRCHP,1)="$"
SET PRCHDA=$PIECE(PRCHP,"$",2)/PRCHACT
+2 IF '$TEST
if +$PIECE(^PRC(443.6,PRCHPO,2,PRCHN,2),U,6)>0
SET PRCHD=PRCHD-$PIECE(^(2),U,6)
SET PRCHDA=$JUSTIFY(PRCHD*(PRCHP/100),0,3)
+3 SET PRCHDAM=PRCHDAM+PRCHDA
SET $PIECE(^PRC(443.6,PRCHPO,2,PRCHN,2),U,6)=$PIECE(^PRC(443.6,PRCHPO,2,PRCHN,2),U,6)+PRCHDA
QUIT
REST DO MV^PRCHAM2
DO MVDIS^PRCHAM2
FOR I=0:0
SET I=$ORDER(^PRC(443.6,PRCHPO,2,I))
if 'I
QUIT
if $DATA(^(I,2))
SET $PIECE(^(2),U,6)=""
+1 QUIT
MDIS SET PRCHN=$PIECE(^PRC(443.6,PRCHPO,3,PRCH,0),U,3)
IF PRCHO'=PRCHN
SET PRCHAMT=PRCHAMT+(PRCHO-PRCHN)
if K
SET ^TMP("PRCHW",$JOB,K)=" "
SET K=K+1
DO MDIS^PRCHAM2
QUIT
+1 QUIT
DIE SET DIE="^PRC(443.6,"
SET DA=PRCHPO
DO ^DIE
KILL DIE
QUIT
UPDT ;UPDATE DELIVERY DATE/ORIGINAL DELIVERY DATE
+1 SET PRCHDT=$PIECE(^PRC(442,PRCHPO,0),U,10)
SET DR=7
DO DIE^PRCHAM1
IF PRCHDT
IF $PIECE(^PRC(442,PRCHPO,0),U,20)=""
IF $PIECE(^PRC(443.6,PRCHPO,0),U,10)'=PRCHDT
SET $PIECE(^(0),U,20)=PRCHDT
+2 KILL PRCHDT
QUIT
EN8 ;AMEND ESTIMATED SHIPPING/HANDLING
+1 SET PRCHO=$PIECE(PRCH(0),U,13)
SET DR=13
DO DIE
SET PRCHN=$PIECE(^PRC(443.6,PRCHPO,0),U,13)
if PRCHO=PRCHN
QUIT
+2 SET PRCHT=0
SET PRCHAMT=PRCHAMT+(PRCHN-PRCHO)
SET PRCHDL=1
+3 if +PRCHO=0
SET PRCHL1="*"
SET ^TMP("PRCHW",$JOB,1)="Add estimated shipping and/or handling charge of "_PRCHN_" dollars"
if '$PIECE(^PRC(443.6,PRCHPO,0),U,18)
SET PRCHLC=PRCHLC+1
SET $PIECE(^(0),U,18)=PRCHLC
+4 if +PRCHN=0
SET PRCHL1="*"
SET ^TMP("PRCHW",$JOB,1)="Estimated shipping and/or handling charge of "_PRCHO_" dollars has been deleted"
SET $PIECE(^PRC(443.6,PRCHPO,0),U,13)=""
+5 QUIT
EN14 DO MVDIS^PRCHAM2
SET J=$PIECE(^PRC(443.6,PRCHPO,3,0),U,4)+1
SET PRCHD=J_"^"_(PRCHLC+1)
SET J=PRCHLC+1
+1 SET %=2
SET %A=" ADD ITEM DISCOUNT AS LINE ITEM NUMBER: "_J
SET %B=""
DO ^PRCFYN
IF %'=1
WRITE ?40,"<NOTHING ADDED>"
QUIT
+2 SET DIC="^PRC(443.6,PRCHPO,3,"
SET DIC(0)="QEALZ"
SET DLAYGO=443.6
DO ^DIC
if Y<0!($PIECE(Y,U,3)="")
GOTO EX14
SET $PIECE(^(0),U,4)=PRCHJ
SET $PIECE(^(0),U,6)=$PIECE(PRCHD,U,2)
SET PRCHD=+Y
SET PRCHD0=Y(0)
+3 SET DR="[PRCHAMDISCNT]"
DO DIE
if '$DATA(^PRC(443.6,PRCHPO,3,+PRCHD))
GOTO EX14
SET PRCHLC=PRCHLC+1
SET PRCH=+PRCHD
SET PRCHAC=$PIECE(^(PRCH,0),U,1)
SET PRCHACT=$PIECE(^(0),U,4)
SET PRCHP=$PIECE(^(0),U,2)
+4 DO PCTQ
SET PRCHAMT=PRCHAMT-$PIECE(^PRC(443.6,PRCHPO,3,PRCH,0),U,3)
SET PRCHT=0
SET ^TMP("PRCHW",$JOB,1)=" *ADDED THROUGH AMENDMENT*"
SET K=2
DO MDIS^PRCHAM2
SET (PRCHO,PRCHN)=""
EX14 KILL DLAYGO
QUIT
EN15 DO MVDIS^PRCHAM2
SET DIC="^PRC(443.6,PRCHPO,3,"
SET DIC(0)="QAEMZ"
DO ^DIC
if Y<0
QUIT
SET PRCHD=+Y
SET %=2
SET %A=" SURE YOU WANT TO DELETE "
SET %B=""
DO ^PRCFYN
IF %'=1
WRITE ?40,"<NOTHING DELETED>"
QUIT
+1 SET $PIECE(^PRC(443.6,PRCHPO,3,PRCHD,0),U,2)=0
SET PRCHAREC=1
SET PRCHT=0
SET (PRCHO,PRCHN)=""
QUIT
EN16 DO MVDIS^PRCHAM2
SET DIC="^PRC(443.6,PRCHPO,3,"
SET DIC(0)="QAEZ"
DO ^DIC
if Y<0
QUIT
SET PRCHD=+Y
SET PRCHD0=Y(0)
SET DR="[PRCHAMDISCNT]"
DO DIE
SET PRCHAREC=1
SET PRCHT=0
SET (PRCHO,PRCHN)=""
QUIT
+1 QUIT
DIS SET (PRCHJ,X1)=""
if X="Q"
QUIT
FOR I=1:1
SET X2=$PIECE(X,",",I)
if X2=""
QUIT
if X2=+X2
SET X1=X1_X2_","
SET X2=""
IF X2]""
if X2'["
KILL X
if '$DATA(X)
QUIT
SET X1=X1_+X2_":1:"_$PIECE(X2,":",2)_","
+1 if '$DATA(X)
QUIT
SET X1=$EXTRACT(X1,1,($LENGTH(X1)-1))
SET J=0
XECUTE "F I="_X1_" S J=J+1 I '$D(^PRC(443.6,PRCHPO,2,""B"",I)) W "" ??"",$C(7),!,""**ITEM "",I,"" IS NOT A VALID LINE ITEM**"" K X Q"
+2 if '$DATA(X)
QUIT
if X?.E1P
KILL X
if '$DATA(X)
QUIT
SET PRCHJ=J
QUIT
LCK LOCK ^PRC(442,PRCHPO):1
IF '$TEST
WRITE !?5,"P.O. is being edited by another user "
QUIT
+1 IF '$DATA(^PRC(442,PRCHPO,0))
+2 QUIT
