source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPLO2A.m@ 636

Last change on this file since 636 was 636, checked in by George Lilly, 14 years ago

WorldVistAEHR overlayed on FOIAVistA
File size: 8.9 KB
Line 
1PRCPLO2A ;WOIFO/DAP-stock status report (cont) ; 1/26/06 12:00pm
2V ;;5.1;IFCAP;**83,98**;Oct 20, 2000;Build 37
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5ENT ;*83 Building ^TMP with total result data, totaling logic pulled from PRCPRSS0
6 N PRCPIN,PRCPIN1,PRCPIN2,PRCPIN3,TOTVAL,TOTCLOS,TOTCLO1,TOTCLO2,SSRIEN
7 S U="^",STA=PRC("SITE"),INV=PRCP("I")
8 ;
9SSR1 ;*98 First Stock Status Report data field set
10 ;
11 S $P(^TMP($J,"PRCPSSR1",STA,INV),U,1)=STA ;Station #
12 S DATRN=$$FMTE^XLFDT(DATESTRT)
13 S DATRN1=$P(DATRN," ",1)_","_$P(DATRN," ",2)
14 S $P(^TMP($J,"PRCPSSR1",STA,INV),U,2)=DATRN1 ;Date Range
15 S $P(^TMP($J,"PRCPSSR1",STA,INV),U,3)=INARNG ;Inactivity Range
16 S $P(^TMP($J,"PRCPSSR1",STA,INV),U,4)=INV ;Inventory Point #
17 ;*83 Retrieve external inventory point name and primary/secondary/
18 ;warehouse indicator
19 S PRCPIN=$G(^PRCP(445,INV,0))
20 I PRCPIN'="" S PRCPIN1=$P(PRCPIN,"^",1),PRCPIN2=$P(PRCPIN1,"-",2,99)
21 I PRCPIN'="" S PRCPIN3=$P(PRCPIN,"^",3)
22 I PRCPIN="" S PRCPIN2="",PRCPIN3=""
23 S PRCPIN2=$TR(PRCPIN2,"*","|") ; Needed due to "*" delimiter
24 S $P(^TMP($J,"PRCPSSR1",STA,INV),U,5)=PRCPIN2 ;Inventory Point Name
25 S $P(^TMP($J,"PRCPSSR1",STA,INV),U,6)=PRCPIN3 ;P/S/W Indicator
26 ;
27 S PRCPDX=$TR(^TMP($J,"PRCPSSR1",STA,INV),"^","*"),DR="3///"_PRCPDX
28 D FILE
29 ;
30SSR2 ;*98 Second Stock Status Report data field set
31 ;
32 S TOTOPEN=0 F ACCT=1,2,3,6,8 S %=$P($G(^TMP($J,1,"OPEN",ACCT)),U,2),TOTOPEN=TOTOPEN+%
33 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,1)=TOTOPEN ;Std. Open Balance Total $
34 S TOTOPEN=0 F ACCT=1,2,3,6,8 S %=$P($G(^TMP($J,2,"OPEN",ACCT)),U,2),TOTOPEN=TOTOPEN+%
35 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,2)=TOTOPEN ;ODI Open Balance Total $
36 S TOTOPEN=0 F ACCT=1,2,3,6,8 S %=$P($G(^TMP($J,3,"OPEN",ACCT)),U,2),TOTOPEN=TOTOPEN+%
37 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,3)=TOTOPEN ;All Open Balance Total $
38 ;
39 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,4)=+$G(^TMP($J,1,"REC","TOTAL"))
40 ;Std. Receipts Total $
41 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,5)=+$G(^TMP($J,2,"REC","TOTAL"))
42 ;ODI Receipts Total $
43 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,6)=+$G(^TMP($J,3,"REC","TOTAL"))
44 ;All Receipts Total $
45 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,7)=+$G(^TMP($J,1,"ISS","TOTAL"))
46 ;Std. Usages Total $
47 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,8)=+$G(^TMP($J,2,"ISS","TOTAL"))
48 ;ODI Usages Total $
49 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,9)=+$G(^TMP($J,3,"ISS","TOTAL"))
50 ;All Usages Total $
51 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,10)=+$G(^TMP($J,1,"ADJ","TOTAL"))
52 ;Std. Adjustments Total $
53 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,11)=+$G(^TMP($J,2,"ADJ","TOTAL"))
54 ;ODI Adjustments Total $
55 S $P(^TMP($J,"PRCPSSR2",STA,INV),U,12)=+$G(^TMP($J,3,"ADJ","TOTAL"))
56 ;All Adjustments Total $
57 ;
58 S PRCPDX=$TR(^TMP($J,"PRCPSSR2",STA,INV),"^","*"),DR="4///"_PRCPDX
59 D FILE
60 ;
61SSR3 ;*98 Third Stock Status Report data field set
62 ;
63 S TOTCLOS=0
64 S TOTCLOS=$P($G(^TMP($J,"PRCPSSR2",STA,INV)),U,1)+$G(^TMP($J,1,"REC","TOTAL"))
65 S TOTCLOS=TOTCLOS+$G(^TMP($J,1,"ISS","TOTAL"))+$G(^TMP($J,1,"ADJ","TOTAL"))
66 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,1)=TOTCLOS ;Std. Closing Bal Total $
67 S TOTCLO1=0
68 S TOTCLO1=$P($G(^TMP($J,"PRCPSSR2",STA,INV)),U,2)+$G(^TMP($J,2,"REC","TOTAL"))
69 S TOTCLO1=TOTCLO1+$G(^TMP($J,2,"ISS","TOTAL"))+$G(^TMP($J,2,"ADJ","TOTAL"))
70 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,2)=TOTCLO1 ;ODI Closing Bal Total $
71 S TOTCLO2=0
72 S TOTCLO2=$P($G(^TMP($J,"PRCPSSR2",STA,INV)),U,3)+$G(^TMP($J,3,"REC","TOTAL"))
73 S TOTCLO2=TOTCLO2+$G(^TMP($J,3,"ISS","TOTAL"))+$G(^TMP($J,3,"ADJ","TOTAL"))
74 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,3)=TOTCLO2 ;All Closing Bal Total $
75 ;
76 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,4)=+$G(^TMP($J,1,"RECN","TOTAL"))
77 ;# Std. Receipts
78 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,5)=+$G(^TMP($J,2,"RECN","TOTAL"))
79 ;# ODI Receipts
80 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,6)=+$G(^TMP($J,3,"RECN","TOTAL"))
81 ;# All Receipts
82 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,7)=+$G(^TMP($J,1,"ISSN","TOTAL"))
83 ;# Std. Issues
84 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,8)=+$G(^TMP($J,2,"ISSN","TOTAL"))
85 ;# ODI Issues
86 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,9)=+$G(^TMP($J,3,"ISSN","TOTAL"))
87 ;# All Issues
88 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,10)=+$G(^TMP($J,1,"ADJN","TOTAL"))
89 ;# Std. Adjustments
90 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,11)=+$G(^TMP($J,2,"ADJN","TOTAL"))
91 ;# ODI Adjustments
92 S $P(^TMP($J,"PRCPSSR3",STA,INV),U,12)=+$G(^TMP($J,3,"ADJN","TOTAL"))
93 ;# All Adjustments
94 ;
95 S PRCPDX=$TR(^TMP($J,"PRCPSSR3",STA,INV),"^","*"),DR="5///"_PRCPDX
96 D FILE
97 ;
98SSR4 ;*98 Fourth Stock Status Report data field set
99 ;
100 ;*83 Turnover computation logic also pulled from PRCPRSS0
101 S DAYS=$P("31^28^31^30^31^30^31^31^30^31^30^31",U,+$E(DATESTRT,4,5))
102 I DAYS=28 S %=(17+$E(DATESTRT))_$E(DATESTRT,2,3),DAYS=$S(%#400=0:29,(%#4=0&(%#100'=0)):29,1:28)
103 ;
104 S %=($G(^TMP($J,1,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLOS:0,1:-%/TOTCLOS)
105 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2)
106 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,1)=%
107 ;Std. Turnover
108 S %=($G(^TMP($J,2,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLO1:0,1:-%/TOTCLO1)
109 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2)
110 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,2)=%
111 ;ODI Turnover
112 S %=($G(^TMP($J,3,"ISS","TOTAL"))*365)/DAYS,%=$S('TOTCLO2:0,1:-%/TOTCLO2)
113 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2)
114 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,3)=%
115 ;All Turnover
116 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,4)=+$G(^TMP($J,1,"INACTN","TOTAL"))
117 ;# Std. Inactive
118 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,5)=+$G(^TMP($J,2,"INACTN","TOTAL"))
119 ;# ODI Inactive
120 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,6)=+$G(^TMP($J,3,"INACTN","TOTAL"))
121 ;# All Inactive
122 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,7)=+$G(^TMP($J,1,"INACT","TOTAL"))
123 ;Std Inactive Total $
124 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,8)=+$G(^TMP($J,2,"INACT","TOTAL"))
125 ;ODI Inactive Total $
126 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,9)=+$G(^TMP($J,3,"INACT","TOTAL"))
127 ;All Inactive Total $
128 ;
129 S %=$S('$G(^TMP($J,1,"VALUE","TOTAL")):0,1:$G(^TMP($J,1,"INACT","TOTAL"))/$G(^TMP($J,1,"VALUE","TOTAL")))
130 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2)
131 I %="" S %=0
132 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,10)=%
133 ;Std. Inactive %
134 S %=$S('$G(^TMP($J,2,"VALUE","TOTAL")):0,1:$G(^TMP($J,2,"INACT","TOTAL"))/$G(^TMP($J,2,"VALUE","TOTAL")))
135 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2)
136 I %="" S %=0
137 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,11)=%
138 ;ODI Inactive %
139 S %=$S('$G(^TMP($J,3,"VALUE","TOTAL")):0,1:$G(^TMP($J,3,"INACT","TOTAL"))/$G(^TMP($J,3,"VALUE","TOTAL")))
140 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2)
141 I %="" S %=0
142 S $P(^TMP($J,"PRCPSSR4",STA,INV),U,12)=%
143 ;All Inactive %
144 ;
145 S PRCPDX=$TR(^TMP($J,"PRCPSSR4",STA,INV),"^","*"),DR="6///"_PRCPDX
146 D FILE
147 ;
148SSR5 ;*98 Fifth Stock Status Report data field set
149 ;
150 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,1)=+$G(^TMP($J,1,"LONGN","TOTAL"))
151 ;# Std. Long Supply
152 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,2)=+$G(^TMP($J,2,"LONGN","TOTAL"))
153 ;# ODI Long Supply
154 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,3)=+$G(^TMP($J,3,"LONGN","TOTAL"))
155 ;# All Long Supply
156 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,4)=+$G(^TMP($J,1,"LONG","TOTAL"))
157 ;Std. Long Supply Total $
158 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,5)=+$G(^TMP($J,2,"LONG","TOTAL"))
159 ;ODI Long Supply Total $
160 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,6)=+$G(^TMP($J,3,"LONG","TOTAL"))
161 ;All Long Supply Total $
162 ;
163 S %=$S('$G(^TMP($J,1,"VALUE","TOTAL")):0,1:$G(^TMP($J,1,"LONG","TOTAL"))/$G(^TMP($J,1,"VALUE","TOTAL")))
164 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2)
165 I %="" S %=0
166 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,7)=%
167 ;Std. Long Supply %
168 S %=$S('$G(^TMP($J,2,"VALUE","TOTAL")):0,1:$G(^TMP($J,2,"LONG","TOTAL"))/$G(^TMP($J,2,"VALUE","TOTAL")))
169 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2)
170 I %="" S %=0
171 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,8)=%
172 ;ODI Long Supply %
173 S %=$S('$G(^TMP($J,3,"VALUE","TOTAL")):0,1:$G(^TMP($J,3,"LONG","TOTAL"))/$G(^TMP($J,3,"VALUE","TOTAL")))
174 I $P(%,".",2) S %=$P(%,".",1)_"."_$E($P(%,".",2),1,2)
175 I %="" S %=0
176 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,9)=%
177 ;All Long Supply %
178 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,10)=+$G(^TMP($J,1,"CNT","TOTAL"))
179 ;# Std. Items
180 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,11)=+$G(^TMP($J,2,"CNT","TOTAL"))
181 ;# On-Demand Items
182 S $P(^TMP($J,"PRCPSSR5",STA,INV),U,12)=+$G(^TMP($J,3,"CNT","TOTAL"))
183 ;# All Items
184 ;
185 S PRCPDX=$TR(^TMP($J,"PRCPSSR5",STA,INV),"^","*"),DR="7///"_PRCPDX
186 D FILE
187 K Y
188 ;
189 Q
190 ;
191 ;*98 Created filing subroutine
192FILE ; Subroutine that creates entries in File #446.7 fields as they
193 ; are created
194 ;
195 N PRCPDR,PRCPSNM,PRCPDA,PRCPDX,X,Y
196 S PRCPDR=DR
197 S SSRIEN=STA_INV
198 S DIC="^PRCP(446.7,",DIC(0)="L",DLAYGO=446.7,X=SSRIEN D ^DIC K DIC,DLAYGO
199 S PRCPDA=Y+0
200 ;*98 Send enhanced mail message if exception occurs during FileMan set
201 I Y=-1 N PRCPMSG D Q
202 . S PRCPMSG(1)="Error saving to File #446.7 for Stock Status Report, related data: "
203 . S PRCPSNM=$$GET1^DIQ(4,STA_",",.01)
204 . S PRCPMSG(2)="",PRCPMSG(3)="Station: "_STA_" "_PRCPSNM
205 . S PRCPMSG(4)="Inventory Point: "_$P(^TMP($J,"PRCPSSR1",STA,INV),U,4)_" "_$P(^TMP($J,"PRCPSSR1",STA,INV),U,5)
206 . S PRCPMSG(5)="File #446.7 Field Set Attempted: "_PRCPDR
207 . D MAIL^PRCPLO3 Q
208 ;
209 S DIE="^PRCP(446.7,",DA=PRCPDA D ^DIE K DIE,DR,DA
210 ;
211 Q
Note: See TracBrowser for help on using the repository browser.