source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCVRE1.m@ 802

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

initial load of FOIAVistA 6/30/08 version
File size: 8.3 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**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, 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 F X8=1:1 S PRCFCP=$O(TMP($J,PRCFCP)) Q:PRCFCP="" D
135 .S PRCFCP1=X8
136 .S PRCCC=""
137 .F X9=1:1 S PRCCC=$O(TMP($J,PRCFCP,PRCCC)) Q:PRCCC="" D
138 ..S PRCCC1=X9
139 I (PRCFCP1>1)!(PRCCC1>1) D Q
140 .S $P(^TMP("PRCVRIL",$J,"NAK",2),PRCFS,2)="Message contains multiple FCP's or CC's: "_HL("ETN") D NAKIT^PRCVREA
141 ;
142PARSIT ;Read the ^TMP global and build the ^XTMP global to pass to IFCAP
143 ;
144 S PRCI=0,PRCJ=0,LENVAL="OK"
145 F S PRCI=$O(^TMP("PRCVRE",$J,PRCSUB,PRCI)) Q:PRCI="" Q:LENVAL="NOTOK" D
146 .S NODE1=$G(^TMP("PRCVRE",$J,PRCSUB,PRCI)) Q:NODE1=""
147 .F PRCJ=1:1 D Q:$G(^TMP("PRCVRE",$J,PRCSUB,PRCI,PRCJ))=""
148 ..S NODE2=$G(^TMP("PRCVRE",$J,PRCSUB,PRCI,PRCJ))
149 ..I $L(NODE1)+$L(NODE2)>1024 S LENVAL="NOTOK" Q
150 ..S NODE1=NODE1_NODE2
151 .Q:LENVAL="NOTOK"
152 .S PRCNODE=$E(NODE1,1,3)
153 .;
154 .; IF MSH segment ignore the record
155 .;
156 .I PRCNODE="MSH" Q
157 .S PRCNODE2=$E(NODE1,5,$L(NODE1))
158 .;
159 .; If ORC segment process the record
160 .;
161 .I PRCNODE="ORC" D Q
162 ..I $D(^XTMP(PRCSUB,1))'=0 Q
163 ..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)
164 ..S PRCFCP=$P(PRCNODE2,PRCFS,3),PRCCC=$P(PRCNODE2,PRCFS,17)
165 ..S PRCDATE=$$HL7TFM^XLFDT(DYNADATE)
166 ..S $P(^XTMP(PRCSUB,1),U,1)=0
167 ..S $P(^XTMP(PRCSUB,1),U,4)=PRCORD,$P(^XTMP(PRCSUB,1),U,5)=PRCSITE
168 ..S $P(^XTMP(PRCSUB,1),U,6)=PRCDATE,$P(^XTMP(PRCSUB,1),U,7)=PRCEMP
169 .;
170 .; If RQD segment process the record
171 .;
172 .I PRCNODE="RQD" D Q
173 ..S PRCCTR=$P(PRCNODE2,PRCFS,1)
174 ..S PRCDOC=$P(PRCNODE2,PRCFS,2),PRCITM=$P(PRCNODE2,PRCFS,3)
175 ..S PRCQTY=$P(PRCNODE2,PRCFS,5),DYNADATE=$P(PRCNODE2,PRCFS,10)
176 ..S PRCNEED=$$HL7TFM^XLFDT(DYNADATE)
177 .;
178 .;If RQ1 segment process the record and build the XTMP global record
179 .;
180 .I PRCNODE="RQ1" D Q
181 ..S PRCCOST=$P(PRCNODE2,PRCFS,1),PRCBOC=$P(PRCNODE2,PRCFS,3),PRCVND=$P(PRCNODE2,PRCFS,4),PRCNIF=$P(PRCNODE2,PRCFS,5)
182 ..;
183 ..; Now build the XTMP record
184 ..;
185 ..S PRCVINDX=$P($G(^XTMP(PRCSUB,1)),U,1)
186 ..I PRCCTR>PRCVINDX S $P(^XTMP(PRCSUB,1),U,1)=PRCCTR
187 ..S $P(^XTMP(PRCSUB,1),U,2)=PRCFCP
188 ..S $P(^XTMP(PRCSUB,1),U,3)=PRCCC
189 ..S ^XTMP(PRCSUB,2,PRCCTR)=PRCITM_U_PRCQTY_U_PRCVND_U_PRCCOST_U_PRCNEED_U_PRCDOC_U_PRCNIF_U_PRCBOC
190 ;
191 I LENVAL="NOTOK" D Q
192 .S $P(^TMP("PRCVRIL",$J,"NAK",2),PRCFS,2)="HL7 Segment length greater than 1K"
193 .D NAKIT^PRCVREA
194 .K ^XTMP(PRCSUB)
195 D CALLIT^PRCVREA
196 Q
197 ;
198BUILD ;Build the ^XTMP global zero node record.
199 ;
200 S XX=$$HTFM^XLFDT($H,1)
201 S X1=$$FMADD^XLFDT(XX,5)
202 S ^XTMP(PRCSUB,0)=X1_U_XX_"^Transmit message to IFCAP to build the RIL"_U_$H
203 Q
204 ;
205CLEANUP ;This area will kill all temporary globals and variables
206 ;
207 K ^TMP("PRCVRE",$J),TMP($J)
208 K ^TMP("HLA",$J)
209 K ^TMP("PRCVRIL",$J)
210 K PRCCTR,PRCCNT,PRCORD,DYNADATE,PRCDATE,PRCEMP,PRCSITE,PRCDOC
211 K PRCITM,PRCQTY,PRCFCP,PRCCC,PRCNIF,PRCBOC
212 K PRCCOST,PRCVND,PRCSUB,PRCSUB2,PRCDT,PRCNEED
213 K PRCFS,PRCCS,PRCRS,PRCVINDX
214 K ERRARY
215 K PRCFS,PRCRS,PRCNODE,PRCNODE2,PRCI,PRCJ
216 K ACKCNT,NODE1,NODE2,LENVAL
217 K X,X1,X2,X8,X9,XX,TMP,PRCCC1,PRCFCP1
218 ;Fields killed here are used in PRCVREA
219 K MID,MSG,MSGFLG,MYRESULT,PRCDET,PRCHD,ERRLOC,ERRSUB
220 K DOCID,ERRCNT,ERRCOD,ERRDAT,ERRS,ERRSTR,I,II,III,IL,J,ERRTXT,SEVER
221 K TOT,TOTERR,TOTGOOD,TOTREC,FLDNO,PRCVERR,PRCVRES
222 Q
Note: See TracBrowser for help on using the repository browser.