source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHAM4.m@ 1688

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

initial load of FOIAVistA 6/30/08 version
File size: 5.0 KB
Line 
1PRCHAM4 ;WISC/AKS,ID/RSD,SF-ISC/TKW-ADJUSTMENT VOUCHER ;6/8/96 13:06
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN ;ADJUSTMENT VOUCHER
5 I $D(^PRC(443.6,PRCHPO)) D Q
6 .W !!,"There is a pending amendment against this purchase order." Q
7 S PRCHAV="" D ENAV^PRCHAM Q:'$D(PRCHPO)
8PAR S DIC="^PRC(442,PRCHPO,11,",DIC(0)="QEANZ"
9 S DIC("S")="I $P(^PRC(442,PRCHPO,11,+Y,0),U,12)'<0" D ^DIC K DIC
10 ;I $G(PRCHAUTH)=1 S DIC("S")="I $P(^PRC(442,PRCHPO,11,+Y,0),U,12)'<0,$P(^PRC(442,PRCHPO,23),U,11)=""P"""
11 ;I $G(PRCHAUTH)=2 S DIC("S")="I $P(^PRC(442,PRCHPO,11,+Y,0),U,12)'<0,$P(^PRC(442,PRCHPO,23),U,11)=""D"""
12 G:Y<0 Q^PRCHAM
13 I $P(^PRC(442,PRCHPO,11,+Y,0),U,6)="",$P($G(^PRC(442,PRCHPO,0)),U,2)'=25,'$G(PRCHAUTH) W !,"This Receiving Report has not been processed in Fiscal Service." G PAR
14 S (PRCHRPTO,PRCHRPT)=+Y,PRCHAV0=Y(0),PRCHRD=$P(Y(0),U)
15 S (PRCHRTT,PRCHRT)=0
16 S:$D(^PRC(442,PRCHPO,11,PRCHRPTO,1)) PRCHAV1=^(1),$P(PRCHAV1,U,16)=PRCHRPTO
17 S PRCHSAM1=$P(PRCHAV0,U,3),PRCHSAM2=$P(PRCHAV0,U,5)
18 D NOW^%DTC
19 I X>($P(^PRC(442,PRCHPO,11,PRCHRPTO,0),U)+30) D I %'=1 G Q^PRCHAM
20 .W !!,?10,"This partial receipt is more than 30 days old."
21 .W !,?10,"Please check payment status with Fiscal.",!," "
22 .S %="",%A=" Would you like to continue? ",%B="" D ^PRCFYN
23 S ^TMP("PRCHW",$J,1)="Adjustment Voucher for Purchase Order "_$P(PRCH(0),U)
24 S (PRCHII,PRCHNN)=0 F S PRCHNN=$O(^PRC(442,PRCHPO,11,PRCHNN)) Q:'PRCHNN S PRCHII=PRCHII+1
25 S PRCHRPTN=PRCHII+1
26 S PRCHJ=3,PRCHL1="*",(PRCHO,PRCHN,PRCHL2)="" D EN^PRCHAM
27ITEM S DIC("S")="I $O(^PRC(443.6,PRCHPO,2,""AB"",PRCHRD,+Y,0))"
28 K PRCHI,^TMP("PRCHW",$J) D MV^PRCHAM2,EN^PRCHAM2 K DIC
29 I '$D(PRCHNFLG) G Q^PRCHAM
30 G LST:Y<0,ITEM:'$D(^PRC(443.6,PRCHPO,2,+PRCHI,2))
31 S PRCHI(0)=^PRC(443.6,PRCHPO,2,+PRCHI,0),PRCHI(2)=^(2),I=PRCHJ
32 D MES^PRCHAM2 S PRCHAV=+$O(^PRC(443.6,PRCHPO,2,"AB",PRCHRD,+PRCHI,0))
33 G:'$D(^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHAV,0)) ITEM S (PRCHITR,Y)=^(0)
34 ;S PRCHO=$S($P(Y,U,7):$P(Y,U,7),1:$P(Y,U,2)),PRCHAMT1=$P(Y,U,3)
35 S PRCHO=$P(Y,U,2),PRCHAMT1=$P(Y,U,3)
36 I $P(Y,U,7)]"" S PRCHO=$P(Y,U,7),PRCHAMT1=$P(Y,U,8)
37 S PRCHDA=$P(Y,U,5),PRCHK=K+1
38 S ^TMP("PRCHW",$J,PRCHK)=" ORIGINALLY QTY RECEIVED = "_PRCHO_" ,COST = $ "_PRCHAMT1
39 S PRCHK=PRCHK+1 D EN2^PRCHAM44 G ITEM:'$D(X)
40 S PRCHN=PRCHXX G:PRCHO=PRCHN ITEM
41 S PRCHADAM=$S($P(PRCHITR,U,8):$P(PRCHITR,U,8),1:$P(PRCHITR,U,3))+PRCHAMT1
42 S $P(^PRC(443.6,PRCHPO,2,+PRCHI,3,PRCHAVLD,0),U,8)=PRCHADAM
43 S ^TMP("PRCHW",$J,PRCHK)=" will now read: QTY RECEIVED="_PRCHQTY_", COST=$"_PRCHADAM
44 S PRCHJ=PRCHK+1,PRCHL1="*",PRCHL2="",PRCHJ=1 D EN^PRCHAM G ITEM
45LST S (PRCHAMT1,PRCHDA)=0,PRCHAVA=$P(PRCHAV0,U,3)+$P(PRCHAV0,U,5)
46 I 'PRCHCHK D Q G Q^PRCHAM
47 S I=0 F S I=$O(^PRC(443.6,PRCHPO,2,"AB",PRCHRD,I)) Q:'I D
48 .S J=0 F S J=$O(^PRC(443.6,PRCHPO,2,"AB",PRCHRD,I,J)) Q:'J D
49 ..S PRCHAV=J I $D(^PRC(443.6,PRCHPO,2,I,0)),$D(^(2)) S PRCHRS=$P(^(2),U,7) I $D(^(3,PRCHAV,0)) S (PRCHITSB,Y)=^(0) D SUB
50 D TM^PRCHREC2,EN2^PRCHREC S K=1
51 S ^TMP("PRCHW",$J,K)=" Vendor: "_$P(^PRC(440,$P(^PRC(442,PRCHPO,1),U),0),U),K=K+1
52 S ^TMP("PRCHW",$J,K)=" APPROPRIATION: "_$P(^PRC(442,PRCHPO,0),U,4),K=K+1
53 S ^TMP("PRCHW",$J,K)=" This Receiving Report will now read: ",K=K+1
54 I PRCHDA D
55 .S ^TMP("PRCHW",$J,K)=" Discounted Amount: "_PRCHDA,K=K+1
56 S ^TMP("PRCHW",$J,K)=" Total Amount: "_PRCHRAM
57 I PRCHRT S PRCHRTT=PRCHRAM*PRCHRT D
58 .S ^TMP("PRCHW",$J,K+1)=" Term Discount Amount: "_$J(PRCHRTT,8,2)
59 .S ^TMP("PRCHW",$J,K+2)=" Net Amount: "_$J(PRCHRAMN,10,2)
60 S (PRCHAMT1,PRCHDA)=0,PRCHAVA=$P(PRCHAV0,U,3)+$P(PRCHAV0,U,5) K PRCHR
61 ;I 'PRCHCHK D Q G Q^PRCHAM
62 S I=0 F S I=$O(^PRC(443.6,PRCHPO,2,"AB",PRCHRD,I)) Q:'I D
63 .S J=0 F S J=$O(^PRC(443.6,PRCHPO,2,"AB",PRCHRD,I,J)) Q:'J D
64 ..I '$D(^PRC(442,PRCHPO,11,J)) S PRCHAV=J I $D(^PRC(443.6,PRCHPO,2,I,0)),$D(^(2)) S PRCHRS=$P(^(2),U,7) I $D(^(3,PRCHAV,0)) S (PRCHITSB,Y)=^(0) D SUB
65 D TM^PRCHREC2,EN2^PRCHREC S K=1
66 S $P(PRCHAV0,U,2,5)=PRCHR(1)_U_PRCHR(2)
67 S X=$P(PRCHAV0,U,9) S:X]""&($D(PRCHAF)) $P(PRCHAV0,U,9)=""
68 S $P(PRCHAV0,U,19)=""
69 S $P(PRCHAV0,U,10)=$S($D(PRCHROV):"Y",1:""),$P(PRCHAV0,U,12)=PRCHRAM
70 S X=$P(^PRC(443.6,PRCHPO,0),U,17),X=X-PRCHAVA,$P(^(0),U,17)=X
71 S $P(PRCHAV0,U,6)="",$P(PRCHAV0,U,9)=""
72 S ^PRC(443.6,PRCHPO,11,PRCHRPT,0)=PRCHAV0,PRCHL1="*"
73 S:$D(PRCHAV1) ^PRC(443.6,PRCHPO,11,PRCHRPT,1)=PRCHAV1
74 S (PRCHO,PRCHN,PRCHL2)="" D EN^PRCHAM,Q G EN2^PRCHAM
75SUB S PRCHDA=PRCHDA+$P(Y,U,5) S:PRCHRS="" PRCHRS="**"
76 S:'$D(PRCHR("SA",PRCHRS)) PRCHR("SA",PRCHRS)=0
77 S PRCHR("SA",PRCHRS)=PRCHR("SA",PRCHRS)+$P(Y,U,3)-$P(Y,U,5) Q
78SETC ;IF ESTIMATED ORDER, PARTIAL ORDER RECEIVED, RESET 'C' X-REF ON ALL ITEMS
79 Q:'$D(^PRC(442,PRCHPO,7)) Q:$P(^(7),U,3)'="Y" Q:$P(^(7),U,2)'=26
80 F I=0:0 S I=$O(^PRC(442,PRCHPO,2,I)) Q:'I I $D(^(I,0)) D
81 .S X=+^(0),PRCHX(X,X)="^PRC(442,PRCHPO,2,""C"",X,"_I_")"
82 Q
83W1 W:$E(X)'="?" " ??",$C(7)
84 W !,"Enter the quantity (a number between 0 & 999,999 with up to two decimal places)" Q
85Q K PRCHAMT1,PRCHDA,PRCHRD,PRCHR,PRCHRPT,PRCHRES,PRCHRAM,PRCHRAMN,PRCHRT
86 K PRCHRT2,PRCHRS,PRCHRQ,PRCHRQ1,PRCHROV,PRCHAV0,PRCHAVA,PRCHAF,PRCHRTT
87 QUIT
88EN2Q K X
89 QUIT
Note: See TracBrowser for help on using the repository browser.