| [613] | 1 | PRCHAM44 ;WISC/AKS,ID/RSD,SF-ISC/TKW-ADJUSTMENT VOUCHER (Contd...) ;8-2-89/9:18 AM
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | EN2 ;EDIT QTY BEING RECEIVED
|
|---|
| 5 | S X="" W !?3,"QTY BEING RECEIVED: ",PRCHO,"// " R X:DTIME
|
|---|
| 6 | ;I $E(X)="?"!(+X'=X)!(X<0)!(X?.E1"."3N.N) D W1^PRCHAM4 G EN2
|
|---|
| 7 | G EN2Q^PRCHAM4:'$T!($E(X)="^")!(X="")
|
|---|
| 8 | I $E(X)="?"!(+X'=X)!(X<0)!(X?.E1"."3N.N) D W1^PRCHAM4 G EN2
|
|---|
| 9 | I X'<PRCHO D G EN2
|
|---|
| 10 | .W !?3,"You can only DECREASE a receiving report quantity !",$C(7)
|
|---|
| 11 | S PRCHQTY=+X,X=X-PRCHO
|
|---|
| 12 | S $P(^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHAV,0),U,7)=+PRCHQTY
|
|---|
| 13 | S:X<0 PRCHXX=X
|
|---|
| 14 | I +PRCHQTY=0&(PRCHII=1) D
|
|---|
| 15 | .I $P($G(^PRC(443.6,PRCHPO,0)),U,13) W !!," This purchase order has shipping charges $"_$P(^(0),U,13)
|
|---|
| 16 | .S %="",%A=" Do you wish to delete? Y/N//",%B="" D ^PRCFYN
|
|---|
| 17 | .I %=2 S PRCHSHIP=$P($G(^PRC(443.6,PRCHPO,0)),U,13) D
|
|---|
| 18 | ..I +PRCHSAM2>0 S PRCHSHIP=PRCHSHIP/2,PRCHSHIP=PRCHSHIP*100+.5\1/100
|
|---|
| 19 | ..S $P(PRCHAV0,U,3)=PRCHSAM1-PRCHSHIP
|
|---|
| 20 | ..S:+PRCHSAM2>0 $P(PRCHAV0,U,5)=PRCHSAM2-PRCHSHIP
|
|---|
| 21 | ;..S DR="13///@;13.05///@",DIE="^PRC(443.6,",DA=PRCHPO D ^DIE K DIE,DR
|
|---|
| 22 | ;..I $P(^PRC(443.6,PRCHPO,0),U,18) S $P(^(0),U,18)=""
|
|---|
| 23 | S PRCHRPT=PRCHRPTN
|
|---|
| 24 | S ^PRC(443.6,PRCHPO,11,0)=^PRC(442,PRCHPO,11,0)
|
|---|
| 25 | S $P(^PRC(443.6,PRCHPO,11,0),U,3,4)=PRCHRPT_U_($P(^(0),U,4)+1)
|
|---|
| 26 | S PRCHRAM=$P(PRCHI(0),U,9),PRCHRQ1=$P(PRCHI(0),U,2)
|
|---|
| 27 | S PRCHDA=$P(PRCHI(2),U,6),PRCHRQ=$P(PRCHI(2),U,8),PRCHTOT=+PRCHI(2)
|
|---|
| 28 | S:PRCHXX<0 PRCHXX1=+$FN(PRCHXX,"T")
|
|---|
| 29 | S PRCHAMT1=PRCHRAM*PRCHXX1*100+.5\1/100
|
|---|
| 30 | S:PRCHXX<0 PRCHAMT1=-PRCHAMT1
|
|---|
| 31 | I PRCHTOT'=0 S PRCHDA=PRCHDA/PRCHTOT*PRCHAMT1,PRCHDA=$FN(PRCHDA,"",2)
|
|---|
| 32 | I PRCHTOT=0 S PRCHDA=$FN(PRCHDA,"",2)
|
|---|
| 33 | ;S PRCHRQ=PRCHRQ-PRCHO+PRCHXX
|
|---|
| 34 | ;S PRCHSHIP=$P($G(^PRC(443.6,PRCHPO,0)),U,13)
|
|---|
| 35 | ;I $G(PRCHSHIP) S $P(^(0),U,15)=$P(^PRC(443.6,PRCHPO,0),U,15)-PRCHSHIP
|
|---|
| 36 | ;K PRCHSHIP
|
|---|
| 37 | S $P(^PRC(443.6,PRCHPO,2,+PRCHI,2),U,8)=$P(^PRC(443.6,PRCHPO,2,+PRCHI,2),U,8)+PRCHXX
|
|---|
| 38 | S PRCHMM=0
|
|---|
| 39 | ;F S PRCHMM=$O(^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHMM)) Q:'PRCHMM S PRCHJJ=PRCHMM
|
|---|
| 40 | F S PRCHMM=$O(^PRC(442,PRCHPO,11,PRCHMM)) Q:'PRCHMM S PRCHJJ=PRCHMM
|
|---|
| 41 | S PRCHAVLD=PRCHAV,PRCHAV=PRCHJJ+1
|
|---|
| 42 | S $P(^PRC(443.6,PRCHPO,2,+PRCHI,3,0),U,3,4)=PRCHAV_U_($P(^(0),U,4)+1)
|
|---|
| 43 | S ^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHAV,0)=PRCHITR
|
|---|
| 44 | S $P(^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHAV,0),U,2,4)=PRCHXX_U_PRCHAMT1_U_PRCHAV
|
|---|
| 45 | S $P(^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHAV,0),U,5)=PRCHDA
|
|---|
| 46 | S ^PRC(443.6,PRCHPO,2,+PRCHI,3,"AC",PRCHAV,PRCHAV)=""
|
|---|
| 47 | S ^PRC(443.6,PRCHPO,2,"AB",PRCHRD,+PRCHI,PRCHAV)=""
|
|---|
| 48 | S:PRCHRQ>PRCHRQ1 PRCHROV=""
|
|---|
| 49 | I PRCHRQ1>PRCHRQ D
|
|---|
| 50 | .S PRCHX($P(PRCHI,U,2),$P(PRCHI,U,2))="^PRC(442,PRCHPO,2,""C"",X,"_+PRCHI_")",PRCHAF=""
|
|---|
| 51 | Q
|
|---|
| 52 | ESIG N PNAM S PNAM=$P($G(^VA(200,P,0)),"^",1)
|
|---|
| 53 | W !?5,PNAM," was assigned to this Adjustment and"
|
|---|
| 54 | W !?5,"must enter their Electronic Signature now."
|
|---|
| 55 | W !?5,"Otherwise, the amendment will be deleted.",$C(7)
|
|---|
| 56 | QUIT
|
|---|
| 57 | 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
|
|---|
| 58 | Q
|
|---|
