ORMGMRC ; SLC/MKB - Process Consult ORM msgs ;Sep 10, 2020@14:17:35
;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,26,68,92,153,174,195,255,243,280,350,415,519**;Dec 17, 1997;Build 36
EN ; -- entry point for GMRC messges
I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q
I ORDCNTRL'="SN",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q
S:ORDCNTRL="OC"&(ORTYPE="ORR") ORDCNTRL="UA" ;new code
N ORSTS,OREASON1,NTE S ORSTS=$$STATUS(ORDSTS)
S:'ORLOG ORLOG=$$NOW^XLFDT S:'ORDUZ ORDUZ=DUZ S:$G(DGPMT) ORDUZ=""
S OREASON=$P(OREASON,U,5),NTE=$O(@ORMSG@(+ORC)),OREASON1=""
I NTE,$E(@ORMSG@(NTE),1,3)="NTE" S OREASON1=$P(@ORMSG@(NTE),"|",4)
D @ORDCNTRL
Q
;
ZP ; -- Purged
Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0))
K ^OR(100,+ORIFN,4) I "^3^5^6^8^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,14) ; Remove pkg reference, sts=lapsed if still active
Q
;
ZR ; -- Purged as requested [ack]
D DELETE^ORCSAVE2(+ORIFN)
Q
;
ZU ; -- Unable to purge [ack]
S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity
Q
;
OK ; -- Order accepted, GMRC order # assigned [ack]
S ^OR(100,+ORIFN,4)=PKGIFN S:'$G(ORSTS) ORSTS=5
D STATUS^ORCSAVE2(+ORIFN,ORSTS) ; 5=pending
D DATES^ORCSAVE2(+ORIFN,+$E($$NOW^XLFDT,1,12))
Q
;
XX ; -- Change order
N ORDIALOG,ORDG,ORDA,ORX,ORP,ORSIG S:'$L(ORNATR) ORNATR="S"
D DLG Q:$D(ORERR) Q:'$D(ORDIALOG) S ORIFN=+ORIFN
S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,OREASON1,ORLOG,ORDUZ)
I ORDA'>0 S ORERR="Cannot create new order action" Q
; -Update sts of order to active, last action to dc/edit:
S ORX=+$P($G(^OR(100,ORIFN,3)),U,7) S:ORX'>0 ORX=+$O(^(8,ORDA),-1)
I $D(^OR(100,ORIFN,8,ORX,0)),$P(^(0),U,15)="" S $P(^(0),U,15)=12
S $P(^OR(100,ORIFN,3),U,7)=ORDA D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS)
D PXRMKILL^ORDD100(ORIFN,ORVP,ORLOG) ; JEH 255
D RELEASE^ORCSAVE2(ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd
S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0)
D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG
; -Update responses, get/save new order text:
K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA)
S $P(^OR(100,ORIFN,8,ORDA,0),U,14)=ORDA
K:OREASON="RESUBMIT" ^OR(100,ORIFN,6) ;clear previous DC data
I OREASON="RESUBMIT" N DA S DA=+ORIFN D EK^ORDD100A S $P(^OR(100,ORIFN,0),U,9)="" ;p415 clear stop date/time including xref "AE"
D PXRMADD^ORDD100(ORIFN,ORVP,ORLOG) ; JEH 255
I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
Q
;
SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg
N ORDIALOG,ORDG,ORP K ^TMP("ORWORD",$J) S:'$L(ORNATR) ORNATR="W"
I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q
I ORDUZ,'$D(^VA(200,ORDUZ,0)) S ORERR="Invalid entering person" Q
I '$G(ORL) S ORERR="Missing or invalid patient location" Q
D DLG Q:$D(ORERR) Q:'$D(ORDIALOG)
SN1 D EN^ORCSAVE K ^TMP("ORWORD",$J) ; setting status, xrefs
I '$G(ORIFN) S ORERR="Cannot create new order" Q
;Save DG1 and ZCL segments of HL7 message from backdoor orders
D BDOSTR^ORWDBA3
D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1)
S:'ORSTRT ORSTRT=$$NOW^XLFDT D DATES^ORCSAVE2(+ORIFN,ORSTRT)
D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS)
I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy
S ^OR(100,ORIFN,4)=PKGIFN
Q
;
DLG ; -- Build ORDIALOG(),ORDG from msg
N OBR,USID,TYPE,OI,ZSV,J,OBX,WP,I,DSTID
S OBR=$$OBR I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q
S USID=$P(@ORMSG@(OBR),"|",5),TYPE=$S(USID["99CON":"CONSULT",1:"REQUEST")
S ORDIALOG=$O(^ORD(101.41,"AB","GMRCOR "_TYPE,0))
D GETDLG1^ORCD(ORDIALOG)
S ORDIALOG($$PTR("URGENCY"),1)=ORURG
;ORSTRT & ORSTOP defined in routine ORM
S ORDIALOG($$PTR("CLINICALLY INDICATED DATE"),1)=ORSTRT ;WAT/280/350
S OI=$$ORDITEM^ORM(USID) I 'OI S ORERR="Invalid consult or procedure" Q
S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
S ZSV=$O(@ORMSG@(OBR)) I ZSV,$E(@ORMSG@(ZSV),1,3)="ZSV" D
. N X1,X2 S X1=$P(@ORMSG@(ZSV),"|",2),X2=$P(@ORMSG@(ZSV),"|",3)
. I TYPE="REQUEST" S ORDIALOG($$PTR("REQUEST SERVICE"),1)=+$P(X1,U,4)
. I TYPE="CONSULT",$L(X2) S ORDIALOG($$PTR("FREE TEXT OI"),1)=X2
. S DSTID=$P(@ORMSG@(ZSV),"|",4) S:$L(DSTID) ORDIALOG($$PTR("DST ID"),1)=DSTID
D1 S ORDIALOG($$PTR("CATEGORY"),1)=$G(ORCAT)
S J=$P(@ORMSG@(OBR),"|",19),ORDIALOG($$PTR("PLACE OF CONSULTATION"),1)=$S(J="OC":"C",1:J)
S ORDIALOG($$PTR("PROVIDER"),1)=$P(@ORMSG@(OBR),"|",20)
S OBX=OBR F S OBX=$O(@ORMSG@(OBX)) Q:OBX'>0 S J=$E(@ORMSG@(OBX),1,3) Q:J="ORC" Q:J="MSH" I J="OBX" D
. N SEG,NAME,VALUE S SEG=@ORMSG@(OBX)
. S NAME=$$UP^XLFSTR($P($P(SEG,"|",4),U,2)),VALUE=$P(SEG,"|",6)
. I NAME="PROVISIONAL DIAGNOSIS" D Q
.. S:$P(SEG,"|",3)="CE" ORDIALOG($$PTR("CODE"),1)=$P(VALUE,U),VALUE=$P(VALUE,U,2)
.. S ORDIALOG($$PTR("FREE TEXT"),1)=VALUE
. S WP=$$PTR("WORD PROCESSING 1"),I=1,^TMP("ORWORD",$J,WP,1,I,0)=VALUE
. S J=0 F S J=$O(@ORMSG@(OBX,J)) Q:J'>0 S I=I+1,^TMP("ORWORD",$J,WP,1,I,0)=@ORMSG@(OBX,J)
S:$G(I) ^TMP("ORWORD",$J,WP,1,0)="^^"_I_U_I_U_DT_U,ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)"
Q
;
OBR() ; -- Return subscript of RXE segment
N X,I,SEG S X="",I=+ORC
F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="OBR" S X=I Q
Q X
;
SC ; -- Status changed (i.e. scheduled)
S:'$G(ORSTS) ORSTS=6 D STATUS^ORCSAVE2(+ORIFN,ORSTS) ; 6=active
Q
;
STATUS(X) ; -- Returns ptr to Order Status file #100.01
Q $S(X="DC":1,X="CM":2,X="HD":3,X="IP":5,X="SC":6,X="A":9,X="RP":12,X="CA":13,X="ZC":8,1:5)
;
RE ; -- Completed, w/results
N I,SEG,DA,DR,DIE,X,Y
S:'$G(ORSTS) ORSTS=2 D STATUS^ORCSAVE2(+ORIFN,ORSTS)
S X="",DA=+ORIFN,DIE="^OR(100,"
S DR="71////"_+$E($$NOW^XLFDT,1,12) D ^DIE
S I=+ORC,X="" F S I=$O(@ORMSG@(I)) Q:I<1 S SEG=$G(@ORMSG@(I)) Q:$E(SEG,1,3)="ORC" I $E(SEG,1,3)="OBX",$P(SEG,"|",4)["SIG FINDINGS" S X=$P(SEG,"|",6) Q
S $P(^OR(100,DA,7),U,2)=$S(X="Y":1,1:"")
S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4)
I $P(ORC,"|",17)["MAINTENANCE" Q ;group update - no CM ack needed
I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov
Q
;
UA ; -- Unable to Accept [ack]
S ORDUZ="" I '$L(OREASON1),$L(OREASON) S OREASON1=OREASON
OC ; -- Cancelled/Denied
S:'$L(ORNATR) ORNATR="X" ;Rejected
S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_ORDUZ_U_ORLOG_U_U_OREASON1
D STATUS^ORCSAVE2(+ORIFN,13) I ORDCNTRL="OC" D UPDATE("DC") Q
UD ; -- Unable to discontinue [ack]
N DA S DA=$P(ORIFN,";",2) I DA D
. S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;request rejected
. S:$L(OREASON1) ^OR(100,+ORIFN,8,DA,1)=OREASON1
Q
;
OD ; -- Discontinued
S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON1
D STATUS^ORCSAVE2(+ORIFN,1),UPDATE("DC"):$L(ORNATR)
Q
;
DR ; -- Discontinued [ack]
D STATUS^ORCSAVE2(+ORIFN,1)
Q
;
UPDATE(ORACT) ; -- continue processing
N ORX,ORDA,ORP
S ORX=$$CREATE^ORX1(ORNATR) D:ORX
. S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON1,ORLOG,ORDUZ)
. I ORDA'>0 S ORERR="Cannot create new order action" Q
. D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
. D SIGSTS^ORCSAVE2(+ORIFN,ORDA)
. I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
. S $P(^OR(100,+ORIFN,3),U,7)=ORDA
I 'ORX,ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0
D:$G(ORACT)="DC" CANCEL^ORCSEND(+ORIFN)
Q
;
PTR(X) ; -- Returns ptr to prompt in Order Dialog file #101.41
Q $O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORMGMRC 7668 printed Apr 09, 2024@21:44:40 Page 2
ORMGMRC ; SLC/MKB - Process Consult ORM msgs ;Sep 10, 2020@14:17:35
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,26,68,92,153,174,195,255,243,280,350,415,519**;Dec 17, 1997;Build 36
EN ; -- entry point for GMRC messges
+1 ;S ORERR="Invalid order control code" Q
IF '$LENGTH($TEXT(@ORDCNTRL))
QUIT
+2 IF ORDCNTRL'="SN"
IF ORDCNTRL'="ZP"
IF 'ORIFN!('$DATA(^OR(100,+ORIFN,0)))
SET ORERR="Invalid OE/RR order number"
QUIT
+3 ;new code
if ORDCNTRL="OC"&(ORTYPE="ORR")
SET ORDCNTRL="UA"
+4 NEW ORSTS,OREASON1,NTE
SET ORSTS=$$STATUS(ORDSTS)
+5 if 'ORLOG
SET ORLOG=$$NOW^XLFDT
if 'ORDUZ
SET ORDUZ=DUZ
if $GET(DGPMT)
SET ORDUZ=""
+6 SET OREASON=$PIECE(OREASON,U,5)
SET NTE=$ORDER(@ORMSG@(+ORC))
SET OREASON1=""
+7 IF NTE
IF $EXTRACT(@ORMSG@(NTE),1,3)="NTE"
SET OREASON1=$PIECE(@ORMSG@(NTE),"|",4)
+8 DO @ORDCNTRL
+9 QUIT
+10 ;
ZP ; -- Purged
+1 if 'ORIFN
QUIT
if '$DATA(^OR(100,+ORIFN,0))
QUIT
+2 ; Remove pkg reference, sts=lapsed if still active
KILL ^OR(100,+ORIFN,4)
IF "^3^5^6^8^"[(U_$PIECE($GET(^(3)),U,3)_U)
DO STATUS^ORCSAVE2(+ORIFN,14)
+3 QUIT
+4 ;
ZR ; -- Purged as requested [ack]
+1 DO DELETE^ORCSAVE2(+ORIFN)
+2 QUIT
+3 ;
ZU ; -- Unable to purge [ack]
+1 ; update Last Activity
SET $PIECE(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT
+2 QUIT
+3 ;
OK ; -- Order accepted, GMRC order # assigned [ack]
+1 SET ^OR(100,+ORIFN,4)=PKGIFN
if '$GET(ORSTS)
SET ORSTS=5
+2 ; 5=pending
DO STATUS^ORCSAVE2(+ORIFN,ORSTS)
+3 DO DATES^ORCSAVE2(+ORIFN,+$EXTRACT($$NOW^XLFDT,1,12))
+4 QUIT
+5 ;
XX ; -- Change order
+1 NEW ORDIALOG,ORDG,ORDA,ORX,ORP,ORSIG
if '$LENGTH(ORNATR)
SET ORNATR="S"
+2 DO DLG
if $DATA(ORERR)
QUIT
if '$DATA(ORDIALOG)
QUIT
SET ORIFN=+ORIFN
+3 SET ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,OREASON1,ORLOG,ORDUZ)
+4 IF ORDA'>0
SET ORERR="Cannot create new order action"
QUIT
+5 ; -Update sts of order to active, last action to dc/edit:
+6 SET ORX=+$PIECE($GET(^OR(100,ORIFN,3)),U,7)
if ORX'>0
SET ORX=+$ORDER(^(8,ORDA),-1)
+7 IF $DATA(^OR(100,ORIFN,8,ORX,0))
IF $PIECE(^(0),U,15)=""
SET $PIECE(^(0),U,15)=12
+8 SET $PIECE(^OR(100,ORIFN,3),U,7)=ORDA
if $GET(ORSTS)
DO STATUS^ORCSAVE2(ORIFN,ORSTS)
+9 ; JEH 255
DO PXRMKILL^ORDD100(ORIFN,ORVP,ORLOG)
+10 DO RELEASE^ORCSAVE2(ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
+11 ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd
+12 SET ORSIG=$SELECT($PIECE($GET(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0)
+13 if ORSIG
DO SIGSTS^ORCSAVE2(ORIFN,ORDA)
if 'ORSIG
DO SIGN^ORCSAVE2(ORIFN,,,5,ORX)
+14 ; -Update responses, get/save new order text:
+15 KILL ^OR(100,ORIFN,4.5)
DO RESPONSE^ORCSAVE
DO ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA)
+16 SET $PIECE(^OR(100,ORIFN,8,ORDA,0),U,14)=ORDA
+17 ;clear previous DC data
if OREASON="RESUBMIT"
KILL ^OR(100,ORIFN,6)
+18 ;p415 clear stop date/time including xref "AE"
IF OREASON="RESUBMIT"
NEW DA
SET DA=+ORIFN
DO EK^ORDD100A
SET $PIECE(^OR(100,ORIFN,0),U,9)=""
+19 ; JEH 255
DO PXRMADD^ORDD100(ORIFN,ORVP,ORLOG)
+20 IF $GET(ORL)
SET ORP(1)=+ORIFN_";"_ORDA_"^1"
DO PRINTS^ORWD1(.ORP,+ORL)
+21 QUIT
+22 ;
SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg
+1 NEW ORDIALOG,ORDG,ORP
KILL ^TMP("ORWORD",$JOB)
if '$LENGTH(ORNATR)
SET ORNATR="W"
+2 IF '$DATA(^VA(200,ORNP,0))
SET ORERR="Missing or invalid ordering provider"
QUIT
+3 IF ORDUZ
IF '$DATA(^VA(200,ORDUZ,0))
SET ORERR="Invalid entering person"
QUIT
+4 IF '$GET(ORL)
SET ORERR="Missing or invalid patient location"
QUIT
+5 DO DLG
if $DATA(ORERR)
QUIT
if '$DATA(ORDIALOG)
QUIT
SN1 ; setting status, xrefs
DO EN^ORCSAVE
KILL ^TMP("ORWORD",$JOB)
+1 IF '$GET(ORIFN)
SET ORERR="Cannot create new order"
QUIT
+2 ;Save DG1 and ZCL segments of HL7 message from backdoor orders
+3 DO BDOSTR^ORWDBA3
+4 DO RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR)
DO SIGSTS^ORCSAVE2(ORIFN,1)
+5 if 'ORSTRT
SET ORSTRT=$$NOW^XLFDT
DO DATES^ORCSAVE2(+ORIFN,ORSTRT)
+6 if $GET(ORSTS)
DO STATUS^ORCSAVE2(ORIFN,ORSTS)
+7 ; chart copy
IF $GET(ORL)
SET ORP(1)=ORIFN_";1^1"
DO PRINTS^ORWD1(.ORP,+ORL)
+8 SET ^OR(100,ORIFN,4)=PKGIFN
+9 QUIT
+10 ;
DLG ; -- Build ORDIALOG(),ORDG from msg
+1 NEW OBR,USID,TYPE,OI,ZSV,J,OBX,WP,I,DSTID
+2 SET OBR=$$OBR
IF 'OBR!($EXTRACT($GET(@ORMSG@(OBR)),1,3)'="OBR")
SET ORERR="Missing OBR segment"
QUIT
+3 SET USID=$PIECE(@ORMSG@(OBR),"|",5)
SET TYPE=$SELECT(USID["99CON":"CONSULT",1:"REQUEST")
+4 SET ORDIALOG=$ORDER(^ORD(101.41,"AB","GMRCOR "_TYPE,0))
+5 DO GETDLG1^ORCD(ORDIALOG)
+6 SET ORDIALOG($$PTR("URGENCY"),1)=ORURG
+7 ;ORSTRT & ORSTOP defined in routine ORM
+8 ;WAT/280/350
SET ORDIALOG($$PTR("CLINICALLY INDICATED DATE"),1)=ORSTRT
+9 SET OI=$$ORDITEM^ORM(USID)
IF 'OI
SET ORERR="Invalid consult or procedure"
QUIT
+10 SET ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
+11 SET ZSV=$ORDER(@ORMSG@(OBR))
IF ZSV
IF $EXTRACT(@ORMSG@(ZSV),1,3)="ZSV"
Begin DoDot:1
+12 NEW X1,X2
SET X1=$PIECE(@ORMSG@(ZSV),"|",2)
SET X2=$PIECE(@ORMSG@(ZSV),"|",3)
+13 IF TYPE="REQUEST"
SET ORDIALOG($$PTR("REQUEST SERVICE"),1)=+$PIECE(X1,U,4)
+14 IF TYPE="CONSULT"
IF $LENGTH(X2)
SET ORDIALOG($$PTR("FREE TEXT OI"),1)=X2
+15 SET DSTID=$PIECE(@ORMSG@(ZSV),"|",4)
if $LENGTH(DSTID)
SET ORDIALOG($$PTR("DST ID"),1)=DSTID
End DoDot:1
D1 SET ORDIALOG($$PTR("CATEGORY"),1)=$GET(ORCAT)
+1 SET J=$PIECE(@ORMSG@(OBR),"|",19)
SET ORDIALOG($$PTR("PLACE OF CONSULTATION"),1)=$SELECT(J="OC":"C",1:J)
+2 SET ORDIALOG($$PTR("PROVIDER"),1)=$PIECE(@ORMSG@(OBR),"|",20)
+3 SET OBX=OBR
FOR
SET OBX=$ORDER(@ORMSG@(OBX))
if OBX'>0
QUIT
SET J=$EXTRACT(@ORMSG@(OBX),1,3)
if J="ORC"
QUIT
if J="MSH"
QUIT
IF J="OBX"
Begin DoDot:1
+4 NEW SEG,NAME,VALUE
SET SEG=@ORMSG@(OBX)
+5 SET NAME=$$UP^XLFSTR($PIECE($PIECE(SEG,"|",4),U,2))
SET VALUE=$PIECE(SEG,"|",6)
+6 IF NAME="PROVISIONAL DIAGNOSIS"
Begin DoDot:2
+7 if $PIECE(SEG,"|",3)="CE"
SET ORDIALOG($$PTR("CODE"),1)=$PIECE(VALUE,U)
SET VALUE=$PIECE(VALUE,U,2)
+8 SET ORDIALOG($$PTR("FREE TEXT"),1)=VALUE
End DoDot:2
QUIT
+9 SET WP=$$PTR("WORD PROCESSING 1")
SET I=1
SET ^TMP("ORWORD",$JOB,WP,1,I,0)=VALUE
+10 SET J=0
FOR
SET J=$ORDER(@ORMSG@(OBX,J))
if J'>0
QUIT
SET I=I+1
SET ^TMP("ORWORD",$JOB,WP,1,I,0)=@ORMSG@(OBX,J)
End DoDot:1
+11 if $GET(I)
SET ^TMP("ORWORD",$JOB,WP,1,0)="^^"_I_U_I_U_DT_U
SET ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)"
+12 QUIT
+13 ;
OBR() ; -- Return subscript of RXE segment
+1 NEW X,I,SEG
SET X=""
SET I=+ORC
+2 FOR
SET I=$ORDER(@ORMSG@(I))
if I'>0
QUIT
SET SEG=$EXTRACT(@ORMSG@(I),1,3)
if SEG="ORC"
QUIT
IF SEG="OBR"
SET X=I
QUIT
+3 QUIT X
+4 ;
SC ; -- Status changed (i.e. scheduled)
+1 ; 6=active
if '$GET(ORSTS)
SET ORSTS=6
DO STATUS^ORCSAVE2(+ORIFN,ORSTS)
+2 QUIT
+3 ;
STATUS(X) ; -- Returns ptr to Order Status file #100.01
+1 QUIT $SELECT(X="DC":1,X="CM":2,X="HD":3,X="IP":5,X="SC":6,X="A":9,X="RP":12,X="CA":13,X="ZC":8,1:5)
+2 ;
RE ; -- Completed, w/results
+1 NEW I,SEG,DA,DR,DIE,X,Y
+2 if '$GET(ORSTS)
SET ORSTS=2
DO STATUS^ORCSAVE2(+ORIFN,ORSTS)
+3 SET X=""
SET DA=+ORIFN
SET DIE="^OR(100,"
+4 SET DR="71////"_+$EXTRACT($$NOW^XLFDT,1,12)
DO ^DIE
+5 SET I=+ORC
SET X=""
FOR
SET I=$ORDER(@ORMSG@(I))
if I<1
QUIT
SET SEG=$GET(@ORMSG@(I))
if $EXTRACT(SEG,1,3)="ORC"
QUIT
IF $EXTRACT(SEG,1,3)="OBX"
IF $PIECE(SEG,"|",4)["SIG FINDINGS"
SET X=$PIECE(SEG,"|",6)
QUIT
+6 SET $PIECE(^OR(100,DA,7),U,2)=$SELECT(X="Y":1,1:"")
+7 if '$GET(ORNP)
SET ORNP=+$PIECE($GET(^OR(100,+ORIFN,0)),U,4)
+8 ;group update - no CM ack needed
IF $PIECE(ORC,"|",17)["MAINTENANCE"
QUIT
+9 ;Ack stub for prov
IF $LENGTH($TEXT(ADD^ORRCACK))
DO ADD^ORRCACK(+ORIFN,ORNP)
+10 QUIT
+11 ;
UA ; -- Unable to Accept [ack]
+1 SET ORDUZ=""
IF '$LENGTH(OREASON1)
IF $LENGTH(OREASON)
SET OREASON1=OREASON
OC ; -- Cancelled/Denied
+1 ;Rejected
if '$LENGTH(ORNATR)
SET ORNATR="X"
+2 SET ^OR(100,+ORIFN,6)=$ORDER(^ORD(100.02,"C",ORNATR,0))_U_ORDUZ_U_ORLOG_U_U_OREASON1
+3 DO STATUS^ORCSAVE2(+ORIFN,13)
IF ORDCNTRL="OC"
DO UPDATE("DC")
QUIT
UD ; -- Unable to discontinue [ack]
+1 NEW DA
SET DA=$PIECE(ORIFN,";",2)
IF DA
Begin DoDot:1
+2 ;request rejected
SET $PIECE(^OR(100,+ORIFN,8,DA,0),U,15)=13
+3 if $LENGTH(OREASON1)
SET ^OR(100,+ORIFN,8,DA,1)=OREASON1
End DoDot:1
+4 QUIT
+5 ;
OD ; -- Discontinued
+1 SET ^OR(100,+ORIFN,6)=$SELECT($LENGTH(ORNATR):$ORDER(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON1
+2 DO STATUS^ORCSAVE2(+ORIFN,1)
if $LENGTH(ORNATR)
DO UPDATE("DC")
+3 QUIT
+4 ;
DR ; -- Discontinued [ack]
+1 DO STATUS^ORCSAVE2(+ORIFN,1)
+2 QUIT
+3 ;
UPDATE(ORACT) ; -- continue processing
+1 NEW ORX,ORDA,ORP
+2 SET ORX=$$CREATE^ORX1(ORNATR)
if ORX
Begin DoDot:1
+3 SET ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON1,ORLOG,ORDUZ)
+4 IF ORDA'>0
SET ORERR="Cannot create new order action"
QUIT
+5 DO RELEASE^ORCSAVE2(+ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
+6 DO SIGSTS^ORCSAVE2(+ORIFN,ORDA)
+7 IF $GET(ORL)
SET ORP(1)=+ORIFN_";"_ORDA_"^1"
DO PRINTS^ORWD1(.ORP,+ORL)
+8 SET $PIECE(^OR(100,+ORIFN,3),U,7)=ORDA
End DoDot:1
+9 IF 'ORX
IF ORACT="DC"
IF '$$ACTV^ORX1(ORNATR)
SET $PIECE(^OR(100,+ORIFN,3),U,7)=0
+10 if $GET(ORACT)="DC"
DO CANCEL^ORCSEND(+ORIFN)
+11 QUIT
+12 ;
PTR(X) ; -- Returns ptr to prompt in Order Dialog file #101.41
+1 QUIT $ORDER(^ORD(101.41,"AB",$EXTRACT("OR GTX "_X,1,63),0))
