source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHRPTX.m@ 1240

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

initial load of WorldVistAEHR
File size: 6.8 KB
Line 
1PRCHRPTX ;AAC/JDM-PRCH ITEM HISTORY BY DATE RANGE ; [1/13/99 11:13am]
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; <<<<<<<<<<<< Expected Variables In >>>>>>>>>>>>>
6 ; PRC("SITE")=Stn.# (Mandatory)
7 ; ITMNO;ITMNO=Item Master #
8 ; <<<<<<<<<<<< Other Variables Used >>>>>>>>>>>>>>
9 ; FR1 & TO1=Starting and ending FCP for sort
10 ; FR2 & TO2=Starting & ending Stn.# for sort (Set from PRC("SITE")
11 ; FR3 & TO3=Starting & ending Itm.# for sort (Set from ITMNO)
12 ; FR4 & TO4=Starting & ending PO Date for sort
13 ; ITMDESC=Set from file entry
14 ;
15EN ;DISPLAY ITEM HISTORY
16 ;
17XXLST S STN=PRC("SITE")
18 S ABORT=0
19 W !,"STN: ",STN
20 K DIR
21 S DIR(0)="S^ALL:ALL FCPs;RANGE:RANGE of FCPs;SPECIFIC:SPECIFIC FCP"
22 S DIR("A")="List Item Activity (by DATE RANGE) for"
23 S DIR("B")="ALL"
24 D ^DIR
25 I X["^"!($D(DTOUT)) G EXIT
26 S SCTL=X
27 I $E(X,1)="A"!($E(X,1)="a") D G XXITM
28 . S FR2=STN
29 . S TO2=STN
30 . S FR1=0
31 . S TO1="99999 ZZZ"
32 . Q
33 W !!,"START WITH FCP"
34 I $E(SCTL,1)="S"!($E(SCTL,1)="s") W " and END WITH FCP"
35 S DIC="^PRC(420,STN,1,"
36 S DIC(0)="QEAMNZ"
37 D ^DIC
38 I X="^" G EXIT
39 I Y'>0 W !,"INVALID SELECTION. TRY AGAIN ('^' TO ABORT)." G XXLST
40 S X=$P(Y,U,2)
41 S FR1=$P(X," ",1)
42 S FR2=STN
43 I $E(SCTL,1)="S"!($E(SCTL,1)="s") G XFCP
44 ;
45TOFCP W !!,"END WITH FCP"
46 D ^DIC
47 I Y'>0 W !,"INVALID SELECTION. TRY AGAIN ('^' TO ABORT)." G TOFCP
48 I X="^" G EXIT
49 ;
50XFCP S X=$P(Y,U,2)
51 S TO1=$P(X," ",1)
52 S TO2=STN
53 ;
54XXITM I $D(ITMNO) D G XXDT
55 . S FR3=ITMNO
56 . S TO3=ITMNO
57 . Q
58 S DIC="^PRC(441,"
59 S DIC(0)="QEAMNZ"
60 D ^DIC
61 I X="^" G EXIT
62 I Y'>0 W !,"INVALID SELECTION" G XXITM
63 S ITMNO=$P(Y(0),U,1)
64 S FR3=ITMNO
65 S TO3=ITMNO
66 ;
67XXDT S ITMDESC=$P(^PRC(441,ITMNO,0),U,2)
68 D NOW^%DTC
69 D YX^%DTC
70 S DTX=$P(Y,"@",1)
71 S DTX="JAN 1,"_$P(DTX,",",2)
72 K DIR
73 S DIR(0)="D"
74 S DIR("A")="DATE ORDERED (BEGIN RANGE)"
75 S DIR("B")=DTX
76 D ^DIR
77 I $D(DTOUT)!(X["^") G EXIT
78 D ^%DT
79 S FR4=Y
80 K DIR
81 S DIR(0)="D"
82 S DIR("A")="DATE ORDERED (END RANGE) "
83 S DIR("B")="TODAY"
84 D ^DIR
85 I $D(DTOUT)!(X["^") G EXIT
86 D ^%DT
87 S TO4=Y
88 ;
89 S NX=0
90 ;
91 S ZTSAVE("FR1")=""
92 S ZTSAVE("FR2")=""
93 S ZTSAVE("FR3")=""
94 S ZTSAVE("FR4")=""
95 S ZTSAVE("TO1")=""
96 S ZTSAVE("TO2")=""
97 S ZTSAVE("TO3")=""
98 S ZTSAVE("TO4")=""
99 S ZTSAVE("ITMNO")=""
100 S ZTSAVE("ITMDESC")=""
101 D EN^XUTMDEVQ("LOOPPD^PRCHRPTX","ITEM HISTORY Report by Date Range",.ZTSAVE,.%ZIS)
102 I '$D(ZTSK) W ! G EXIT
103 K ZTSK
104 Q
105 ;
106LOOPPD ; Set up to locate records to display.
107 N FCPS,FCPE,STN,DATES,DATET,LNCT,ABORT,NX,SITFCPS,SITFCPE
108 N FCP,COUNT,HDR,PG
109 S PG=0
110 S FCPS=FR1
111 S FCPE=TO1
112 S STN=FR2
113 S ITMNO=FR3
114 S DATES=FR4
115 S DATET=TO4
116 S ABORT=0
117 S NX=0
118 S SITFCPS=STN_FCPS
119 S SITFCPE=STN_FCPE
120 ;
121LOOPPD1 ; Loop through file 441.
122 ;
123 ; 1. Loop through Fund Control Point for PRC("SITE")
124 ; within one Item Master File Number.
125 ; 2. Loop through P.O. DATE (in reverse order).
126 ; 3. Loop through a single P.O. DATE to get file 442 PO NUMBER.
127 ;
128 ; These three nested loops will locate Purchase Orders to display.
129 ;
130 S FCP=0
131 S COUNT=0
132 ;
133 ; Get FCP.
134 ;
135 F S FCP=$O(^PRC(441,ITMNO,4,"B",FCP)) Q:FCP'>0 D Q:ABORT=1
136 . Q:STN'=$E(FCP,1,$L(STN))
137 . Q:FCPS>0&((FCP<SITFCPS)!(FCP>SITFCPE))
138 . ;
139 . ; Because DATE in "AC" x-reference is in reverse order(latest
140 . ; date first) the search must start after TO4, the ending PO date.
141 . ;
142 . S DATE=(9999999-DATET)-1
143 . S NODATE=0
144 . ;
145 . ; Starting a new FCP. Force listing a header.
146 . ;
147 . K HDR
148 . ;
149 . ; Get DATE.
150 . ;
151 . F D Q:NODATE=1 Q:ABORT=1
152 . . S DATE=$O(^PRC(441,ITMNO,4,FCP,1,"AC",DATE))
153 . . I DATE'>0 S NODATE=1 Q
154 . . S CKDATE=9999999-DATE
155 . . ;
156 . . ; See if date found is before FR4 (starting date).
157 . . ; If true, there will be no more dates between FR4 and TO4.
158 . . ; Set the flag to stop this loop through "AC".
159 . . ;
160 . . I CKDATE<DATES S NODATE=1 Q
161 . . ;
162 . . ; If the date found is after TO4 (ending date) there may be
163 . . ; some dates between FR4 and TO4.
164 . . ;
165 . . Q:CKDATE>DATET
166 . . S PO=0
167 . . ;
168 . . ; Get PO NUMBER (may be more than one per DATE).
169 . . ;
170 . . F S PO=$O(^PRC(441,ITMNO,4,FCP,1,"AC",DATE,PO)) Q:PO'>0 D Q:ABORT=1
171 . . . S POCK=$G(^PRC(442,PO,0))
172 . . . Q:POCK']""
173 . . . S COUNT=COUNT+1
174 . . . D DISP
175 . . . Q
176 . . Q
177 . Q
178 Q
179 ;
180DISP S LX=$O(^PRC(442,PO,2,"AE",ITMNO,0))
181 Q:LX'>0
182 S LXN0(LX)=$G(^PRC(442,PO,2,LX,0))
183 S LXN2(LX)=$G(^PRC(442,PO,2,LX,2))
184 S ND0=$G(^PRC(442,PO,0))
185 S ND1=$G(^PRC(442,PO,1))
186 S PONUM=$P(ND0,U,1)
187 S PODTX=$P(ND1,U,15)
188 S FCPX=$P(ND0,U,3)
189 S VP=$P(ND1,U,1)
190 S IMFX=$P(LXN0(LX),U,5)
191 S QTY=$P(LXN0(LX),U,2)
192 S UIP=$P(LXN0(LX),U,3)
193 S ACST=$P(LXN0(LX),U,9)
194 S QPR=+$P(LXN2(LX),U,8)
195 S TCST=$P(LXN2(LX),U,1)
196 S STNX=$P(PONUM,"-",1)
197 S FCPX=$P(FCPX," ",1)
198 S MAXL=IOSL-4
199 I '$D(LNCT) D Q:ABORT=1
200 . S LNCT=0
201 . D HDR
202 . S HDR=1
203 . Q
204 I '$D(HDR)&(LNCT>9) D Q:ABORT=1
205 . S HDR=1
206 . S LCNT=1
207 . D HDR
208 . Q
209 S LNCT=LNCT+3
210 D:LNCT>MAXL HDR
211 S X=PODTX
212 D H^%DTC
213 D YX^%DTC
214 S PODT=Y
215 S UIPX=" "
216 S VNDX=" "
217 S:UIP'="" UIPX=$P(^PRCD(420.5,UIP,0),U,1)
218 S:VP'=""&(VP'=0) VNDX=$P(^PRC(440,VP,0),U,1)
219 S:ACST'["." ACST=ACST_".00"
220 S:TCST'["." TCST=TCST_".00"
221 S ACL=$L(ACST)
222 S TCL=$L(TCST)
223 S ACS2=$P(ACST,".",2)
224 S TCS2=$P(TCST,".",2)
225 F M=1:1:2 D
226 . S ACS2=ACS2_$E("00",1,2-$L(ACS2))
227 . S TCS2=TCS2_$E("00",1,2-$L(TCS2))
228 . Q
229 S ACST=$P(ACST,".",1)_"."_ACS2
230 S TCST=$P(TCST,".",1)_"."_TCS2
231 S SP9=" "
232 F M=1:1:9 D
233 . S ACST=$E(SP9,1,9-$L(ACST))_ACST
234 . S TCST=$E(SP9,1,9-$L(TCST))_TCST
235 . S QTY=$E(SP9,1,9-$L(QTY))_QTY
236 . S QPR=$E(SP9,1,9-$L(QPR))_QPR
237 . Q
238 I ABORT=0 D
239 . W !!,PODT,?15,PONUM,?26,QPR,?38,UIPX,?48,ACST,?59,TCST,?70,QTY,!,VNDX
240 . S STATX=$P($G(^PRC(442,PO,7)),U,1)
241 . W:STATX=45 ?50,"Order Status=CANCELLED"
242 . Q
243 Q
244 ;
245MOFCP K DIR
246 S DIR(0)="Y"
247 S DIR("A")="Would you like to do another FCP Date-Range Listing for this item"
248 S DIR("B")="NO"
249 D ^DIR
250 I $D(DTOUT)!(X["^")!(X["N")!(X="n") G EXIT
251 G XXLST
252 ;
253EXIT K CST,P2,ABORT
254 D Q^PRCHRPT1
255 G EN^PRCHRPT1
256 ;
257CALCCST ; EP -- CALCULATES ACTUAL UNIT COST TO 2 DECIMALS
258 S CST=$P(X,U,9)
259 I CST'["." S CST=CST_"."
260 S P2=$P(CST,".",2)
261 I $L(P2)=0 S P2="00"
262 I $L(P2)=1 S P2=P2_"0"
263 I $L(P2)>2&($E(P2,3)>4) S $E(P2,2)=$E(P2,2)+1
264 I $L(P2)>2 S P2=$E(P2,1,2)
265 S CST=$P(CST,".",1)_"."_P2
266 F J=1:1:10 I $L(CST)<10 S CST=" "_CST
267 W CST
268 Q
269 ;
270HDR I $E(IOST)="C"&(LNCT'=0) W ! D PAUSE Q:ABORT=1
271 S FCPD=FCPX
272 S PG=PG+1
273 S:FCPX>0 FCPD=$P(ND0,U,3)
274 W @IOF,!!,"Item Number: ",ITMNO,?25,"Description: "
275 W ITMDESC,?71,"Page ",PG
276 W !?7,"SITE: ",STN,?25,"FCP: ",FCPD,!!,?26,"Quantity"
277 W !,?26,"Previously",?38,"Unit of",?71,"Quantity"
278 W !,"Date Ordered",?15,"PO Number",?26,"Received",?38,"Purchase"
279 W ?48,"Unit Cost",?59,"Total Cost",?71,"Ordered",!
280 F I=1:1:80 W "_"
281 S LNCT=9
282 Q
283 ;
284PAUSE ; Test for prompt to return or exit
285 K DIR
286 S ABORT=0
287 S DIR(0)="E"
288 D ^DIR
289 I Y=""!(Y=0) S ABORT=1
290 Q
291 ;
292ASK Q:$E(IOST)="P"
293 W !!,"Press RETURN to continue"
294 R X:DTIME
295 S ASK=1
296 Q
Note: See TracBrowser for help on using the repository browser.