source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVRE1.m@ 613

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

initial load of WorldVistAEHR
File size: 8.4 KB
Line 
1PRCVRE1 ;WOIFO/VC-Transmit HL7 message to IFCAP for requisition received from DynaMed ; 11/3/04 3:13pm ; 5/6/05 3:43pm
2 ;;5.1;IFCAP;**81,119**;Oct 20, 2000;Build 8
3 ;Per VHA Directive 2004-038, this routine should not be modified
4 ;
5 ;An exemption from the 245 character length standard for a variable
6 ; has been requested from the SACC for reading HL7 segments into
7 ; a single variable. The limit is request to be 1K and if longer
8 ; than that the system will exit with an Application ACK reject.
9 ; Submitted 4/14/05.
10 ;
11 ;This routine processes messages from DynaMed to IFCAP to build a RIL
12 ;
13 ;HL("MID") - Message Control ID
14 ;HL7DT - Today's date in HL7 format
15 ;PRCDT - Date value
16 ;ORC Segment will repeat for each item
17 ; PRCORD - Order control should be NW for new order - ORC-1
18 ; PRCFCP - Fund control Point - ORC-3
19 ; PRCDATE - Date and time item entered - ORC-9
20 ; PRCEMP - Enter by - ORC-10 DUZ^Lname^Fname^Approving Authority
21 ; PRCCC - Cost Center - ORC-17
22 ; PRCSITE - Site Code should be 516 - ORC-21
23 ;RQD Segment will repeat for each item
24 ; PRCCTR - Item counter - RQD-1
25 ; PRCDOC - DynaMed Document number - unique per item - RQD-2
26 ; PRCITM - Item number $p1 of RQD-3
27 ; PRCQTY - Item quantity - RQD-5
28 ; PRCNEED - Date Needed - RQD-10
29 ;RQ1 Segment one segment for each RQD segment
30 ; PRCCOST - Estimated Unit Cost - RQ1-1
31 ; PRCBOC - BOC Number - RQ1-3
32 ; PRCVND - Vendor number - pointer to file 440 - RQ1-4
33 ; PRCNIF - National Item File number - RQ1-5
34 ;PRCTYP - Repetitive Item List type - default to blank
35 ;Message builds an ^XTMP to pass data to IFCAP RIL build routine.
36 ; The first node is "PRCVRE*"+the Message Control ID. The next nodes
37 ; are 0,1, and 2. The 0 node is the standard ^XTMP structure plus
38 ; $H. The $H is used to measure transmission timing. The 1 node holds
39 ; header data common to all detail items being transmitted. The 2
40 ; node holds detail information about each item ordered in a counter
41 ; sub-node.
42 ; Under the 1 and 2 nodes are "ERR" subnodes that hold error
43 ; information about each item. There can be multiple errors
44 ; associated with each item, therefore there are multiple sub-nodes
45 ; possible under each "ERR" node.
46 ;Counters
47 ; PRCCNT, ACKCNT,PRCCC1,PRCFCP1,X,X1,X2,X8,X9,I,II,LL,ERRCNT
48 ;ERRCOD - Error code from IFCAP
49 ;ERRDAT - Error data from IFCAP
50 ;ERRSTR - Error text from IFCAP
51 ;ERRSUB - A substring of ERRSTR
52 ;ERRS - Error substring from IFCAP
53 ;SEVER - Error severity value - W or E
54 ;TOT,TOTERR,TOTGOOD,TOTREC - Counters of errors returned to DM
55 ;FLDNO - Field identified in an error message
56 ;ERRVAL - ERROR FLAG
57 ;ERRARY - Message Error array sent to Prosthetics
58 ;ERRLOC - Location of error sent in ACK
59 ;PRCCS, PRCFS, PRCRS - Field delimiters
60 ;PRCNODE - Message segment identifier
61 ;Temporary Globals
62 ; ^TMP("PRCVRIL",$J,"ACK") - Acknowledgement is ok
63 ; ^TMP("PRCVRIL",$J,"NAK") - Acknowledgement is not ok
64 ; ^TMP("HLA",$J) - Message array sent to DynaMed
65 ; ^XTMP("PRCVRE*"_Message Control ID,) - Data sent to IFCAP
66 ;Temporary variables
67 ; TMP,MSGFLG,X, X1
68 ;PRCHD - Array to hold map between HL7 and XTMP for Header info
69 ;PRCDET - Array to hold map between HL7 and XTMP for Detail info
70 ;PRCVERR - Array to hold error messages for MailMan
71 ;PRCSUB - XTMP first node
72 ;PRCSUB2 - Second $p of PRCSUB equal to Message Control ID
73 ;PRCVRES - Return variable from GENACK - Note:this doesn't work.
74 ;PRCVINDX - Index number into XTMP to keep track of number of items
75 ;
76 Q
77 ;
78BEGIN N PRCORD,DYNADATE,PRCDATE,PRCEMP,PRCSITE
79 N PRCDOC,PRCITM,PRCQTY,PRCFCP,PRCCC
80 N PRCCOST,PRCVND,PRCBOC,PRCNEED,PRCNIF
81 N PRCSUB,PRCSUB2,PRCDT,PRCVINDX
82 N ERRARY,PRCCS,PRCFS,PRCRS,PRCNODE,PRCNODE2
83 N ACKCNT,NODE1,NODE2,PRCCTR,PRCCNT,PRCI,PRCJ,MID
84 N X,X1,X2,X8,X9,XX,TMP,PRCCC1,PRCFCP1,LENVAL
85 ; Fields used in PRCVREA are NEWed and KILLed here
86 N MSG,MSGFLG,DOCID,ERRCNT,ERRCOD,ERRDAT,ERRS,ERRSTR,ERRSUB,FLDNO
87 N I,IL,ERRTXT,I,II,III,J,SEVER,TOT,TOTERR,TOTGOOD,TOTREC
88 N PRCDET,PRCHD,PRCVERR,MYRESULT,ERRLOC,PRCVRES
89 D:'$D(U) DT^DICRW
90 S PRCDT=$$NOW^XLFDT
91 S HL7DT=$$FMTHL7^XLFDT(PRCDT),PRCDT=HL7DT
92 S PRCSUB="PRCVRE*"_HL("MID") K ^XTMP(PRCSUB)
93 D BUILD
94 S PRCCNT=0
95 S PRCFS=$G(HL("FS")),PRCCS=$E($G(HL("ECH"))),PRCRS=$E($G(HL("ECH")),2)
96 D START
97 D CLEANUP
98 Q
99 ;
100START ;This will read the incoming message from DynaMed and build ^TMP
101 ;
102SETACK ; Set up information for the ACK or NAK
103 ;
104 K ^TMP("PRCVRIL",$J)
105 S ^TMP("PRCVRIL",$J,"ACK",1)="MSA"_PRCFS_"AA"_PRCFS_HL("MID")
106 S ^TMP("PRCVRIL",$J,"NAK",1)="MSA"_PRCFS_"AE"_PRCFS_HL("MID")
107 S ^TMP("PRCVRIL",$J,"NAK",2)="ERR"_PRCFS
108 S ACKCNT=2
109 ;
110 ;If this is not the right message quit
111 ;
112 I HL("MTN")'="OMN" D Q
113 .S $P(^TMP("PRCVRIL",$J,"NAK",ACKCNT),PRCFS,2)="Wrong Message Type: "_HL("MTN")
114 .D NAKIT^PRCVREA
115 I HL("ETN")'="O07" D Q
116 .S $P(^TMP("PRCVRIL",$J,"NAK",ACKCNT),PRCFS,2)="Wrong Event Type: "_HL("ETN")
117 .D NAKIT^PRCVREA
118 ;
119 S ERRARY(1)="OK"
120 ;
121 ;Read the message and build the ^TMP global
122 ;
123 K ^TMP("PRCVRE",$J)
124 S PRCI=""
125 F PRCI=1:1 X HLNEXT Q:HLQUIT'>0 D
126 .S ^TMP("PRCVRE",$J,PRCSUB,PRCI)=HLNODE,PRCJ=0
127 .F S PRCJ=$O(HLNODE(PRCJ)) Q:'PRCJ S ^TMP("PRCVRE",$J,PRCSUB,PRCI,PRCJ)=HLNODE(PRCJ)
128 .I $E(HLNODE,1,3)="ORC" D
129 ..S PRCFCP=$P(HLNODE,PRCFS,4),PRCCC=$P(HLNODE,PRCFS,18)
130 ..S TMP($J,PRCFCP,PRCCC)=""
131 ;
132 ;Validate that there is only one FCP and CC
133 S PRCFCP="",PRCFCP1=""
134 ; Prevent PRCCC1 undefined PRC*5.1*119
135 S PRCCC1=""
136 F X8=1:1 S PRCFCP=$O(TMP($J,PRCFCP)) Q:PRCFCP="" D
137 .S PRCFCP1=X8
138 .S PRCCC=""
139 .F X9=1:1 S PRCCC=$O(TMP($J,PRCFCP,PRCCC)) Q:PRCCC="" D
140 ..S PRCCC1=X9
141 I (PRCFCP1>1)!(PRCCC1>1) D Q
142 .S $P(^TMP("PRCVRIL",$J,"NAK",2),PRCFS,2)="Message contains multiple FCP's or CC's: "_HL("ETN") D NAKIT^PRCVREA
143 ;
144PARSIT ;Read the ^TMP global and build the ^XTMP global to pass to IFCAP
145 ;
146 S PRCI=0,PRCJ=0,LENVAL="OK"
147 F S PRCI=$O(^TMP("PRCVRE",$J,PRCSUB,PRCI)) Q:PRCI="" Q:LENVAL="NOTOK" D
148 .S NODE1=$G(^TMP("PRCVRE",$J,PRCSUB,PRCI)) Q:NODE1=""
149 .F PRCJ=1:1 D Q:$G(^TMP("PRCVRE",$J,PRCSUB,PRCI,PRCJ))=""
150 ..S NODE2=$G(^TMP("PRCVRE",$J,PRCSUB,PRCI,PRCJ))
151 ..I $L(NODE1)+$L(NODE2)>1024 S LENVAL="NOTOK" Q
152 ..S NODE1=NODE1_NODE2
153 .Q:LENVAL="NOTOK"
154 .S PRCNODE=$E(NODE1,1,3)
155 .;
156 .; IF MSH segment ignore the record
157 .;
158 .I PRCNODE="MSH" Q
159 .S PRCNODE2=$E(NODE1,5,$L(NODE1))
160 .;
161 .; If ORC segment process the record
162 .;
163 .I PRCNODE="ORC" D Q
164 ..I $D(^XTMP(PRCSUB,1))'=0 Q
165 ..S PRCORD=$P(PRCNODE2,PRCFS,1),DYNADATE=$P(PRCNODE2,PRCFS,9),PRCEMP=$P($P(PRCNODE2,PRCFS,10),PRCCS,1,3),PRCSITE=$P(PRCNODE2,PRCFS,21)
166 ..S PRCFCP=$P(PRCNODE2,PRCFS,3),PRCCC=$P(PRCNODE2,PRCFS,17)
167 ..S PRCDATE=$$HL7TFM^XLFDT(DYNADATE)
168 ..S $P(^XTMP(PRCSUB,1),U,1)=0
169 ..S $P(^XTMP(PRCSUB,1),U,4)=PRCORD,$P(^XTMP(PRCSUB,1),U,5)=PRCSITE
170 ..S $P(^XTMP(PRCSUB,1),U,6)=PRCDATE,$P(^XTMP(PRCSUB,1),U,7)=PRCEMP
171 .;
172 .; If RQD segment process the record
173 .;
174 .I PRCNODE="RQD" D Q
175 ..S PRCCTR=$P(PRCNODE2,PRCFS,1)
176 ..S PRCDOC=$P(PRCNODE2,PRCFS,2),PRCITM=$P(PRCNODE2,PRCFS,3)
177 ..S PRCQTY=$P(PRCNODE2,PRCFS,5),DYNADATE=$P(PRCNODE2,PRCFS,10)
178 ..S PRCNEED=$$HL7TFM^XLFDT(DYNADATE)
179 .;
180 .;If RQ1 segment process the record and build the XTMP global record
181 .;
182 .I PRCNODE="RQ1" D Q
183 ..S PRCCOST=$P(PRCNODE2,PRCFS,1),PRCBOC=$P(PRCNODE2,PRCFS,3),PRCVND=$P(PRCNODE2,PRCFS,4),PRCNIF=$P(PRCNODE2,PRCFS,5)
184 ..;
185 ..; Now build the XTMP record
186 ..;
187 ..S PRCVINDX=$P($G(^XTMP(PRCSUB,1)),U,1)
188 ..I PRCCTR>PRCVINDX S $P(^XTMP(PRCSUB,1),U,1)=PRCCTR
189 ..S $P(^XTMP(PRCSUB,1),U,2)=PRCFCP
190 ..S $P(^XTMP(PRCSUB,1),U,3)=PRCCC
191 ..S ^XTMP(PRCSUB,2,PRCCTR)=PRCITM_U_PRCQTY_U_PRCVND_U_PRCCOST_U_PRCNEED_U_PRCDOC_U_PRCNIF_U_PRCBOC
192 ;
193 I LENVAL="NOTOK" D Q
194 .S $P(^TMP("PRCVRIL",$J,"NAK",2),PRCFS,2)="HL7 Segment length greater than 1K"
195 .D NAKIT^PRCVREA
196 .K ^XTMP(PRCSUB)
197 D CALLIT^PRCVREA
198 Q
199 ;
200BUILD ;Build the ^XTMP global zero node record.
201 ;
202 S XX=$$HTFM^XLFDT($H,1)
203 S X1=$$FMADD^XLFDT(XX,5)
204 S ^XTMP(PRCSUB,0)=X1_U_XX_"^Transmit message to IFCAP to build the RIL"_U_$H
205 Q
206 ;
207CLEANUP ;This area will kill all temporary globals and variables
208 ;
209 K ^TMP("PRCVRE",$J),TMP($J)
210 K ^TMP("HLA",$J)
211 K ^TMP("PRCVRIL",$J)
212 K PRCCTR,PRCCNT,PRCORD,DYNADATE,PRCDATE,PRCEMP,PRCSITE,PRCDOC
213 K PRCITM,PRCQTY,PRCFCP,PRCCC,PRCNIF,PRCBOC
214 K PRCCOST,PRCVND,PRCSUB,PRCSUB2,PRCDT,PRCNEED
215 K PRCFS,PRCCS,PRCRS,PRCVINDX
216 K ERRARY
217 K PRCFS,PRCRS,PRCNODE,PRCNODE2,PRCI,PRCJ
218 K ACKCNT,NODE1,NODE2,LENVAL
219 K X,X1,X2,X8,X9,XX,TMP,PRCCC1,PRCFCP1
220 ;Fields killed here are used in PRCVREA
221 K MID,MSG,MSGFLG,MYRESULT,PRCDET,PRCHD,ERRLOC,ERRSUB
222 K DOCID,ERRCNT,ERRCOD,ERRDAT,ERRS,ERRSTR,I,II,III,IL,J,ERRTXT,SEVER
223 K TOT,TOTERR,TOTGOOD,TOTREC,FLDNO,PRCVERR,PRCVRES
224 Q
Note: See TracBrowser for help on using the repository browser.