source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHMA0.m@ 1351

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

initial load of WorldVistAEHR
File size: 6.1 KB
Line 
1PRCHMA0 ;WISC/AKS-Amendments to purchase orders and requisitions ;3/5/97 15:05
2 ;;5.1;IFCAP;**97**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN1 ;Ship to edit
5 N DR,DIE,DA,DIE,PRCH0
6 S PRCH0=$G(^PRC(443.6,PRCHPO,0))
7 S DR=$S($P(PRCH0,U,2)'=4:5.4,1:5.3)
8 S DIE="^PRC(443.6,",DA=PRCHPO D ^DIE
9 S DELIVER=1 W !
10 Q
11EN2 ;Line Item add
12 N J,%,%A,%B,DIE,DA,DR,D0,D1,PRCHI,PRCHLC,PRCHSTN,NODE0,PRCHI1,PRCHPONO,BFLAG
13 N X,Y
14 D MV,MVDIS^PRCHMA3 S NODE0=^PRC(443.6,PRCHPO,0),PRCHLC=$P(NODE0,U,14)
15 S J=PRCHLC+1,BFLAG=0
16 S (I,N,M)=0 F S N=$O(^PRC(443.6,PRCHPO,2,N)) Q:'N S I=$P(^(N,0),U),M=N
17 S PRCHI=(I+1)_"^"_J S:$P(^PRC(443.6,PRCHPO,2,0),U,3)<M $P(^(0),U,3)=M
18 S %=2,%A=" ADD LINE ITEM "_+PRCHI,%B="" D ^PRCFYN
19 I %'=1 W ?40,"<NOTHING ADDED>" Q
20 K DD,DO S DA(1)=PRCHPO,X=+PRCHI,DIC="^PRC(443.6,"_DA(1)_",2,"
21 S DIC(0)="L" D FILE^DICN K DIC Q:+Y'>0
22 S PRCHI1=+PRCHI,$P(PRCHI,U)=+Y
23 ;S $P(^PRC(443.6,PRCHPO,2,0),U,3)=$P(PRCHI,U),$P(^(0),U,4)=+PRCHI
24 S $P(NODE0,U,14)=J
25 I $D(^PRC(443.6,PRCHPO,3)) D
26 .S N=0 F S N=$O(^PRC(443.6,PRCHPO,3,N)) Q:'N S $P(^PRC(443.6,PRCHPO,3,N,0),U,6)=$P(^PRC(443.6,PRCHPO,3,N,0),U,6)+1
27 S:$P(NODE0,U,18)]"" $P(NODE0,U,18)=J
28 S ^PRC(443.6,PRCHPO,0)=NODE0
29 S PRCHEDI=$G(^PRC(440,$P(^PRC(443.6,PRCHPO,1),U),3)) S:PRCHEDI]"" PRCHEDI=$P(PRCHEDI,U,2)
30 S PRCHSTN=$P($P(NODE0,U),"-"),PRCHPONO=$P(NODE0,U)
31 S DIE="^PRC(443.6,",DA=PRCHPO
32 S DR=$S($D(PRCHREQ):"[PRCHRQITM]",1:"[PRCHLINE]"),DIE("NO^")="BACK"
33 I $G(PRCHAUTH)=1 S DR="[PRCH PURCHASE CARD AMEND]"
34 I $G(PRCHAUTH)=2 S DR="[PRCH DELIVERY ORDER AMEND]"
35 S DIE("NO^")="OUTOK"
36 D ^DIE K DIE
37 I $D(^PRC(443.6,PRCHPO,2,+PRCHI,0)) D
38 .S:'$D(^(2)) ^(2)=0
39 .I $P(^PRC(443.6,PRCHPO,2,+PRCHI,0),U,2)="" D
40 ..W !,"Line item is being deleted because of incomplete information.",!
41 ..S DA=+PRCHI,DA(1)=PRCHPO,DIK="^PRC(443.6,"_DA(1)_",2,",BFLAG=1
42 ..D ^DIK
43 I BFLAG=0 D
44 .S DELIVER=1 W !
45 .D ERCHK^PRCHMA1 K ERROR
46 .S DA(1)=PRCHPO,DA=PRCHI1 D EN12^PRCHAMXG
47 Q
48EN3 ;Line Item delete
49 N PRCHI,I442,I2Z,DIC,PRCHAREC,DIE,DR,DELIVER,%,%A,%B,PONUM,DIK
50 N PONOEXT,PODS,IENDS
51 D MV,MVDIS^PRCHMA3 S DA(1)=PRCHPO,DIC="^PRC(443.6,"_DA(1)_",2,",DIC(0)="AEQZ" D ^DIC
52 I Y<0 W !?5,"<NOTHING DELETED>" Q
53 S PRCHI=Y
54 I $P($G(^PRC(443.6,PRCHPO,2,+PRCHI,2)),U,8)>0 D Q
55 .W !?5,"CANNOT DELETE ITEM ",$P(PRCHI,U,2),", IT HAS ALREADY BEEN RECEIVED!",$C(7)
56 S %="",%A=" SURE YOU WANT TO DELETE LINE ITEM "_$P(PRCHI,U,2),%B=""
57 D ^PRCFYN I %'=1 W ?50,"<NOTHING DELETED>" Q
58 S I442=$G(^PRC(442,PRCHPO,2,+PRCHI,0)) I I442="" D Q
59 .S PONUM=$P(^PRC(443.6,PRCHPO,2,+PRCHI,0),U)
60 .K ^PRC(443.6,PRCHPO,2,"B",PONUM),^PRC(443.6,PRCHPO,2,"C",PONUM)
61 .I $P($G(^PRC(443.6,PRCHPO,2,+PRCHI,0)),U,5)]"" K ^PRC(443.6,PRCHPO,2,"AE",$P(^PRC(443.6,PRCHPO,2,+PRCHI,0),U,5))
62 .;
63 .;If item was added during amendment process then kill Item/Del. Sch.
64 .S PONOEXT=$P(^PRC(443.6,PRCHPO,0),U),PODS=0
65 .F S PODS=$O(^PRC(441.7,"AG",PONOEXT,+PRCHI,PODS)) Q:'PODS I $D(PODS) S DA=PODS,DIK="^PRC(441.7," D ^DIK
66 .;
67 .K ^PRC(443.6,PRCHPO,2,+PRCHI)
68 .S I2Z=^PRC(443.6,PRCHPO,2,0),$P(I2Z,U,4)=$P(I2Z,U,4)-1
69 .S ^PRC(443.6,PRCHPO,2,0)=I2Z
70 .S N=0 F I=1:1 S N=$O(^PRC(443.6,PRCHPO,2,N)) Q:'N D
71 ..S $P(^PRC(443.6,PRCHPO,2,N,0),U)=I
72 .K ^PRC(443.6,PRCHPO,2,"B"),^PRC(443.6,PRCHPO,2,"C")
73 .S DA(1)=PRCHPO,DIK(1)=".01^B^C"
74 .S DIK="^PRC(443.6,"_DA(1)_",2," D ENALL^DIK K N,I,DIK
75 .S J=$P(^PRC(443.6,PRCHPO,0),U,14)-1
76 .S $P(^PRC(443.6,PRCHPO,0),U,14)=J,$P(^(0),U,18)=J
77 .I $D(^PRC(443.6,PRCHPO,3)) D
78 ..S N=0 F S N=$O(^PRC(443.6,PRCHPO,3,N)) Q:'N S $P(^PRC(443.6,PRCHPO,3,N,0),U,6)=$P(^PRC(443.6,PRCHPO,3,N,0),U,6)-1
79 I $D(^PRC(443.6,PRCHPO,2,+PRCHI,2)),$P(^(2),U,6)>0 S PRCHAREC=1
80 ;
81 ;If item already exists then either mark or delete the Del. Sch.
82 I I442]"" D
83 .S PONOEXT=$P(^PRC(443.6,PRCHPO,0),U)
84 .S POSC=0
85 .F S POSC=$O(^PRC(441.7,"AG",PONOEXT,+PRCHI,POSC)) Q:'POSC D
86 . . S IENDS=$G(^PRC(441.7,POSC,0))
87 . . Q:IENDS=""
88 . . S PERM=+$P(IENDS,U,7)
89 . . I PERM>0 S DR="5////D",DIE="^PRC(441.7,",DA=POSC D ^DIE Q
90 . . I PERM'>0 K PRCHNORE S DIK="^PRC(441.7,",DA=POSC D ^DIK S PRCHNORE=1 Q
91 ;
92 S DR="5///0;2////0"
93 S DA(1)=PRCHPO,DA=+PRCHI
94 S DIE="^PRC(443.6,"_DA(1)_",2,"
95 D ^DIE K DIE
96 S DELIVER=1 W !
97 Q
98MV ;Move line item information from 442
99 Q:$D(^PRC(443.6,PRCHPO,2,0)) Q:$P($G(^(0)),U,4)>0 D WAIT^DICD
100 N %X,%Y,N,M,PRCHPO1,OK,PRCHNORE
101 S %X="^PRC(442,PRCHPO,2,",%Y="^PRC(443.6,PRCHPO,2," D %XY^%RCR
102 S $P(^PRC(443.6,PRCHPO,2,0),U,2)=$P(^DD(443.6,40,0),U,2) K ^("C")
103 S PRCHPO1=$P(^PRC(442,PRCHPO,0),"^")
104 Q:'$D(^PRC(442.8,"B",PRCHPO1)) Q:$D(^PRC(441.7,"B",PRCHPO1))
105 S N=0,M=+$P(^PRC(441.7,0),"^",3)
106 F S N=$O(^PRC(442.8,"B",PRCHPO1,N)) Q:'N D
107MV1 .S M=M+1,OK=$G(^PRC(441.7,M,0)) I OK'="" G MV1
108 .S ^PRC(441.7,M,0)=^PRC(442.8,N,0)
109 .S $P(^PRC(441.7,M,0),U,7)=N
110 .S $P(^PRC(441.7,0),"^",3)=M
111 .S $P(^PRC(441.7,0),"^",4)=$P(^(0),"^",4)+1
112 .S DIK="^PRC(441.7,",DA=M D IX^DIK K DIK,DA
113 .Q
114 Q
115ONLY ;Make sure only 'Cancel' amendment
116 S PRCHON=0
117 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)>2 D ERR Q
118 I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,0)),U,4)=2 D Q
119 .I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,3,2,0)),U,2)'=34 D ERR Q
120 .S PRCHON=1
121 S PRCHON=1
122 QUIT
123ERR ;Error
124 ;W !?5,"You can only "_$S($D(PRCHREQ):$P(^PRCD(442.2,15,0),U,2),1:$P(^PRCD(442.2,5,0),U,2))_" if this is the ONLY change you",!?5,"are making to the "_$S($D(PRCHREQ):"requisition.",1:"purchase order.")
125 W !?5,"To "_$S($D(PRCHREQ):$P(^PRCD(442.2,15,0),U,2),1:$P(^PRCD(442.2,5,0),U,2))_" it must be the ONLY change you",!?5,"are making on the amendment."
126 QUIT
127 ;
128SUPBOC(QUIETLY) ;compute pre-implied BOC, moved from template PRCHRQITEM, PRCHLINE into this routine and also called in BOC input transform
129 N PRCHIDA,SPFCP,PRCHBOCC,ACCT
130 S:$G(QUIETLY)=-1 X=$P($G(^PRC(443.6,DA(1),2,DA,0)),U,4)
131 Q:'$D(X)
132 S PRCHIDA=+$P($G(^PRC(443.6,DA(1),2,DA,0)),U,5),SPFCP=+$P(^PRC(443.6,DA(1),0),U,19)
133 I SPFCP=2 D
134 . S PRCHN("SFC")=SPFCP,ACCT=$$ACCT^PRCPUX1($E($$NSN^PRCPUX1(PRCHIDA),1,4))
135 . D ;:$D(ACCT)
136 . . S PRCHBOCC=$P($G(^PRCD(420.2,$S(ACCT=1:2697,ACCT=2:2698,ACCT=3:2699,ACCT=6:2699,ACCT=8:2696,1:2699),0)),U)
137 . . I PRCHBOCC S $P(^PRC(443.6,DA(1),2,DA,0),U,4)=PRCHBOCC D
138 . . . I PRCHBOCC'=X,PRCHBOCC W:'$G(QUIETLY) !,?5,"BOC must be ",PRCHBOCC,!,?5,"For a supply fund order, a BOC ",X," is invalid.",! S X=PRCHBOCC
139 Q X
140 ;
Note: See TracBrowser for help on using the repository browser.