171 lines
6.0 KiB
Mathematica
171 lines
6.0 KiB
Mathematica
RMPRHL7A ;HINES CIOFO/HNC - Receive HL-7 CPRS Message, parse into components and store in File 668 ;3/13/00
|
|
;;3.0;PROSTHETICS;**45,78**;Feb 09, 1996
|
|
;
|
|
;Patch #78 - 09/25/03 - TH - Add multiple DG1 and ZCL segments.
|
|
;
|
|
Q
|
|
URG(X) ;Return Urgency give Z-code from HL-7 segment; see ORC+9
|
|
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)
|
|
I $E(X,1)="Z" S X=$S(X="ZT":"TODAY",X="ZE":"EMERGENCY",1:"")
|
|
Q X
|
|
;
|
|
ORC(RMPRORC) ;Get fields from ORC segment and set into RMPR variables
|
|
;RMPRTRLC=ORC control code from HL7 Table 119
|
|
;RMPRURGI=priority/urgency RMPRPLCR=who entered the order
|
|
;RMPRORNP=provider RMPRNATO=nature of order
|
|
;RMPRAD=date of request RMPROCR=order request reason
|
|
;RMPR RMPRORFN=oe/rr file number
|
|
;RMPRO=file 668 IEN - if not a new order
|
|
;RMPRS38=order status - taken from Table 38, HL7 standard
|
|
I $E(RMPRMSG,1,6)'="ORC|NW" S RMPRQT=1 Q
|
|
S RMPRTRLC=$P(RMPRORC,"|",2)
|
|
S RMPRORFN=$P(RMPRORC,"|",3)
|
|
S RMPRORFN=$P($P(RMPRORFN,"^",1),";",1)
|
|
S RMPRAPP=$P($P(RMPRORC,"|",3),"^",2)
|
|
S RMPRS38=$P(RMPRORC,"|",6)
|
|
S RMPRURGI=$P($P(RMPRORC,"|",8),"^",6)
|
|
S RMPRPLCR=$P(RMPRORC,"|",11)
|
|
S RMPRORNP=$P(RMPRORC,"|",13)
|
|
I $L(RMPRURGI) S RMPRURGI=$$URG(RMPRURGI)
|
|
S RMPRO=+$P($P(RMPRORC,"|",4),"^",1)
|
|
N RMPRODT S RMPRODT=$P(RMPRORC,"|",16)
|
|
S RMPRAD=$$FMDATE^RMPRHL7(RMPRODT)
|
|
S RMPROCR=$P(RMPRORC,"|",17)
|
|
S RMPRNATO=$P(RMPROCR,"^",5)
|
|
Q
|
|
OBR(RMPROBR) ;Get fields from OBR segment and set into RMPR variables
|
|
;RMPRSS=type of consult, field 9, 1-4 if NO, then not prosthetics
|
|
;Must have 99CON in RMPR99C.
|
|
;
|
|
;RMPRODT=observation date/time
|
|
;RMPRPRI=procedure from file ^ORD(101,
|
|
;
|
|
N RMPR99C
|
|
S RMPR99C=$P($P(RMPROBR,"|",5),"^",6)
|
|
I RMPR99C'="99CON" S RMPRSS="NO",RMPRQT=1 Q
|
|
S RMPRSST=$P($P(RMPROBR,"|",5),"^",4)
|
|
S RMPRSS=$P(^GMR(123.5,RMPRSST,0),U,1) D
|
|
.;translate to set of codes
|
|
.I RMPRSS["PROSTHETICS REQUEST" S RMPRSS=1 Q
|
|
.I RMPRSS["CONTACT LENS REQUEST" S RMPRSS=3 Q
|
|
.I RMPRSS["HOME OXYGEN REQUEST" S RMPRSS=4 Q
|
|
.I RMPRSS["EYEGLASS REQUEST" S RMPRSS=2 Q
|
|
.;then not prosthetics
|
|
.S RMPRSS="NO"
|
|
;
|
|
I RMPRSS="NO" S RMPRQT=1 Q
|
|
;
|
|
S RMPRODT=$P(RMPROBR,"|",7)
|
|
I RMPRODT]"" S RMPRODT=$$FMDATE^RMPRHL7(RMPRODT)
|
|
S RMPRATN=$P(RMPROBR,"|",20)
|
|
S RMPRSTDT=$P(RMPROBR,"|",23)
|
|
S RMPRSTDT=$$FMDATE^RMPRHL7(RMPRSTDT)
|
|
S RMPRS668=$P(RMPROBR,"|",26)
|
|
S RMPRINTR=$P(RMPROBR,"|",33)
|
|
Q
|
|
;
|
|
DG1(RMPRDG1) ;Get fields from DG1 and ZCL segments
|
|
; RMPRSID = Set ID
|
|
; RMPRDIAG = pointer to ICD DIAGNOSIS (#80)
|
|
; RMPRCI = Outpat. Classification Type
|
|
; RMPRVAL = Value of each SC or EI - 0,1,Null.
|
|
S RMPRMSG=MSG(RMPRDG1)
|
|
S RMPRSID=$P(RMPRMSG,"|",2)
|
|
I $P(RMPRMSG,"|",1)="DG1" D
|
|
. S RMPRDIAG=$P($P(RMPRMSG,"|",4),"^",1)
|
|
. S RMPRMSG1(RMPRSID,1)=RMPRDIAG
|
|
I $P(RMPRMSG,"|",1)="ZCL" D
|
|
. S RMPRCI=$P(RMPRMSG,"|",3)
|
|
. S RMPRVAL=$P(RMPRMSG,"|",4)
|
|
. S RMPRMSG1(RMPRSID,RMPRCI+1)=RMPRVAL
|
|
Q
|
|
;
|
|
ZSV(RMPRZSV) ;Get service from ZSV segment
|
|
S RMPRZSS=$P($P(RMPRZSV,"|",2),"^",4)
|
|
;Set the service if ZSV provided
|
|
I $L($P(RMPRZSV,"|",3)) S RMPROTXT=$P(RMPRZSV,"|",3) ;consult type
|
|
Q
|
|
;
|
|
OBX(RMPROBX) ;Get fields from OBX segment and set into RMPR variables
|
|
;RMPRVTYP=Value type from table 668-i.e. TX(text), ST(string data),etc.
|
|
;RMPROID=observation id identifying value in seg. 5
|
|
;RMPRVAL=observation value coded by segment 3
|
|
;RMPRPRDG=provisional diagnosis
|
|
;free text or code^free text^I9C
|
|
S RMPRMSG=MSG(RMPROBX)
|
|
S RMPRVTYP=$P(RMPRMSG,"|",3),RMPROID=$P($P(RMPRMSG,"|",4),"^",2)
|
|
S RMPRVAL=$P(RMPROID,"^",3)
|
|
I RMPROID="REASON FOR REQUEST" D
|
|
.S RMPRRFQ(1)=$P(RMPRMSG,"|",6)
|
|
.S LN=0 F S LN=$O(MSG(RMPROBX,LN)) Q:LN="" S RMPRRFQ(LN+1)=MSG(RMPROBX,LN)
|
|
.Q
|
|
I RMPROID="PROVISIONAL DIAGNOSIS" D Q
|
|
. I RMPRVTYP="TX" S RMPRPRDG=$P(RMPRMSG,"|",6) Q
|
|
. I RMPRVTYP="CE" D Q
|
|
.. N PRDXSEG S PRDXSEG=$P(RMPRMSG,"|",6)
|
|
.. S RMPRPRDG=$P(PRDXSEG,"^",2)_" ("_$P(PRDXSEG,"^")_")"
|
|
.. S RMPRPRCD=$P(PRDXSEG,"^")
|
|
I RMPROID["COMMENT" D
|
|
.S RMPRCMT(1)=$P(RMPRMSG,"|",6)
|
|
.S LN=0 F S LN=$O(MSG(RMPROBX,NL)) Q:LN="" S RMPRCMT(LN+1)=MSG(RMPROBX,LN)
|
|
.Q
|
|
K LN
|
|
Q
|
|
;
|
|
EN(MSG) ;Entry point from protocol RMPR RECEIVE
|
|
;
|
|
;MSG = local array which contains the HL-7 segments
|
|
;RMPRFAC=sending facility
|
|
;RMPRMTP=message type
|
|
N DFN,RMPRACT,RMPRADD,RMPRFAC,RMPRMTP,RMPRPNM,RMPRO,RMPROCR,RMPRORNP
|
|
N RMPRORFN,RMPRPLCR,RMPRRB,RMPRSEND,RMPRSTS,RMPRTRLC,RMPRWARD,ORIFN
|
|
N RMPRTRLC,RMPRAD,ORC,RMPRSBR,RMPRZSS,RMPRSS,RMPRSST,RMPROTXT
|
|
N RMPRMSGO
|
|
S RMPRMSG="",RMPRNOD=0,RMPRI=0
|
|
F S RMPRNOD=$O(MSG(RMPRNOD)) Q:RMPRNOD="" S RMPRMSG=MSG(RMPRNOD) I $E(RMPRMSG,1,3)="MSH" D Q
|
|
.S RMPRSEND=$P(RMPRMSG,"|",3),RMPRFAC=$P(RMPRMSG,"|",4),RMPRMTP=$P(RMPRMSG,"|",9)
|
|
.Q
|
|
;RMPRQT, stop flag in loop
|
|
S RMPRMSG="",RMPRNOD=0,RMPRQT=0,N=0
|
|
F S RMPRNOD=$O(MSG(RMPRNOD)) Q:RMPRNOD="" Q:RMPRQT=1 S RMPRMSG=MSG(RMPRNOD) D
|
|
.I $E(RMPRMSG,1,3)="PID" D PID^RMPRHL7U(RMPRMSG) Q
|
|
.I $E(RMPRMSG,1,3)="PV1" D PV1^RMPRHL7U(RMPRMSG) Q
|
|
.;look at ORC|NW for new order
|
|
.I $E(RMPRMSG,1,3)="ORC" D ORC(RMPRMSG) Q
|
|
.I RMPRQT=1 Q
|
|
.I $E(RMPRMSG,1,3)="OBR" D OBR(RMPRMSG) I RMPRSS="NO" S RMPRQT=1 K RMPRSS Q
|
|
.I RMPRQT=1 Q
|
|
.;Patch #78 - Add multiple DG1 and ZCL segments
|
|
.I $E(RMPRMSG,1,3)="DG1"!($E(RMPRMSG,1,3)="ZCL") D DG1(RMPRNOD) Q
|
|
.;look at ZSV for Prosthetic (4)
|
|
.I $E(RMPRMSG,1,3)="ZSV" D ZSV(RMPRMSG) Q
|
|
.I $E(RMPRMSG,1,3)="OBX" D OBX(RMPRNOD) Q
|
|
.;I $E(RMPRMSG,1,3)="NTE" D NTE^RMPRHL7U(.MSG,RMPRNOD,RMPRO,RMPRTRLC) Q
|
|
.Q
|
|
K N
|
|
;check for new order, NW, and a prosthetic consult in RMPRSS
|
|
I '$D(RMPRTRLC) D EXIT^RMPRHL7U Q
|
|
I RMPRTRLC'="NW" D EXIT^RMPRHL7U Q
|
|
I '$D(RMPRSS) D EXIT^RMPRHL7U Q
|
|
I RMPRSS="NO" D EXIT^RMPRHL7U Q
|
|
;
|
|
D NEW^RMPRHL7B
|
|
;
|
|
I '$D(RMPRO) D REJECT^RMPRHL7U(.MSG,"unable to file order"),EXIT^RMPRHL7U Q
|
|
;
|
|
D RTN(RMPRORFN,.RMPRO)
|
|
;
|
|
D EXIT^RMPRHL7U
|
|
Q
|
|
;
|
|
RTN(RMPRORN,RMPRO) ;Put ^OR(100, ien for order into ^RMPR(668,
|
|
S DA=RMPRO
|
|
S DIE="^RMPR(668,",DR="19////^S X=RMPRORN"
|
|
L +^RMPR(668,RMPRO) D ^DIE L -^RMPR(668,RMPRO)
|
|
K DIE,DR
|
|
; set file 123 ien
|
|
S RMPRGMRC=$$PKGID^ORX8($P(^RMPR(668,RMPRO,0),U,14))
|
|
I RMPRGMRC["GMRC" S $P(^RMPR(668,RMPRO,0),U,15)=+RMPRGMRC
|
|
E D REJECT^RMPRHL7U(.MSG),EXIT^RMPRHL7U
|
|
Q
|