source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHMA2.m@ 1154

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

initial load of WorldVistAEHR
File size: 4.8 KB
RevLine 
[613]1PRCHMA2 ;WISC/AKS-Amendments to purchase orders and requisitions ;6/9/96 20:44
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN10 ;EST. SHIPPING Edit
5 N X,I,PRCHO,PRCHN,PRCHOO,PRCH0,PRCHSBOC,PRCH12,PRCHGNP,PRCHGPO,PRCHGSHP
6 N PRCHSHP
7 S (I,ER)=0,X=""
8 ;F S I=$O(^PRC(442,PRCHPO,11,I)) Q:I'>0 I $D(^(I,0)) S X=$P(^(0),U,8) Q:X]""
9 D CAN^PRCHMA3
10 I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CHANGE ESTIMATED SHIPPING!",$C(7) Q
11 S PRCH0=$G(^PRC(443.6,PRCHPO,0))
12 S PRCHO=$P(PRCH0,U,13),PRCHOO=$P(^PRC(443.6,PRCHPO,23),U)
13 S PRCH12=$G(^PRC(443.6,PRCHPO,12)) I PRCH12]"" D
14 .S PRCHGNO=$P(PRCH12,U,7),PRCHGPO=$P(PRCH12,U,8),PRCHGSHP=$P(PRCH12,U,9)
15 S DR="13;I X=""""!($P($G(^PRC(442,PRCHPO,23)),U)]"""") S Y="""";13.05"
16 S DIE="^PRC(443.6,",DA=PRCHPO
17 I $P(^PRC(442,PRCHPO,0),U,19)=2 D
18 .S PRCHSBOC=$P($G(^PRCD(420.2,2299,0)),U)
19 .S DR="13;I X=""""!($P($G(^PRC(442,PRCHPO,23)),U)]"""") S Y="""";13.05////^S X=PRCHSBOC"
20 D ^DIE
21 S PRCHN("FOB")=$P($G(^PRC(443.6,PRCHPO,1)),U,6),PRCHSHP=$P(^(0),U,13)
22 I $P($G(^PRC(443.6,PRCHPO,0)),U,13)]"" D
23 .I (PRCHN("FOB")="O"&((PRCHSHP>250)!(PRCHSHP=0))) S DR="13.2;13.4;13.3" D ^DIE K DIE
24 I PRCHSHP=""!(PRCHSHP'>250&(PRCHSHP'=0)) D GBL
25 S PRCHX=X
26 I PRCHO'=$P($G(^PRC(443.6,PRCHPO,0)),U,13) S X=$S(PRCHO]"":PRCHO,1:0) D EN4^PRCHAMXC
27 I PRCHOO'=$P($G(^PRC(443.6,PRCHPO,23)),U) S X=$S(PRCHOO]"":PRCHOO,1:0) D EN11^PRCHAMXC
28 I PRCHGNO'=$P($G(^PRC(443.6,PRCHPO,12)),U,7) S X=$S(PRCHGNO]"":PRCHGNO,1:0) D EN12^PRCHAMXC
29 I PRCHGPO'=$P($G(^PRC(443.6,PRCHPO,12)),U,8) S X=$S(PRCHGPO]"":PRCHGPO,1:0) D EN14^PRCHAMXC
30 I PRCHGSHP'=$P($G(^PRC(443.6,PRCHPO,12)),U,9) S X=$S(PRCHGSHP]"":PRCHGSHP,1:0) D EN13^PRCHAMXC
31 S X=PRCHX,PRCHN=$P(^PRC(443.6,PRCHPO,0),U,13) K PRCHX,PRCHOO
32 I PRCHO=""&(PRCHN]"") D
33 .S $P(^PRC(443.6,PRCHPO,0),U,14)=$P(PRCH0,U,14)+1
34 .S $P(^PRC(443.6,PRCHPO,0),U,18)=$P(PRCH0,U,14)+1
35 I PRCHO]""&(PRCHN="") D
36 .S $P(^PRC(443.6,PRCHPO,0),U,14)=$P(PRCH0,U,14)-1,$P(^(0),U,18)=""
37 .S $P(^PRC(443.6,PRCHPO,23),U)=""
38 S DELIVER=1 W !
39 QUIT
40EN11 ;F.C.P. Edit
41 N X,I
42 S (I,ER)=0,X=""
43 ;F S I=$O(^PRC(442,PRCHPO,11,I)) Q:'I I $D(^(I,0)) S X=$P(^(0),U,8) Q:X]""
44 D CAN^PRCHMA3
45 I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CHANGE FUND CONTROL POINT!",$C(7) Q
46 I $P(^PRC(442,PRCHPO,0),U,12)>0 W !!,?5,"This purchase order has a 2237 attached to it.",!,?5,"To change F.C.P. you must do the following: " D QUIT
47 .W !!,?7,"1. Cancel the purchase order." Q:$G(PRCHAUTH)
48 .W !,?7,"2. Copy the 2237 to another 2237 with new FCP."
49 .W !,?7,"3. Have it signed by CP Official and Accountable Officer."
50 .W !,?7,"4. Attach the 2237 to a new purchase order."
51 S DR="1;2;5.2",DIE="^PRC(443.6,",DA=PRCHPO D ^DIE K DIE
52 QUIT
53EN12 ;Change Vendor
54 N X,I,DLAYGO,N,NN
55 S (I,ER)=0,X=""
56 ;F S I=$O(^PRC(442,PRCHPO,11,I)) Q:I'>0 I $D(^(I,0)) S X=$P(^(0),U,8) Q:X]""
57 D CAN^PRCHMA3
58 I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CHANGE VENDOR!",$C(7) Q
59 S DIC="^PRC(440,",DIC(0)="AEQ"
60 S:$D(PRCHREQ) DIC("S")="I $P($G(^(2)),U,2)'="""""
61 S:'$D(PRCHREQ) DIC("S")="I $P($G(^(2)),U,2)="""""
62 S:$P($G(^PRC(443.6,PRCHPO,1)),U) DIC("B")=$P(^PRC(440,$P(^(1),U),0),U)
63 D ^DIC K DIC Q:Y<0 S PRCHN=+Y
64 S DR="5///"_+Y,DIE="^PRC(443.6,",DA=PRCHPO D ^DIE K DIE
65 S N=""
66 F S N=$O(^PRC(443.6,PRCHPO,2,N)) Q:'N S NN=$P(^(N,0),U,5) I '$D(^PRC(441,NN,2,PRCHN)) D
67 .W !,"For item, ",$P(^PRC(441,NN,0),U,2)
68 .W !?5,"Enter the following information: "
69 .S DA(1)=NN,DIC="^PRC(441,"_DA(1)_",2,",DIC(0)="LZ",DIC("DR")="1;1.5;2;3;4"
70 .S DIE("NO^")="",DLAYGO=441,(DA,DA(1))=NN,X=PRCHN D ^DIC K DIC,DIE("NO^")
71 .S DIE="^PRC(441,"_DA(1)_",2,",DA=1,DR=6 D ^DIE
72 S N=0 F S N=$O(^PRC(443.6,PRCHPO,2,N)) Q:'N I $P($G(^PRC(443.6,PRCHPO,2,N,2)),U,2)]'"" D
73 . W !,"For line item: ",+^PRC(443.6,PRCHPO,2,N,0)
74 . W !?5,"Enter the following information: "
75 . S DA(1)=PRCHPO,DA=N,DIE="^PRC(443.6,"_DA(1)_",2,",DR=4 D ^DIE K DA,DIE,DR
76 S DELIVER=1 W !
77 QUIT
78 ;
79EN14 ;Prompt payment edit
80 N DIC,DA,Y,PRCHX,PRCHXX,PRCHVAL,PRCHDA,%X,%Y
81 I '$D(^PRC(443.6,PRCHPO,5)) D
82 .S %X="^PRC(442,PRCHPO,5,",%Y="^PRC(443.6,PRCHPO,5," D %XY^%RCR
83 S DA(1)=PRCHPO,DIC="^PRC(443.6,"_DA(1)_",5,",DIC(0)="AELQZ" D ^DIC Q:Y<0 S (PRCHDA,DA)=+Y,PRCHXX=$P(Y,U,3)
84 S PRCHVAL=$G(^PRC(443.6,PRCHPO,5,DA,0))
85 S PRCHP0=Y(0),PRCHO=$P(Y(0),U)_"/"_$P(Y(0),U,2)
86 S $P(^PRC(443.6,PRCHPO,5,0),U,2)=$P(^DD(443.6,9.2,0),U,2)
87 S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",5,"
88 S DR=".01//^S X=""NET"";1//^S X=30"
89 D ^DIE K DIE
90 S DA(1)=PRCHPO,DA=PRCHDA,PRCHX=X,X=$S(PRCHXX=1:0,1:$P(PRCHVAL,U)) D EN0^PRCHAMXB
91 S X=$S(PRCHXX=1:0,1:$P(PRCHVAL,U,2)) D EN1^PRCHAMXB
92 ;S X=$S(PRCHXX=1:0,1:$P(PRCHVAL,U,5)) D EN11^PRCHAMXB
93 S X=PRCHX
94 W !
95 QUIT
96GBL ;Delete GBL information
97 N DIE,DA,DR
98 S DIE="^PRC(443.6,",DA=PRCHPO,DR="13.2///@;13.4///@;13.3///@"
99 D ^DIE
Note: See TracBrowser for help on using the repository browser.