ORMVBEC ; SLC/MKB - Process VBECS order msgs ;Mar 04, 2019@16:11:47
;;3.0;ORDER ENTRY/RESULTS REPORTING;**212,309,332,405**;Dec 17, 1997;Build 211
;
EN ; -- entry point for VBEC messages from ORMHLREC
;M ^MKB(+ORIFN)=@ORMSG ;for testing
I '$L($T(@ORDCNTRL)) Q ;S ORERR="1^Invalid order control code" Q
I '$G(ORIFN)!'$D(^OR(100,+$G(ORIFN),0)) S ORERR="1^Invalid order number" Q
S:$G(ORLOG)<1 ORLOG=+$E($$NOW^XLFDT,1,12)
D @ORDCNTRL
Q
;
ACK(ORIFN) ; -- process DIRECT^HLMA acknowledgment [from ORMBLDVB]
N ORMSG,I,J,MSH,MSA,ORC,ORTYPE,ORLOG,OREASON,ORNATR,ORDCNTRL,PKGIFN,X
F I=1:1 X HLNEXT Q:HLQUIT'>0 D ;get,parse message from HL7 package
. S ORMSG(I)=HLNODE,J=0 ;Get segment node
. ; Get continuation nodes for long segments, if any
. F S J=$O(HLNODE(J)) Q:'J S ORMSG(I,J)=HLNODE(J)
;I '$O(ORMSG(0)) D EN^ORERR("Missing HL7 message",.ORMSG) Q
S MSH=0 F S MSH=$O(ORMSG(MSH)) Q:MSH'>0 Q:$E(ORMSG(MSH),1,3)="MSH"
I 'MSH S ORERR="1^Missing or invalid MSH segment" D ERR Q
S MSA=+$O(ORMSG(MSH)) I 'MSA!($E($G(ORMSG(MSA)),1,3)'="MSA") D Q
. S ORERR="1^Missing or invalid MSA segment" D ERR
S ORTYPE=$P(ORMSG(MSH),"|",9),MSA=MSA_U_ORMSG(MSA)
S ORLOG=+$E($$NOW^XLFDT,1,12),OREASON=U_$P(MSA,"|",4),ORNATR=""
I $P(MSA,"|",2)'="AA",'$O(ORMSG(+MSA)) D Q ;unsuccessful, no order#
. S ORERR="1^"_$P(OREASON,U,2) D UA,ERR
S ORC=+MSA F S ORC=$O(ORMSG(+ORC)) Q:ORC<1 I $E(ORMSG(ORC),1,3)="ORC" D
. S X=ORMSG(ORC),ORDCNTRL=$P(X,"|",2),PKGIFN=+$P(X,"|",4)
. I '$G(ORIFN) S ORIFN=+$P(X,"|",3) I ORDCNTRL["U" D ;find action to cancel
.. N DA,CODE S CODE=$S(ORDCNTRL="UC":"DC",1:"NW")
.. S DA=$O(^OR(100,DA,8,"C",CODE,"?"),-1) S:DA<1 DA=1
.. S ORIFN=ORIFN_";"_DA
. D @ORDCNTRL
Q
;
ERR ; -- Log an error
N X S X=$P(ORERR,U,2)
D EN^ORERR(X,.ORMSG)
Q
;
STATUS(X) ; -- Returns Order Status for HL7 code X
N Y S Y=$S(X="DC":1,X="OC":1,X="CM":2,X="IP":5,X="SC":6,X="ZE":7,X="CA":7,1:"") ;phase out ZE,OC
Q Y
;
OK ; -- Order accepted, VBECS order # assigned [reply]
S ^OR(100,+ORIFN,4)=PKGIFN ;VBECS identifier
D STATUS^ORCSAVE2(+ORIFN,5) ;pending
Q
;
SC ; -- Status changed
N ORSTS S ORSTS=$$STATUS(ORDSTS)
I ORSTS=1 D OC Q ;Cancel
D STATUS^ORCSAVE2(+ORIFN,ORSTS)
D:ORSTS=6 DATES^ORCSAVE2(+ORIFN,ORLOG) ;Start Time
I ORSTS=7 D
. D DATES^ORCSAVE2(+ORIFN,,+$E($$NOW^XLFDT,1,12)) ;Stop Time
. D OC ;Cancel Children
Q
;
OC ; -- Cancelled
G:ORTYPE["ORG" UA ;reject reply
S:ORNATR="" ORNATR=+$O(^ORD(100.02,"C","X",0)) ;Rejected
S ^OR(100,+ORIFN,6)=ORNATR_U_ORDUZ_U_ORLOG_U_U_$E($P(OREASON,U,2),1,80)
D UPDATE(1,"DC"),LAB D ;set parent's 6-node
. N DAD S DAD=+$P($G(^OR(100,+ORIFN,3)),U,9)
. I DAD,$P($G(^OR(100,DAD,3)),U,3)=1,'$D(^(6)) S ^OR(100,DAD,6)=^OR(100,+ORIFN,6)
Q
;
CR ; -- Cancelled [reply]
D STATUS^ORCSAVE2(+ORIFN,1)
Q
;
UA ; -- Unable to accept [reply]
S:'ORNATR ORNATR=$O(^ORD(100.02,"C","X",0)) ;rejected
S ^OR(100,+ORIFN,6)=ORNATR_U_U_ORLOG_U_U_$E($P(OREASON,U,2),1,80)
D STATUS^ORCSAVE2(+ORIFN,13),CANCEL ;cancel associated orders
UC ; -- Unable to cancel [reply]
DE ; -- Data Error [reply]
N DA S DA=$P(ORIFN,";",2) Q:'DA
S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;request rejected
S:$L($P(OREASON,U,2)) ^OR(100,+ORIFN,8,DA,1)=$E($P(OREASON,U,2),1,240)
Q
;
CANCEL ; -- cancel associated lab, parent orders
N ORDAD
S ORDAD=+$P($G(^OR(100,+ORIFN,3)),U,9) Q:'ORDAD
D CANCEL^ORCSEND2(ORDAD,$P(OREASON,U,2)) ;cancel parent+children
Q
;
UPDATE(ORSTS,ORACT) ; -- continue processing
N DA,ORX,ORCMMT,ORP
;D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) ;DC stop set in $$STATUS
D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS)
S ORCMMT=$E($P(OREASON,U,2),1,240),ORX=$$CREATE^ORX1(ORNATR) D:ORX
. S DA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,ORCMMT,ORLOG,ORDUZ)
. I DA'>0 S ORERR="1^Cannot create new order action" Q
. D RELEASE^ORCSAVE2(+ORIFN,DA,ORLOG,ORDUZ,ORNATR)
. D SIGSTS^ORCSAVE2(+ORIFN,DA)
. I $G(ORL) S ORP(1)=+ORIFN_";"_DA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
. S $P(^OR(100,+ORIFN,3),U,7)=DA
I '$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0
D:ORACT="DC" CANCEL^ORCSEND(+ORIFN) ;cancel unreleased actions
Q
;
ZP ; -- Purged
Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0))
S $P(^OR(100,+ORIFN,4),";",1,3)=";;" I "^5^6^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,$S($P(^(4),";",5):2,1:14)) ; Remove pkg reference, sts=lapsed if still active
Q
;
ZR ; -- Purged as requested [reply]
D DELETE^ORCSAVE2(+ORIFN)
Q
;
ZU ; -- Unable to purge [reply]
S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity
Q
;
LAB ; -- find and cancel ORIFN'S associated Lab order
N ORLRIFN,ORSAVDUZ
S ORLRIFN=$$VALUE^ORX8(ORIFN,"LAB")
I 'ORLRIFN D ;search children for match
. N ORDAD,ORIT,ORLAB,ORI,ORX
. S ORDAD=+$P($G(^OR(100,+ORIFN,3)),U,9) Q:'ORDAD
. S ORIT=$$VALUE^ORX8(ORIFN,"ORDERABLE",1,"E") Q:'$L(ORIT)
. S ORLAB=$$PKG^ORMPS1("LR"),(ORLRIFN,ORI)=0
. F S ORI=+$O(^OR(100,ORDAD,2,+ORI)) Q:'ORI I ORI'=+ORIFN D Q:ORLRIFN
.. Q:$P($G(^OR(100,ORI,0)),U,14)'=ORLAB
.. S ORX=$$VALUE^ORX8(ORI,"ORDERABLE",1,"E")
.. I ORX[ORIT S ORLRIFN=ORI Q
I ORLRIFN D
. ;reset DUZ to the person who canceled the order,
. ;not the person who started the VBECS-OERR link
. S ORSAVDUZ=DUZ
. S DUZ=$S($G(ORDUZ):ORDUZ,1:DUZ)
. D MSG^ORMBLD(ORLRIFN,"CA")
. S DUZ=ORSAVDUZ
. ;checking to make sure the cancel did result in a
. ;discontinued status on the companion order
. I $P($G(^OR(100,ORLRIFN,3)),U,3)=1,'$D(^(6)) D
. . S ^OR(100,ORLRIFN,6)=$G(^OR(100,+ORIFN,6))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORMVBEC 5582 printed Sep 23, 2025@20:08:33 Page 2
ORMVBEC ; SLC/MKB - Process VBECS order msgs ;Mar 04, 2019@16:11:47
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**212,309,332,405**;Dec 17, 1997;Build 211
+2 ;
EN ; -- entry point for VBEC messages from ORMHLREC
+1 ;M ^MKB(+ORIFN)=@ORMSG ;for testing
+2 ;S ORERR="1^Invalid order control code" Q
IF '$LENGTH($TEXT(@ORDCNTRL))
QUIT
+3 IF '$GET(ORIFN)!'$DATA(^OR(100,+$GET(ORIFN),0))
SET ORERR="1^Invalid order number"
QUIT
+4 if $GET(ORLOG)<1
SET ORLOG=+$EXTRACT($$NOW^XLFDT,1,12)
+5 DO @ORDCNTRL
+6 QUIT
+7 ;
ACK(ORIFN) ; -- process DIRECT^HLMA acknowledgment [from ORMBLDVB]
+1 NEW ORMSG,I,J,MSH,MSA,ORC,ORTYPE,ORLOG,OREASON,ORNATR,ORDCNTRL,PKGIFN,X
+2 ;get,parse message from HL7 package
FOR I=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+3 ;Get segment node
SET ORMSG(I)=HLNODE
SET J=0
+4 ; Get continuation nodes for long segments, if any
+5 FOR
SET J=$ORDER(HLNODE(J))
if 'J
QUIT
SET ORMSG(I,J)=HLNODE(J)
End DoDot:1
+6 ;I '$O(ORMSG(0)) D EN^ORERR("Missing HL7 message",.ORMSG) Q
+7 SET MSH=0
FOR
SET MSH=$ORDER(ORMSG(MSH))
if MSH'>0
QUIT
if $EXTRACT(ORMSG(MSH),1,3)="MSH"
QUIT
+8 IF 'MSH
SET ORERR="1^Missing or invalid MSH segment"
DO ERR
QUIT
+9 SET MSA=+$ORDER(ORMSG(MSH))
IF 'MSA!($EXTRACT($GET(ORMSG(MSA)),1,3)'="MSA")
Begin DoDot:1
+10 SET ORERR="1^Missing or invalid MSA segment"
DO ERR
End DoDot:1
QUIT
+11 SET ORTYPE=$PIECE(ORMSG(MSH),"|",9)
SET MSA=MSA_U_ORMSG(MSA)
+12 SET ORLOG=+$EXTRACT($$NOW^XLFDT,1,12)
SET OREASON=U_$PIECE(MSA,"|",4)
SET ORNATR=""
+13 ;unsuccessful, no order#
IF $PIECE(MSA,"|",2)'="AA"
IF '$ORDER(ORMSG(+MSA))
Begin DoDot:1
+14 SET ORERR="1^"_$PIECE(OREASON,U,2)
DO UA
DO ERR
End DoDot:1
QUIT
+15 SET ORC=+MSA
FOR
SET ORC=$ORDER(ORMSG(+ORC))
if ORC<1
QUIT
IF $EXTRACT(ORMSG(ORC),1,3)="ORC"
Begin DoDot:1
+16 SET X=ORMSG(ORC)
SET ORDCNTRL=$PIECE(X,"|",2)
SET PKGIFN=+$PIECE(X,"|",4)
+17 ;find action to cancel
IF '$GET(ORIFN)
SET ORIFN=+$PIECE(X,"|",3)
IF ORDCNTRL["U"
Begin DoDot:2
+18 NEW DA,CODE
SET CODE=$SELECT(ORDCNTRL="UC":"DC",1:"NW")
+19 SET DA=$ORDER(^OR(100,DA,8,"C",CODE,"?"),-1)
if DA<1
SET DA=1
+20 SET ORIFN=ORIFN_";"_DA
End DoDot:2
+21 DO @ORDCNTRL
End DoDot:1
+22 QUIT
+23 ;
ERR ; -- Log an error
+1 NEW X
SET X=$PIECE(ORERR,U,2)
+2 DO EN^ORERR(X,.ORMSG)
+3 QUIT
+4 ;
STATUS(X) ; -- Returns Order Status for HL7 code X
+1 ;phase out ZE,OC
NEW Y
SET Y=$SELECT(X="DC":1,X="OC":1,X="CM":2,X="IP":5,X="SC":6,X="ZE":7,X="CA":7,1:"")
+2 QUIT Y
+3 ;
OK ; -- Order accepted, VBECS order # assigned [reply]
+1 ;VBECS identifier
SET ^OR(100,+ORIFN,4)=PKGIFN
+2 ;pending
DO STATUS^ORCSAVE2(+ORIFN,5)
+3 QUIT
+4 ;
SC ; -- Status changed
+1 NEW ORSTS
SET ORSTS=$$STATUS(ORDSTS)
+2 ;Cancel
IF ORSTS=1
DO OC
QUIT
+3 DO STATUS^ORCSAVE2(+ORIFN,ORSTS)
+4 ;Start Time
if ORSTS=6
DO DATES^ORCSAVE2(+ORIFN,ORLOG)
+5 IF ORSTS=7
Begin DoDot:1
+6 ;Stop Time
DO DATES^ORCSAVE2(+ORIFN,,+$EXTRACT($$NOW^XLFDT,1,12))
+7 ;Cancel Children
DO OC
End DoDot:1
+8 QUIT
+9 ;
OC ; -- Cancelled
+1 ;reject reply
if ORTYPE["ORG"
GOTO UA
+2 ;Rejected
if ORNATR=""
SET ORNATR=+$ORDER(^ORD(100.02,"C","X",0))
+3 SET ^OR(100,+ORIFN,6)=ORNATR_U_ORDUZ_U_ORLOG_U_U_$EXTRACT($PIECE(OREASON,U,2),1,80)
+4 ;set parent's 6-node
DO UPDATE(1,"DC")
DO LAB
Begin DoDot:1
+5 NEW DAD
SET DAD=+$PIECE($GET(^OR(100,+ORIFN,3)),U,9)
+6 IF DAD
IF $PIECE($GET(^OR(100,DAD,3)),U,3)=1
IF '$DATA(^(6))
SET ^OR(100,DAD,6)=^OR(100,+ORIFN,6)
End DoDot:1
+7 QUIT
+8 ;
CR ; -- Cancelled [reply]
+1 DO STATUS^ORCSAVE2(+ORIFN,1)
+2 QUIT
+3 ;
UA ; -- Unable to accept [reply]
+1 ;rejected
if 'ORNATR
SET ORNATR=$ORDER(^ORD(100.02,"C","X",0))
+2 SET ^OR(100,+ORIFN,6)=ORNATR_U_U_ORLOG_U_U_$EXTRACT($PIECE(OREASON,U,2),1,80)
+3 ;cancel associated orders
DO STATUS^ORCSAVE2(+ORIFN,13)
DO CANCEL
UC ; -- Unable to cancel [reply]
DE ; -- Data Error [reply]
+1 NEW DA
SET DA=$PIECE(ORIFN,";",2)
if 'DA
QUIT
+2 ;request rejected
SET $PIECE(^OR(100,+ORIFN,8,DA,0),U,15)=13
+3 if $LENGTH($PIECE(OREASON,U,2))
SET ^OR(100,+ORIFN,8,DA,1)=$EXTRACT($PIECE(OREASON,U,2),1,240)
+4 QUIT
+5 ;
CANCEL ; -- cancel associated lab, parent orders
+1 NEW ORDAD
+2 SET ORDAD=+$PIECE($GET(^OR(100,+ORIFN,3)),U,9)
if 'ORDAD
QUIT
+3 ;cancel parent+children
DO CANCEL^ORCSEND2(ORDAD,$PIECE(OREASON,U,2))
+4 QUIT
+5 ;
UPDATE(ORSTS,ORACT) ; -- continue processing
+1 NEW DA,ORX,ORCMMT,ORP
+2 ;D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP) ;DC stop set in $$STATUS
+3 if $GET(ORSTS)
DO STATUS^ORCSAVE2(+ORIFN,ORSTS)
+4 SET ORCMMT=$EXTRACT($PIECE(OREASON,U,2),1,240)
SET ORX=$$CREATE^ORX1(ORNATR)
if ORX
Begin DoDot:1
+5 SET DA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,ORCMMT,ORLOG,ORDUZ)
+6 IF DA'>0
SET ORERR="1^Cannot create new order action"
QUIT
+7 DO RELEASE^ORCSAVE2(+ORIFN,DA,ORLOG,ORDUZ,ORNATR)
+8 DO SIGSTS^ORCSAVE2(+ORIFN,DA)
+9 IF $GET(ORL)
SET ORP(1)=+ORIFN_";"_DA_"^1"
DO PRINTS^ORWD1(.ORP,+ORL)
+10 SET $PIECE(^OR(100,+ORIFN,3),U,7)=DA
End DoDot:1
+11 IF '$$ACTV^ORX1(ORNATR)
SET $PIECE(^OR(100,+ORIFN,3),U,7)=0
+12 ;cancel unreleased actions
if ORACT="DC"
DO CANCEL^ORCSEND(+ORIFN)
+13 QUIT
+14 ;
ZP ; -- Purged
+1 if 'ORIFN
QUIT
if '$DATA(^OR(100,+ORIFN,0))
QUIT
+2 ; Remove pkg reference, sts=lapsed if still active
SET $PIECE(^OR(100,+ORIFN,4),";",1,3)=";;"
IF "^5^6^"[(U_$PIECE($GET(^(3)),U,3)_U)
DO STATUS^ORCSAVE2(+ORIFN,$SELECT($PIECE(^(4),";",5):2,1:14))
+3 QUIT
+4 ;
ZR ; -- Purged as requested [reply]
+1 DO DELETE^ORCSAVE2(+ORIFN)
+2 QUIT
+3 ;
ZU ; -- Unable to purge [reply]
+1 ; update Last Activity
SET $PIECE(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT
+2 QUIT
+3 ;
LAB ; -- find and cancel ORIFN'S associated Lab order
+1 NEW ORLRIFN,ORSAVDUZ
+2 SET ORLRIFN=$$VALUE^ORX8(ORIFN,"LAB")
+3 ;search children for match
IF 'ORLRIFN
Begin DoDot:1
+4 NEW ORDAD,ORIT,ORLAB,ORI,ORX
+5 SET ORDAD=+$PIECE($GET(^OR(100,+ORIFN,3)),U,9)
if 'ORDAD
QUIT
+6 SET ORIT=$$VALUE^ORX8(ORIFN,"ORDERABLE",1,"E")
if '$LENGTH(ORIT)
QUIT
+7 SET ORLAB=$$PKG^ORMPS1("LR")
SET (ORLRIFN,ORI)=0
+8 FOR
SET ORI=+$ORDER(^OR(100,ORDAD,2,+ORI))
if 'ORI
QUIT
IF ORI'=+ORIFN
Begin DoDot:2
+9 if $PIECE($GET(^OR(100,ORI,0)),U,14)'=ORLAB
QUIT
+10 SET ORX=$$VALUE^ORX8(ORI,"ORDERABLE",1,"E")
+11 IF ORX[ORIT
SET ORLRIFN=ORI
QUIT
End DoDot:2
if ORLRIFN
QUIT
End DoDot:1
+12 IF ORLRIFN
Begin DoDot:1
+13 ;reset DUZ to the person who canceled the order,
+14 ;not the person who started the VBECS-OERR link
+15 SET ORSAVDUZ=DUZ
+16 SET DUZ=$SELECT($GET(ORDUZ):ORDUZ,1:DUZ)
+17 DO MSG^ORMBLD(ORLRIFN,"CA")
+18 SET DUZ=ORSAVDUZ
+19 ;checking to make sure the cancel did result in a
+20 ;discontinued status on the companion order
+21 IF $PIECE($GET(^OR(100,ORLRIFN,3)),U,3)=1
IF '$DATA(^(6))
Begin DoDot:2
+22 SET ^OR(100,ORLRIFN,6)=$GET(^OR(100,+ORIFN,6))
End DoDot:2
End DoDot:1
+23 QUIT
