source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHUTL.m@ 619

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

initial load of WorldVistAEHR

File size: 7.6 KB
Line 
1PRCHUTL ;SF/TKW/ID/RSD-UTILITY ROUTINES FOR SUPPLY SYSTEM ; 5/10/99 10:58am
2 ;;5.1;IFCAP;**15**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN2 ;CALLED FROM FILE 441 FIELD .01, INPUT X="NEW", OUTPUT X=NEXT INTERNAL NUMBER
6 S PRCHU=$P(^PRC(441,0),U,3) F I=1:1 S PRCHU=PRCHU+1 I '$D(^PRC(441,PRCHU)) L ^PRC(441,PRCHU) I S (X,DIX)=PRCHU K PRCHU Q
7 Q
8 ;
9ENPO ;ENTER NEW PO IN FILE 442
10 K PRCHPO,PRCHNEW,DA,DIC,DLAYGO,L Q:'$D(PRC("SITE"))
11 I '$D(DT) S X="T" D ^%DT S DT=Y
12 W !!,"ENTER A NEW "_$S($G(PRCHDELV):"DELIVERY",1:"PURCHASE")_" ORDER NUMBER OR A COMMON NUMBERING SERIES"
13 W !?3,$S($G(PRCHDELV):"DELIVERY",1:"PURCHASE")_" ORDER: " R X:DTIME
14 G:X=""!(X=U) ENPOQ
15 D:'$D(DIC("S"))
16 . S DIC="^PRC(442.6,",DIC(0)="QEMZ"
17 . I $G(PRCHPC) S DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),$P(^(0),U,5)=6"
18 . E I $G(PRCHDELV) S DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),$P(^(0),U,5)=7"
19 . E S DIC("S")="I +$P(^(0),U,1)=PRC(""SITE""),($P(^(0),U,5)=2!($P(^(0),U,5)="""")!($P(^(0),U,5)=6))"
20 I $L(X)<4!($E(X,1)="?") S D="C" D IX^DIC G ENPO:Y<0,NUM:$L(X)<4
21 I '$O(^PRC(442.6,"B",PRC("SITE")_"-"_$E(X,1,2),0)) W " ??? Not part of an existing Common Numbering Series." G ENPO
22 I $E(X,1,2)["B" W $C(7),!! W "'B' numbers are normally used for Acquisitions from Federal Sources." S %A=" ARE YOU SURE ",%B="This number should only be used for Federal Source Acquisitions",%=2 D ^PRCFYN G:%=-1 ENPOQ G:%'=1 ENPO
23 S X=PRC("SITE")_"-"_X I $D(^PRC(442,"B",X)) W !?3,"P.O. ",X," already exist, use edit option to modify." G ENPO
24 ;
25ENPO1 K DIC("S") S PRCHNEW="",DIC="^PRC(442,",DLAYGO=442,DIC(0)="L" D ^DIC L G ENPO:Y<0,W3:'+$P(Y,U,3)
26 S (DA,PRCHPO)=+Y,%DT="T",X="NOW" D ^%DT S $P(^PRC(442,PRCHPO,12),U,4,5)=DUZ_U_Y
27 S (X,Y)=1,DA=PRCHPO D UPD^PRCHSTAT
28 S $P(^PRC(442,PRCHPO,1),U,10)=DUZ
29 D DOCID
30 G ENPOQ
31 ;
32NUM L ^PRC(442.6,+Y,0):1 G:'$T W1 S X=$P(Y,U,2),Z=$S(+$P(Y(0),U,4)<$P(Y(0),U,2):+$P(Y(0),U,2),1:+$P(Y(0),U,4)),L=$L(X)#2-3
33 ;
34Z G:Z>$P(Y(0),U,3) W2 S Z="000"_Z,Z=$E(Z,$L(Z)+L,$L(Z)),X=X_Z I $D(^PRC(442,"B",X)) S Z=Z+1,X=$P(Y,U,2) G Z
35 W $C(7) S %A=" Are you adding '"_X_"' as a new Purchase Order number ",%B="",%="" D ^PRCFYN I %'=1 L G ENPO
36 S $P(^PRC(442.6,+Y,0),U,4)=+Z
37 G ENPO1
38 ;
39DOCID S Z=$P($P(^PRC(442,PRCHPO,0),U,1),"-",2) Q:$L(Z)'=6 F I=1:1:6 S X=$E(Z,I,I) Q:+X=X
40 I +X=X S $P(^PRC(442,PRCHPO,18),"^",3)=$S(I=1:$E(Z,2,6),1:$E(Z,1,I-1)_$E(Z,I+1,6))
41 Q
42 ;
43W1 L W !?3," Common numbering series is being edited by another user, try later",$C(7)
44 G ENPO
45 ;
46W2 L W !?3,"UPPER BOUND HAS BEEN EXCEEDED FOR COMMON NUMBERING SERIES ",$P(Y,U,2),$C(7)
47 G ENPO
48 ;
49W3 W " Purchase Order number already exist, please try again ",$C(7)
50 G ENPO
51 ;
52ENPOQ K DIC,DLAYGO,%DT,PRCHNEW,L
53 Q
54 ;several old linetags that encoded/decoded esigs were removed from here
55 ;
56WORD ; PRCH=GLOBAL,WX=LINE TO INSERT
57 I '$D(@(PRCH_"0)")) S @(PRCH_"0)")="^^0^0^"_DT
58 S WI=0 F WJ=1:1 S WI=$O(@(PRCH_WI_")")) Q:'WI I $D(^(WI,0)) S WY=^(0),^(0)=WX,WX=WY
59 S $P(@(PRCH_"0)"),U,3,4)=WJ_U_WJ,^(WJ,0)=WX K WI,WJ,WX,WY
60 Q
61 ;
62SWITCH N X K PRCHLOG,PRCHISMS S X=$$ISMSFLAG^PRCPUX2(PRC("SITE")) S:X#2 PRCHLOG="" S:X\2 PRCHISMS="",PRCHTYP="I"
63 Q
64 ;
65EDISTAT(D0,D1,LINECNT) ;DISPLAY P.O.'S EDI STATUS & QUANTITY
66 ;REQUIRES INTERNAL RECORD NUMBER AS D0
67 ; INTERNAL SUBRECORD NUMBER AS D1
68 ; RETURNS THE NUMBER OF LINES PRINTED AS LINECNT
69 ;NOTE: THE NAKED REFERENCE WILL BE ^DD(442.01,12 or 13,0) WHEN
70 ; THIS MODULE FINISHES.
71 N X,Y,C
72 S:'$D(LINECNT) LINECNT=0
73 I $D(^PRC(442,D0,2,D1,2)) S X=$P(^(2),"^",9,12) D
74 .I $P(X,"^",1)=""&($P(X,"^",3)="") Q
75 .W !," E D I S T A T U S : ",?26
76 .I $P(X,"^",1)]"" S Y=$P(X,"^",1),C=$P(^DD(442.01,12,0),"^",2) D Y^DIQ W "#1: ",Y," QTY: ",$P(X,"^",2),!,?26 S LINECNT=LINECNT+1
77 .I $P(X,"^",3)]"" S Y=$P(X,"^",3),C=$P(^DD(442.01,13,0),"^",2) D Y^DIQ W "#2: ",Y," QTY: ",$P(X,"^",4) S LINECNT=LINECNT+1
78 .W ! S LINECNT=LINECNT+1
79 .Q
80 Q
81 ;
82 ;
83 ;
84VEN(A) ; Entry point to get FMS Vendor ID_ Alt.Address Indicator from the vendor file. -- Used by AR (Only)
85 ; A = internal entry number to vendor file (#440)
86 ;
87 N T S T=$G(^PRC(440,+A,3))
88 I $L($P(T,U,4))'=9 Q ""
89 Q $P(T,U,4)_$P(T,U,5)
90 ;
91VENSEL() ; VENSEL = VENdor SELection
92 ; EXTRINSIC FUNCTION THAT ALLOWS A USER TO SELECT AN IFCAP VENDOR.
93 ; THIS FUNCTION WILL BE USED BY ACCOUNTS RECEIVABLE USERS.
94 ;
95 ; THIS EXTRINSIC FUNCTION WILL RETURN A STRING.
96 ; CONDITION STRING VALUE ^DIC VALUE
97 ; LOOKUP FAILED -1 Y=-1
98 ; TIMED-OUT -2 DTOUT
99 ; UP-ARROW -3 DUOUT
100 ; SUCCESSFUL DA^.01 FIELD Y=N^S
101 ; SUCCESSFUL & NEW DA^.01 FIELD^1 Y=N^S^1
102 ;
103 ; THE DEFINITIONS OF THE ^DIC VALUEs MAY BE FOUND IN VA FileMan
104 ; V.21.0 Programmer Manual ON PAGES 56-57. THIS IS THE RETURNED
105 ; STRING OF THIS FUNCTION.
106 ;
107 ; FIRST, ASK THE USER FOR THEIR "SITE".
108 ;
109 S PRCF("X")="S"
110 D ^PRCFSITE
111 ;
112 ; NOW THAT WE HAVE THE SITE, CONTINUE ON.
113 ;
114 S DIC="^PRC(440,"
115 S DIC(0)="AEMO"
116 S DIC("A")="Select the DEBTOR from the VENDOR list: "
117 K DTOUT,DUOUT
118 D ^DIC
119 S:$D(DTOUT) Y=-2
120 S:$D(DUOUT) Y=-3
121 K DIC,DTOUT,DUOUT
122 S PRCOY=Y
123 I +PRCOY<0 Q PRCOY
124 ;
125 ; NOW LETS SEE IF THIS VENDOR RECORD IS PROPERLY SET UP.
126 ;
127 S DA=+Y
128 K ^PRC(440.3,DA)
129 S %X="^PRC(440,DA,"
130 S %Y="^PRC(440.3,DA,"
131 D %XY^%RCR
132 S FLAG=1
133 S FISCAL=$G(^PRC(411,PRC("SITE"),9))
134 S FISCAL=$P(FISCAL,U,3)
135 S SAVE=$$CHECK^PRCOVTST(DA,PRC("SITE"),FLAG)
136 I FISCAL="Y",SAVE=0 D
137 . S DIE="^PRC(440.3,"
138 . S DR="47///^S X=FLAG;48///^S X=DA;49///^S X=PRC(""SITE"")"
139 . D ^DIE
140 . Q
141 I FISCAL'="Y",SAVE=0 S PRCZDA=DA D VRQ^PRCOVTST(DA,PRC("SITE")) S DA=PRCZDA K PRCZDA
142 I SAVE=1 D
143 . S AR=449
144 . S DIE="^PRC(440.3,"
145 . S DR="50///^S X=FLAG;51///^S X=DA;52///^S X=PRC(""SITE"")"
146 . D ^DIE
147 . K AR
148 . Q
149 Q PRCOY
150 ;
151AF ; CALLED BY "AF" X-REF IN FIELD 52 (SITE AR) IN FILE 440.3.
152 N PRCX,DIC,DLAYGO,Y
153 Q:$G(AR)'=449
154 S PRCX=$O(^PRCF(422.2,"B","AR-EDIT-01",0)) D:PRCX=""
155 . ; NEED TO SET UP ENTRY IN COUNTER FILE.
156 . K DD,DO
157 . S DIC="^PRCF(422.2,"
158 . S DIC(0)="L"
159 . S X="AR-EDIT-01"
160 . S DELAYGO=422.2
161 . D FILE^DICN
162 . S PRCX=+Y
163 . Q
164 S $P(^PRCF(422.2,PRCX,0),U,2)=+$P(^PRCF(422.2,PRCX,0),U,2)+1
165 Q
166 ;
167VENEDITF ; THIS ENTRY POINT WILL INFORM USERS THAT THERE ARE VENDOR
168 ; RECORDS, USED BY Accounts Receivable, THAT NEED TO BE EDITED
169 ; BEFORE THEY CAN BE ENTERED INTO A VRQ.
170 ;
171 ; SEE IF FISCAL CAN ADD A VENDOR. IF SO, TELL THE USER THERE
172 ; RECORDS TO EDIT.
173 ;
174 N COUNT,STN411,SHOWIT
175 Q:'$D(DUZ) ; YOU ARE UNDEFINED.
176 ;
177 ; SEE IF FISCAL CAN ADD VENDORS.
178 ;
179 D FIND
180 Q:STN411'=1
181 ;
182 S SHOWIT=0
183 ;
184 ; I STN411=1 THEN FISCAL CAN ADD VENDORS.
185 ; SEE IF THE USER IS A FISCAL USER.
186 ;
187 I $D(^XUSEC("PRCFA VENDOR EDIT",DUZ))=1 S SHOWIT=1
188 Q:SHOWIT'=1
189 G COUNT
190 ;
191VENEDITS ; THIS ENTRY POINT WILL INFORM USERS THAT THERE ARE VENDOR
192 ; RECORDS, USED BY Accounts Receivable, THAT NEED TO BE EDITED
193 ; BEFORE THEY CAN BE ENTERED INTO A VRQ.
194 ;
195 ; SEE IF FISCAL CAN ADD A VENDOR. IF NOT, HAVE SUPPLY EDIT THE
196 ; VENDOR RECORDS.
197 ;
198 N COUNT,STN411,SHOWIT
199 Q:'$D(DUZ) ; YOU ARE UNDEFINED.
200 ;
201 ; SEE IF FISCAL CAN ADD VENDORS.
202 ;
203 D FIND
204 Q:STN411=1
205 ;
206 S SHOWIT=0
207 ;
208 ; SEE IF THE USER IS A PURCHASING AGENT OR A MANAGER.
209 ;
210 I +$P($G(^VA(200,DUZ,400)),U)>2 S SHOWIT=1
211 Q:SHOWIT'=1
212 ;
213COUNT ; NOW SHOW MESSAGE, IF ANY
214 ;
215 S COUNT=$O(^PRCF(422.2,"B","AR-EDIT-01",0)) Q:COUNT'>0
216 S COUNT=$P($G(^PRCF(422.2,COUNT,0)),U,2) Q:COUNT'>0
217 W !!,"There are Vendor Records that AR is using to be edited."
218 Q
219 ;
220FIND ; SEE IF FISCAL CAN ADD A VENDOR.
221 ;
222 N STATION,STNIEN
223 S STATION=0
224 S STN411=""
225 F S STATION=$O(^PRC(411,"B",STATION)) Q:STATION']"" D Q:STN411=1
226 . S STNIEN=$O(^PRC(411,"B",STATION,0)) Q:STNIEN'>0
227 . S STN411=$P($G(^PRC(411,STNIEN,0)),U,20)
228 . Q
229 Q
Note: See TracBrowser for help on using the repository browser.