- 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 Feb 18, 2025@23:58:47 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