source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHID.m@ 1582

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

initial load of WorldVistAEHR

File size: 5.8 KB
Line 
1PRCHID ;WISC/DJM/BGJ-VENDOR IDENTIFIER DATA ;5/3/99 1:11pm
2V ;;5.1;IFCAP;**7**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4START ;DISPLAY IDENTIFYING DATA FROM RECORD IN FILE 440
5 N LN0,LN2,LN3,LN7,LN9,LN10,PHONE,PH,A,T,T1,NO,ADDR1,FMS,CITY,STATE
6 N ZIP,ADDR2,CODE,FAX,FX,RV,IVCK,PRCFD,BTMSG
7 ;
8 ; FIND OUT WHAT OPTION USER IS IN NOW. IF OPTION BEGINS WITH 'PRCF'
9 ; RECORD FACT THAT OPTION IS A 'FISCAL' OPTION.
10 ;
11 D OP^XQCHK
12 I XQOPT'=-1,($E(XQOPT,1,4)="PRCF") S PRCFD("PAY")=1
13 ;
14 ;GET CURRENT RECORD NODES NEEDED TO DISPLAY IDENTIFIERS
15 ;
16 S IEN=+Y
17 S LN0=$G(^PRC(440,IEN,0))
18 S LN2=$G(^PRC(440,IEN,2))
19 S LN3=$G(^PRC(440,IEN,3))
20 S LN7=$G(^PRC(440,IEN,7))
21 S LN9=$G(^PRC(440,IEN,9))
22 S LN10=$G(^PRC(440,IEN,10))
23 S PRCFLAG=""
24 ;
25 ;DISPLAY ADDITIONAL DATA ON LINE WITH VENDOR NAME IF VENDOR
26 ;IS INACTIVATED.
27 ;
28 I $P(LN10,U,5)=1 G IEN
29 ;
30 ;DISPLAY ADDITIONAL DATA ON LINE WITH VENDOR NAME IF VENDOR
31 ;IS NOT INACTIVATED.
32 ;
33 I $P(LN3,U,2)="Y" D EN^DDIOL("EDI","","?49")
34 S PHONE="PH:"
35 S PH=$P(LN0,U,10)
36 D PHONE
37 S PHONE=PHONE_PH
38 D EN^DDIOL(PHONE,"","?54")
39 ;
40 ;COME HERE TO DISPLAY THE RECORD'S INTERNAL ENTRY NUMBER
41 ;
42IEN S NO=" "_IEN
43 S NO="NO:"_$E(NO,$L(NO)-5,99)
44 D EN^DDIOL(NO,"","?71")
45 ;
46 ;NOW DISPLAY ORDERING ADDRESS DATA IN IDENTIFIERS
47 ;
48 I '$D(PRCFD("PAY")) D
49 . ;
50 . ;FIRST ORDERING ADDRESS LINE
51 . ;
52 . S ADDR1="ORD ADD:"_$P(LN0,U,2)
53 . D EN^DDIOL(ADDR1,"","!")
54 . S FMS="FMS:"_$P(LN3,U,7)
55 . D EN^DDIOL(FMS,"","?46")
56 . ;
57 . ;SECOND ORDERING ADDRESS LINE
58 . ;
59 . S CITY=$P(LN0,U,6)
60 . S STATE=$P(LN0,U,7)
61 . I STATE>0 D
62 . . S STATE=$P($G(^DIC(5,STATE,0)),U,2)
63 . S ZIP=$P(LN0,U,8)
64 . I ZIP?9N S ZIP=$E(ZIP,1,5)_"-"_$E(ZIP,6,9)
65 . S ADDR2=""
66 . I CITY]"",STATE]"" S ADDR2=ADDR2_CITY_", "_STATE
67 . I CITY="",STATE]"" S ADDR2=ADDR2_STATE
68 . I CITY]"",STATE="" S ADDR2=ADDR2_CITY
69 . S:ADDR2]"" ADDR2=ADDR2_" "_ZIP
70 . S:ADDR2="" ADDR2=ADDR2_ZIP
71 . D EN^DDIOL(ADDR2,"","!?8")
72 . S CODE="CODE:"_$P(LN3,U,4)_$P(LN3,U,5)
73 . D EN^DDIOL(CODE,"","?46")
74 . S FAX="FAX:"
75 . K PH
76 . S PH=$P(LN10,U,6)
77 . D PHONE
78 . S FAX=FAX_PH
79 . D EN^DDIOL(FAX,"","?64")
80 ;
81 ;END OF ORDERING ADDRESS LINES
82 ;
83 ;SHOW PAYMENT ADDRESS LINES
84 ;
85 I $D(PRCFD("PAY")) D
86 . ;
87 . ;FIRST PAYMENT ADDRESS LINE
88 . ;
89 . S ADDR1="PAY ADD:"_$P(LN7,U,3)
90 . D EN^DDIOL(ADDR1,"","!")
91 . S FMS="FMS:"_$P(LN3,U,7)
92 . D EN^DDIOL(FMS,"","?46")
93 . ;
94 . ;SECOND PAYMENT ADDRESS LINE
95 . ;
96 . S CITY=$P(LN7,U,7)
97 . S STATE=$P(LN7,U,8)
98 . I STATE>0 D
99 . . S STATE=$P($G(^DIC(5,STATE,0)),U,2)
100 . S ZIP=$P(LN7,U,9)
101 . I ZIP?9N S ZIP=$E(ZIP,1,5)_"-"_$E(ZIP,6,9)
102 . S ADDR2=""
103 . I CITY]"",STATE]"" S ADDR2=ADDR2_CITY_", "_STATE
104 . I CITY="",STATE]"" S ADDR2=ADDR2_STATE
105 . I CITY]"",STATE="" S ADDR2=ADDR2_CITY
106 . S:ADDR2]"" ADDR2=ADDR2_" "_ZIP
107 . S:ADDR2="" ADDR2=ADDR2_ZIP
108 . D EN^DDIOL(ADDR2,"","!?8")
109 . S CODE="CODE:"_$P(LN3,U,4)_$P(LN3,U,5)
110 . D EN^DDIOL(CODE,"","?46")
111 . S FAX="FAX:"
112 . K PH
113 . S PH=$P(LN10,U,6)
114 . D PHONE
115 . S FAX=FAX_PH
116 . D EN^DDIOL(FAX,"","?64")
117 . Q
118 ;
119 ;END OF PAYMENT ADDRESS LINES
120 ;
121 ;LETS INFORM USER IF THIS VENDOR IS INACTIVATED
122 ;
123 D EN^DDIOL("","","!")
124 I $P(LN10,U,5)=1 D
125 . D EN^DDIOL("****THIS VENDOR IS INACTIVE","","?0")
126 . ;
127 . ;NOW SEE IF WE CAN FIND A SUBSTITUTE VENDOR
128 . ;
129 . ;RV = REPLACEMENT VENDOR INTERNAL ENTRY NUMBER
130 . ;IVCK = INACTIVATED VENDOR CHECK
131 . ;
132 . S LOOP=""
133 . S RV=+LN9
134 . I RV=0&($E(LN0,1,2)["**") D
135 . . D EN^DDIOL(", NO REPLACEMENT VENDOR *****","","?27")
136 . . S PRCFLAG=1 W !,?5," PLEASE CHOOSE ANOTHER VENDOR " Q
137 . ;
138 . ;STOP IF A REPLACEMENT VENDOR POINTS TO ITSELF
139 . ;
140 . I RV=IEN S RV=0
141 . F Q:RV=0 S IVCK=$P($G(^PRC(440,RV,10)),U,5) Q:IVCK="" D Q:LOOP=1
142 . . S RVX=+$G(^PRC(440,RV,9))
143 . . I RVX'>0 S LOOP=1 Q
144 . . I RV=RVX S LOOP=1 Q
145 . . S RV=RVX
146 . . I RV=0!(LOOP=1) D EN^DDIOL("****","","?27") Q
147 . I RV>0 D
148 . . S RVX=RV
149 . . S RV=" "_RV
150 . . S RV=$E(RV,$L(RV)-5,99)
151 . . D EN^DDIOL(", USE VENDOR NO:"_RV_"****","","?27")
152 . . S PRCFLAG=1,LN0=$G(^PRC(440,RVX,0)),NAME=$P(LN0,U,1)
153 . . W !,?5," VENDOR NAME "_NAME Q
154 . ;
155 . Q
156 ;
157 ;ONLY IF VENDER IS ACTIVE & THIS VENDOR LOOKUP IS NOT COMING FROM
158 ;A FISCAL OPTION DISPLAY 'BUSINESS TYPE' SETUP
159 ;
160 I $P(LN10,U,5)="",'$D(PRCFD("PAY")) D
161 . D SETBTMSG
162 . I $P(LN0,U,11)]"" Q
163 . I LN2="" D EN^DDIOL(.BTMSG) Q
164 . I $P(LN2,U,2)]"" Q
165 . I $P(LN2,U,3)']"" D EN^DDIOL(.BTMSG) Q
166 ;
167 ;IF VENDOR IS INACTIVE DISPLAY 'EDI VENDOR'
168 ;
169 I $P(LN10,U,5)=1 D
170 . I $P(LN3,U,2)="Y" D EN^DDIOL("EDI VENDOR","","?56") Q
171EXIT Q
172 ;
173PHONE ; PHONE/FAX FORMATTING
174 ;
175 S PH=$TR(PH,"abcdefghijklmnoprstuvwxy","222333444555666777888999")
176 S PH=$TR(PH,"ABCDEFGHIJKLMNOPRSTUVWXY","222333444555666777888999")
177 I PH]"" D
178 . I PH'?.N D Q
179 . . S A=1
180 . . F S T=$E(PH,1) D:T?1N S:T'?1N PH=$E(PH,2,99) Q:PH=""
181 . . . S PH(A)=""
182 . . . F S T1=$E(PH,1) Q:T1'?1N S PH(A)=PH(A)_T1,PH=$E(PH,2,99) Q:PH=""
183 . . . Q:PH=""
184 . . . S A=A+1
185 . . . Q
186 . . I $G(PH(1))="011" S PH="INTERN'L" Q
187 . . I $L($G(PH(1)))=1,$L($G(PH(2)))=3,$L($G(PH(3)))=3,$L($G(PH(4)))=4 S PH=PH(2)_"-"_PH(3)_"-"_PH(4) Q
188 . . I $L($G(PH(1)))=3,$L($G(PH(2)))=3,$L($G(PH(3)))=4 S PH=PH(1)_" "_PH(2)_"-"_PH(3) Q
189 . . I $L($G(PH(1)))=3,$L($G(PH(2)))=4 S PH=" "_PH(1)_"-"_PH(2) Q
190 . . Q
191 . I $L(PH)>9 S PH=$E(PH,1,3)_" "_$E(PH,4,6)_"-"_$E(PH,7,10) Q
192 . I $L(PH)>6 S PH=" "_$E(PH,1,3)_"-"_$E(PH,4,7) Q
193 . Q
194 Q
195SETBTMSG ;SET ARRAY TO HOLD VENDOR BUSINESS TYPE FIELD MESSAGE
196 S BTMSG(1)="*** BUSINESS TYPE UNDEFINED ***"
197 S BTMSG(1,"F")="$C(7),!"
198 ;
199 ;IF NOT ENTERING A PURCHASE ORDER, DON'T DISPLAY REMAINDER OF MSG
200 ;
201 I '$D(PRCHPO) S BTMSG(2)="",BTMSG(2,"F")="!" Q
202 S BTMSG(2)="You will not be able to complete this Purchase Order"
203 S BTMSG(2,"F")="!"
204 S BTMSG(3)="with this vendor until the BUSINESS TYPE is defined"
205 S BTMSG(3,"F")="$C(7),!"
206 S BTMSG(4)=""
207 S BTMSG(4,"F")="!"
208 Q
Note: See TracBrowser for help on using the repository browser.