source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPLO1.m@ 1096

Last change on this file since 1096 was 628, checked in by George Lilly, 16 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.7 KB
Line 
1PRCPLO1 ;WOIFO/RLL/DAP-utilities: setup inventory variables ; 1/24/06 9:56am
2V ;;5.1;IFCAP;**83**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ; Copied from routine PRCPUSEL
5PRCPUSEL ; Old routine label (to resolve goto below for xindex)
6 Q
7 ;
8 ; enter distribution point--input variables:
9 ; prcp("dptype")=distribution point type code [W,P,S]
10 ;
11 ; returns the following variables:
12 ; prcp("in")=name of inv pt (no station #),
13 ; prcp("inv")=keep perpetual inventory flag
14 ; prcp("his")=keep detailed history flag,
15 ; prcp("i")=da of inv pt
16 ;
17DOIT ; ADDED label here
18 N D,IORVOFF,IORVON,PRCHAUTH ; needed to New for xindex
19 D DOIT1
20 Q
21GETIPT ; $O through PRCP(^445,"B", get Station ID, Inactive?, IPID#
22 ;
23 N V1,V2,V3,V4,V5,DATA1,DATA2
24 S V1=0,V2=0
25 F S V1=$O(^PRCP(445,"B",V1)) Q:V1="" D
26 . F S V2=$O(^PRCP(445,"B",V1,V2)) Q:V2="" D
27 . . Q:V1["***INACTIVE"
28 . . ;S V1=$TR(V1,"*","&") ; needed due to using "*" as delimiter
29 . . S V3=$P(V1,"-",1)
30 . . S V4=$P(V1,"-",2,99)
31 . . ; W !," Station ID#=",V3
32 . . ; W !," Inventory Point =",V4
33 . . ; W !," Inventory Point ID# =",V2
34 . . S DATA1=$G(^PRCP(445,+(V2),0)) ; DATA for Inv Point
35 . . S PRCP("DPTYPE")=$P(DATA1,"^",3) ; Prim, Second, or warehouse
36 . . S PRCP("PAR")=DATA1 ; Data for Inv point set in array
37 . . S PRCP("HIS")=$P(DATA1,"^",6) ;
38 . . S PRCP("I")=V2 ; Inv Point ID#
39 . . S PRCP("INV")=$P(DATA1,"^",2) ; External Name, Inv Point
40 . . ; W !,"DATA 1 IS ",DATA1
41 . . ;
42 . . S DATA2=$G(^PRC(411,+(V3),0)) ; Data for Station ID#
43 . . S PRC("PARAM")=DATA2 ; parameters for Station ID
44 . . S PRC("SITE")=V3 ; station id#
45 . . S PRC("MDIV")="" ; multi division , add lookup/check here
46 . . S PRC("PER")="" ; normally DUZ, may not be needed
47 . . S PRC("FY")="06"
48 . . S PRC("QTR")="01" ; add lookup/check here
49 . . ; W !," PRC(PARAM) IS ",PRC("PARAM")
50 . . ; THE WRITE STATEMENTS ABOVE WILL BE REPLACED WITH
51 . . ; THE SETTING OF PRCP() AND PRC() VALUES
52 . . ; *83 add code here from Days of Stock on hand logic
53 . . ; if Item Inventory does not contain any items for
54 . . ; an inventory point, quit here. Get next Inv. point
55 . . ; N ITMDAK
56 . . ; S ITMDAK=$G(^PRCP(445,+PRCP("I"),1,0)) ;at least 1 item?
57 . . ; Q:'ITMDAK ; quit if no item exists, go to next Inv. Pt.
58 . . I CLRSFLAG="SS" D EN1^PRCPLO2 ; Do stock status report
59 . . I CLRSFLAG="SOH" D EN1^PRCPLO ; Do days of stock on hand rpt.
60 . . Q
61 . Q
62 Q
63 ;
64 ;
65DOIT1 ; ADDED label here
66 N %,C,DISYS,I,J,PRCF,PRCPFLAG,X,Y
67 I +$G(DUZ)<1 W !,"YOU ARE NOT SETUP AS A USER!" K PRC,PRCP Q
68 ;
69 S %=0 F I="FY","PARAM","PER","QTR","SITE" I '+$G(PRC(I)) S %=1 Q
70 ; I % S PRCF("X")="S" D ^PRCFSITE I '+$G(PRC("SITE")) K PRC,PRCP Q
71 ;
72DOSITE ; Set up PRC array from PRCFSITE
73 S PRC("MDIV")="" ; multi division (need to check for this)
74 S PRC("FY")="06" ; NEED TO make this calculation
75 S PRC("PARAM")=$G(^PRC(411,V2,0)) ; get params for inv pt
76 S PRC("PER")=DUZ ; may not be needed
77 S PRC("QTR")="01" ; NEED TO make this calcuation
78 S PRC("SITE")=V2
79 Q
80 ;
81DOSITEP ; Set up PRCP array from DISPLAY^PRCPLO1
82 S %=0 F I="DPTYPE","HIS","I","IN","INV" I '$D(PRCP(I)) S %=1 Q
83 ; I '% D DISPLAY Q
84 ;
85 D PARAM(+V2)
86 Q
87 ; allow adding new whse if not one for station
88 I $G(PRCP("DPTYPE"))="W" D Q:$G(PRCPFLAG)
89 . K PRCPFLAG
90 . S %=0 F S %=$O(^PRCP(445,"AC","W",%)) Q:'% I $P($P($G(^PRCP(445,%,0)),"^"),"-")=PRC("SITE") S PRCPFLAG=1 Q
91 . I $G(PRCPFLAG) K PRCPFLAG Q
92 . S PRCP("I")=$$INVPT^PRCPUINV(PRC("SITE"),"W",1,1,"")
93 . I 'PRCP("I") S PRCPFLAG=1 K PRC,PRCP
94 ;
95 S %=$S($D(PRCP("DPTYPE")):PRCP("DPTYPE"),1:"^")
96 S (I,J)=0
97 F S I=$O(^PRCP(445,"AD",DUZ,I)) Q:'I I $D(^PRCP(445,I,0)) D I J>1 Q
98 . S:%="^"!(%[$P(^PRCP(445,I,0),"^",3)) Y(0)=^(0),J=J+1,Y=I
99 I J=1 D Q:$G(PRCPFLAG) S PRC("SITE")=+Y(0) D V1 Q
100 . I '$D(^PRC(411,+Y(0),0)) D K PRC,PRCP S PRCPFLAG=1
101 . . W !,"ERROR - SITE PARAMETERS IN FILE 411 FOR SITE "
102 . . W +Y(0)," ARE MISSING."
103 I $G(PRCHAUTH) Q:'$G(PRCP("I")) D G V1
104 . S Y=PRCP("I")_"^"_$P($G(^PRCP(445,PRCP("I"),0)),U)
105 ;
106 S DIC="^PRCP(445,",DIC(0)="AEQMOZ"
107 S DIC("S")="I +^(0)=PRC(""SITE""),$P(^(0),U,2)=""Y"",$D(^PRCP(445,+Y,4,DUZ,0))"
108 I $D(PRCP("DPTYPE")) S DIC("S")=DIC("S")_",PRCP(""DPTYPE"")[$P(^PRCP(445,+Y,0),U,3)"
109 S DIC("A")="Select "_$S('$D(PRCP("DPTYPE")):"",PRCP("DPTYPE")="W":"Supply Warehouse ",PRCP("DPTYPE")="P":"Primary ",PRCP("DPTYPE")="S":"Secondary ",1:"")_"Inventory Point: "
110 S D="C",PRCPPRIV=1
111 D IX^DIC
112 K PRCPPRIV,DIC
113 I Y<0 K PRC,PRCP Q
114 ;
115V1 ; internal program jump
116 D PARAM(+Y)
117 ;
118DISPLAY ; display top of page header
119 I '$G(PRCP("I")) G PRCPUSEL
120 S %=0 F I="RV1","RV0","XY" I '$D(PRCP(I)) S %=1 Q
121 I % D TERM
122 ;
123 S %="",$P(%," ",81)=""
124 S X="I N V E N T O R Y version "_$P($T(PRCPUSEL+1),";",3)
125 S Y=80-$L(X)\2
126 S X=$E(%,1,Y)_X_%
127 W @IOF,PRCP("RV1"),$E(X,1,40)
128 X PRCP("XY")
129 W $E(X,41,80),PRCP("RV0")
130 S PRCP("PAR")=^PRCP(445,PRCP("I"),0)
131 S X=$S(+$G(PRC("SITE")):"("_PRC("SITE")_") ",1:"")
132 S X=X_$S(PRCP("DPTYPE")="W":"Warehouse ",PRCP("DPTYPE")="P":"Primary ",PRCP("DPTYPE")="S":"Secondary ",1:"")
133 S X=X_"Inventory Point: "_PRCP("IN")
134 W !,X,?(80-$L($P($G(PRC("PER")),"^",2))),$P($G(PRC("PER")),"^",2)
135 I PRCP("DPTYPE")="P" S Y=$P(PRCP("PAR"),"^",12) I Y,Y'>DT D
136 . D DD^%DT
137 . W !,?6,"--> NEXT REQUEST FOR WAREHOUSE ISSUES IS DUE IN SUPPLY ON ",Y,"."
138 I $P(PRCP("PAR"),"^",9)="Y" D
139 . W !?6,"--> THERE ARE ITEMS AT OR BELOW THE EMERGENCY STOCK LEVEL."
140 I $E($P(PRCP("PAR"),"^",14),1,5)'=$E(DT,1,5) D
141 . W !?6,"--> USAGE/DISTRIBUTION TOTALS NEEDS TO BE PURGED."
142 I $E($P(PRCP("PAR"),"^",17),1,5)'=$E(DT,1,5) D
143 . W !?6,"--> RECEIPTS HISTORY BY ITEM NEEDS TO BE PURGED."
144 I PRCP("DPTYPE")'="S",$E($P(PRCP("PAR"),"^",19),1,5)'=$E(DT,1,5) D
145 . W !?6,"--> DISTRIBUTION HISTORY NEEDS TO BE PURGED."
146 I $E($P(PRCP("PAR"),"^",18),1,5)'=$E(DT,1,5) D
147 . W !?6,"--> TRANSACTION REGISTER NEEDS TO BE PURGED."
148 I $P(PRCP("PAR"),"^",6)="Y",$E($P(PRCP("PAR"),"^",22),1,5)'=$E(DT,1,5) D
149 . W !?6,"--> OPENING MONTHLY INVENTORY BALANCES NEED TO BE SET."
150 I PRCP("DPTYPE")="S",$P($G(^PRCP(445,PRCP("I"),5)),"^",1)]"" D SSMSG
151 I $O(^PRCP(447.1,"C",+PRCP("PAR"),PRCP("I"),"")) D
152 . W !?6,"--> THERE ARE UNPROCESSED SUPPLY STATION TRANSACTIONS."
153 ;
154 W !,PRCP("RV1"),$E(%,1,40) X PRCP("XY") W $E(%,41,80),PRCP("RV0")
155 Q
156 ;
157 ;
158NOMENU ; user did not select a valid inventory point, do not allow access
159 ; to the menu (called from option file)
160 N X
161 S X(1)="YOU MUST SELECT A VALID INVENTORY POINT BEFORE ACCESSING THIS MENU" D DISPLAY^PRCPUX2(1,79,.X)
162 Q
163 ;
164 ;
165PARAM(INVPT) ; set up parameters for inventory point
166 K PRCP
167 N DATA,PRCPEX
168 S DATA=$G(^PRCP(445,INVPT,0)) I DATA="" Q
169 ; *83 new code, need to $TR PRCP("IN", convert "*" to "|"
170 ;S PRCP("I")=INVPT,PRCP("INV")=(DATA,"^",2),PRCP("HIS")=$P(DATA,"^",6),PRCP("DPTYPE")=$P(DATA,"^",3)
171 ;S PRCPEX=$P($P(DATA,"^"),"-",2,99)
172 ;S PRCPEX=$TR(PRCPEX,"*","&") ; Change "*" to "|"
173 ;S PRCP("IN")=PRCPEX
174 ; *83 (old code below)
175 S PRCP("I")=INVPT,PRCP("IN")=$P($P(DATA,"^"),"-",2,99),PRCP("INV")=$P(DATA,"^",2),PRCP("HIS")=$P(DATA,"^",6),PRCP("DPTYPE")=$P(DATA,"^",3)
176 ; D TERM ;commented out for CLRS
177 Q
178 ;
179 ;
180TERM ; get terminal attributes
181 N X
182 I '$D(IOF)!('$G(IOST(0))) S IOP="HOME" D ^%ZIS K IOP
183 S X="IORVON;IORVOFF" D ENDR^%ZISS
184 S PRCP("RV1")=$G(IORVON),PRCP("RV0")=$G(IORVOFF)
185 S PRCP("XY")="N DX,DY S (DX,DY)=0 "_$G(^%ZOSF("XY"))
186 Q
187 ;
188SSMSG ; check supply station secondaries, give message of qty mismatch
189 N GIPCNT,INVPT,ITEM,PRCPFLAG,SSCNT
190 S INVPT=PRCP("I")
191 S ITEM=0
192 F S ITEM=$O(^PRCP(445,INVPT,1,ITEM)) Q:'+ITEM D I $D(PRCPFLAG) Q
193 . I $P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",9)<1 Q ; not a SS item
194 . S GIPCNT=$P($G(^PRCP(445,INVPT,1,ITEM,0)),"^",7)
195 . S SSCNT=$P($G(^PRCP(445,INVPT,1,ITEM,9)),"^",1)
196 . I 'GIPCNT,'SSCNT Q
197 . I GIPCNT=SSCNT Q
198 . W !,?6,"--> QUANTITY DISCREPANCIES EXIST WITH THE SUPPLY STATION."
199 . S PRCPFLAG=1
Note: See TracBrowser for help on using the repository browser.