PRCHAM2 ;WISC/AKS,ID/RSD,SF-ISC/TKW-CONT. OF AMENDMENTS ;2-1-90/2:05 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
EN S DIC="^PRC(443.6,PRCHPO,2,",DIC(0)="AEQZ" D ^DIC Q:Y<0 S (PRCHI,PRCHNFLG)=Y Q
EN10 D MV S J=$P(^PRC(443.6,PRCHPO,2,0),U,3)+1,PRCHI=J_"^"_(PRCHLC+1),J=PRCHLC+1
S %=2,%A=" ADD LINE ITEM "_J,%B="" D ^PRCFYN I %'=1 W ?40,"<NOTHING ADDED>" Q
S DR="[PRCHAMIT]",DIE("NO^")="" D DIE^PRCHAM1 S ^TMP("PRCHW",$J,1)=" *ADDED THROUGH AMENDMENT* "
S $P(PRCHI,U,1)=$P(^PRC(443.6,PRCHPO,2,0),U,3) I $D(^PRC(443.6,PRCHPO,2,+PRCHI,0)) S:'$D(^(2)) ^(2)=0 S PRCHAMT=PRCHAMT+^(2),PRCHT=0,PRCHDL=1,PRCHLC=PRCHLC+1,I=2 D MES Q
Q
EN11 D MV,EN I Y<0 W !?5,"<NOTHING DELETED>" Q
I +$P(^PRC(443.6,PRCHPO,2,+PRCHI,2),U,8) W !?5,"CANNOT DELETE ITEM ",$P(PRCHI,U,2),", IT HAS ALREADY BEEN RECEIVED!",$C(7) Q
S %="",%A=" SURE YOU WANT TO DELETE LINE ITEM "_$P(PRCHI,U,2),%B="" D ^PRCFYN I %'=1 W ?50,"<NOTHING DELETED>" Q
S ^TMP("PRCHW",$J,1)="The following line item has been cancelled: ",I=2 D MES S WX="*****CANCELLED*****",PRCH="^PRC(443.6,PRCHPO,2,+PRCHI,1,",K=K+1 D WORD^PRCHUTL,DIS
S DR="40///^S X=$P(PRCHI,U,2);",DR(2,443.61)="5///0;2////0",PRCHAMT=PRCHAMT-^PRC(443.6,PRCHPO,2,+PRCHI,2) D DIE^PRCHAM1
S PRCHX($P(PRCHI,U,2),"@")="^PRC(442,PRCHPO,2,""C"",X,"_+PRCHI_")",PRCHT=0,PRCHDL=1 Q
EN12 D MV,EN Q:Y<0 S I=1 D MES S PRCHX=K,PRCHO=$S($D(^PRC(443.6,PRCHPO,2,+PRCHI,2)):+^(2),1:0),DR="[PRCHAMIT]" D DIE^PRCHAM1
S PRCHN=$S($D(^PRC(443.6,PRCHPO,2,+PRCHI,2)):+^(2),1:0) I PRCHO'=PRCHN S PRCHAMT=PRCHAMT+(PRCHN-PRCHO)
S PRCHT=0,PRCHDL=1,^TMP("PRCHW",$J,PRCHX+1)=" **Will now be AMENDED to read: ",I=PRCHX+2 D MES,DIS
S WX=" *AMENDED* ",PRCH="^PRC(443.6,PRCHPO,2,+PRCHI,1," D WORD^PRCHUTL I $P(^PRC(443.6,PRCHPO,2,+PRCHI,0),U,2)'>$P(^(2),U,8) S PRCHX($P(PRCHI,U,2),"@")="^PRC(442,PRCHPO,2,""C"",X,"_+PRCHI_")"
E S PRCHX($P(PRCHI,U,2),$P(PRCHI,U,2))="^PRC(442,PRCHPO,2,""C"",X,"_+PRCHI_")"
Q
MV ;MOVE LINE ITEMS INFO
Q:$D(^PRC(443.6,PRCHPO,2,0)) D WAIT^DICD S %X="^PRC(442,PRCHPO,2,",%Y="^PRC(443.6,PRCHPO,2," D %XY^%RCR S $P(^PRC(443.6,PRCHPO,2,0),U,2)="443.61IA" K ^("C") Q
MVDIS ;MOVE DISCOUNT ITEM INFO
Q:$D(^PRC(443.6,PRCHPO,3,0)) D MV S %X="^PRC(442,PRCHPO,3,",%Y="^PRC(443.6,PRCHPO,3," D %XY^%RCR S $P(^PRC(443.6,PRCHPO,3,0),U,2)="443.63A" Q
MDIS ;CREATE AMENDMENT MESSAGE FOR DISCOUNT
Q:'$D(^PRC(443.6,PRCHPO,3,PRCH)) S PRCHD0=^(PRCH,0)
S ^TMP("PRCHW",$J,K)=$P(PRCHD0,U,2)_$S($E($P(PRCHD0,U,2))="$":"",1:"%")_" Discount For "_$S($P(PRCHD0,U,1)="Q":"Quantity ",1:"Items: "_$P(PRCHD0,U,1))
S K=K+1,^TMP("PRCHW",$J,K)=" Will now be AMENDED to read $"_$P(^PRC(443.6,PRCHPO,3,PRCH,0),U,3) Q
MES ;CREATE AMENDMENT MESSAGE FOR ITEM
Q:'$D(^PRC(443.6,PRCHPO,2,+PRCHI)) S M(0)=^(+PRCHI,0),M(2)=^(2),K=I,^TMP("PRCHW",$J,K)=""
I $D(^PRC(443.6,PRCHPO,2,+PRCHI,1,0)) F J=0:0 S J=$O(^PRC(443.6,PRCHPO,2,+PRCHI,1,J)) Q:'J I $D(^(J,0)) S X=^(0),^TMP("PRCHW",$J,K)=$E(X,1,226),K=K+1 I $E(X,227,300)]"" S ^TMP("PRCHW",$J,K)=$E(X,227,300),K=K+1
S ^TMP("PRCHW",$J,I)="Item No. "_+M(0)_" "_^TMP("PRCHW",$J,I),X=$S($D(^PRCD(420.5,+$P(M(0),U,3),0)):$P(^(0),U,1),1:"")
I ('$P(M(0),U,12))&($P(M(0),U,6)="")&($P(M(0),U,13)="") G MES2
S ^TMP("PRCHW",$J,K)=" " I $P(M(0),U,12) S ^TMP("PRCHW",$J,K)=^TMP("PRCHW",$J,K)_"Items per "_X_": "_$P(M(0),U,12)_$E(" ",1,(6-$L($P(M(0),U,12))+2))
I $P(M(0),U,6)'="" S ^TMP("PRCHW",$J,K)=^TMP("PRCHW",$J,K)_"STK#: "_$P(M(0),U,6)_" "
I $P(M(0),U,13)'="" S ^TMP("PRCHW",$J,K)=^TMP("PRCHW",$J,K)_"NSN: "_$P(M(0),U,13)
S K=K+1
MES2 S ^TMP("PRCHW",$J,K)=" "_$P(M(0),U,2)_" "_$S($D(^PRCD(420.5,+$P(M(0),U,3),0)):$P(^(0),U,1),1:"")_" at $ "_$J($P(M(0),U,9),6,2)_" = $ "_$J(+M(2),10,2) Q
DIS I $D(^PRC(443.6,PRCHPO,2,+PRCHI,2)),$P(^(2),U,6)>0 S PRCHAREC=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHAM2 3809 printed Dec 13, 2024@02:05:37 Page 2
PRCHAM2 ;WISC/AKS,ID/RSD,SF-ISC/TKW-CONT. OF AMENDMENTS ;2-1-90/2:05 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN SET DIC="^PRC(443.6,PRCHPO,2,"
SET DIC(0)="AEQZ"
DO ^DIC
if Y<0
QUIT
SET (PRCHI,PRCHNFLG)=Y
QUIT
EN10 DO MV
SET J=$PIECE(^PRC(443.6,PRCHPO,2,0),U,3)+1
SET PRCHI=J_"^"_(PRCHLC+1)
SET J=PRCHLC+1
+1 SET %=2
SET %A=" ADD LINE ITEM "_J
SET %B=""
DO ^PRCFYN
IF %'=1
WRITE ?40,"<NOTHING ADDED>"
QUIT
+2 SET DR="[PRCHAMIT]"
SET DIE("NO^")=""
DO DIE^PRCHAM1
SET ^TMP("PRCHW",$JOB,1)=" *ADDED THROUGH AMENDMENT* "
+3 SET $PIECE(PRCHI,U,1)=$PIECE(^PRC(443.6,PRCHPO,2,0),U,3)
IF $DATA(^PRC(443.6,PRCHPO,2,+PRCHI,0))
if '$DATA(^(2))
SET ^(2)=0
SET PRCHAMT=PRCHAMT+^(2)
SET PRCHT=0
SET PRCHDL=1
SET PRCHLC=PRCHLC+1
SET I=2
DO MES
QUIT
+4 QUIT
EN11 DO MV
DO EN
IF Y<0
WRITE !?5,"<NOTHING DELETED>"
QUIT
+1 IF +$PIECE(^PRC(443.6,PRCHPO,2,+PRCHI,2),U,8)
WRITE !?5,"CANNOT DELETE ITEM ",$PIECE(PRCHI,U,2),", IT HAS ALREADY BEEN RECEIVED!",$CHAR(7)
QUIT
+2 SET %=""
SET %A=" SURE YOU WANT TO DELETE LINE ITEM "_$PIECE(PRCHI,U,2)
SET %B=""
DO ^PRCFYN
IF %'=1
WRITE ?50,"<NOTHING DELETED>"
QUIT
+3 SET ^TMP("PRCHW",$JOB,1)="The following line item has been cancelled: "
SET I=2
DO MES
SET WX="*****CANCELLED*****"
SET PRCH="^PRC(443.6,PRCHPO,2,+PRCHI,1,"
SET K=K+1
DO WORD^PRCHUTL
DO DIS
+4 SET DR="40///^S X=$P(PRCHI,U,2);"
SET DR(2,443.61)="5///0;2////0"
SET PRCHAMT=PRCHAMT-^PRC(443.6,PRCHPO,2,+PRCHI,2)
DO DIE^PRCHAM1
+5 SET PRCHX($PIECE(PRCHI,U,2),"@")="^PRC(442,PRCHPO,2,""C"",X,"_+PRCHI_")"
SET PRCHT=0
SET PRCHDL=1
QUIT
EN12 DO MV
DO EN
if Y<0
QUIT
SET I=1
DO MES
SET PRCHX=K
SET PRCHO=$SELECT($DATA(^PRC(443.6,PRCHPO,2,+PRCHI,2)):+^(2),1:0)
SET DR="[PRCHAMIT]"
DO DIE^PRCHAM1
+1 SET PRCHN=$SELECT($DATA(^PRC(443.6,PRCHPO,2,+PRCHI,2)):+^(2),1:0)
IF PRCHO'=PRCHN
SET PRCHAMT=PRCHAMT+(PRCHN-PRCHO)
+2 SET PRCHT=0
SET PRCHDL=1
SET ^TMP("PRCHW",$JOB,PRCHX+1)=" **Will now be AMENDED to read: "
SET I=PRCHX+2
DO MES
DO DIS
+3 SET WX=" *AMENDED* "
SET PRCH="^PRC(443.6,PRCHPO,2,+PRCHI,1,"
DO WORD^PRCHUTL
IF $PIECE(^PRC(443.6,PRCHPO,2,+PRCHI,0),U,2)'>$PIECE(^(2),U,8)
SET PRCHX($PIECE(PRCHI,U,2),"@")="^PRC(442,PRCHPO,2,""C"",X,"_+PRCHI_")"
+4 IF '$TEST
SET PRCHX($PIECE(PRCHI,U,2),$PIECE(PRCHI,U,2))="^PRC(442,PRCHPO,2,""C"",X,"_+PRCHI_")"
+5 QUIT
MV ;MOVE LINE ITEMS INFO
+1 if $DATA(^PRC(443.6,PRCHPO,2,0))
QUIT
DO WAIT^DICD
SET %X="^PRC(442,PRCHPO,2,"
SET %Y="^PRC(443.6,PRCHPO,2,"
DO %XY^%RCR
SET $PIECE(^PRC(443.6,PRCHPO,2,0),U,2)="443.61IA"
KILL ^("C")
QUIT
MVDIS ;MOVE DISCOUNT ITEM INFO
+1 if $DATA(^PRC(443.6,PRCHPO,3,0))
QUIT
DO MV
SET %X="^PRC(442,PRCHPO,3,"
SET %Y="^PRC(443.6,PRCHPO,3,"
DO %XY^%RCR
SET $PIECE(^PRC(443.6,PRCHPO,3,0),U,2)="443.63A"
QUIT
MDIS ;CREATE AMENDMENT MESSAGE FOR DISCOUNT
+1 if '$DATA(^PRC(443.6,PRCHPO,3,PRCH))
QUIT
SET PRCHD0=^(PRCH,0)
+2 SET ^TMP("PRCHW",$JOB,K)=$PIECE(PRCHD0,U,2)_$SELECT($EXTRACT($PIECE(PRCHD0,U,2))="$":"",1:"%")_" Discount For "_$SELECT($PIECE(PRCHD0,U,1)="Q":"Quantity ",1:"Items: "_$PIECE(PRCHD0,U,1))
+3 SET K=K+1
SET ^TMP("PRCHW",$JOB,K)=" Will now be AMENDED to read $"_$PIECE(^PRC(443.6,PRCHPO,3,PRCH,0),U,3)
QUIT
MES ;CREATE AMENDMENT MESSAGE FOR ITEM
+1 if '$DATA(^PRC(443.6,PRCHPO,2,+PRCHI))
QUIT
SET M(0)=^(+PRCHI,0)
SET M(2)=^(2)
SET K=I
SET ^TMP("PRCHW",$JOB,K)=""
+2 IF $DATA(^PRC(443.6,PRCHPO,2,+PRCHI,1,0))
FOR J=0:0
SET J=$ORDER(^PRC(443.6,PRCHPO,2,+PRCHI,1,J))
if 'J
QUIT
IF $DATA(^(J,0))
SET X=^(0)
SET ^TMP("PRCHW",$JOB,K)=$EXTRACT(X,1,226)
SET K=K+1
IF $EXTRACT(X,227,300)]""
SET ^TMP("PRCHW",$JOB,K)=$EXTRACT(X,227,300)
SET K=K+1
+3 SET ^TMP("PRCHW",$JOB,I)="Item No. "_+M(0)_" "_^TMP("PRCHW",$JOB,I)
SET X=$SELECT($DATA(^PRCD(420.5,+$PIECE(M(0),U,3),0)):$PIECE(^(0),U,1),1:"")
+4 IF ('$PIECE(M(0),U,12))&($PIECE(M(0),U,6)="")&($PIECE(M(0),U,13)="")
GOTO MES2
+5 SET ^TMP("PRCHW",$JOB,K)=" "
IF $PIECE(M(0),U,12)
SET ^TMP("PRCHW",$JOB,K)=^TMP("PRCHW",$JOB,K)_"Items per "_X_": "_$PIECE(M(0),U,12)_$EXTRACT(" ",1,(6-$LENGTH($PIECE(M(0),U,12))+2))
+6 IF $PIECE(M(0),U,6)'=""
SET ^TMP("PRCHW",$JOB,K)=^TMP("PRCHW",$JOB,K)_"STK#: "_$PIECE(M(0),U,6)_" "
+7 IF $PIECE(M(0),U,13)'=""
SET ^TMP("PRCHW",$JOB,K)=^TMP("PRCHW",$JOB,K)_"NSN: "_$PIECE(M(0),U,13)
+8 SET K=K+1
MES2 SET ^TMP("PRCHW",$JOB,K)=" "_$PIECE(M(0),U,2)_" "_$SELECT($DATA(^PRCD(420.5,+$PIECE(M(0),U,3),0)):$PIECE(^(0),U,1),1:"")_" at $ "_$JUSTIFY($PIECE(M(0),U,9),6,2)_" = $ "_$JUSTIFY(+M(2),10,2)
QUIT
DIS IF $DATA(^PRC(443.6,PRCHPO,2,+PRCHI,2))
IF $PIECE(^(2),U,6)>0
SET PRCHAREC=1
+1 QUIT
