Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VBECHLOR

VBECHLOR.m

Go to the documentation of this file.
  1. VBECHLOR ;;HOIFO/BNT-VBECS HL7 Order Update Message ; JULY 19, 2017@14:43
  1. ;;2.0;VBEC;**1**;Jun 05, 2015;Build 13
  1. ;
  1. ; Note: This routine supports data exchange with an FDA registered
  1. ; medical device. As such, it may not be changed in any way without
  1. ; prior written approval from the medical device manufacturer.
  1. ;
  1. ; Integration Agreements:
  1. ; Reference to GENACK^HLMA1 supported by IA #2165
  1. ;
  1. QUIT
  1. ;
  1. EN ; -- main entry point for HL7 v1.6 message processing.
  1. N ORMSG,ORNMSP,ORTYPE,ORACK,ORERR,ORVP,ORTS,ORL,ORCAT,I,J,SNDACK,SG
  1. N ORDCNTRL,ORDSTS,PKGIFN,ORIFN,ORNP,ORTN,ORLOG,ORDUZ,ORQT,ORSTRT,ORSTOP
  1. N ORURG,ORNATR,OREASON,ORI,ORSEG,ORSEGID
  1. ;
  1. ; Is this an Acknowledgement message? Additional ACK message types
  1. ; should be included in this $S statment where appropriate to set
  1. ; ORACK=1
  1. S ORACK=$S(HL("MTN")="ORG":1,HL("MTN")="ACK":1,1:0)
  1. ;
  1. F I=1:1 X HLNEXT Q:HLQUIT'>0 D
  1. . S ORMSG(I)=HLNODE,J=0
  1. . F S J=$O(HLNODE(J)) Q:'J S ORMSG(I,J)=HLNODE(J)
  1. ;
  1. ;I $G(VBTEST) S X=0 F S X=$O(^XTMP("VBECS-ORM",$J,X)) Q:X="" S ORMSG(X)=^(X)
  1. S ORNMSP=$$NMSP(HL("SAN")),ORTYPE=HL("MTN")
  1. I '$L(ORNMSP) S ORERR="Missing or invalid sending application" D ERROR Q
  1. S ORTN="EN^ORM"_ORNMSP
  1. ;
  1. S ORI=0 F S ORI=$O(ORMSG(ORI)) Q:'ORI D Q:$D(ORERR)
  1. . S ORSEG=ORMSG(ORI),ORSEGID=$P(ORMSG(ORI),HL("FS"))
  1. . I $T(@ORSEGID)]"" D @ORSEGID
  1. Q:$D(ORERR)
  1. ;
  1. I $L($G(ORDCNTRL)) D @ORTN I $D(ORERR) D ERROR Q
  1. I 'ORACK D GENACK
  1. ; If this is an Order Complete message, send message to Lab to complete the Lab order too.
  1. I ORDSTS="CM" D MSG^XQOR("LR7O VBECS RECEIVE",.ORMSG)
  1. Q
  1. ;
  1. ORC S ORDCNTRL=$TR($P(ORSEG,HL("FS"),2),"@","P")
  1. I '$L(ORDCNTRL) S ORERR="Invalid control code" D ERROR Q
  1. S ORIFN=$P($P(ORSEG,HL("FS"),3),$E(HL("ECH")))
  1. S PKGIFN=$P($P(ORSEG,HL("FS"),4),$E(HL("ECH")))
  1. I ORIFN,$G(ORVP),$D(^OR(100,+ORIFN,0)),$P(^(0),U,2)'=ORVP S ORERR="Patient doesn't match" D ERROR Q
  1. S ORDSTS=$P(ORSEG,HL("FS"),6) ;orc.5
  1. S ORQT=$P(ORSEG,HL("FS"),8)
  1. S ORSTRT=$$FMDATE($P(ORQT,U,4))
  1. S ORSTOP=$$FMDATE($P(ORQT,U,5))
  1. S ORURG=$$URGENCY($P(ORQT,U,6))
  1. S ORLOG=$$FMDATE($P(ORSEG,HL("FS"),10))
  1. S OREASON=$P(ORSEG,HL("FS"),17) ;rlm 9/26/17
  1. S ORDUZ=+$P($P(ORSEG,HL("FS"),17),"^",5) ;RLM 09/26/17
  1. S ORNP=+$P(ORSEG,HL("FS"),13)
  1. S ORNATR=$S($P(OREASON,$E(HL("ECH")),3)="99ORN":$P(OREASON,$E(HL("ECH"))),1:"")
  1. Q
  1. ;
  1. NMSP(NAME) ; -- Returns pkg namespace
  1. I NAME="RADIOLOGY"!(NAME="IMAGING") Q "RA"
  1. I NAME="LABORATORY" Q "LR"
  1. I NAME="DIETETICS" Q "FH"
  1. I NAME="PHARMACY" Q "PS"
  1. I NAME="CONSULTS" Q "GMRC"
  1. I NAME="PROCEDURES" Q "GMRC"
  1. I NAME="ORDER ENTRY" Q "ORG"
  1. I NAME="VBECS" Q "VBEC"
  1. Q ""
  1. ;
  1. MSA ; -- Process MSA segment
  1. S ORACK=1
  1. I $P(ORSEG,HL("FS"),2)'="AA" D
  1. . S ORERR=$P(ORSEG,HL("FS"),4)
  1. . I '$D(OREASON) S OREASON=U_ORERR
  1. . D ERROR Q
  1. Q
  1. ;
  1. PID ; -- Process PID segment
  1. ; Sets PID, ORVP, ORTS if valid patient
  1. N I,DFN,SEG,PIDLST,X
  1. ; Adding logic to support v2.4 Patient Id List
  1. S PIDLST=$P(ORSEG,HL("FS"),4)
  1. I PIDLST[$E(HL("ECH")) D
  1. . 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
  1. I PIDLST'[$E(HL("ECH")) S DFN=+$P(ORSEG,HL("FS"),4),PID=ORSEG
  1. I $D(^DPT(DFN,0)) S ORVP=DFN_";DPT(",ORTS=$G(^DPT(DFN,.103)) Q
  1. S:$L($P(ORSEG,HL("FS"),5)) ORVP=$P(ORSEG,HL("FS"),5) ; alt ID for Lab
  1. I '$G(ORVP) S ORERR="Missing or invalid patient ID" D ERROR Q
  1. Q
  1. ;
  1. PV1 ; -- Process PV1 segment
  1. ; Sets ORCAT, & ORL if valid location
  1. N I,X
  1. S X=+$P(ORSEG,HL("FS"),4),ORCAT=$P(ORSEG,HL("FS"),3)
  1. S:$D(^SC(X,0)) ORL=X_";SC("
  1. Q
  1. ;
  1. ORDITEM(USID) ; -- Returns pointer to Orderable Item file for USID
  1. N ID,OI
  1. S ID=$P(USID,U,4)_";"_$P(USID,U,6)
  1. S OI=+$O(^ORD(101.43,"ID",ID,0))
  1. Q OI
  1. ;
  1. URGENCY(CODE) ; -- Return ptr to Order Urgency file #101.42
  1. S:'$L(CODE) CODE="R"
  1. Q $O(^ORD(101.42,"C",CODE,0))
  1. ;
  1. FMDATE(Y) ; -- Convert HL7 date/time to FM format
  1. Q $$HL7TFM^XLFDT(Y) ;**97
  1. ;
  1. ERROR ; -- Log an error and return ACK if necessary
  1. N ORV S ORV("XQY0")="",ORQUIT=1
  1. D EN^ORERR(ORERR,.ORMSG,.ORV)
  1. ; send an ack to current message ??
  1. I 'ORACK D GENACK
  1. Q
  1. ;
  1. GENACK ; -- Send and acknowldegement to original message
  1. Q:$G(VBTEST)
  1. S MSA1="AA"
  1. I $D(ORERR) S MSA1="AR"
  1. S HLA("HLA",1)="MSA"_HL("FS")_MSA1_HL("FS")_HL("MID")_$S($D(ORERR):HL("FS")_ORERR,1:"")
  1. S HLEID=HL("EID"),HLEIDS=HL("EIDS")
  1. D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.RESULT)
  1. K MSA
  1. Q
  1. TEST ; Testing utility
  1. ;Q
  1. S VBTEST=1
  1. S HL("FS")="|",HL("ECH")="^~\&",HL("SAN")="VBECS",HL("RAN")="OERR"
  1. S HL("MTN")="OMG"
  1. D EN
  1. Q