source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHEA.m@ 724

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

initial load of WorldVistAEHR

File size: 4.1 KB
Line 
1PRCHEA ;WOIFO/ID/RSD,SF-ISC/TKW-EDIT ROUTINES FOR SUPPLY SYSTEM ;3/5/98 11:05 AM
2V ;;5.1;IFCAP;**81**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EN3 ;ADD A REQUISITION
5 ;
6 ;Variables PRCHNRQ and PRCHZZZ9 are flags stating that this is a
7 ;REQUESITION.
8 ;
9 N PRCHP,PRCHZZZ9
10 D ST
11EN30 S (PRCHNRQ,PRCHZZZ9)=1,PRCHP("A")="REQUISITION NUMBER",PRCHP("T")=8,PRCHP("S")=1 D EN^PRCHPAT I '$D(PRCHPO) K PRCHNRQ Q
12 D LCK1 G:'$D(DA) EN30 S X=1,DA=PRCHPO D ENS^PRCHSTAT
13 S Z=$P(^PRC(442,PRCHPO,0),"-",2),$P(^PRC(442,PRCHPO,18),"^",3)=$S($E(Z):$E(Z,2,6),1:$E(Z)_$E(Z,3,6))
14 D ^PRCHNPO L
15 G EN30
16 ;
17EN4 ;EDIT A REQUISITION
18 ;
19 ;Variables PRCHNREQ and PRCHZZZ9 are flags stating that this is a
20 ;REQUESITION.
21 ;
22 N PRCHP,PRCHZZZ9
23 D ST
24EN40 S (PRCHNRQ,PRCHZZZ9)=1,PRCHP("A")="REQUISTION NUMBER: "
25 S PRCHP("S")="$P($G(^(7)),U,2)<9,($P(^(0),U,2)=5!($P(^(0),U,2)=8)!($P(^(0),U,2)=25)!($P(^(0),U,2)=26))"
26 S:$G(PRCHPC) PRCHP("S")="$P($G(^(7)),U,2)<9,$P($G(^(1)),U,10)=DUZ,$P(^(0),U,2)=25"
27 D EN3^PRCHPAT I '$D(PRCHPO) K PRCHNRQ Q
28 I 'X W " ??",$C(7) G EN40
29 D LCK1 G:'$D(DA) EN40 D ^PRCHNPO L
30 G EN40
31 ;
32EN5 ;EDIT BOC IN ITEM FILE
33 S DIC="^PRC(441,",DIC(0)="AEMQ",DR=12 D ^DIC G:Y<0 Q S DA=+Y W ! F I=0:0 S I=$O(^PRC(441,DA,1,I)) Q:'I W !?3,^(I,0)
34 W ! S DIE=DIC D ^DIE,Q W !
35 G EN5
36 ;
37EN6 ;AMENDMENTS
38 N PRCHP S PRCHFLG=0 D ST
39EN60 K PRCHP Q:'$D(PRC("SITE")) S PRCHP("S")="$P($G(^(7)),U,2)>19,(453328'[$P($G(^(7)),U,2)),($P(^(0),U,2)"
40 S:'$D(PRCHNRQ) PRCHP("S")=PRCHP("S")_"<8)" S:$D(PRCHNRQ) PRCHP("A")="REQUISITION NO.: ",PRCHP("S")=PRCHP("S")_"=8"
41 S PRCHFLG=1 D EN3^PRCHPAT Q:'$D(PRCHPO)
42 ;I X=28!(X=33) W $C(7),!,"Amendments not allowed until after order has been Obligated!!" G EN60
43 I 'X W $C(7)," ??" G EN60
44 D ^PRCHAM
45 G EN60
46 ;
47EN7 ;CANCEL UNOBLIGATED PO
48 N PRCHP D ST
49EN70 Q:'$D(PRC("SITE")) S PRCHP("S")="$P($G(^(7)),U,2)<9,($P(^(0),U,2)"
50 S:'$D(PRCHNRQ) PRCHP("S")=PRCHP("S")_"<8!($P(^(0),U,2)>24))"
51 S:$D(PRCHNRQ) PRCHP("A")="REQUISITION NO.: ",PRCHP("S")=PRCHP("S")_"=8)" S:$D(PRCHIMP) PRCHP("A")="IMPREST FUND P.O.NO.: ",PRCHP("S")="($P($G(^(7)),U,2)<9!($P($G(^(7)),U,2)=22))&($P(^(0),U,2)=7)"
52 D EN3^PRCHPAT Q:'$D(PRCHPO) I 'X W $C(7)," ??" G EN70
53 I $P(^PRC(442,PRCHPO,0),U,12) W $C(7),!!,"WARNING--2237 HAS NOT BEEN REMOVED FROM THIS ORDER!!" G EN70
54 D LCK1 G:'$D(DA) EN70 S %A=" SURE YOU WANT TO CANCEL PURCHASE ORDER ",%B="",%="" D ^PRCFYN I %'=1 W ?40," <NOTHING CANCELLED>",$C(7) G EN70
55 S X=$O(^PRCD(442.3,"C",45,0)),$P(^PRC(442,PRCHPO,0),U,15,16)="0^0" K ^(9) S (X,Y)=45,DA=PRCHPO D UPD^PRCHSTAT
56 ; PRC*5.1*81 - if site runs DynaMed, may need to build update txn
57 I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 D DEL^PRCV442A(PRCHPO)
58 G EN70
59 ;
60EN8 ;GRAB A PO NUMBER
61 D ST
62EN80 Q:'$D(PRC("SITE")) K PRCHX W !!,"How many Purchase Order numbers do you want: " R X:DTIME Q:X["^" I X'=+X!(X<1)!(X>5)!'(X?1N) W " ??",$C(7),!,"Enter a number between 1 and 5." G EN80
63 S PRCHX=X,DIC="^PRC(442.6,",DIC(0)="QEAMZ",DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),($P(^(0),U,5)=2!($P(^(0),U,5)="""")!($P(^(0),U,5)=6)!($P(^(0),U,5)=7))",D="C" D IX^DIC I Y<0 K DIC Q
64 S DA=+Y D LCK K DIC G:'$D(DA) EN80 D WAIT^DICD S PRCHY=Y,PRCHY(0)=Y(0) F PRCHI=1:1:PRCHX D EN81
65 L W !,"Here is your Purchase Order Numbers: " F I=0:0 S I=$O(PRCHX(I)) Q:'I W !?37,PRCHX(I)
66 R !!,"Press RETURN to continue",X:DTIME K DIC,DA,PRCHX,PRCHY,Z Q
67EN81 S X=$P(PRCHY,U,2),Z=$S(+$P(PRCHY(0),U,4)<$P(PRCHY(0),U,2):+$P(PRCHY(0),U,2),1:+$P(PRCHY(0),U,4)),L=$L(X)#2-3
68EN82 I Z>$P(PRCHY(0),U,3) L W !?3,"UPPER BOUND HAS BEEN EXCEEDED FOR COMMON NUMBERING SERIES ",$P(PRCHY,U,2),$C(7) S PRCHI=PRCHX+1 Q
69 S Z="000"_Z,Z=$E(Z,$L(Z)+L,$L(Z)),X=X_Z I $D(^PRC(442,"B",X)) S Z=Z+1,X=$P(PRCHY,U,2) G EN82
70 S $P(^PRC(442.6,+PRCHY,0),U,4)=+Z,DIC(0)="L",DIC="^PRC(442,",DLAYGO=442 D ^DIC L ^PRC(442.6,+PRCHY):5 G EN82:Y<0!'(+$P(Y,U,3)) E S PRCHI=PRCHX+1 Q
71 S PRCHX(PRCHI)=$P(Y,U,2) D NOW^%DTC S $P(^PRC(442,+Y,12),U,4,5)=DUZ_U_X S DA=+Y,(X,Y)=1 D UPD^PRCHSTAT
72 Q
73 ;
74Q K DIC,DIE,DR,DA,PRCHREAV,PRCHX,PRCHY L W !
75 Q
76 ;
77LCK1 S DIC="^PRC(442,"
78 ;
79LCK L @(DIC_DA_"):0") E W !,$C(7),"ANOTHER USER IS EDITING THIS ENTRY!" K DA
80 Q
81 ;
82ST S PRCF("X")="S" D ^PRCFSITE
83 Q
Note: See TracBrowser for help on using the repository browser.