PRCHAM44 ;WISC/AKS,ID/RSD,SF-ISC/TKW-ADJUSTMENT VOUCHER (Contd...) ;8-2-89/9:18 AM
V ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN2 ;EDIT QTY BEING RECEIVED
 S X="" W !?3,"QTY BEING RECEIVED: ",PRCHO,"// " R X:DTIME
 ;I $E(X)="?"!(+X'=X)!(X<0)!(X?.E1"."3N.N) D W1^PRCHAM4 G EN2
 G EN2Q^PRCHAM4:'$T!($E(X)="^")!(X="")
 I $E(X)="?"!(+X'=X)!(X<0)!(X?.E1"."3N.N) D W1^PRCHAM4 G EN2
 I X'<PRCHO D  G EN2
 .W !?3,"You can only DECREASE a receiving report quantity !",$C(7)
 S PRCHQTY=+X,X=X-PRCHO
 S $P(^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHAV,0),U,7)=+PRCHQTY
 S:X<0 PRCHXX=X
 I +PRCHQTY=0&(PRCHII=1) D
 .I $P($G(^PRC(443.6,PRCHPO,0)),U,13) W !!,"   This purchase order has shipping charges $"_$P(^(0),U,13)
 .S %="",%A="   Do you wish to delete? Y/N//",%B="" D ^PRCFYN
 .I %=2 S PRCHSHIP=$P($G(^PRC(443.6,PRCHPO,0)),U,13) D
 ..I +PRCHSAM2>0 S PRCHSHIP=PRCHSHIP/2,PRCHSHIP=PRCHSHIP*100+.5\1/100
 ..S $P(PRCHAV0,U,3)=PRCHSAM1-PRCHSHIP
 ..S:+PRCHSAM2>0 $P(PRCHAV0,U,5)=PRCHSAM2-PRCHSHIP
 ;..S DR="13///@;13.05///@",DIE="^PRC(443.6,",DA=PRCHPO D ^DIE K DIE,DR
 ;..I $P(^PRC(443.6,PRCHPO,0),U,18) S $P(^(0),U,18)=""
 S PRCHRPT=PRCHRPTN
 S ^PRC(443.6,PRCHPO,11,0)=^PRC(442,PRCHPO,11,0)
 S $P(^PRC(443.6,PRCHPO,11,0),U,3,4)=PRCHRPT_U_($P(^(0),U,4)+1)
 S PRCHRAM=$P(PRCHI(0),U,9),PRCHRQ1=$P(PRCHI(0),U,2)
 S PRCHDA=$P(PRCHI(2),U,6),PRCHRQ=$P(PRCHI(2),U,8),PRCHTOT=+PRCHI(2)
 S:PRCHXX<0 PRCHXX1=+$FN(PRCHXX,"T")
 S PRCHAMT1=PRCHRAM*PRCHXX1*100+.5\1/100
 S:PRCHXX<0 PRCHAMT1=-PRCHAMT1
 I PRCHTOT'=0 S PRCHDA=PRCHDA/PRCHTOT*PRCHAMT1,PRCHDA=$FN(PRCHDA,"",2)
 I PRCHTOT=0 S PRCHDA=$FN(PRCHDA,"",2)
 ;S PRCHRQ=PRCHRQ-PRCHO+PRCHXX
 ;S PRCHSHIP=$P($G(^PRC(443.6,PRCHPO,0)),U,13)
 ;I $G(PRCHSHIP) S $P(^(0),U,15)=$P(^PRC(443.6,PRCHPO,0),U,15)-PRCHSHIP
 ;K PRCHSHIP
 S $P(^PRC(443.6,PRCHPO,2,+PRCHI,2),U,8)=$P(^PRC(443.6,PRCHPO,2,+PRCHI,2),U,8)+PRCHXX
 S PRCHMM=0
 ;F  S PRCHMM=$O(^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHMM)) Q:'PRCHMM  S PRCHJJ=PRCHMM
 F  S PRCHMM=$O(^PRC(442,PRCHPO,11,PRCHMM)) Q:'PRCHMM  S PRCHJJ=PRCHMM
 S PRCHAVLD=PRCHAV,PRCHAV=PRCHJJ+1
 S $P(^PRC(443.6,PRCHPO,2,+PRCHI,3,0),U,3,4)=PRCHAV_U_($P(^(0),U,4)+1)
 S ^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHAV,0)=PRCHITR
 S $P(^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHAV,0),U,2,4)=PRCHXX_U_PRCHAMT1_U_PRCHAV
 S $P(^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHAV,0),U,5)=PRCHDA
 S ^PRC(443.6,PRCHPO,2,+PRCHI,3,"AC",PRCHAV,PRCHAV)=""
 S ^PRC(443.6,PRCHPO,2,"AB",PRCHRD,+PRCHI,PRCHAV)=""
 S:PRCHRQ>PRCHRQ1 PRCHROV=""
 I PRCHRQ1>PRCHRQ D
 .S PRCHX($P(PRCHI,U,2),$P(PRCHI,U,2))="^PRC(442,PRCHPO,2,""C"",X,"_+PRCHI_")",PRCHAF=""
 Q
ESIG N PNAM S PNAM=$P($G(^VA(200,P,0)),"^",1)
 W !?5,PNAM," was assigned to this Adjustment and"
 W !?5,"must enter their Electronic Signature now."
 W !?5,"Otherwise, the amendment will be deleted.",$C(7)
 QUIT
KILL K PRCSUM,PRCHCHK,PRCHES,PRCHNM,PRCHT,PRCHI,PRCHJ,PRCHK,PRCHP,PRCHD,PRCHDAM,PRCHDL,PRCHX,ZTSK,DIE,DR,DIC,^TMP("PRCHW",$J),%,%A,%B,%X,%Y,D0,D1,DIR,P,PNAM,PRCHAM,PRCHQ,PRCSIG,PRCHAV1
 Q