source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHMA3.m@ 1800

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

initial load of WorldVistAEHR
File size: 4.8 KB
RevLine 
[613]1PRCHMA3 ;WISC/AKS-Amends to po and req ;6/8/96 14:14
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN15 ;Auth edit
5 N DA,DIE,DA,DR
6 K CAN
7 S PRCHO=$P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)
8 S DA(1)=PRCHPO,DIE="^PRC(443.6,"_DA(1)_",6,"
9 S DA=PRCHAM,DR="3//^S X=""D""" D ^DIE W !
10 I $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,4)=5!($P(^(0),U,4)=15) D
11 .D ONLY^PRCHMA0 I '$G(PRCHON) S DR="3///^S X=PRCHO" D ^DIE S NOCAN=1 Q
12 .D ENC^PRCHMA
13 .I $G(ER)!$G(NOCAN) S DR="3///^S X=PRCHO" D ^DIE S NOCAN=1 Q
14 .S CAN=1
15 I +$G(PRCHO)=5!(+$G(PRCHO)=15) I PRCHO'=$P($G(^PRC(443.6,PRCHPO,6,PRCHAM,0)),U,4) D NOSIGN1^PRCHMA
16 S DA(1)=PRCHPO,DA=PRCHAM,PRCHX=X,X=PRCHO D
17 .S:X="" X=4 D EN8^PRCHAMXB S X=PRCHX K PRCHX
18 QUIT
19EN16 ;F.O.B. Edit
20 N X,I,PRCHSBOC,%,%A,%B,PRCH0,PRCH12,PRCHGNO,PRCHGPO,PRCHGSHP,PRCHN
21 N PRCHSHP
22 S (I,ER)=0,X=""
23 D CAN^PRCHMA3
24 I $G(NOCAN)=1 W !?5,$S($D(PRCHREQ):"REQUISITION",1:"PURCHASE ORDER")_" HAS BEEN RECEIVED, CANNOT CHANGE F.O.B. EDIT!",$C(7) Q
25 S PRCH0=$G(^PRC(443.6,PRCHPO,0))
26 S PRCHO=$P(PRCH0,U,13),PRCHOO=$P($G(^PRC(443.6,PRCHPO,23)),U)
27 S PRCH12=$G(^PRC(443.6,PRCHPO,12)) I PRCH12]"" D
28 .S PRCHGNO=$P(PRCH12,U,7),PRCHGPO=$P(PRCH12,U,8),PRCHGSHP=$P(PRCH12,U,9)
29 S DR="6.4;S:X'=""O"" Y="""";13;I X=""""!($P($G(^PRC(442,PRCHPO,23)),U)]"""") S Y="""";13.05"
30 I $P(^PRC(442,PRCHPO,0),U,19)=2 D
31 .S PRCHSBOC=$P($G(^PRCD(420.2,2299,0)),U)
32 .S DR="6.4;S:X'=""O"" Y="""";13;I X=""""!($P($G(^PRC(442,PRCHPO,23)),U)]"""") S Y="""";13.05////^S X=PRCHSBOC"
33 S DIE="^PRC(443.6,",DA=PRCHPO D ^DIE
34 S PRCHN("FOB")=$P($G(^PRC(443.6,PRCHPO,1)),U,6),PRCHSHP=+$P(^(0),U,13)
35 I $P($G(^PRC(443.6,PRCHPO,0)),U,13)]"" D
36 .I $G(PRCHAUTH)'=1 I (PRCHN("FOB")="O"&((PRCHSHP>250)!(PRCHSHP=0))) S DR="13.2;13.4;13.3" D ^DIE K DIE
37 I $P($G(^PRC(443.6,PRCHPO,1)),U,6)="D" D
38 .I $P(^PRC(443.6,PRCHPO,0),U,13)]"" D
39 ..S %="",%A=" This purchase order has shipping charges, Would you like to delete? ",%B="" D ^PRCFYN
40 ..I %=1 D
41 ...S DIE="^PRC(443.6,",DA=PRCHPO,DR="13///@;13.2///@;13.4///@;13.3///@" D ^DIE K DIE,DA,DR
42 ...S $P(^PRC(443.6,PRCHPO,0),U,14)=$P(PRCH0,U,14)-1
43 ...S $P(^PRC(443.6,PRCHPO,0),U,18)=""
44 ..I %'=1 D GBL^PRCHMA2
45 I $P($G(^PRC(443.6,PRCHPO,1)),U,6)="O"&(PRCHSHP=""!(PRCHSHP'>250&(PRCHSHP'=0))) D GBL^PRCHMA2
46 I $P($G(^PRC(443.6,PRCHPO,1)),U,6)="O" S PRCHN=$P(^PRC(443.6,PRCHPO,0),U,13) D
47 .I PRCHO=""&(PRCHN]"") D
48 ..S $P(^PRC(443.6,PRCHPO,0),U,14)=$P(PRCH0,U,14)+1
49 ..S $P(^PRC(443.6,PRCHPO,0),U,18)=$P(PRCH0,U,14)+1
50 .I PRCHO]""&(PRCHN="") D
51 ..S $P(^PRC(443.6,PRCHPO,0),U,14)=$P(PRCH0,U,14)-1,$P(^(0),U,18)=""
52 ..S $P(^PRC(443.6,PRCHPO,23),U)=""
53 S DA=PRCHPO,PRCHX=X,X=$S(PRCHO]"":PRCHO,1:0) I PRCHO'=$P(^PRC(443.6,PRCHPO,0),U,13) S PRCHAMDA=29 D EN4^PRCHAMXC
54 S X=$S(PRCHOO]"":PRCHOO,1:0) I PRCHOO'=$P($G(^PRC(443.6,PRCHPO,23)),U) S PRCHAMDA=29 D EN11^PRCHAMXC
55 I PRCHGNO'=$P($G(^PRC(443.6,PRCHPO,12)),U,7) S X=$S(PRCHGNO]"":PRCHGNO,1:0) D EN12^PRCHAMXC
56 I PRCHGPO'=$P($G(^PRC(443.6,PRCHPO,12)),U,8) S X=$S(PRCHGPO]"":PRCHGPO,1:0) D EN14^PRCHAMXC
57 I PRCHGSHP'=$P($G(^PRC(443.6,PRCHPO,12)),U,9) S X=$S(PRCHGSHP]"":PRCHGSHP,1:0) D EN13^PRCHAMXC
58 S X=PRCHX K PRCHO,PRCHOO Q
59 S DELIVER=1 W !
60 QUIT
61EN17 ;ITEM DISC Add/Edit
62 N DIE,DR,X,Y,N
63 D MV^PRCHMA0,MVDIS,^PRCHDIS2
64 S DIE="^PRC(443.6,",DR="[PRCHAMDISCOUNT]",DA=PRCHPO D ^DIE
65 S (I,N)=0 F S N=$O(^PRC(443.6,PRCHPO,2,N)) Q:'N S I=I+1
66 S N=0 F S N=$O(^PRC(443.6,PRCHPO,3,N)) Q:'N S I=I+1,$P(^(N,0),U,6)=I
67 I $P(^PRC(443.6,PRCHPO,0),U,13)]"" D
68 .S $P(^PRC(443.6,PRCHPO,0),U,14)=I+1,$P(^(0),U,18)=I+1
69 QUIT
70EN18 ;ITEM DISC Delete
71 N PRCHD,ID442,PRCHOLD,DIC,DIE,DR,DA,ID,Y
72 D MV^PRCHMA0,MVDIS
73 S DA(1)=PRCHPO,DIC="^PRC(443.6,"_DA(1)_",3,",DIC(0)="QAEMZ" D ^DIC
74 Q:Y<0 S PRCHD=+Y
75 S %=2,%A=" SURE YOU WANT TO DELETE ",%B="" D ^PRCFYN
76 I %'=1 W ?40,"<NOTHING DELETED>" Q
77 S ID442=$G(^PRC(442,DA(1),3,PRCHD,0)) I ID442="" D Q
78 .K ^PRC(443.6,DA(1),3,PRCHD)
79 .S ID=$G(^PRC(443.6,PRCHPO,3,0)) Q:ID="" S $P(ID,U,4)=$P(ID,U,4)-1,^PRC(443.6,PRCHPO,3,0)=ID
80 .S (I,N)=0 F S N=$O(^PRC(443.6,PRCHPO,2,N)) Q:'N S I=I+1
81 .S N=0 F S N=$O(^PRC(443.6,PRCHPO,3,N)) Q:'N S I=I+1,$P(^(N,0),U,6)=I
82 .I $P(^PRC(443.6,PRCHPO,0),U,13)]"" D
83 ..S $P(^PRC(443.6,PRCHPO,0),U,14)=I+1,$P(^(0),U,18)=I+1
84 S PRCHOLD=$P($G(^PRC(443.6,DA(1),3,PRCHD,0)),U,2)
85 S DIE="^PRC(443.6,"_DA(1)_",3,",DA=PRCHD,DR="1////0" D ^DIE K DIE
86 S X=PRCHOLD D EN10^PRCHAMXC
87 QUIT
88 ;
89MVDIS ;MOVE DISC ITEM INFO
90 Q:$D(^PRC(443.6,PRCHPO,3,0)) D MV^PRCHMA0
91 N %X,%Y
92 S %X="^PRC(442,PRCHPO,3,",%Y="^PRC(443.6,PRCHPO,3," D %XY^%RCR
93 S $P(^PRC(443.6,PRCHPO,3,0),U,2)=$P(^DD(443.6,14,0),U,2)
94 QUIT
95CAN ;CANCEL ALLOWED?
96 N M
97 S NOCAN=0 Q:'$D(^PRC(442,PRCHPO,11))
98 S M=0 F S M=$O(^PRC(442,PRCHPO,2,M)) Q:'M D Q:NOCAN
99 .I $P($G(^PRC(442,PRCHPO,2,M,2)),U,8) S NOCAN=1
100 I NOCAN=0,$P($G(^PRC(442,PRCHPO,0)),U,2)'=25 S M=0 F S M=$O(^PRC(442,PRCHPO,11,M)) Q:'M D Q:NOCAN
101 .I $P($G(^PRC(442,PRCHPO,11,M,0)),U,6)="" S NOCAN=1
102 QUIT
Note: See TracBrowser for help on using the repository browser.