source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVRCG.m@ 1046

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

initial load of WorldVistAEHR
File size: 6.8 KB
Line 
1PRCVRCG ;ISC-SF/GJW; Receive messages ; 5/24/05 10:56am
2 ;;5.1;IFCAP;**81**;Oct. 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5SUB(PRCVACT) ;
6 N PRCVFS,PRCVCS,PRCVRS,PRCVES,PRCVSS,HLQUIT,HLNODE
7 N PRCVMSG,PRCVMID,PRCVSEG,X,PRCVEVN,PRCVEVT,PRCVSTAT,PRCVCP
8 N HLQUIT,HLNODE,X1,MYERR,MYSEQ
9 S PRCVFS=$G(HL("FS"))
10 S PRCVCS=$E($G(HL("ECH")),1)
11 S PRCVRS=$E($G(HL("ECH")),2)
12 S PRCVES=$E($G(HL("ECH")),3)
13 S PRCVSS=$E($G(HL("ECH")),4)
14 S (HLQUIT,HLNODE)=0
15 ;Note: the following variable is KILLed to avoid certain
16 ;problems with $$REPROC^HLUTIL
17 K HLDONE1
18 S PRCVMSG=$G(HL("MTN"))
19 S PRCVMID=$G(HL("MID"))
20 I ((PRCVACT=1)&(PRCVMSG'="QSB"))!((PRCVACT=2)&(PRCVMSG'="QCN")) D Q
21 .;Error: wrong message type
22 .S MYERR("HL_CODE")="HL200"
23 .S MYERR("HL_TEXT")="Unsupported Message Type"
24 .S MYSEQ("FIELD_POS")=9 ;message type
25 .S MYSEQ("SEG_POS")=1
26 .D ACK("AR",PRCVMID,"MSH",.MYSEQ,.MYERR)
27 X HLNEXT I HLQUIT'>0 D Q
28 .;Error: MSH segment not found
29 .S MYERR("HL_CODE")="HL100"
30 .S MYERR("HL_TEXT")="Segment Sequence Error"
31 .S MYSEQ("SEG_POS")=1
32 .D ACK("AE",$G(PRCVMID),"MSH",1,.MYERR)
33 X HLNEXT I HLQUIT'>0 D Q
34 .;Error: no segments after MSH
35 S PRCVSEG=$$FLD^HLCSUTL(.HLNODE,1)
36 I ((PRCVACT=1)&(PRCVSEG'="QPD")) D Q
37 .;Error: QPD segment expected
38 .S MYERR("HL_CODE")="HL100"
39 .S MYERR("HL_TEXT")="Segment Sequence Error"
40 .S MYSEQ("SEG_POS")=2
41 .D ACK("AE",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
42 I ((PRCVACT=2)&(PRCVSEG'="QID")) D Q
43 .;Error: QID segment expected
44 .S MYERR("HL_CODE")="HL100"
45 .S MYERR("HL_TEXT")="Segment Sequence Error"
46 .S MYSEQ("SEG_POS")=2
47 .D ACK("AE",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
48 S X=$$FLD^HLCSUTL(.HLNODE,$S(PRCVACT=1:2,PRCVACT=2:3,1:999))
49 I (X="") D Q
50 .S MYERR("HL_CODE")="HL101"
51 .S MYERR("HL_TEXT")="Required field missing"
52 .S MYSEQ("SEG_POS")=2
53 .S MYSEQ("FIELD_POS")=$S(PRCVSEG="QPD":1,PRCVSEG="QID":2,1:"")
54 .D ACK("AE",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
55 S PRCVEVN=$P(X,PRCVCS,1)
56 S PRCVEVT=$P(X,PRCVCS,2)
57 I PRCVEVN'="Q16" D Q
58 .;Error: wrong event code
59 .S MYERR("HL_CODE")="HL207"
60 .S MYERR("HL_TEXT")="Application internal error"
61 .S MYSEQ("SEG_POS")=1
62 .S MYSEQ("FIELD_POS")=$S(PRCVACT=1:2,PRCVACT=1:2)
63 .S MYSEQ("CMP_POS")=1
64 .D ACK("AR",PRCVMID,$S(PRCVACT=1:"QPD",1:"QID"),.MYSEQ,.MYERR)
65 I PRCVEVT'="Fund_Subscription" D Q
66 .;Error: wrong event
67 .S MYERR("HL_CODE")="HL207"
68 .S MYERR("HL_TEXT")="Application internal error"
69 .S MYSEQ("SEG_POS")=2
70 .S MYSEQ("FIELD_POS")=$S(PRCVACT=1:2,PRCVACT=1:2)
71 .S MYSEQ("CMP_POS")=2
72 .D ACK("AR",PRCVMID,$S(PRCVACT=1:"QPD",1:"QID"),.MYSEQ,.MYERR)
73 I ((PRCVACT=2)&(PRCVEVT'="Fund_Subscription")) D Q
74 .;Error: wrong event
75 .S MYERR("HL_CODE")="HL207"
76 .S MYERR("HL_TEXT")="Application internal error"
77 .S MYSEQ("SEG_POS")=2
78 .S MYSEQ("FIELD_POS")=2
79 .S MYSEQ("CMP_POS")=2
80 .D ACK("AR",PRCVMID,"QID",.MYSEQ,.MYERR)
81 S X=$$FLD^HLCSUTL(.HLNODE,$S(PRCVACT=1:3,PRCVACT=2:2,1:999))
82 I (X="") D Q
83 .S MYERR("HL_CODE")="HL101"
84 .S MYERR("HL_TEXT")="Required field missing"
85 .S MYSEQ("SEG_POS")=2
86 .S MYSEQ("FIELD_POS")=$S(PRCVSEG="QPD":3,PRCVSEG="QID":2,1:"")
87 .D ACK("AE",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
88 S PRCVSTAT=$P(X,"-",1)
89 S PRCVCP=+$P(X,"-",2)
90 I '$D(^PRC(420,PRCVSTAT,0)) D Q
91 .;invalid station number
92 .S MYERR("HL_CODE")="HL204"
93 .S MYERR("HL_TEXT")="Unknown key identfier"
94 .S MYSEQ("SEG_POS")=2
95 .S MYSEQ("FIELD_POS")=$S(PRCVSEG="QPD":2,PRCVSEG="QID":1,1:"")
96 .D ACK("AR",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
97 I '$D(^PRC(420,PRCVSTAT,1,PRCVCP,0)) D Q
98 .;invalid station/FCP pair
99 .S MYERR("HL_CODE")="HL204"
100 .S MYERR("HL_TEXT")="Unknown key identfier"
101 .S MYSEQ("SEG_POS")=2
102 .S MYSEQ("FIELD_POS")=$S(PRCVSEG="QPD":2,PRCVSEG="QID":1,1:"")
103 .D ACK("AR",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
104 G:PRCVACT=2 DEL
105 S X1=$$ADDSUB^PRCVSUB(PRCVSTAT,PRCVCP,1)
106 I $P(X1,"^",1)["?" D Q
107 .;Duplicate
108 .;S MYERR("SEVERITY")="W"
109 .D ACK("AA",PRCVMID)
110 I $P(X1,"^",1)="E" D Q
111 .;Fileman generated error
112 .S MYERR("HL_CODE")="HL207"
113 .S MYERR("HL_TEXT")="Application internal error"
114 .S MYSEQ("SEG_POS")=2
115 .D ACK("AR",PRCVSEG,.MYSEQ,.MYERR)
116 G:PRCVACT=2 DONE ;end of message
117 X HLNEXT I HLQUIT'>0 D Q
118 .;Error: RCP segment expected
119 .S MYERR("HL_CODE")="HL100"
120 .S MYERR("HL_TEXT")="Segment sequence error"
121 .S MYSEQ("SEG_POS")=3
122 .D ACK("AE",PRCVMID,PRCVSEG,.MYSEQ,.MYERR)
123 G DONE
124DEL ;
125 S X1=$$DELSUB^PRCVSUB(PRCVSTAT,+PRCVCP,1)
126 I X1["E" D Q
127 .;Error during Fileman call
128 .S MYERR("HL_CODE")="HL207"
129 .S MYERR("HL_TEXT")="Application internal error"
130 .S MYSEQ("SEG_POS")=1
131 .S MYSEQ("FIELD_POS")=1
132 .D ACK("AE",PRCVMID,"QID",.MYSEQ,.MYERR)
133 I X1'["@" D Q
134 .;Deletion error
135 .S MYERR("HL_CODE")="HL207"
136 .S MYERR("HL_TEXT")="Application internal error"
137 .S MYSEQ("SEG_POS")=1
138 .S MYSEQ("FIELD_POS")=1
139 .D ACK("AE",PRCVMID,"QID",.MYSEQ,.MYERR)
140DONE ;
141 ;Success!
142 D ACK("AA",PRCVMID)
143 Q
144 ;
145ACK(PRCVSTAT,PRCVOMID,PRCVSID,PRCVSEQ,PRCVERR) ;
146 N HLA,ERR,I,SEV,PRCVEID,PRCVAPP,PRCVEIDS,PRCVRES
147 ;Make sure the parameters are defined
148 S PRCVSTAT=$G(PRCVSTAT),PRCVOMID=$G(PRCVOMID),PRCVSID=$G(PRCVSID)
149 S HLA("HLA",1)="MSA"_PRCVFS_$G(PRCVSTAT)_PRCVFS_$G(PRCVOMID)
150 S SEV=$S($D(PRCVERR("SEVERITY")):$G(PRCVERR("SEVERITY")),1:"E")
151 ;set some variables
152 S PRCVEID=$G(HL("EID"))
153 S PRCVEIDS=$G(HL("EIDS"))
154 ;S PRCVAPP=$$FIND1^DIC(771,,"MX","PRCV_DYNAMED")
155 Q:(($L(PRCVEID)=0)!($L($G(HLMTIENS))=0)!($L(PRCVEIDS)=0))
156 S PRCVRES=""
157 S:PRCVSTAT="AA" HLA("HLA",1)=HLA("HLA",1)_PRCVFS_"OK"
158 D:$L(PRCVSID)>0
159 .S ERR="ERR"_PRCVFS_PRCVFS_PRCVSID_PRCVCS_$G(PRCVSEQ("SEG_POS"))
160 .S ERR=ERR_PRCVCS_$G(PRCVSEQ("FIELD_POS"))_PRCVFS
161 .;S ERR=ERR_PRCVCS_$G(PRCVSEQ("FIELD_POS"))_PRCVCS
162 .;S ERR=ERR_$G(PRCVSEQ("FIELD_REP"))_PRCVCS_$G(PRCVSEQ("CMP_POS"))
163 .;S ERR=ERR_PRCVCS_$G(PRCVSEQ("SUBCMP_POS"))_PRCVFS
164 .;S ERR=ERR_$G(PRCVSEQ("FIELD_REP"))_PRCVFS
165 .S ERR=ERR_$G(PRCVERR("HL_CODE"))_PRCVCS_$G(PRCVERR("HL_TEXT"))
166 .S ERR=ERR_PRCVCS_"0357"_PRCVFS_SEV_PRCVFS
167 .I $D(PRCVERR("APP",1)) D
168 ..;application error(s)
169 ..S ERR=ERR_$G(PRCVERR("APP",1,"CODE"))_PRCVCS_$G(PRCVERR("APP",1,"TEXT"))
170 ..S I=1
171 ..F S I=$O(PRCVERR("APP",I)) Q:((I="")!(I>10)) D
172 ...S ERR=ERR_PRCVRS
173 ...S ERR=ERR_$G(PRCVERR("APP",I,"CODE"))_PRCVCS
174 ...S ERR=ERR_$G(PRCVERR("APP",I,"TEXT"))
175 .S HLA("HLA",2)=ERR
176 D GENACK^HLMA1(PRCVEID,$G(HLMTIENS),PRCVEIDS,"LM",1,.PRCVRES)
177 Q
178 ;
179PUBACK ;
180 N PRCVFS,PRCVCS,PRCVRS,PRCVES,PRCVSS,HLQUIT,HLNODE,X
181 N ATYPE,OMID,SEQ,ERR,I,X1,ECNT,RFAC
182 S PRCVFS=$G(HL("FS"))
183 S PRCVCS=$E($G(HL("ECH")),1)
184 S PRCVRS=$E($G(HL("ECH")),2)
185 S PRCVES=$E($G(HL("ECH")),3)
186 S PRCVSS=$E($G(HL("ECH")),4)
187 S (HLQUIT,HLNODE)=0
188 ;Note: the following variable is KILLed to avoid certain
189 ;problems with $$REPROC^HLUTIL
190 K HLDONE1
191 S PRCVMSG=$G(HL("MTN"))
192 S PRCVMID=$G(HL("MID"))
193 Q:HL("MTN")'="MFK"
194 X HLNEXT ;read MSH
195 I HLQUIT'>0 Q
196 S X=$$FLD^HLCSUTL(.HLNODE,1)
197 Q:X'="MSH"
198 S RFAC=$P($$FLD^HLCSUTL(.HLNODE,6),PRCVCS,1)
199 X HLNEXT ;read MSA
200 I HLQUIT'>0 Q
201 S X=$$FLD^HLCSUTL(.HLNODE,1)
202 Q:X'="MSA"
203 S ATYPE=$$FLD^HLCSUTL(.HLNODE,2)
204 ;No need to go further
205 Q
Note: See TracBrowser for help on using the repository browser.