- 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 Apr 23, 2025@18:20:07 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
