ORMRA ; SLC/MKB/RV - Process Radiology ORM msgs ;Oct 27, 2023@12:13:58
;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,53,92,110,136,153,174,195,228,243,296,535**;Dec 17, 1997;Build 20
;Reference to ^DIC(34 in ICR #2968
;Reference to ^RAMIS(71.2,"B" in ICR #2419
;Reference to ^VA(200 in ICR #4329
;Reference to ^DIE in ICR #10018
;Reference to $$SWSTAT^IBBAPI in ICR #4663
;Reference to $$NOW^XLFDT in ICR #10103
;Reference to $$UP^XLFSTR in ICR #10104
;
EN ; -- entry point for RA messages
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 OREASON=$S($P(OREASON,U,6)="99RAR":$P(OREASON,U,5),1:$P(OREASON,U,2))
S:'ORDUZ ORDUZ=DUZ S:'ORLOG ORLOG=+$E($$NOW^XLFDT,1,12)
D @ORDCNTRL
Q
;
ZP ; -- Purged
Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0)) K ^OR(100,+ORIFN,4)
; - Set status=lapsed, if still active
I "^3^5^6^8^"[(U_$P($G(^OR(100,+ORIFN,3)),U,3)_U) D STATUS^ORCSAVE2(ORIFN,14)
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, RA order # assigned [ack]
N ORSTS,OBR S ^OR(100,+ORIFN,4)=PKGIFN,ORSTS=5 ; 5=pending
; Ck if also scheduled, else quit
S OBR=$O(@ORMSG@(+ORC)) G:'OBR OKQ G:$E(@ORMSG@(OBR),1,3)'="OBR" OKQ
S ORSTRT=$$FMDATE^ORM($P(@ORMSG@(OBR),"|",37))
D:ORSTRT DATES^ORCSAVE2(+ORIFN,ORSTRT)
OKQ D STATUS^ORCSAVE2(ORIFN,ORSTS)
;Save the Radiology pre-certification Account Reference in the PV1
;segment of the HL7 message from the Radiology package to the Order
;File (#100). Support for Patch OR*3.0*228
I +$$SWSTAT^IBBAPI() D PRECERT^ORWPFSS2 ;IA #4663
Q
;
XX ; -- Change order
N ORDIALOG,ORDG,ORDA,ORX,ORP S:'$L(ORNATR) ORNATR="S"
D DLG Q:$D(ORERR) Q:'$D(ORDIALOG) S ORIFN=+ORIFN
S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,OREASON,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:$P($G(^OR(100,ORIFN,8,ORX,0)),U,15)="" $P(^(0),U,15)=12
S $P(^OR(100,ORIFN,3),U,7)=ORDA D STATUS^ORCSAVE2(ORIFN,6)
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
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 ORDUZ,'$D(^VA(200,ORDUZ,0)) S ORERR="Invalid entering person" Q
I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q
I '$G(ORL) S ORERR="Missing or invalid patient location" Q
D DLG Q:$D(ORERR) Q:'$D(ORDIALOG)
SNQ D EN^ORCSAVE K ^TMP("ORWORD",$J)
I '$G(ORIFN) S ORERR="Cannot create new order" Q
;Save DG1 and ZCL segments of HL7 message from backdoor orders
D BDOSTR^ORWDBA3
;Save the Radiology pre-certification Account Reference in the PV1
;segment of the HL7 message from the Radiology package to the Order
;File (#100). Support for Patch OR*3.0*228
I +$$SWSTAT^IBBAPI() D PRECERT^ORWPFSS2 ;IA #4663
D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1)
D STATUS^ORCSAVE2(ORIFN,5) S ^OR(100,ORIFN,4)=PKGIFN
I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy
Q
;
DLG ; -- Build ORDIALOG() from msg
N OBR,OI,MODS,J,X,Y,ILOC,MODE,CH,CHI,OBX,NTE,REASON
S ORDIALOG=$O(^ORD(101.41,"AB","RA OERR EXAM",0))
D GETDLG1^ORCD(ORDIALOG)
S ORDIALOG($$PTR("CATEGORY"),1)=$G(ORCAT)
S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT
S ORDIALOG($$PTR("URGENCY"),1)=ORURG
S:$P(ORC,"|",12) ORDIALOG($$PTR("PROVIDER"),1)=+$P(ORC,"|",12)
D1 S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q
S OI=$$ORDITEM^ORM($P(@ORMSG@(OBR),"|",5))
I 'OI S ORERR="Invalid procedure" Q
S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
S ORDG=$P($G(^ORD(101.43,+OI,"RA")),U,3) S:$L(ORDG) ORDG=+$O(^ORD(100.98,"B",ORDG,0)) I 'ORDG S ORDG=$P(^ORD(101.41,+ORDIALOG,0),U,5) ; Im Type
S MODS=$P(@ORMSG@(OBR),"|",19) I $L(MODS) D
. F J=1:1:$L(MODS,"~") S X=$P(MODS,"~",J) I $L(X) S Y=$O(^RAMIS(71.2,"B",X,0)) S:Y ORDIALOG($$PTR("MODIFIERS"),J)=Y
S ILOC=+$P(@ORMSG@(OBR),"|",20),MODE=$P(@ORMSG@(OBR),"|",31),REASON=$P($P(@ORMSG@(OBR),"|",32),U,2)
S:ILOC ORDIALOG($$PTR("IMAGING LOCATION"),1)=ILOC
S ORDIALOG($$PTR("MODE OF TRANSPORT"),1)=$S(MODE="WALK":"A",MODE="CART":"S",1:$E(MODE))
S:$L(REASON) ORDIALOG($$PTR("STUDY REASON"),1)=REASON
I ORDCNTRL="XX" S NTE=+$O(@ORMSG@(OBR)) I NTE,$E($G(@ORMSG@(NTE)),1,3)="NTE" S OREASON=$P(@ORMSG@(NTE),"|",4) ;Tech's Comments
D2 ; might the procedure be scheduled at this point ?? Not in spec
S CH=$$PTR("WORD PROCESSING 1"),CHI=0
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 NAME,VALUE,X0 S VALUE=$P(@ORMSG@(OBX),"|",6)
. S NAME=$$UP^XLFSTR($P($P(@ORMSG@(OBX),"|",4),U,2))
. I NAME="CONTRACT/SHARING SOURCE" S X0=$G(^DIC(34,+VALUE,0)) S:$L(X0) ORDIALOG($$PTR(NAME),1)=+VALUE,ORDIALOG($$PTR("CATEGORY"),1)=$P(X0,U,2) Q
. I NAME="RESEARCH SOURCE" S ORDIALOG($$PTR(NAME),1)=VALUE,ORDIALOG($$PTR("CATEGORY"),1)="R" Q
. I NAME="PREGNANT" S ORDIALOG($$PTR(NAME),1)=VALUE Q
. I NAME="PRE-OP SCHEDULED DATE/TIME" S ORDIALOG($$PTR(NAME),1)=$$FMDATE^ORM(VALUE) Q
. S CHI=CHI+1,^TMP("ORWORD",$J,CH,1,CHI,0)=VALUE
S:CHI ^TMP("ORWORD",$J,CH,1,0)="^^"_CHI_U_CHI_U_DT_U,ORDIALOG(CH,1)="^TMP(""ORWORD"",$J,"_CH_",1)"
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))
;
SC ; -- Status changed (scheduled, registered, or unverified)
N ORSTS,OBR,OR3 ;110
S ORSTS=$S(ORDSTS="ZR":6,ORDSTS="ZU":6,1:8),OR3=$G(^OR(100,+ORIFN,3)) ;110
G:ORSTS=6 SCQ ;136 Done if active, else get scheduled data
S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q
S ORSTRT=$$FMDATE^ORM($P(@ORMSG@(OBR),"|",37))
D:ORSTRT DATES^ORCSAVE2(+ORIFN,ORSTRT)
I $P(OR3,U,3)=3,$P($G(^OR(100,+ORIFN,8,+$P(OR3,U,7),0)),U,2)="HD" D RL ;If status is hold and current action is hold then release. Added with 110
SCQ D STATUS^ORCSAVE2(ORIFN,ORSTS)
Q
;
RE ; -- Completed, w/results
N I,SEG,OBX
D STATUS^ORCSAVE2(ORIFN,2)
S OBX="" D ;get Results D/T [from OBR]
. N DA,DR,DIE,X,Y,OBR
. S DA=+ORIFN,DIE="^OR(100,",OBR=+$O(@ORMSG@(+ORC)),X=""
. I OBR,$E($G(@ORMSG@(OBR)),1,3)="OBR" S X=$P(@ORMSG@(OBR),"|",23)
. S DR="71////"_$S(X:$$FMDATE^ORM(X),1:+$E($$NOW^XLFDT,1,12)) D ^DIE
S I=+ORC 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" S OBX=I_U_SEG Q ;first one
S $P(^OR(100,+ORIFN,7),U,2)=$S($P(OBX,"|",9)="A":1,1:"")
S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4)
Q
;
OH ; -- Held
D UPDATE(3,"HD")
Q
;
OC ; -- Cancelled/Unable to accept [ack]
UA ; -- Unable to accept [ack]
S:'$L(ORNATR) ORNATR="X" ;Rejected
S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORLOG_U_U_OREASON
D STATUS^ORCSAVE2(ORIFN,13)
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(OREASON) ^OR(100,+ORIFN,8,DA,1)=OREASON
Q
;
OD ; -- Discontinued
S:$G(DGPMT) ORDUZ="" ;auto-dc on movement
S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON
D UPDATE(1,"DC")
Q
;
DR ; -- Discontinued [ack]
D STATUS^ORCSAVE2(ORIFN,1)
Q
;
UPDATE(ORSTS,ORACT) ; -- continue processing
N ORX,ORDA,ORP D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS)
S ORX=$$CREATE^ORX1(ORNATR) D:ORX
. S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,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 D ;no new action created
. ;I ORACT="DC" S:'$$ACTV^ORX1(ORNATR) $P(^OR(100,+ORIFN,3),U,7)=0 Q
. S:ORACT="HD"&$L(OREASON) ^OR(100,+ORIFN,8,1,1)=OREASON ;pend/sch only
I ORACT="DC" D CANCEL^ORCSEND(+ORIFN) S:'$$ACTV^ORX1(ORNATR) $P(^OR(100,+ORIFN,3),U,7)=0
Q
;
RL ;Release hold --entire section added with patch 110
S ^OR(100,+ORIFN,8,$P(OR3,U,7),2)=ORLOG_"^"_ORDUZ ;Set release hold date/time and release hold user
S ORNATR=$S($L(ORNATR):ORNATR,1:$P(^OR(100,+ORIFN,8,$P(OR3,U,7),0),U,12)) ;set nature of order for release equal to nature of order for hold if it doesn't exist
I $G(ORSTS)="" S ORSTS=6
D UPDATE(ORSTS,"RL")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORMRA 9076 printed Nov 22, 2024@17:42:06 Page 2
ORMRA ; SLC/MKB/RV - Process Radiology ORM msgs ;Oct 27, 2023@12:13:58
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,53,92,110,136,153,174,195,228,243,296,535**;Dec 17, 1997;Build 20
+2 ;Reference to ^DIC(34 in ICR #2968
+3 ;Reference to ^RAMIS(71.2,"B" in ICR #2419
+4 ;Reference to ^VA(200 in ICR #4329
+5 ;Reference to ^DIE in ICR #10018
+6 ;Reference to $$SWSTAT^IBBAPI in ICR #4663
+7 ;Reference to $$NOW^XLFDT in ICR #10103
+8 ;Reference to $$UP^XLFSTR in ICR #10104
+9 ;
EN ; -- entry point for RA messages
+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 SET OREASON=$SELECT($PIECE(OREASON,U,6)="99RAR":$PIECE(OREASON,U,5),1:$PIECE(OREASON,U,2))
+4 if 'ORDUZ
SET ORDUZ=DUZ
if 'ORLOG
SET ORLOG=+$EXTRACT($$NOW^XLFDT,1,12)
+5 DO @ORDCNTRL
+6 QUIT
+7 ;
ZP ; -- Purged
+1 if 'ORIFN
QUIT
if '$DATA(^OR(100,+ORIFN,0))
QUIT
KILL ^OR(100,+ORIFN,4)
+2 ; - Set status=lapsed, if still active
+3 IF "^3^5^6^8^"[(U_$PIECE($GET(^OR(100,+ORIFN,3)),U,3)_U)
DO STATUS^ORCSAVE2(ORIFN,14)
+4 QUIT
+5 ;
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, RA order # assigned [ack]
+1 ; 5=pending
NEW ORSTS,OBR
SET ^OR(100,+ORIFN,4)=PKGIFN
SET ORSTS=5
+2 ; Ck if also scheduled, else quit
+3 SET OBR=$ORDER(@ORMSG@(+ORC))
if 'OBR
GOTO OKQ
if $EXTRACT(@ORMSG@(OBR),1,3)'="OBR"
GOTO OKQ
+4 SET ORSTRT=$$FMDATE^ORM($PIECE(@ORMSG@(OBR),"|",37))
+5 if ORSTRT
DO DATES^ORCSAVE2(+ORIFN,ORSTRT)
OKQ DO STATUS^ORCSAVE2(ORIFN,ORSTS)
+1 ;Save the Radiology pre-certification Account Reference in the PV1
+2 ;segment of the HL7 message from the Radiology package to the Order
+3 ;File (#100). Support for Patch OR*3.0*228
+4 ;IA #4663
IF +$$SWSTAT^IBBAPI()
DO PRECERT^ORWPFSS2
+5 QUIT
+6 ;
XX ; -- Change order
+1 NEW ORDIALOG,ORDG,ORDA,ORX,ORP
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,OREASON,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)
+7 if $PIECE($GET(^OR(100,ORIFN,8,ORX,0)),U,15)=""
SET $PIECE(^(0),U,15)=12
+8 SET $PIECE(^OR(100,ORIFN,3),U,7)=ORDA
DO STATUS^ORCSAVE2(ORIFN,6)
+9 DO RELEASE^ORCSAVE2(ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
+10 ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd
+11 SET ORSIG=$SELECT($PIECE($GET(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0)
+12 if ORSIG
DO SIGSTS^ORCSAVE2(ORIFN,ORDA)
if 'ORSIG
DO SIGN^ORCSAVE2(ORIFN,,,5,ORX)
+13 ; -Update responses, get/save new order text:
+14 KILL ^OR(100,ORIFN,4.5)
DO RESPONSE^ORCSAVE
DO ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA)
+15 SET $PIECE(^OR(100,ORIFN,8,ORDA,0),U,14)=ORDA
+16 IF $GET(ORL)
SET ORP(1)=+ORIFN_";"_ORDA_"^1"
DO PRINTS^ORWD1(.ORP,+ORL)
+17 QUIT
+18 ;
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 ORDUZ
IF '$DATA(^VA(200,ORDUZ,0))
SET ORERR="Invalid entering person"
QUIT
+3 IF '$DATA(^VA(200,ORNP,0))
SET ORERR="Missing or invalid ordering provider"
QUIT
+4 IF '$GET(ORL)
SET ORERR="Missing or invalid patient location"
QUIT
+5 DO DLG
if $DATA(ORERR)
QUIT
if '$DATA(ORDIALOG)
QUIT
SNQ 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 ;Save the Radiology pre-certification Account Reference in the PV1
+5 ;segment of the HL7 message from the Radiology package to the Order
+6 ;File (#100). Support for Patch OR*3.0*228
+7 ;IA #4663
IF +$$SWSTAT^IBBAPI()
DO PRECERT^ORWPFSS2
+8 DO RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR)
DO SIGSTS^ORCSAVE2(ORIFN,1)
+9 DO STATUS^ORCSAVE2(ORIFN,5)
SET ^OR(100,ORIFN,4)=PKGIFN
+10 ; chart copy
IF $GET(ORL)
SET ORP(1)=ORIFN_";1^1"
DO PRINTS^ORWD1(.ORP,+ORL)
+11 QUIT
+12 ;
DLG ; -- Build ORDIALOG() from msg
+1 NEW OBR,OI,MODS,J,X,Y,ILOC,MODE,CH,CHI,OBX,NTE,REASON
+2 SET ORDIALOG=$ORDER(^ORD(101.41,"AB","RA OERR EXAM",0))
+3 DO GETDLG1^ORCD(ORDIALOG)
+4 SET ORDIALOG($$PTR("CATEGORY"),1)=$GET(ORCAT)
+5 SET ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT
+6 SET ORDIALOG($$PTR("URGENCY"),1)=ORURG
+7 if $PIECE(ORC,"|",12)
SET ORDIALOG($$PTR("PROVIDER"),1)=+$PIECE(ORC,"|",12)
D1 SET OBR=$ORDER(@ORMSG@(+ORC))
IF 'OBR!($EXTRACT($GET(@ORMSG@(OBR)),1,3)'="OBR")
SET ORERR="Missing OBR segment"
QUIT
+1 SET OI=$$ORDITEM^ORM($PIECE(@ORMSG@(OBR),"|",5))
+2 IF 'OI
SET ORERR="Invalid procedure"
QUIT
+3 SET ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
+4 ; Im Type
SET ORDG=$PIECE($GET(^ORD(101.43,+OI,"RA")),U,3)
if $LENGTH(ORDG)
SET ORDG=+$ORDER(^ORD(100.98,"B",ORDG,0))
IF 'ORDG
SET ORDG=$PIECE(^ORD(101.41,+ORDIALOG,0),U,5)
+5 SET MODS=$PIECE(@ORMSG@(OBR),"|",19)
IF $LENGTH(MODS)
Begin DoDot:1
+6 FOR J=1:1:$LENGTH(MODS,"~")
SET X=$PIECE(MODS,"~",J)
IF $LENGTH(X)
SET Y=$ORDER(^RAMIS(71.2,"B",X,0))
if Y
SET ORDIALOG($$PTR("MODIFIERS"),J)=Y
End DoDot:1
+7 SET ILOC=+$PIECE(@ORMSG@(OBR),"|",20)
SET MODE=$PIECE(@ORMSG@(OBR),"|",31)
SET REASON=$PIECE($PIECE(@ORMSG@(OBR),"|",32),U,2)
+8 if ILOC
SET ORDIALOG($$PTR("IMAGING LOCATION"),1)=ILOC
+9 SET ORDIALOG($$PTR("MODE OF TRANSPORT"),1)=$SELECT(MODE="WALK":"A",MODE="CART":"S",1:$EXTRACT(MODE))
+10 if $LENGTH(REASON)
SET ORDIALOG($$PTR("STUDY REASON"),1)=REASON
+11 ;Tech's Comments
IF ORDCNTRL="XX"
SET NTE=+$ORDER(@ORMSG@(OBR))
IF NTE
IF $EXTRACT($GET(@ORMSG@(NTE)),1,3)="NTE"
SET OREASON=$PIECE(@ORMSG@(NTE),"|",4)
D2 ; might the procedure be scheduled at this point ?? Not in spec
+1 SET CH=$$PTR("WORD PROCESSING 1")
SET CHI=0
+2 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
+3 NEW NAME,VALUE,X0
SET VALUE=$PIECE(@ORMSG@(OBX),"|",6)
+4 SET NAME=$$UP^XLFSTR($PIECE($PIECE(@ORMSG@(OBX),"|",4),U,2))
+5 IF NAME="CONTRACT/SHARING SOURCE"
SET X0=$GET(^DIC(34,+VALUE,0))
if $LENGTH(X0)
SET ORDIALOG($$PTR(NAME),1)=+VALUE
SET ORDIALOG($$PTR("CATEGORY"),1)=$PIECE(X0,U,2)
QUIT
+6 IF NAME="RESEARCH SOURCE"
SET ORDIALOG($$PTR(NAME),1)=VALUE
SET ORDIALOG($$PTR("CATEGORY"),1)="R"
QUIT
+7 IF NAME="PREGNANT"
SET ORDIALOG($$PTR(NAME),1)=VALUE
QUIT
+8 IF NAME="PRE-OP SCHEDULED DATE/TIME"
SET ORDIALOG($$PTR(NAME),1)=$$FMDATE^ORM(VALUE)
QUIT
+9 SET CHI=CHI+1
SET ^TMP("ORWORD",$JOB,CH,1,CHI,0)=VALUE
End DoDot:1
+10 if CHI
SET ^TMP("ORWORD",$JOB,CH,1,0)="^^"_CHI_U_CHI_U_DT_U
SET ORDIALOG(CH,1)="^TMP(""ORWORD"",$J,"_CH_",1)"
+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))
+2 ;
SC ; -- Status changed (scheduled, registered, or unverified)
+1 ;110
NEW ORSTS,OBR,OR3
+2 ;110
SET ORSTS=$SELECT(ORDSTS="ZR":6,ORDSTS="ZU":6,1:8)
SET OR3=$GET(^OR(100,+ORIFN,3))
+3 ;136 Done if active, else get scheduled data
if ORSTS=6
GOTO SCQ
+4 SET OBR=$ORDER(@ORMSG@(+ORC))
IF 'OBR!($EXTRACT($GET(@ORMSG@(OBR)),1,3)'="OBR")
SET ORERR="Missing OBR segment"
QUIT
+5 SET ORSTRT=$$FMDATE^ORM($PIECE(@ORMSG@(OBR),"|",37))
+6 if ORSTRT
DO DATES^ORCSAVE2(+ORIFN,ORSTRT)
+7 ;If status is hold and current action is hold then release. Added with 110
IF $PIECE(OR3,U,3)=3
IF $PIECE($GET(^OR(100,+ORIFN,8,+$PIECE(OR3,U,7),0)),U,2)="HD"
DO RL
SCQ DO STATUS^ORCSAVE2(ORIFN,ORSTS)
+1 QUIT
+2 ;
RE ; -- Completed, w/results
+1 NEW I,SEG,OBX
+2 DO STATUS^ORCSAVE2(ORIFN,2)
+3 ;get Results D/T [from OBR]
SET OBX=""
Begin DoDot:1
+4 NEW DA,DR,DIE,X,Y,OBR
+5 SET DA=+ORIFN
SET DIE="^OR(100,"
SET OBR=+$ORDER(@ORMSG@(+ORC))
SET X=""
+6 IF OBR
IF $EXTRACT($GET(@ORMSG@(OBR)),1,3)="OBR"
SET X=$PIECE(@ORMSG@(OBR),"|",23)
+7 SET DR="71////"_$SELECT(X:$$FMDATE^ORM(X),1:+$EXTRACT($$NOW^XLFDT,1,12))
DO ^DIE
End DoDot:1
+8 ;first one
SET I=+ORC
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"
SET OBX=I_U_SEG
QUIT
+9 SET $PIECE(^OR(100,+ORIFN,7),U,2)=$SELECT($PIECE(OBX,"|",9)="A":1,1:"")
+10 if '$GET(ORNP)
SET ORNP=+$PIECE($GET(^OR(100,+ORIFN,0)),U,4)
+11 QUIT
+12 ;
OH ; -- Held
+1 DO UPDATE(3,"HD")
+2 QUIT
+3 ;
OC ; -- Cancelled/Unable to accept [ack]
UA ; -- Unable to accept [ack]
+1 ;Rejected
if '$LENGTH(ORNATR)
SET ORNATR="X"
+2 SET ^OR(100,+ORIFN,6)=$ORDER(^ORD(100.02,"C",ORNATR,0))_U_U_ORLOG_U_U_OREASON
+3 DO STATUS^ORCSAVE2(ORIFN,13)
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(OREASON)
SET ^OR(100,+ORIFN,8,DA,1)=OREASON
End DoDot:1
+4 QUIT
+5 ;
OD ; -- Discontinued
+1 ;auto-dc on movement
if $GET(DGPMT)
SET ORDUZ=""
+2 SET ^OR(100,+ORIFN,6)=$SELECT($LENGTH(ORNATR):$ORDER(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON
+3 DO UPDATE(1,"DC")
+4 QUIT
+5 ;
DR ; -- Discontinued [ack]
+1 DO STATUS^ORCSAVE2(ORIFN,1)
+2 QUIT
+3 ;
UPDATE(ORSTS,ORACT) ; -- continue processing
+1 NEW ORX,ORDA,ORP
if $GET(ORSTS)
DO STATUS^ORCSAVE2(ORIFN,ORSTS)
+2 SET ORX=$$CREATE^ORX1(ORNATR)
if ORX
Begin DoDot:1
+3 SET ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,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 ;no new action created
IF 'ORX
Begin DoDot:1
+10 ;I ORACT="DC" S:'$$ACTV^ORX1(ORNATR) $P(^OR(100,+ORIFN,3),U,7)=0 Q
+11 ;pend/sch only
if ORACT="HD"&$LENGTH(OREASON)
SET ^OR(100,+ORIFN,8,1,1)=OREASON
End DoDot:1
+12 IF ORACT="DC"
DO CANCEL^ORCSEND(+ORIFN)
if '$$ACTV^ORX1(ORNATR)
SET $PIECE(^OR(100,+ORIFN,3),U,7)=0
+13 QUIT
+14 ;
RL ;Release hold --entire section added with patch 110
+1 ;Set release hold date/time and release hold user
SET ^OR(100,+ORIFN,8,$PIECE(OR3,U,7),2)=ORLOG_"^"_ORDUZ
+2 ;set nature of order for release equal to nature of order for hold if it doesn't exist
SET ORNATR=$SELECT($LENGTH(ORNATR):ORNATR,1:$PIECE(^OR(100,+ORIFN,8,$PIECE(OR3,U,7),0),U,12))
+3 IF $GET(ORSTS)=""
SET ORSTS=6
+4 DO UPDATE(ORSTS,"RL")
+5 QUIT
