source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHAM44.m@ 1078

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

initial load of WorldVistAEHR
File size: 2.9 KB
Line 
1PRCHAM44 ;WISC/AKS,ID/RSD,SF-ISC/TKW-ADJUSTMENT VOUCHER (Contd...) ;8-2-89/9:18 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN2 ;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
52ESIG 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
57KILL 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
Note: See TracBrowser for help on using the repository browser.