- VBECHLOR ;;HOIFO/BNT-VBECS HL7 Order Update Message ; JULY 19, 2017@14:43
- ;;2.0;VBEC;**1**;Jun 05, 2015;Build 13
- ;
- ; Note: This routine supports data exchange with an FDA registered
- ; medical device. As such, it may not be changed in any way without
- ; prior written approval from the medical device manufacturer.
- ;
- ; Integration Agreements:
- ; Reference to GENACK^HLMA1 supported by IA #2165
- ;
- QUIT
- ;
- 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 statment 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
- ; If this is an Order Complete message, send message to Lab to complete the Lab order too.
- I ORDSTS="CM" D MSG^XQOR("LR7O VBECS RECEIVE",.ORMSG)
- 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) ;orc.5
- 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 OREASON=$P(ORSEG,HL("FS"),17) ;rlm 9/26/17
- S ORDUZ=+$P($P(ORSEG,HL("FS"),17),"^",5) ;RLM 09/26/17
- S ORNP=+$P(ORSEG,HL("FS"),13)
- S ORNATR=$S($P(OREASON,$E(HL("ECH")),3)="99ORN":$P(OREASON,$E(HL("ECH"))),1:"")
- Q
- ;
- NMSP(NAME) ; -- Returns pkg 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),PID=ORSEG
- 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 S ORV("XQY0")="",ORQUIT=1
- D EN^ORERR(ORERR,.ORMSG,.ORV)
- ; send an ack to current message ??
- I 'ORACK D GENACK
- Q
- ;
- GENACK ; -- Send and acknowldegement to original message
- Q:$G(VBTEST)
- 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,.RESULT)
- K MSA
- Q
- TEST ; Testing utility
- ;Q
- 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[HVBECHLOR 4615 printed Jan 18, 2025@03:45:23 Page 2
- VBECHLOR ;;HOIFO/BNT-VBECS HL7 Order Update Message ; JULY 19, 2017@14:43
- +1 ;;2.0;VBEC;**1**;Jun 05, 2015;Build 13
- +2 ;
- +3 ; Note: This routine supports data exchange with an FDA registered
- +4 ; medical device. As such, it may not be changed in any way without
- +5 ; prior written approval from the medical device manufacturer.
- +6 ;
- +7 ; Integration Agreements:
- +8 ; Reference to GENACK^HLMA1 supported by IA #2165
- +9 ;
- +10 QUIT
- +11 ;
- 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 statment 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 ; If this is an Order Complete message, send message to Lab to complete the Lab order too.
- +27 IF ORDSTS="CM"
- DO MSG^XQOR("LR7O VBECS RECEIVE",.ORMSG)
- +28 QUIT
- +29 ;
- 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 ;orc.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 ;rlm 9/26/17
- SET OREASON=$PIECE(ORSEG,HL("FS"),17)
- +12 ;RLM 09/26/17
- SET ORDUZ=+$PIECE($PIECE(ORSEG,HL("FS"),17),"^",5)
- +13 SET ORNP=+$PIECE(ORSEG,HL("FS"),13)
- +14 SET ORNATR=$SELECT($PIECE(OREASON,$EXTRACT(HL("ECH")),3)="99ORN":$PIECE(OREASON,$EXTRACT(HL("ECH"))),1:"")
- +15 QUIT
- +16 ;
- NMSP(NAME) ; -- Returns pkg 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)
- SET PID=ORSEG
- +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
- SET ORV("XQY0")=""
- SET ORQUIT=1
- +2 DO EN^ORERR(ORERR,.ORMSG,.ORV)
- +3 ; send an ack to current message ??
- +4 IF 'ORACK
- DO GENACK
- +5 QUIT
- +6 ;
- GENACK ; -- Send and acknowldegement to original message
- +1 if $GET(VBTEST)
- QUIT
- +2 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 SET HLEID=HL("EID")
- SET HLEIDS=HL("EIDS")
- +6 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.RESULT)
- +7 KILL MSA
- +8 QUIT
- TEST ; Testing utility
- +1 ;Q
- +2 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