source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHAM2.m@ 636

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