source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHAM2.m@ 862

Last change on this file since 862 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 3.7 KB
Line 
1PRCHAM2 ;WISC/AKS,ID/RSD,SF-ISC/TKW-CONT. OF AMENDMENTS ;2-1-90/2:05 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN S DIC="^PRC(443.6,PRCHPO,2,",DIC(0)="AEQZ" D ^DIC Q:Y<0 S (PRCHI,PRCHNFLG)=Y Q
5EN10 D MV S J=$P(^PRC(443.6,PRCHPO,2,0),U,3)+1,PRCHI=J_"^"_(PRCHLC+1),J=PRCHLC+1
6 S %=2,%A=" ADD LINE ITEM "_J,%B="" D ^PRCFYN I %'=1 W ?40,"<NOTHING ADDED>" Q
7 S DR="[PRCHAMIT]",DIE("NO^")="" D DIE^PRCHAM1 S ^TMP("PRCHW",$J,1)=" *ADDED THROUGH AMENDMENT* "
8 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
9 Q
10EN11 D MV,EN I Y<0 W !?5,"<NOTHING DELETED>" Q
11 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
12 S %="",%A=" SURE YOU WANT TO DELETE LINE ITEM "_$P(PRCHI,U,2),%B="" D ^PRCFYN I %'=1 W ?50,"<NOTHING DELETED>" Q
13 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
14 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
15 S PRCHX($P(PRCHI,U,2),"@")="^PRC(442,PRCHPO,2,""C"",X,"_+PRCHI_")",PRCHT=0,PRCHDL=1 Q
16EN12 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
17 S PRCHN=$S($D(^PRC(443.6,PRCHPO,2,+PRCHI,2)):+^(2),1:0) I PRCHO'=PRCHN S PRCHAMT=PRCHAMT+(PRCHN-PRCHO)
18 S PRCHT=0,PRCHDL=1,^TMP("PRCHW",$J,PRCHX+1)=" **Will now be AMENDED to read: ",I=PRCHX+2 D MES,DIS
19 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_")"
20 E S PRCHX($P(PRCHI,U,2),$P(PRCHI,U,2))="^PRC(442,PRCHPO,2,""C"",X,"_+PRCHI_")"
21 Q
22MV ;MOVE LINE ITEMS INFO
23 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
24MVDIS ;MOVE DISCOUNT ITEM INFO
25 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
26MDIS ;CREATE AMENDMENT MESSAGE FOR DISCOUNT
27 Q:'$D(^PRC(443.6,PRCHPO,3,PRCH)) S PRCHD0=^(PRCH,0)
28 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))
29 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
30MES ;CREATE AMENDMENT MESSAGE FOR ITEM
31 Q:'$D(^PRC(443.6,PRCHPO,2,+PRCHI)) S M(0)=^(+PRCHI,0),M(2)=^(2),K=I,^TMP("PRCHW",$J,K)=""
32 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
33 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:"")
34 I ('$P(M(0),U,12))&($P(M(0),U,6)="")&($P(M(0),U,13)="") G MES2
35 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))
36 I $P(M(0),U,6)'="" S ^TMP("PRCHW",$J,K)=^TMP("PRCHW",$J,K)_"STK#: "_$P(M(0),U,6)_" "
37 I $P(M(0),U,13)'="" S ^TMP("PRCHW",$J,K)=^TMP("PRCHW",$J,K)_"NSN: "_$P(M(0),U,13)
38 S K=K+1
39MES2 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
40DIS I $D(^PRC(443.6,PRCHPO,2,+PRCHI,2)),$P(^(2),U,6)>0 S PRCHAREC=1
41 Q
Note: See TracBrowser for help on using the repository browser.