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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHAM44 3040 printed Dec 13, 2024@02:05:40 Page 2
PRCHAM44 ;WISC/AKS,ID/RSD,SF-ISC/TKW-ADJUSTMENT VOUCHER (Contd...) ;8-2-89/9:18 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN2 ;EDIT QTY BEING RECEIVED
+1 SET X=""
WRITE !?3,"QTY BEING RECEIVED: ",PRCHO,"// "
READ X:DTIME
+2 ;I $E(X)="?"!(+X'=X)!(X<0)!(X?.E1"."3N.N) D W1^PRCHAM4 G EN2
+3 if '$TEST!($EXTRACT(X)="^")!(X="")
GOTO EN2Q^PRCHAM4
+4 IF $EXTRACT(X)="?"!(+X'=X)!(X<0)!(X?.E1"."3N.N)
DO W1^PRCHAM4
GOTO EN2
+5 IF X'<PRCHO
Begin DoDot:1
+6 WRITE !?3,"You can only DECREASE a receiving report quantity !",$CHAR(7)
End DoDot:1
GOTO EN2
+7 SET PRCHQTY=+X
SET X=X-PRCHO
+8 SET $PIECE(^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHAV,0),U,7)=+PRCHQTY
+9 if X<0
SET PRCHXX=X
+10 IF +PRCHQTY=0&(PRCHII=1)
Begin DoDot:1
+11 IF $PIECE($GET(^PRC(443.6,PRCHPO,0)),U,13)
WRITE !!," This purchase order has shipping charges $"_$PIECE(^(0),U,13)
+12 SET %=""
SET %A=" Do you wish to delete? Y/N//"
SET %B=""
DO ^PRCFYN
+13 IF %=2
SET PRCHSHIP=$PIECE($GET(^PRC(443.6,PRCHPO,0)),U,13)
Begin DoDot:2
+14 IF +PRCHSAM2>0
SET PRCHSHIP=PRCHSHIP/2
SET PRCHSHIP=PRCHSHIP*100+.5\1/100
+15 SET $PIECE(PRCHAV0,U,3)=PRCHSAM1-PRCHSHIP
+16 if +PRCHSAM2>0
SET $PIECE(PRCHAV0,U,5)=PRCHSAM2-PRCHSHIP
End DoDot:2
End DoDot:1
+17 ;..S DR="13///@;13.05///@",DIE="^PRC(443.6,",DA=PRCHPO D ^DIE K DIE,DR
+18 ;..I $P(^PRC(443.6,PRCHPO,0),U,18) S $P(^(0),U,18)=""
+19 SET PRCHRPT=PRCHRPTN
+20 SET ^PRC(443.6,PRCHPO,11,0)=^PRC(442,PRCHPO,11,0)
+21 SET $PIECE(^PRC(443.6,PRCHPO,11,0),U,3,4)=PRCHRPT_U_($PIECE(^(0),U,4)+1)
+22 SET PRCHRAM=$PIECE(PRCHI(0),U,9)
SET PRCHRQ1=$PIECE(PRCHI(0),U,2)
+23 SET PRCHDA=$PIECE(PRCHI(2),U,6)
SET PRCHRQ=$PIECE(PRCHI(2),U,8)
SET PRCHTOT=+PRCHI(2)
+24 if PRCHXX<0
SET PRCHXX1=+$FNUMBER(PRCHXX,"T")
+25 SET PRCHAMT1=PRCHRAM*PRCHXX1*100+.5\1/100
+26 if PRCHXX<0
SET PRCHAMT1=-PRCHAMT1
+27 IF PRCHTOT'=0
SET PRCHDA=PRCHDA/PRCHTOT*PRCHAMT1
SET PRCHDA=$FNUMBER(PRCHDA,"",2)
+28 IF PRCHTOT=0
SET PRCHDA=$FNUMBER(PRCHDA,"",2)
+29 ;S PRCHRQ=PRCHRQ-PRCHO+PRCHXX
+30 ;S PRCHSHIP=$P($G(^PRC(443.6,PRCHPO,0)),U,13)
+31 ;I $G(PRCHSHIP) S $P(^(0),U,15)=$P(^PRC(443.6,PRCHPO,0),U,15)-PRCHSHIP
+32 ;K PRCHSHIP
+33 SET $PIECE(^PRC(443.6,PRCHPO,2,+PRCHI,2),U,8)=$PIECE(^PRC(443.6,PRCHPO,2,+PRCHI,2),U,8)+PRCHXX
+34 SET PRCHMM=0
+35 ;F S PRCHMM=$O(^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHMM)) Q:'PRCHMM S PRCHJJ=PRCHMM
+36 FOR
SET PRCHMM=$ORDER(^PRC(442,PRCHPO,11,PRCHMM))
if 'PRCHMM
QUIT
SET PRCHJJ=PRCHMM
+37 SET PRCHAVLD=PRCHAV
SET PRCHAV=PRCHJJ+1
+38 SET $PIECE(^PRC(443.6,PRCHPO,2,+PRCHI,3,0),U,3,4)=PRCHAV_U_($PIECE(^(0),U,4)+1)
+39 SET ^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHAV,0)=PRCHITR
+40 SET $PIECE(^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHAV,0),U,2,4)=PRCHXX_U_PRCHAMT1_U_PRCHAV
+41 SET $PIECE(^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHAV,0),U,5)=PRCHDA
+42 SET ^PRC(443.6,PRCHPO,2,+PRCHI,3,"AC",PRCHAV,PRCHAV)=""
+43 SET ^PRC(443.6,PRCHPO,2,"AB",PRCHRD,+PRCHI,PRCHAV)=""
+44 if PRCHRQ>PRCHRQ1
SET PRCHROV=""
+45 IF PRCHRQ1>PRCHRQ
Begin DoDot:1
+46 SET PRCHX($PIECE(PRCHI,U,2),$PIECE(PRCHI,U,2))="^PRC(442,PRCHPO,2,""C"",X,"_+PRCHI_")"
SET PRCHAF=""
End DoDot:1
+47 QUIT
ESIG NEW PNAM
SET PNAM=$PIECE($GET(^VA(200,P,0)),"^",1)
+1 WRITE !?5,PNAM," was assigned to this Adjustment and"
+2 WRITE !?5,"must enter their Electronic Signature now."
+3 WRITE !?5,"Otherwise, the amendment will be deleted.",$CHAR(7)
+4 QUIT
KILL KILL PRCSUM,PRCHCHK,PRCHES,PRCHNM,PRCHT,PRCHI,PRCHJ,PRCHK,PRCHP,PRCHD,PRCHDAM,PRCHDL,PRCHX,ZTSK,DIE,DR,DIC,^TMP("PRCHW",$JOB),%,%A,%B,%X,%Y,D0,D1,DIR,P,PNAM,PRCHAM,PRCHQ,PRCSIG,PRCHAV1
+1 QUIT
