source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHAM3.m@ 1806

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

initial load of WorldVistAEHR

File size: 3.7 KB
Line 
1PRCHAM3 ;WISC/AKS,ID/RSD,SF-ISC/TKW-CONT. OF AMENDMENTS ;4/20/94 11:13 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4RECAL 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
5 Q
6PCTQ I PRCHAC="Q" S PRCHACT=$P(^PRC(443.6,PRCHPO,2,0),U,4),PRCHAC="1:1:"_PRCHLC G PCT
7 I PRCHAC[":" S PRCHAC=$P(PRCHAC,":",1)_":1:"_$P(PRCHAC,":",2)
8PCT S PRCHDAM=0,Y="F J="_PRCHAC_" S PRCHN=J D PCT1" X Y
9 S PRCHDAM=PRCHDAM*100+.5\1/100,$P(^PRC(443.6,PRCHPO,3,PRCH,0),U,3)=PRCHDAM Q
10PCT1 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)
11 I $E(PRCHP,1)="$" S PRCHDA=$P(PRCHP,"$",2)/PRCHACT
12 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)
13 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
14REST 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)=""
15 Q
16MDIS 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
17 Q
18DIE S DIE="^PRC(443.6,",DA=PRCHPO D ^DIE K DIE Q
19UPDT ;UPDATE DELIVERY DATE/ORIGINAL DELIVERY DATE
20 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
21 K PRCHDT Q
22EN8 ;AMEND ESTIMATED SHIPPING/HANDLING
23 S PRCHO=$P(PRCH(0),U,13),DR=13 D DIE S PRCHN=$P(^PRC(443.6,PRCHPO,0),U,13) Q:PRCHO=PRCHN
24 S PRCHT=0,PRCHAMT=PRCHAMT+(PRCHN-PRCHO),PRCHDL=1
25 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
26 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)=""
27 Q
28EN14 D MVDIS^PRCHAM2 S J=$P(^PRC(443.6,PRCHPO,3,0),U,4)+1,PRCHD=J_"^"_(PRCHLC+1),J=PRCHLC+1
29 S %=2,%A=" ADD ITEM DISCOUNT AS LINE ITEM NUMBER: "_J,%B="" D ^PRCFYN I %'=1 W ?40,"<NOTHING ADDED>" Q
30 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)
31 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)
32 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)=""
33EX14 K DLAYGO Q
34EN15 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
35 S $P(^PRC(443.6,PRCHPO,3,PRCHD,0),U,2)=0,PRCHAREC=1,PRCHT=0,(PRCHO,PRCHN)="" Q
36EN16 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
37 Q
38DIS 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)_","
39 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"
40 Q:'$D(X) K:X?.E1P X Q:'$D(X) S PRCHJ=J Q
41LCK L ^PRC(442,PRCHPO):1 I '$T W !?5,"P.O. is being edited by another user " Q
42 I '$D(^PRC(442,PRCHPO,0))
43 Q
Note: See TracBrowser for help on using the repository browser.