source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPAGPR.m@ 810

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

initial load of WorldVistAEHR
File size: 5.0 KB
Line 
1PRCPAGPR ;WISC/RFJ/DXH - autogen primary or whse order (rep item list) ;9.28.99
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6 ;
7GETRIL() ; get repetitive item list
8 ; returns repetitive item list number
9 N %,CONTPT,COSTCNTR,COUNT,PRCPFLAG,PRCPREPN,PRCSFYT,PRCSQTT,X,Y
10 S COSTCNTR=$P($G(^PRCP(445,PRCP("I"),0)),"^",7) I 'COSTCNTR,PRCP("DPTYPE")="W" S COSTCNTR=+$$SUPPLYCC^PRCSCK()
11 I 'COSTCNTR W !!,"COST CENTER IS MISSING FOR THIS INVENTORY POINT." Q ""
12 W !!,"COST CENTER: ",COSTCNTR
13 ; get control points
14 S CONTPT=$$CONTPT(PRC("SITE"),PRCP("I"),COSTCNTR) I 'CONTPT Q ""
15 S PRC("CP")=$P($P($G(^PRC(420,PRC("SITE"),1,CONTPT,0)),"^")," ")
16 K PRC("FY") D FY^PRCSUT I PRC("FY")["^" Q ""
17 K PRC("QTR") D QT^PRCSUT I PRC("QTR")["^" Q ""
18 S PRCPREPN=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_PRC("CP")_"-"_COSTCNTR W !!,"I will generate requests for: ",PRCPREPN
19 S IOP="HOME" D ^%ZIS K IOP,^TMP($J,"PRCPAGPR")
20 S COUNT=1,X=PRCPREPN F S X=$O(^PRCS(410.3,"B",X)) Q:X=""!($P(X,"-",1,5)'=PRCPREPN)!($G(PRCPFLAG)) S Y=0 F S Y=$O(^PRCS(410.3,"B",X,Y)) Q:'Y!($G(PRCPFLAG)) D
21 . S %=$G(^PRCS(410.3,Y,0)) I %="" Q
22 . I $P(%,"^",3)'=PRCP("I") Q
23 . I COUNT=1 W !!,"You currently have the following repetitive item lists on file:"
24 . S COUNT=COUNT+1,^TMP($J,"PRCPAGPR",Y)=""
25 . W !?5,X,?35,"created: ",$E($P(%,"^",4),4,5),"-",$E($P(%,"^",4),6,7),"-",$E($P(%,"^",4),2,3),?60,"item count: ",+$P($G(^PRCS(410.3,Y,1,0)),"^",4)
26 . I COUNT#(IOSL-4)=0 D P^PRCPUREP
27 I $G(PRCPFLAG) K ^TMP($J,"PRCPAGPR") Q ""
28 I $O(^TMP($J,"PRCPAGPR",0)) D I $G(PRCPFLAG) K ^TMP($J,"PRCPAGPR") Q ""
29 . S XP="Do you want to DELETE all the repetitive item lists on file",XH="Enter 'YES' to delete ALL the repetitive item lists displayed above, 'NO' to",XH(1)="NOT delete them, '^' to exit."
30 . W ! S %=$$YN^PRCPUYN(2)
31 . I %=2 Q
32 . I %'=1 S PRCPFLAG=1 Q
33 . ; delete repetitive item lists on file
34 . W !," deleting repetitive item lists..."
35 . S COUNT=0 F S COUNT=$O(^TMP($J,"PRCPAGPR",COUNT)) Q:'COUNT D DELRIL(COUNT)
36 K ^TMP($J,"PRCPAGPR")
37 Q PRCPREPN
38 ;
39 ;
40CONTPT(V1,V2,V3) ; get control point tied to invpt
41 ; v1=station number
42 ; v2=inventory point da
43 ; v3=costcenter
44 N CONTPT,COUNT,DA,DIC,PRCPCC,PRCPINPT,PRCPSTAT,X,Y,Y1
45 S PRCPSTAT=+V1,PRCPINPT=+V2,PRCPCC=+V3
46 S PRCPINPT("E")=$$GET1^DIQ(445,PRCPINPT,.01)
47 S DIC("S")="I $D(^PRC(420,""C"",DUZ,PRCPSTAT,+Y)),$D(^PRC(420,""AE"",PRCPSTAT,PRCPINPT,+Y)),$S($P(^PRC(420,PRCPSTAT,1,+Y,0),U,12)=2:1,1:$D(^PRC(420,PRCPSTAT,1,+Y,2,PRCPCC,0)))"
48 ; look for control points that user has access to
49 S (COUNT,CONTPT,Y,Y1)=0 F S Y=$O(^PRC(420,"AE",PRCPSTAT,PRCPINPT,Y)) Q:'Y D
50 . S Y1=Y1+1,COUNT("PRCP",Y1)=$P(^PRC(420,PRCPSTAT,1,+Y,0),U)
51 . I $D(^PRC(420,"C",DUZ,PRCPSTAT,+Y)) S $P(COUNT("PRCP",Y1),U,2)=1
52 . I ($P(^PRC(420,PRCPSTAT,1,+Y,0),U,12)=2)!($D(^PRC(420,PRCPSTAT,1,+Y,2,PRCPCC,0))) S $P(COUNT("PRCP",Y1),U,3)=1
53 . Q:'$P(COUNT("PRCP",Y1),U,2)!('$P(COUNT("PRCP",Y1),U,3))
54 . S CONTPT=Y,COUNT=COUNT+1
55 I 'COUNT D Q ""
56 . I 'Y1 W !!,"No FUND CONTROL POINTS tied to INVENTORY POINT '"_PRCPINPT("E")_"'." Q
57 . I Y1=1 D Q
58 .. W !!,"FUND CONTROL POINT '"_$P(COUNT("PRCP",Y1),U)_"' is tied to INVENTORY POINT"
59 .. W !,"'"_PRCPINPT("E")_"', but "
60 .. I '$P(COUNT("PRCP",Y1),U,3) W "it does not include COST CENTER "_PRCPCC W $S('$P(COUNT("PRCP",Y1),U,2):" and",1:".") W:'$P(COUNT("PRCP",Y1),U,2) !
61 .. W:'$P(COUNT("PRCP",Y1),U,2) "you lack control point access." W " Can't proceed."
62 . W !!,"These FUND CONTROL PTS are tied to INVENTORY POINT '"_PRCPINPT("E")_"':"
63 . S Y1=0 F S Y1=$O(COUNT("PRCP",Y1)) Q:'Y1 W !,?2,$E($P(COUNT("PRCP",Y1),U),1,20),?25 W:'$P(COUNT("PRCP",Y1),U,2) "You lack access. " W:'$P(COUNT("PRCP",Y1),U,3) "COST CENTER "_PRCPCC_" is not included."
64 . W !,"Indicated deficiencies must be corrected before we can proceed."
65 I COUNT=1,CONTPT S Y=$P($G(^PRC(420,PRCPSTAT,1,CONTPT,0)),"^") I Y'="" W !!,"FUND CONTROL POINT: ",Y Q CONTPT
66 S DIC="^PRC(420,"_PRCPSTAT_",1,",DIC(0)="QEAM",DA=PRCPSTAT W ! D ^DIC
67 Q $S(Y'>0:0,1:+Y)
68 ;
69 ;
70DELRIL(V1) ; delete repetitive item list da=v1
71 I '$D(^PRCS(410.3,+V1,0)) Q
72 N DA,DIC,DIK
73 S DIK="^PRCS(410.3,",DA=+V1 D ^DIK Q
74 ;
75 ;
76NEWRIL(V1,V2) ; add a new repetitve item list
77 ; v1=invpt da
78 ; v2=number to add
79 ; returns da of entry added
80 N %,%DT,D0,DA,DI,DIC,DIE,DLAYGO,DQ,DR,INVPT,X,Y
81 S INVPT=V1,(PRCPREPN,X)=V2
82 D EN1^PRCUTL1(.X) I X="" Q ""
83 S DIC="^PRCS(410.3,",DIC(0)="L",DLAYGO=410.3,DIC("DR")="3////"_INVPT_";4///NOW" K DD,D0 D FILE^DICN
84 Q $S(Y'>0:0,1:Y)
85 ;
86 ;
87ADDITEM(V1,V2,V3,V4,V5) ; add items to repetitive item list
88 ; v1=repetitive item list da
89 ; v2=item master number
90 ; v3=qty
91 ; v4=vendor da
92 ; v5=cost
93 ; returns entry number
94 I '$D(^PRCS(410.3,+V1,0)) Q ""
95 I '$D(^PRCS(410.3,+V1,1,0)) S ^(0)="^410.31IPA^^"
96 I '$D(^PRC(441,+V2,0)) Q ""
97 I '$D(^PRC(441,+V2,2,0)) S ^(0)="^441.01IP^^"
98 N %,D0,DA,DD,DI,DIC,DIE,DLAYGO,DQ,DR,VENDOR,X,Y
99 S VENDOR=$P($G(^PRC(440,+V4,0)),"^")
100 S (DIC,DIE)="^PRCS(410.3,"_+V1_",1,",DIC(0)="L",DLAYGO=410.3,DA(1)=+V1,X=+V2,DIC("DR")="1////"_+V3_";2////"_VENDOR_";3////"_+V5_";4////"_+V4
101 D FILE^DICN
102 Q $S(Y'>0:0,1:+Y)
Note: See TracBrowser for help on using the repository browser.