source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCOEDI.m@ 1608

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

initial load of FOIAVistA 6/30/08 version
File size: 6.9 KB
Line 
1PRCOEDI ;WISC/DJM-IFCAP EDI ENTRY ROUTINE ; 7/21/99 11:24am
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; Receives variable PRCOPODA from calling routines.
6 ;
7 ; PRCOPODA = sting of up to 4 '^' pieces.
8 ; piece 1 = ien of 442 record
9 ; piece 2 = (optional) flag if not new order
10 ; piece 3 = (optional) amendment number
11 ; piece 4 = (optional) ien of 442 record if
12 ; amendment is PO number change
13 ;
14 ; piece 2 flag values:
15 ; 1 = create a PHM, do not transmit to EDI
16 ; 2 = create a PHA, do not transmit to EDI
17 ;
18NEW N A,AMEND,A1,A12,CSDA,IEN,MO,PRC,PRCFA,PRCFASYS,PRCPXMZ,PTSW,RECORD
19 N REQUEST,SERVICE,TEST,TOTAL,VAR1,VAR2,VAR3,VEN,V1,V2,V3,V4,V5,V6
20 N W1,W2,YR,XMZ
21 S VAR1=$P(PRCOPODA,"^",1)
22 S W2="PHA"
23 I $P(PRCOPODA,"^",2)=1 S W2="PHM"
24 S AMEND=0
25 I $P(PRCOPODA,"^",2)]"" S AMEND=1 ; amendment, don't send to EDI
26 S A=$G(^PRC(442,VAR1,0))
27 I A="" W:'AMEND W2," not generated - purchase order corrupted.",!! Q
28 S PRC("SITE")=$P($P(A,U),"-")
29 S YR=$E(DT,2,3)
30 S MO=$E(DT,4,5)
31 S PRC("FY")=$E(100+$S(MO>9:YR+1,1:YR),2,3)
32 S SERVICE=$P(A,U,12)
33 I SERVICE>0 D I $G(REQUEST)=3 W:'AMEND W2," not generated - inappropriate for this order.",!! Q
34 . S RECORD=$G(^PRC(442,VAR1,13,SERVICE,0))
35 . I RECORD]"" S REQUEST=$P(RECORD,U,9)
36 S A1=$G(^PRC(442,VAR1,1))
37 I A1="" W:'AMEND W2," not generated - PO informated corrupted",!! Q
38 I $P(A1,U,7)=1 W W2," not generated - not used for GSA Supply Depot orders.",!! Q
39 K ^TMP($J,"STRING")
40 S VAR2=""
41 S A12=$G(^PRC(442,VAR1,12))
42 I A12]"",'AMEND G:$P(A12,U,10)>0 EXIT ;Already has EDI message #
43 I 'AMEND S $P(A12,U,10)=999999999,^PRC(442,VAR1,12)=A12
44 ;
45 ; build segments
46 D HE^PRCOE3(PRCOPODA,.VAR2) G:VAR2]"" EXIT
47 D BI^PRCOE1(A,VAR1,.VAR2) G:VAR2]"" EXIT
48 D VE^PRCOE1(A1,.VAR2) G:VAR2]"" EXIT
49 D ST^PRCOE1(A,A1,VAR1,.VAR2) G:VAR2]"" EXIT
50 D MI^PRCOE3(VAR1,.VAR2) G:VAR2]"" EXIT
51 D AC^PRCOE4(A,A1,VAR1,.VAR2) G:VAR2]"" EXIT
52 S TOTAL="" D IT^PRCOE2(VAR1,.VAR2,.TOTAL) G:VAR2]"" EXIT
53 D CO^PRCOE3(VAR1,.VAR2,.TOTAL) G:VAR2]"" EXIT
54 ;
55 S IEN=$S($P($G(^PRC(442,VAR1,23)),U,7)>0:$P(^(23),U,7),1:PRC("SITE"))
56 S PTSW=$P($G(^PRC(411,IEN,9)),U,4) ; test or production site
57 S V2=""
58 S VEN=$P(A1,U)
59 I VEN>0,'AMEND S V1=$G(^PRC(440,VEN,3)),V2=$P(V1,U,2)
60 S W1=PRC("SITE")
61 S V3=$P($P(A,U),"-")_$P($P(A,U),"-",2)
62 S V4=$S(PTSW="T":"IST",1:"ISM")
63 I 'AMEND,V2="Y",$P($G(^PRC(442,VAR1,23)),U,11)'="P",$P($G(^(12)),U,16)'="n" S V4=$S(PTSW="T":"IST^EDT",1:"ISM^EDP")
64 I AMEND D EN^DDIOL("...now generating the "_W2_" transaction...","","!!")
65 D TRANSMIT^PRCPSMCS(W1,W2,V3,V4,200,1)
66 S XMZ=$O(PRCPXMZ(0))
67 I XMZ>0 S $P(^PRC(442,VAR1,12),U,10)=PRCPXMZ(XMZ)
68 I AMEND G EXIT
69 ;
70 ; NOW, IF THIS IS NOT FROM AMENDMENTS AND IS AN EDI 'PHA',
71 ; LETS ADD IT TO FILE 443.75.
72 ;
73 S W1=$P(A,U)
74 S W2="PHA"
75 S V3=PRCPXMZ(XMZ)
76 S V5=$P(A1,U,10)
77 S V6=VAR1
78 S VAR3=$P(A1,U)
79 S V4=$P($G(^PRC(440,VAR3,3)),U,3)
80 I V2="Y",$P($G(^PRC(442,VAR1,12)),U,16)'="n",$P($G(^(23)),U,11)'="P" D ENTER^PRCOEDI(W1,W2,V3,V4,V5,V6)
81 ;
82EXIT I VAR2]"" W:'AMEND W2," not generated - missing information (data code: ",VAR2,")",!!
83 K ^TMP($J,"STRING"),PRCOUT Q
84 ;
85VDEC(VALUE,LENGTH) ;
86 ; EXTRINSIC FUNCTION TO CONVERT NUMBER WITH DECIMAL INTO VIRTUAL
87 ; DECIMAL.
88 ;
89 ; VALUE = NUMBER WITH DECIMAL TO CONVERT
90 ; LENGTH = NUMBER OF VIRTUAL DECIMAL PLACES
91 ;
92 ; CALLED FROM PRCOE4
93 ;
94 N V1,V2
95 S (V1,V2)="" G:'$D(VALUE) EXIT1
96 S V1=$P(VALUE,".",1),V2=$P(VALUE,".",2)
97 I '$D(LENGTH) S LENGTH=0,V2="" G EXIT1
98 I LENGTH=0 S V2="" G EXIT1
99 I LENGTH>0,LENGTH'<$L(V2) S $P(V2,"0",LENGTH)="0",V2=$E(V2,1,LENGTH)
100 I LENGTH>0,LENGTH<$L(V2) S V2=$E(V2,1,LENGTH)
101EXIT1 Q V1_V2
102 ;
103ENTER(ENTRY,TRANS,XMZ,VENDOR,SENDER,POINTER,RFQ,TXT) ;
104 ;
105 ; THIS IS THE PARAMETER PASSED CALL TO ENTER A NEW ENTRY INTO
106 ; FILE 443.75. ONE ENTRY WILL BE CREATED FOR EACH 'PHA'
107 ; TRANSACTION. ONE OR MORE ENTRIES WILL BE CREATED FOR EACH 'RFQ'
108 ; OR 'TXT' TRANSACTION (THE CALLING ROUTINE WILL HAVE TO MAKE
109 ; SEPARATE CALLS, ONE FOR EACH DIFFERENT VENDOR).
110 ;
111 ; INPUT PARAMETERS WHAT IT REPRESENTS
112 ; ENTRY IF THE TRANSACTION IS A 'PHA' THEN SEND
113 ; THE FILE 442, .01 FIELD VALUE.
114 ; IF THE TRANSACTION IS A 'RFQ' OR A 'TXT'
115 ; SEND THE RFQ NUMBER.
116 ; TRANS SEND THE TYPE OF TRANSACTION BEING SENT
117 ; TO AUSTIN ('PHA', 'RFQ' OR 'TXT').
118 ; XMZ THE MAILMAN NUMBER OF THE TRANSACTION.
119 ; VENDOR THE VENDOR ID USED IN THE TRANSACTION.
120 ; SENDER THE DUZ OF THE PERSON CREATING THE
121 ; TRANSACTION ENTERING INTO FILE 443.75.
122 ; POINTER THE INTERNAL ENTRY NUMBER OF THE ENTRY.
123 ; RFQ THIS FIELD WILL CONTAIN '00' OR '01'.
124 ; '00' IS A NORMAL RFQ.
125 ; '01' IS A CANCELLED RFQ.
126 ; TXT THE TXT MESSAGE NUMBER. THIS PARAMETER
127 ; IS OPTIONAL. ALL OTHER PARAMETERS ARE
128 ; REQUIRED.
129 ;
130 ; NOTHING ADDITIONAL IS RETURNED FROM THIS CALL.
131 ;
132 ; ALL PASSED PARAMETERS ARE UNCHANGED.
133 ;
134 N I,IEN,PRCNO,PRC,PRCDA
135 S IEN=""
136 ; SEE IF THE TRANSACTION IS ALREADY ENTERED IN FILE 443.75.
137 ; IF SO JUST UPDATE THE MAILMAN MESSAGE NUMBER AND DATE/TIME
138 ; THE MESSAGE WS MAILED.
139 ;
140 I TRANS="PHA" D I IEN>0 Q
141 . S IEN=$O(^PRC(443.75,"AO",TRANS,ENTRY,VENDOR,0))
142 . I IEN>0 D UPDATE
143 . Q
144 ;
145 I TRANS="RFQ" D I IEN>0 Q
146 . S IEN=$O(^PRC(443.75,"AC",TRANS,ENTRY,VENDOR,RFQ,0))
147 . I IEN>0 D UPDATE
148 . Q
149 ;
150 I TRANS="TXT" D I IEN>0 Q
151 . S IEN=$O(^PRC(443.75,"AF",TRANS,ENTRY,VENDOR,TXT,0))
152 . I IEN>0 D UPDATE
153 . Q
154 ;
155 ; CONTINUE HERE IF NO RECORD OF THE TRANSACTION WAS FOUND.
156 ;
157 F I=1:1:100 L +^PRC(443.75):1 Q:$T=1
158 G:'$T STOP
159 K PRCNO
160 S PRCNO=1+$O(^PRC(443.75,"B",""),-1)
161 S PRC(1,443.75,"?+1,",.01)=PRCNO
162 S PRC(2)=""
163 D UPDATE^DIE("","PRC(1)","PRC(2)")
164 S PRCDA=PRC(2,1)
165 L -^PRC(443.75)
166 ;
167 ; HAVING CREATED A NEW ENTRY LETS POPULATE IT.
168 ;
169 F L +^PRC(443.75,PRCDA):1 Q:$T=1
170 S X=$P($$NET^XMRENT(XMZ),U)
171 S %DT="ST"
172 D ^%DT
173 S:Y>0 PRC(1,443.75,"?+1,",6)=Y
174 S PRC(1,443.75,"?+1,",1)=ENTRY
175 S PRC(1,443.75,"?+1,",3)=TRANS
176 S PRC(1,443.75,"?+1,",5)=VENDOR
177 S PRC(1,443.75,"?+1,",4)=XMZ
178 S PRC(1,443.75,"?+1,",5.5)=SENDER
179 S:TRANS="RFQ" PRC(1,443.75,"?+1,",6.5)=RFQ
180 S:$G(TXT)]"" PRC(1,443.75,"?+1,",2)=TXT
181 S:TRANS="PHA" PRC(1,443.75,"?+1,",7)=POINTER
182 S:TRANS'="PHA" PRC(1,443.75,"?+1,",8)=POINTER
183 S PRC(1,443.75,"?+1,",.01)=PRCDA
184 D UPDATE^DIE("","PRC(1)")
185 L -^PRC(443.75,PRCDA)
186STOP Q
187 ;
188UPDATE ; COME HERE TO UPDATE AN EXISTING RECORD IN FILE 443.75.
189 S PRC(1,443.75,"?+1,",.01)=IEN
190 S PRC(1,443.75,"?+1,",4)=XMZ
191 S X=$P($$NET^XMRENT(XMZ),U)
192 S %DT="ST"
193 D ^%DT
194 S:Y>0 PRC(1,443.75,"?+1,",6)=Y
195 F L +^PRC(443.75,IEN):1 Q:$T=1
196 D UPDATE^DIE("","PRC(1)")
197 L -^PRC(443.75,IEN)
198 G STOP
Note: See TracBrowser for help on using the repository browser.