source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPRHL7A.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 6.0 KB
Line 
1RMPRHL7A ;HINES CIOFO/HNC - Receive HL-7 CPRS Message, parse into components and store in File 668 ;3/13/00
2 ;;3.0;PROSTHETICS;**45,78**;Feb 09, 1996
3 ;
4 ;Patch #78 - 09/25/03 - TH - Add multiple DG1 and ZCL segments.
5 ;
6 Q
7URG(X) ;Return Urgency give Z-code from HL-7 segment; see ORC+9
8 S X=$S(X="S":"STAT",X="R":"ROUTINE",X="ZT":"TODAY",X="Z24":"WITHIN 24 HOURS",X="Z48":"WITHIN 48 HOURS",X="Z72":"WITHIN 72 HOURS",X="ZW":"WITHIN 1 WEEK",X="ZM":"WITHIN 1 MONTH",X="ZNA":"NEXT AVAILABLE",1:X)
9 I $E(X,1)="Z" S X=$S(X="ZT":"TODAY",X="ZE":"EMERGENCY",1:"")
10 Q X
11 ;
12ORC(RMPRORC) ;Get fields from ORC segment and set into RMPR variables
13 ;RMPRTRLC=ORC control code from HL7 Table 119
14 ;RMPRURGI=priority/urgency RMPRPLCR=who entered the order
15 ;RMPRORNP=provider RMPRNATO=nature of order
16 ;RMPRAD=date of request RMPROCR=order request reason
17 ;RMPR RMPRORFN=oe/rr file number
18 ;RMPRO=file 668 IEN - if not a new order
19 ;RMPRS38=order status - taken from Table 38, HL7 standard
20 I $E(RMPRMSG,1,6)'="ORC|NW" S RMPRQT=1 Q
21 S RMPRTRLC=$P(RMPRORC,"|",2)
22 S RMPRORFN=$P(RMPRORC,"|",3)
23 S RMPRORFN=$P($P(RMPRORFN,"^",1),";",1)
24 S RMPRAPP=$P($P(RMPRORC,"|",3),"^",2)
25 S RMPRS38=$P(RMPRORC,"|",6)
26 S RMPRURGI=$P($P(RMPRORC,"|",8),"^",6)
27 S RMPRPLCR=$P(RMPRORC,"|",11)
28 S RMPRORNP=$P(RMPRORC,"|",13)
29 I $L(RMPRURGI) S RMPRURGI=$$URG(RMPRURGI)
30 S RMPRO=+$P($P(RMPRORC,"|",4),"^",1)
31 N RMPRODT S RMPRODT=$P(RMPRORC,"|",16)
32 S RMPRAD=$$FMDATE^RMPRHL7(RMPRODT)
33 S RMPROCR=$P(RMPRORC,"|",17)
34 S RMPRNATO=$P(RMPROCR,"^",5)
35 Q
36OBR(RMPROBR) ;Get fields from OBR segment and set into RMPR variables
37 ;RMPRSS=type of consult, field 9, 1-4 if NO, then not prosthetics
38 ;Must have 99CON in RMPR99C.
39 ;
40 ;RMPRODT=observation date/time
41 ;RMPRPRI=procedure from file ^ORD(101,
42 ;
43 N RMPR99C
44 S RMPR99C=$P($P(RMPROBR,"|",5),"^",6)
45 I RMPR99C'="99CON" S RMPRSS="NO",RMPRQT=1 Q
46 S RMPRSST=$P($P(RMPROBR,"|",5),"^",4)
47 S RMPRSS=$P(^GMR(123.5,RMPRSST,0),U,1) D
48 .;translate to set of codes
49 .I RMPRSS["PROSTHETICS REQUEST" S RMPRSS=1 Q
50 .I RMPRSS["CONTACT LENS REQUEST" S RMPRSS=3 Q
51 .I RMPRSS["HOME OXYGEN REQUEST" S RMPRSS=4 Q
52 .I RMPRSS["EYEGLASS REQUEST" S RMPRSS=2 Q
53 .;then not prosthetics
54 .S RMPRSS="NO"
55 ;
56 I RMPRSS="NO" S RMPRQT=1 Q
57 ;
58 S RMPRODT=$P(RMPROBR,"|",7)
59 I RMPRODT]"" S RMPRODT=$$FMDATE^RMPRHL7(RMPRODT)
60 S RMPRATN=$P(RMPROBR,"|",20)
61 S RMPRSTDT=$P(RMPROBR,"|",23)
62 S RMPRSTDT=$$FMDATE^RMPRHL7(RMPRSTDT)
63 S RMPRS668=$P(RMPROBR,"|",26)
64 S RMPRINTR=$P(RMPROBR,"|",33)
65 Q
66 ;
67DG1(RMPRDG1) ;Get fields from DG1 and ZCL segments
68 ; RMPRSID = Set ID
69 ; RMPRDIAG = pointer to ICD DIAGNOSIS (#80)
70 ; RMPRCI = Outpat. Classification Type
71 ; RMPRVAL = Value of each SC or EI - 0,1,Null.
72 S RMPRMSG=MSG(RMPRDG1)
73 S RMPRSID=$P(RMPRMSG,"|",2)
74 I $P(RMPRMSG,"|",1)="DG1" D
75 . S RMPRDIAG=$P($P(RMPRMSG,"|",4),"^",1)
76 . S RMPRMSG1(RMPRSID,1)=RMPRDIAG
77 I $P(RMPRMSG,"|",1)="ZCL" D
78 . S RMPRCI=$P(RMPRMSG,"|",3)
79 . S RMPRVAL=$P(RMPRMSG,"|",4)
80 . S RMPRMSG1(RMPRSID,RMPRCI+1)=RMPRVAL
81 Q
82 ;
83ZSV(RMPRZSV) ;Get service from ZSV segment
84 S RMPRZSS=$P($P(RMPRZSV,"|",2),"^",4)
85 ;Set the service if ZSV provided
86 I $L($P(RMPRZSV,"|",3)) S RMPROTXT=$P(RMPRZSV,"|",3) ;consult type
87 Q
88 ;
89OBX(RMPROBX) ;Get fields from OBX segment and set into RMPR variables
90 ;RMPRVTYP=Value type from table 668-i.e. TX(text), ST(string data),etc.
91 ;RMPROID=observation id identifying value in seg. 5
92 ;RMPRVAL=observation value coded by segment 3
93 ;RMPRPRDG=provisional diagnosis
94 ;free text or code^free text^I9C
95 S RMPRMSG=MSG(RMPROBX)
96 S RMPRVTYP=$P(RMPRMSG,"|",3),RMPROID=$P($P(RMPRMSG,"|",4),"^",2)
97 S RMPRVAL=$P(RMPROID,"^",3)
98 I RMPROID="REASON FOR REQUEST" D
99 .S RMPRRFQ(1)=$P(RMPRMSG,"|",6)
100 .S LN=0 F S LN=$O(MSG(RMPROBX,LN)) Q:LN="" S RMPRRFQ(LN+1)=MSG(RMPROBX,LN)
101 .Q
102 I RMPROID="PROVISIONAL DIAGNOSIS" D Q
103 . I RMPRVTYP="TX" S RMPRPRDG=$P(RMPRMSG,"|",6) Q
104 . I RMPRVTYP="CE" D Q
105 .. N PRDXSEG S PRDXSEG=$P(RMPRMSG,"|",6)
106 .. S RMPRPRDG=$P(PRDXSEG,"^",2)_" ("_$P(PRDXSEG,"^")_")"
107 .. S RMPRPRCD=$P(PRDXSEG,"^")
108 I RMPROID["COMMENT" D
109 .S RMPRCMT(1)=$P(RMPRMSG,"|",6)
110 .S LN=0 F S LN=$O(MSG(RMPROBX,NL)) Q:LN="" S RMPRCMT(LN+1)=MSG(RMPROBX,LN)
111 .Q
112 K LN
113 Q
114 ;
115EN(MSG) ;Entry point from protocol RMPR RECEIVE
116 ;
117 ;MSG = local array which contains the HL-7 segments
118 ;RMPRFAC=sending facility
119 ;RMPRMTP=message type
120 N DFN,RMPRACT,RMPRADD,RMPRFAC,RMPRMTP,RMPRPNM,RMPRO,RMPROCR,RMPRORNP
121 N RMPRORFN,RMPRPLCR,RMPRRB,RMPRSEND,RMPRSTS,RMPRTRLC,RMPRWARD,ORIFN
122 N RMPRTRLC,RMPRAD,ORC,RMPRSBR,RMPRZSS,RMPRSS,RMPRSST,RMPROTXT
123 N RMPRMSGO
124 S RMPRMSG="",RMPRNOD=0,RMPRI=0
125 F S RMPRNOD=$O(MSG(RMPRNOD)) Q:RMPRNOD="" S RMPRMSG=MSG(RMPRNOD) I $E(RMPRMSG,1,3)="MSH" D Q
126 .S RMPRSEND=$P(RMPRMSG,"|",3),RMPRFAC=$P(RMPRMSG,"|",4),RMPRMTP=$P(RMPRMSG,"|",9)
127 .Q
128 ;RMPRQT, stop flag in loop
129 S RMPRMSG="",RMPRNOD=0,RMPRQT=0,N=0
130 F S RMPRNOD=$O(MSG(RMPRNOD)) Q:RMPRNOD="" Q:RMPRQT=1 S RMPRMSG=MSG(RMPRNOD) D
131 .I $E(RMPRMSG,1,3)="PID" D PID^RMPRHL7U(RMPRMSG) Q
132 .I $E(RMPRMSG,1,3)="PV1" D PV1^RMPRHL7U(RMPRMSG) Q
133 .;look at ORC|NW for new order
134 .I $E(RMPRMSG,1,3)="ORC" D ORC(RMPRMSG) Q
135 .I RMPRQT=1 Q
136 .I $E(RMPRMSG,1,3)="OBR" D OBR(RMPRMSG) I RMPRSS="NO" S RMPRQT=1 K RMPRSS Q
137 .I RMPRQT=1 Q
138 .;Patch #78 - Add multiple DG1 and ZCL segments
139 .I $E(RMPRMSG,1,3)="DG1"!($E(RMPRMSG,1,3)="ZCL") D DG1(RMPRNOD) Q
140 .;look at ZSV for Prosthetic (4)
141 .I $E(RMPRMSG,1,3)="ZSV" D ZSV(RMPRMSG) Q
142 .I $E(RMPRMSG,1,3)="OBX" D OBX(RMPRNOD) Q
143 .;I $E(RMPRMSG,1,3)="NTE" D NTE^RMPRHL7U(.MSG,RMPRNOD,RMPRO,RMPRTRLC) Q
144 .Q
145 K N
146 ;check for new order, NW, and a prosthetic consult in RMPRSS
147 I '$D(RMPRTRLC) D EXIT^RMPRHL7U Q
148 I RMPRTRLC'="NW" D EXIT^RMPRHL7U Q
149 I '$D(RMPRSS) D EXIT^RMPRHL7U Q
150 I RMPRSS="NO" D EXIT^RMPRHL7U Q
151 ;
152 D NEW^RMPRHL7B
153 ;
154 I '$D(RMPRO) D REJECT^RMPRHL7U(.MSG,"unable to file order"),EXIT^RMPRHL7U Q
155 ;
156 D RTN(RMPRORFN,.RMPRO)
157 ;
158 D EXIT^RMPRHL7U
159 Q
160 ;
161RTN(RMPRORN,RMPRO) ;Put ^OR(100, ien for order into ^RMPR(668,
162 S DA=RMPRO
163 S DIE="^RMPR(668,",DR="19////^S X=RMPRORN"
164 L +^RMPR(668,RMPRO) D ^DIE L -^RMPR(668,RMPRO)
165 K DIE,DR
166 ; set file 123 ien
167 S RMPRGMRC=$$PKGID^ORX8($P(^RMPR(668,RMPRO,0),U,14))
168 I RMPRGMRC["GMRC" S $P(^RMPR(668,RMPRO,0),U,15)=+RMPRGMRC
169 E D REJECT^RMPRHL7U(.MSG),EXIT^RMPRHL7U
170 Q
Note: See TracBrowser for help on using the repository browser.