ORMHLREC ; SLC/BNT - ORM HL7 message receiver ;2/11/08 11:05
;;3.0;ORDER ENTRY/RESULTS REPORTING;**212**;Dec 17, 1997;Build 24
;
EN ; -- main entry point for HL7 v1.6 message processing.
N ORMSG,ORNMSP,ORTYPE,ORACK,ORERR,ORVP,ORTS,ORL,ORCAT,I,J,SNDACK,SG
N ORDCNTRL,ORDSTS,PKGIFN,ORIFN,ORNP,ORTN,ORLOG,ORDUZ,ORQT,ORSTRT,ORSTOP
N ORURG,ORNATR,OREASON,ORI,ORSEG,ORSEGID
;
; Is this an Acknowledgement message? Additional ACK message types
; should be included in this $S statement where appropriate to set
; ORACK=1
S ORACK=$S(HL("MTN")="ORG":1,HL("MTN")="ACK":1,1:0)
;
F I=1:1 X HLNEXT Q:HLQUIT'>0 D
. S ORMSG(I)=HLNODE,J=0
. F S J=$O(HLNODE(J)) Q:'J S ORMSG(I,J)=HLNODE(J)
;
;I $G(VBTEST) S X=0 F S X=$O(^XTMP("VBECS-ORM",$J,X)) Q:X="" S ORMSG(X)=^(X)
S ORNMSP=$$NMSP(HL("SAN")),ORTYPE=HL("MTN")
I '$L(ORNMSP) S ORERR="Missing or invalid sending application" D ERROR Q
S ORTN="EN^ORM"_ORNMSP
;
S ORI=0 F S ORI=$O(ORMSG(ORI)) Q:'ORI D Q:$D(ORERR)
. S ORSEG=ORMSG(ORI),ORSEGID=$P(ORMSG(ORI),HL("FS"))
. I $T(@ORSEGID)]"" D @ORSEGID
Q:$D(ORERR)
;
I $L($G(ORDCNTRL)) D @ORTN I $D(ORERR) D ERROR Q
I 'ORACK D GENACK
Q
;
ORC S ORDCNTRL=$TR($P(ORSEG,HL("FS"),2),"@","P")
I '$L(ORDCNTRL) S ORERR="Invalid control code" D ERROR Q
S ORIFN=$P($P(ORSEG,HL("FS"),3),$E(HL("ECH")))
S PKGIFN=$P($P(ORSEG,HL("FS"),4),$E(HL("ECH")))
I ORIFN,$G(ORVP),$D(^OR(100,+ORIFN,0)),$P(^(0),U,2)'=ORVP S ORERR="Patient doesn't match" D ERROR Q
S ORDSTS=$P(ORSEG,HL("FS"),6)
S ORQT=$P(ORSEG,HL("FS"),8)
S ORSTRT=$$FMDATE($P(ORQT,U,4))
S ORSTOP=$$FMDATE($P(ORQT,U,5))
S ORURG=$$URGENCY($P(ORQT,U,6))
S ORLOG=$$FMDATE($P(ORSEG,HL("FS"),10))
S ORDUZ=+$P(ORSEG,HL("FS"),11) D DUZ^XUP(ORDUZ)
S ORNP=+$P(ORSEG,HL("FS"),13)
S OREASON=$P(ORSEG,HL("FS"),17)
S ORNATR=$S($P(OREASON,$E(HL("ECH")),3)="99ORN":$P(OREASON,$E(HL("ECH"))),1:"")
Q
;
NMSP(NAME) ; -- Returns package namespace
I NAME="RADIOLOGY"!(NAME="IMAGING") Q "RA"
I NAME="LABORATORY" Q "LR"
I NAME="DIETETICS" Q "FH"
I NAME="PHARMACY" Q "PS"
I NAME="CONSULTS" Q "GMRC"
I NAME="PROCEDURES" Q "GMRC"
I NAME="ORDER ENTRY" Q "ORG"
I NAME="VBECS" Q "VBEC"
Q ""
;
MSA ; -- Process MSA segment
S ORACK=1
I $P(ORSEG,HL("FS"),2)'="AA" D
. S ORERR=$P(ORSEG,HL("FS"),4)
. I '$D(OREASON) S OREASON=U_ORERR
. D ERROR Q
Q
;
PID ; -- Process PID segment
; Sets PID, ORVP, ORTS if valid patient
N I,DFN,SEG,PIDLST,X
; Adding logic to support v2.4 Patient Id List
S PIDLST=$P(ORSEG,HL("FS"),4)
I PIDLST[$E(HL("ECH")) D
. F I=1:1:$L(PIDLST,$E(HL("ECH"),2)) S X=$P(PIDLST,$E(HL("ECH"),2),I) Q:X="" I $P(X,$E(HL("ECH")),5)["PI" S DFN=+X Q
I PIDLST'[$E(HL("ECH")) S DFN=+$P(ORSEG,HL("FS"),4)
I $D(^DPT(DFN,0)) S ORVP=DFN_";DPT(",ORTS=$G(^DPT(DFN,.103)) Q
S:$L($P(ORSEG,HL("FS"),5)) ORVP=$P(ORSEG,HL("FS"),5) ; alt ID for Lab
I '$G(ORVP) S ORERR="Missing or invalid patient ID" D ERROR Q
Q
;
PV1 ; -- Process PV1 segment
; Sets ORCAT, & ORL if valid location
N I,X
S X=+$P(ORSEG,HL("FS"),4),ORCAT=$P(ORSEG,HL("FS"),3)
S:$D(^SC(X,0)) ORL=X_";SC("
Q
;
ORDITEM(USID) ; -- Returns pointer to Orderable Item file for USID
N ID,OI
S ID=$P(USID,U,4)_";"_$P(USID,U,6)
S OI=+$O(^ORD(101.43,"ID",ID,0))
Q OI
;
URGENCY(CODE) ; -- Return ptr to Order Urgency file #101.42
S:'$L(CODE) CODE="R"
Q $O(^ORD(101.42,"C",CODE,0))
;
FMDATE(Y) ; -- Convert HL7 date/time to FM format
Q $$HL7TFM^XLFDT(Y) ;**97
;
ERROR ; -- Log an error and return ACK if necessary
N ORV,X S ORV("XQY0")="",ORQUIT=1
S X=$S($E(ORERR,1,2)="1^":$P(ORERR,U,2),1:ORERR)
D EN^ORERR(X,.ORMSG,.ORV)
; send an ack to current message ??
I 'ORACK D GENACK
Q
;
GENACK ; -- Send acknowledgment to original message
;Q:$G(VBTEST)
N MSA1,ORESULT S MSA1="AA"
I $D(ORERR) S MSA1="AR"
S HLA("HLA",1)="MSA"_HL("FS")_MSA1_HL("FS")_HL("MID")_$S($D(ORERR):HL("FS")_ORERR,1:"")
;S HLEID=HL("EID"),HLEIDS=HL("EIDS")
D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.ORESULT)
Q
TEST ; Testing utility
Q
N VBTEST S VBTEST=1
S HL("FS")="|",HL("ECH")="^~\&",HL("SAN")="VBECS",HL("RAN")="OERR"
S HL("MTN")="OMG"
D EN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORMHLREC 4207 printed Nov 22, 2024@17:41:57 Page 2
ORMHLREC ; SLC/BNT - ORM HL7 message receiver ;2/11/08 11:05
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**212**;Dec 17, 1997;Build 24
+2 ;
EN ; -- main entry point for HL7 v1.6 message processing.
+1 NEW ORMSG,ORNMSP,ORTYPE,ORACK,ORERR,ORVP,ORTS,ORL,ORCAT,I,J,SNDACK,SG
+2 NEW ORDCNTRL,ORDSTS,PKGIFN,ORIFN,ORNP,ORTN,ORLOG,ORDUZ,ORQT,ORSTRT,ORSTOP
+3 NEW ORURG,ORNATR,OREASON,ORI,ORSEG,ORSEGID
+4 ;
+5 ; Is this an Acknowledgement message? Additional ACK message types
+6 ; should be included in this $S statement where appropriate to set
+7 ; ORACK=1
+8 SET ORACK=$SELECT(HL("MTN")="ORG":1,HL("MTN")="ACK":1,1:0)
+9 ;
+10 FOR I=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+11 SET ORMSG(I)=HLNODE
SET J=0
+12 FOR
SET J=$ORDER(HLNODE(J))
if 'J
QUIT
SET ORMSG(I,J)=HLNODE(J)
End DoDot:1
+13 ;
+14 ;I $G(VBTEST) S X=0 F S X=$O(^XTMP("VBECS-ORM",$J,X)) Q:X="" S ORMSG(X)=^(X)
+15 SET ORNMSP=$$NMSP(HL("SAN"))
SET ORTYPE=HL("MTN")
+16 IF '$LENGTH(ORNMSP)
SET ORERR="Missing or invalid sending application"
DO ERROR
QUIT
+17 SET ORTN="EN^ORM"_ORNMSP
+18 ;
+19 SET ORI=0
FOR
SET ORI=$ORDER(ORMSG(ORI))
if 'ORI
QUIT
Begin DoDot:1
+20 SET ORSEG=ORMSG(ORI)
SET ORSEGID=$PIECE(ORMSG(ORI),HL("FS"))
+21 IF $TEXT(@ORSEGID)]""
DO @ORSEGID
End DoDot:1
if $DATA(ORERR)
QUIT
+22 if $DATA(ORERR)
QUIT
+23 ;
+24 IF $LENGTH($GET(ORDCNTRL))
DO @ORTN
IF $DATA(ORERR)
DO ERROR
QUIT
+25 IF 'ORACK
DO GENACK
+26 QUIT
+27 ;
ORC SET ORDCNTRL=$TRANSLATE($PIECE(ORSEG,HL("FS"),2),"@","P")
+1 IF '$LENGTH(ORDCNTRL)
SET ORERR="Invalid control code"
DO ERROR
QUIT
+2 SET ORIFN=$PIECE($PIECE(ORSEG,HL("FS"),3),$EXTRACT(HL("ECH")))
+3 SET PKGIFN=$PIECE($PIECE(ORSEG,HL("FS"),4),$EXTRACT(HL("ECH")))
+4 IF ORIFN
IF $GET(ORVP)
IF $DATA(^OR(100,+ORIFN,0))
IF $PIECE(^(0),U,2)'=ORVP
SET ORERR="Patient doesn't match"
DO ERROR
QUIT
+5 SET ORDSTS=$PIECE(ORSEG,HL("FS"),6)
+6 SET ORQT=$PIECE(ORSEG,HL("FS"),8)
+7 SET ORSTRT=$$FMDATE($PIECE(ORQT,U,4))
+8 SET ORSTOP=$$FMDATE($PIECE(ORQT,U,5))
+9 SET ORURG=$$URGENCY($PIECE(ORQT,U,6))
+10 SET ORLOG=$$FMDATE($PIECE(ORSEG,HL("FS"),10))
+11 SET ORDUZ=+$PIECE(ORSEG,HL("FS"),11)
DO DUZ^XUP(ORDUZ)
+12 SET ORNP=+$PIECE(ORSEG,HL("FS"),13)
+13 SET OREASON=$PIECE(ORSEG,HL("FS"),17)
+14 SET ORNATR=$SELECT($PIECE(OREASON,$EXTRACT(HL("ECH")),3)="99ORN":$PIECE(OREASON,$EXTRACT(HL("ECH"))),1:"")
+15 QUIT
+16 ;
NMSP(NAME) ; -- Returns package namespace
+1 IF NAME="RADIOLOGY"!(NAME="IMAGING")
QUIT "RA"
+2 IF NAME="LABORATORY"
QUIT "LR"
+3 IF NAME="DIETETICS"
QUIT "FH"
+4 IF NAME="PHARMACY"
QUIT "PS"
+5 IF NAME="CONSULTS"
QUIT "GMRC"
+6 IF NAME="PROCEDURES"
QUIT "GMRC"
+7 IF NAME="ORDER ENTRY"
QUIT "ORG"
+8 IF NAME="VBECS"
QUIT "VBEC"
+9 QUIT ""
+10 ;
MSA ; -- Process MSA segment
+1 SET ORACK=1
+2 IF $PIECE(ORSEG,HL("FS"),2)'="AA"
Begin DoDot:1
+3 SET ORERR=$PIECE(ORSEG,HL("FS"),4)
+4 IF '$DATA(OREASON)
SET OREASON=U_ORERR
+5 DO ERROR
QUIT
End DoDot:1
+6 QUIT
+7 ;
PID ; -- Process PID segment
+1 ; Sets PID, ORVP, ORTS if valid patient
+2 NEW I,DFN,SEG,PIDLST,X
+3 ; Adding logic to support v2.4 Patient Id List
+4 SET PIDLST=$PIECE(ORSEG,HL("FS"),4)
+5 IF PIDLST[$EXTRACT(HL("ECH"))
Begin DoDot:1
+6 FOR I=1:1:$LENGTH(PIDLST,$EXTRACT(HL("ECH"),2))
SET X=$PIECE(PIDLST,$EXTRACT(HL("ECH"),2),I)
if X=""
QUIT
IF $PIECE(X,$EXTRACT(HL("ECH")),5)["PI"
SET DFN=+X
QUIT
End DoDot:1
+7 IF PIDLST'[$EXTRACT(HL("ECH"))
SET DFN=+$PIECE(ORSEG,HL("FS"),4)
+8 IF $DATA(^DPT(DFN,0))
SET ORVP=DFN_";DPT("
SET ORTS=$GET(^DPT(DFN,.103))
QUIT
+9 ; alt ID for Lab
if $LENGTH($PIECE(ORSEG,HL("FS"),5))
SET ORVP=$PIECE(ORSEG,HL("FS"),5)
+10 IF '$GET(ORVP)
SET ORERR="Missing or invalid patient ID"
DO ERROR
QUIT
+11 QUIT
+12 ;
PV1 ; -- Process PV1 segment
+1 ; Sets ORCAT, & ORL if valid location
+2 NEW I,X
+3 SET X=+$PIECE(ORSEG,HL("FS"),4)
SET ORCAT=$PIECE(ORSEG,HL("FS"),3)
+4 if $DATA(^SC(X,0))
SET ORL=X_";SC("
+5 QUIT
+6 ;
ORDITEM(USID) ; -- Returns pointer to Orderable Item file for USID
+1 NEW ID,OI
+2 SET ID=$PIECE(USID,U,4)_";"_$PIECE(USID,U,6)
+3 SET OI=+$ORDER(^ORD(101.43,"ID",ID,0))
+4 QUIT OI
+5 ;
URGENCY(CODE) ; -- Return ptr to Order Urgency file #101.42
+1 if '$LENGTH(CODE)
SET CODE="R"
+2 QUIT $ORDER(^ORD(101.42,"C",CODE,0))
+3 ;
FMDATE(Y) ; -- Convert HL7 date/time to FM format
+1 ;**97
QUIT $$HL7TFM^XLFDT(Y)
+2 ;
ERROR ; -- Log an error and return ACK if necessary
+1 NEW ORV,X
SET ORV("XQY0")=""
SET ORQUIT=1
+2 SET X=$SELECT($EXTRACT(ORERR,1,2)="1^":$PIECE(ORERR,U,2),1:ORERR)
+3 DO EN^ORERR(X,.ORMSG,.ORV)
+4 ; send an ack to current message ??
+5 IF 'ORACK
DO GENACK
+6 QUIT
+7 ;
GENACK ; -- Send acknowledgment to original message
+1 ;Q:$G(VBTEST)
+2 NEW MSA1,ORESULT
SET MSA1="AA"
+3 IF $DATA(ORERR)
SET MSA1="AR"
+4 SET HLA("HLA",1)="MSA"_HL("FS")_MSA1_HL("FS")_HL("MID")_$SELECT($DATA(ORERR):HL("FS")_ORERR,1:"")
+5 ;S HLEID=HL("EID"),HLEIDS=HL("EIDS")
+6 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.ORESULT)
+7 QUIT
TEST ; Testing utility
+1 QUIT
+2 NEW VBTEST
SET VBTEST=1
+3 SET HL("FS")="|"
SET HL("ECH")="^~\&"
SET HL("SAN")="VBECS"
SET HL("RAN")="OERR"
+4 SET HL("MTN")="OMG"
+5 DO EN
+6 QUIT
