source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSUT.m@ 634

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

initial load of WorldVistAEHR
File size: 7.1 KB
RevLine 
[613]1PRCSUT ;WISC/SAW/DGL-CONTROL POINT ACTIVITY UTILITY PROGRAM ;9/14/00 15:49
2V ;;5.1;IFCAP;**93**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5ENF(PRCIPFLG) ;Entry point for Inv. Pt. selection
6EN ;STA,FY,QTR,CP W/SCREEN FOR INACTIVE CP
7 I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0
8 D STA G EX:'SI!(Y<0)
9 D FY G EX:PRC("FY")="^"
10 D QT G EX:PRC("QTR")="^"
11 S DIC("S")="I '$P(^(0),""^"",19),$D(^PRC(420,""A"",DUZ,PRC(""SITE""),+Y,1))!($D(^(2)))"
12 I $D(PRCSC),PRCSC D CPF^PRCSUT1(PRCIPFLG)
13 I '$D(PRCSC) D CPF(PRCIPFLG)
14 G EX:'SI!(Y<0)
15 G:'$$BBFY(PRC("SITE"),PRC("FY"),PRC("CP")) EX
16 G EN11
17 ;
18EN1F(PRCIPFLG) ; Entry point for Inv. Pt. selection
19EN1 ;STA,FY,QTR,CP
20 I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0
21 D STA G EX:'SI!(Y<0)
22 D FY G EX:PRC("FY")="^"
23 D QT G EX:PRC("QTR")="^"
24 I $D(PRCSC),PRCSC D CPF^PRCSUT1(PRCIPFLG)
25 I '$D(PRCSC) D CPF(PRCIPFLG)
26 G EX:'SI!(Y<0)
27 G:'$$BBFY(PRC("SITE"),PRC("FY"),PRC("CP")) EX
28EN11 S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
29 S X=$P(Z,"-",1,2)_"-"_$P(PRC("CP")," ")
30 G EXIT
31 ;
32EN2 ;STA,FY,QTR
33 D STA G EX:'SI!(Y<0)
34 D FY G EX:PRC("FY")="^"
35 D QT G EX:PRC("QTR")="^"
36 G EXIT
37 ;
38EN3F(PRCIPFLG) ; Entry point for Inv. Pt. selection
39EN3 ;STA,CP
40 I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0
41 D STA G EX:'SI!(Y<0)
42 I $D(PRCSC),PRCSC D CPF^PRCSUT1(PRCIPFLG)
43 D:'$D(PRCSC) CPF(PRCIPFLG)
44 G EX:'SI!(Y<0)
45 G EXIT
46 ;
47EN4 ;STA,FY,QTR,CC
48 D STA G EX:'SI!(Y<0)
49 D FY G EX:PRC("FY")="^"
50 D QT G EX:PRC("QTR")="^"
51 D CC
52 G EXIT
53 ;
54EN5 ;STA,FY,QTR,BOC
55 D STA G EX:'SI!(Y<0)
56 D FY G EX:PRC("FY")="^"
57 D QT G EX:PRC("QTR")="^"
58 D SUB
59 G EXIT
60 ;
61EN6F(PRCIPFLG) ; Entry point for Inv. Pt. selection
62EN6 ;STA,CP,FY
63 I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0
64 D STA G EX:'SI!(Y<0)
65 I $D(PRCSC),PRCSC D CPF^PRCSUT1(PRCIPFLG)
66 I '$D(PRCSC) D CPF(PRCIPFLG)
67 G EX:'SI!(Y<0)
68 D FY G EX:PRC("FY")="^"
69 G EXIT
70 ;
71 ;PRCSST is flag to not ask substation
72 ;PRCSK is flag to allow selection of any station
73STA ;SELECT STATION NUMBER
74 S N="",Y=0
75 I $D(PRCSK) S SI=2 ; if privilege flag is set, ask STATION
76 ; else restrict station selection to user's authorized stations
77 E F SI=0:1:2 S N=$O(^PRC(420,"A",DUZ,N)) Q:N'>0 S N(1)=N
78 Q:'SI ; user not allowed to access any station
79 I SI>1 D
80 . S DIC="^PRC(420,",DIC(0)="AEMQ",DIC("A")="Select STATION NUMBER: "
81 . I '$D(PRCSK) S DIC("S")="I $D(^PRC(420,""A"",DUZ,+Y))"
82 . I $D(PRC("SITE")) S DIC("B")=PRC("SITE")
83 . S D="B^C"
84 . D MIX^DIC1 I Y>0 S PRC("SITE")=+Y
85 I SI=1 S PRC("SITE")=N(1)
86 I '$D(PRC("SITE")) S PRC("SITE")="",PRC("SST")=""
87 I PRC("SITE")=""!(Y<0) K DIC,N Q
88 ; substation
89 I '$D(PRC("SST"))!'$D(^PRC(411,"UP",+PRC("SITE"))) S PRC("SST")=""
90 I '$G(PRCSST),$D(^PRC(411,"UP",+PRC("SITE"))) D
91 . S DIC("B")=PRC("SST")
92 . S DIC="^PRC(411,",DIC(0)="AEQZ",DIC("A")="Select SUBSTATION: "
93 . S DIC("S")="I $E($G(^PRC(411,+Y,0)),1,3)=PRC(""SITE"")"
94 . D ^DIC I Y>0 S PRC("SST")=+Y
95 K DIC,N
96 Q
97 ;
98FY ;SELECT FISCAL YEAR
99 D:'$D(DT) DT^DICRW
100 S FYT=$E(100+$E(DT,2,3)+$E(DT,4),2,3),PRC("FY")=FYT
101 W !,"Select FISCAL YEAR: ",FYT,"// " R PRC("FY"):DTIME
102 S:'$T PRC("FY")=U
103 S:PRC("FY")="" PRC("FY")=FYT
104 Q:PRC("FY")="^"
105 I PRC("FY")'?2N W $C(7),!,"Enter a two digit fiscal year (e.g., 87).",! G FY
106 Q
107 ;
108QT ;SELECT QUARTER
109 D:'$D(DT) DT^DICRW
110 I '$D(QTT) S:$D(PRC("QTR")) QTT=PRC("QTR") I '$D(QTT) S SI=$E(DT,4,5),QTT=$P("2^2^2^3^3^3^4^4^4^1^1^1","^",SI)
111 W !,"Select QUARTER: ",QTT,"// " R PRC("QTR"):DTIME
112 S:'$T PRC("QTR")=U
113 S:PRC("QTR")="" PRC("QTR")=QTT
114 Q:PRC("QTR")=U
115 I PRC("QTR")<1!(PRC("QTR")>4)!(PRC("QTR")'?1N) W $C(7),!,"Enter a single digit number from 1 to 4.",! G QT
116 Q
117 ;
118CPF(PRCIPFLG) ; Entry point for inv. pt. selection
119CP ;SELECT CONTROL POINT
120 N FCPDA
121 K PRCSIP ; inventory distribution point variable
122 I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0
123 S FCPDA=$O(^PRC(420,"A",DUZ,PRC("SITE"),0)) Q:'FCPDA ; no fcps
124 I '$O(^PRC(420,"A",DUZ,PRC("SITE"),FCPDA)) D Q ; access to 1 fcp
125 . S PRC("CP")=$P($G(^PRC(420,PRC("SITE"),1,FCPDA,0)),U)
126 . I PRC("CP"),PRCIPFLG D IP
127 ; more than one fcp
128 S DIC="^PRC(420,"_PRC("SITE")_",1,"
129 S DIC(0)="AEMNQZ",DIC("A")="Select CONTROL POINT: "
130 I '$D(DIC("S")) S DIC("S")="I '$P(^(0),""^"",19),$D(^PRC(420,""A"",DUZ,PRC(""SITE""),+Y,1))!($D(^(2)))"
131 I $D(PRC("CP")),PRC("CP"),$D(^PRC(420,PRC("SITE"),1,PRC("CP"))) S DIC("B")=+PRC("CP")
132 S D="B^C" D MIX^DIC1 S:Y<0 PRC("CP")="^"
133 I Y>0 S PRC("CP")=$P(Y(0),"^") I PRCIPFLG=1 D IP
134 K DIC
135 Q
136 ;
137 ;A=station #, B=fiscal year, C=fcp #, PRCA=1 if no user interactive
138BBFY(A,B,C,PRCA) ;extrinsic function of beginning budget fiscal year
139 N D,E,F,X,Y
140 K PRC("BBFY")
141 S E=$G(^PRC(420,A,1,+C,5))
142 I $P(E,"^")]"" S F=$O(^PRCD(420.3,"B",$P(E,"^"),"")) I F I $P(^PRCD(420.3,F,0),"^",8)="Y" S PRC("BBFY")=+$$DATE^PRC0C($P(E,"^",8),"I") QUIT PRC("BBFY")
143 S B=+$$YEAR^PRC0C(B)
144 S D=$$APP^PRC0C(A,$E(B,3,4),C)
145 I $P(D,"^")'["_/_" S PRC("BBFY")=B QUIT PRC("BBFY")
146 S F=$$BBFY^PRC0D(A,C,'$G(PRCA))
147 I F="",$G(PRCA)=1 S PRC("BBFY")=B QUIT PRC("BBFY")
148 I $G(PRCA)=1 S PRC("BBFY")=B-(B-$P(F,"~",2)#$P(F,"~",3)) QUIT PRC("BBFY")
149BBFY1 S E="^2:4^K:X'?2N&(X'?4N) X I $G(X)]"""" S X=+$$YEAR^PRC0C(X) K:X-$P(F,""~"",2)#$P(F,""~"",3) X"
150 S Y(1)="Enter a 2 or 4 digit year."
151 D FT^PRC0A(.X,.Y,"First Year of the Multi-Appropriation ("_$P(D,"^")_")",E,$S(F="":B,1:B-(B-$P(F,"~",2)#$P(F,"~",3))))
152 I Y?2.4N S Y=+$$YEAR^PRC0C(Y) I B<Y!(Y+$P(F,"~",3)-1<B) D EN^DDIOL("You must enter a BBFY such that the document's fiscal year is between"),EN^DDIOL("beginning and ending budget fiscal years") G BBFY1
153 S PRC("BBFY")=$S(Y?4N:Y,1:"")
154 QUIT PRC("BBFY")
155 ;
156CC ;SELECT COST CENTER
157 S DIC="^PRCD(420.1,",DIC(0)="AEMNQZ"
158 D ^DIC Q:Y<0
159 S PRCS("CC")=$P(Y(0),"^")
160 Q
161 ;
162SUB ;SELECT BOC
163 S DIC="^PRCD(420.2,",DIC(0)="AEMNQZ"
164 D ^DIC Q:Y<0
165 S PRCS("SUB")=$P(Y(0),"^")
166 Q
167 ;
168LOCK ;LOCK GLOBAL THAT IS BEING ACCESSED BY ANOTHER USER
169 L @("+"_DIC_DA_"):15")
170 S PRCSL=$T
171 W:$T=0 !!,$C(7),"Sorry, record is being accessed by another user. Please try later."
172 Q
173 ;
174EX S Y=-1
175 K PRC("QTR"),PRC("FY"),PRC("BBFY"),SI
176 I $D(PRC("CP")) K:PRC("CP")="ALL"!(PRC("CP")="^") PRC("CP")
177EXIT K FYT,SI,PRCSK,QTT,DIC("A")
178 Q
179 ;
180NSCRNF(PRCIPFLG) ; Entry point for Inv. Pt. selection
181NSCRN ;STA,FY,QTR,CP
182 I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0
183 D STA G EX:'SI!(Y<0)
184 D FY G EX:PRC("FY")="^"
185 D QT G EX:PRC("QTR")="^"
186 S PRCSC=4 D CPF^PRCSUT1(PRCIPFLG)
187 I '$D(PRCSC) D CPF(PRCIPFLG)
188 G EX:'SI!(Y<0)
189 G:'$$BBFY(PRC("SITE"),PRC("FY"),PRC("CP")) EX
190 QUIT
191 ;
192IP ; Get Inventory point
193 Q:'$D(PRC("SITE"))!('$D(PRC("CP")))
194 N CTR,I
195 K ^TMP($J,"PRCSUT")
196 S (CTR,I)=0,PRCSIP=""
197 F S I=$O(^PRC(420,"AF",PRC("SITE"),+PRC("CP"),I)) Q:'I S CTR=CTR+1,^TMP($J,"PRCSUT",CTR)=I_"^"_$P(^PRCP(445,I,0),"^")
198 I CTR=0 G IPQ
199 I CTR=1 S PRCSIP=$P(^TMP($J,"PRCSUT",1),"^") G IPQ
200 F I=1:1:CTR D Q:$D(DIRUT)
201 . W !,?5,I,") ",$P(^TMP($J,"PRCSUT",I),"^",2)
202 . I I#(IOSL-2)=0 K DIR S DIR(0)="E" D ^DIR
203 S DIR(0)="NO^1:"_CTR_":0"
204 S DIR("A")="Select INVENTORY POINT"
205 S DIR("?",1)="Enter a number from 1 to "_CTR_" to select the displayed"
206 S DIR("?")="Inventory Point. This is an optional response."
207 D ^DIR K DIR
208 I Y>0 S PRCSIP=$P(^TMP($J,"PRCSUT",Y),"^") W " ",$P(^TMP($J,"PRCSUT",Y),"^",2),!
209IPQ K ^TMP($J,"PRCSUT")
210 Q
Note: See TracBrowser for help on using the repository browser.