ORMPS ; SLC/MKB/TC - Process Pharmacy ORM msgs ; Aug 28, 2024@09:14:37
;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,54,62,86,92,94,116,138,152,141,165,149,213,195,243,306,350,480,609**;Dec 17, 1997;Build 23
;Per VHA Directive 2004-038, this routine should not be modified.
;
; Reference to $$MVT^DGPMOBS in ICR #2664
; Reference to $$NOW^XLFDT in ICR #10103
;
EN ; -- entry point
I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q
I ORDCNTRL'="SN",ORDCNTRL'="ZC",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q
N ORSTS,RXE,ZRX,ORWHO,ORNOW
S ORSTS=$$STATUS(ORDSTS),RXE=$$RXE,ZRX=$$ZRX D QT^ORMPS1 ;QT in RXE
S ORNOW=+$E($$NOW^XLFDT,1,12),ORWHO=+$P(ZRX,"|",6) S:'ORWHO ORWHO=DUZ
S:ORLOG ORLOG=+$E(ORLOG,1,12) ;no seconds
S:'$L(ORNATR) ORNATR=$P(ZRX,"|",3) S:OREASON["^" OREASON=$P(OREASON,U,5)
I ORNATR="D",'$L(OREASON) S OREASON="DUPLICATE"
D @ORDCNTRL
Q
;
ZV ; -- Verified
N ORUSR,ORVER,ORDA,ORES,ORI
S ORUSR=+$P(ORC,"|",12),ORVER="N" Q:'ORUSR
S ORDA=+$P($G(^OR(100,+ORIFN,3)),U,7),ORES(+ORIFN_";"_ORDA)=""
Q:$P($G(^OR(100,+ORIFN,8,ORDA,0)),U,8) ;already verified
D REPLCD^ORCACT1 ;get unverified replaced orders
S ORI="" F S ORI=$O(ORES(ORI)) Q:ORI="" D
. S ORDA=+$P(ORI,";",2)
. D VERIFY^ORCSAVE2(+ORI,ORDA,"N",ORUSR,ORLOG)
Q
;
ZP ; -- Purged
Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0))
K ^OR(100,+ORIFN,4) I "^3^5^6^15^"[(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
;
XR ; -- Changed as requested [ack]
N ORIG S ORIG=$P(^OR(100,+ORIFN,3),U,5) I ORIG,$P(^OR(100,ORIG,3),U,3)'=12 D STATUS^ORCSAVE2(ORIG,12)
OK ; -- Order accepted, PS order # assigned [ack]
S ^OR(100,+ORIFN,4)=PKGIFN ;PS identifier
D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS)
Q
;
ZC ; -- convert orders
N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORP,ORSIG,ORIG,TYPE,EVNT
I '$D(^VA(200,ORDUZ,0)) S ORERR="Missing or invalid entering person" Q
I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q
I 'RXE S ORERR="Missing or invalid RXE segment" Q
S RXO=$$RXO,RXC=$$RXC K ^TMP("ORWORD",$J)
D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1")
ZC1 ; continue
Q:$D(ORERR) I 'ORIFN!('$D(^OR(100,+ORIFN,0))) D Q ;create
. K ORIFN D SN1 Q:'$G(ORIFN) S ORDCNTRL="SN"
. I ORSTOP,ORSTOP<ORNOW S $P(^OR(100,ORIFN,3),U)=ORSTOP
S ORIFN=+ORIFN D RESPONSE^ORCSAVE K ^TMP("ORWORD",$J)
S ^OR(100,ORIFN,4)=PKGIFN,$P(^(0),U,5)=+ORDIALOG_";ORD(101.41,"
D DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP),STATUS^ORCSAVE2(ORIFN,ORSTS):ORSTS
Q
;
SN ; -- New backdoor order, return OE# via NA msg
I $$FINISHED^ORMPS2 D RO^ORMPS2 Q ;change action instead
N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORP,ORSIG,ORIG,TYPE,EVNT,ZSC
I '$D(^VA(200,ORDUZ,0)) S ORERR="Missing or 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
I 'RXE S ORERR="Missing or invalid RXE segment" Q
S RXO=$$RXO,RXC=$$RXC K ^TMP("ORWORD",$J),ORIFN
D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1") Q:$D(ORERR)
SN1 ; save order
D EN^ORCSAVE I '$G(ORIFN) S ORERR="Cannot create new order" G SNQ
D BDOSTR^ORWDBA3 ;DG1 & ZCL data
S ORIG=+$P(ZRX,"|",2),TYPE=$P(ZRX,"|",4) I ORIG D ;set fwd/bwd ptrs
. S TYPE=$S(TYPE="R":2,1:1) Q:'$D(^OR(100,ORIG,0))
. S $P(^OR(100,ORIFN,3),U,5)=ORIG,$P(^(3),U,11)=TYPE
. S $P(^OR(100,ORIG,3),U,6)=ORIFN,EVNT=$P(^(0),U,17)
. M ^OR(100,ORIFN,11)=^OR(100,ORIG,11) ; Move transfer multiple to new order
. I $L(EVNT),TYPE=1 S $P(^OR(100,ORIFN,0),U,17)=EVNT
. I TYPE=2,$G(ORCAT)="I" S ORSTRT=ORLOG D PARENT^ORMPS3 ;ck if complex
I $G(ORCAT)="O" S ZSC=$$ZSC^ORMPS3 I ZSC,$P(ZSC,"|",2)'?2.3U S ^OR(100,ORIFN,5)=$TR($P(ZSC,"|",2,9),"|","^") ;1 or 0 instead of [N]SC
SN2 D DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP)
D:ORSTS STATUS^ORCSAVE2(ORIFN,ORSTS)
D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR)
; if unsigned edit, leave ORIFN unsigned & mark ORIG as Sig Not Req'd
S ORSIG=1 ;$S('ORIG:1,TYPE'=1:1,$P($G(^OR(100,ORIG,8,1,0)),U,4)'=2:1,1:0)
D SIGSTS^ORCSAVE2(ORIFN,1):ORSIG,SIGN^ORCSAVE2(ORIG,,,5,1):'ORSIG
I ORDCNTRL="SN" D ;print
. S:ORNATR="" $P(^OR(100,ORIFN,8,1,0),U,12)="" ;CHCS/OP orders
. S ORP(1)=ORIFN_";1"_$S(ORNATR="":"^^^^1",$G(ORL):"^1",1:"")
. I ORP(1)["^" D PRINTS^ORWD1(.ORP,+$G(ORL))
S ^OR(100,ORIFN,4)=PKGIFN
D BACKDOOR^ORDEA(ORIFN,ORNP,.ORDIALOG)
SNQ K ^TMP("ORWORD",$J)
Q
;
XX ; -- Changed (new order not necessary)
Q:$P($G(^OR(100,+ORIFN,3)),U,3)=5 ;pending - update when finished
I '$$CHANGED^ORMPS2 D SC Q ;ck sts/dates only
RO ; -- Replacement order (finished)
S:ORNATR="" ORNATR="S" D RO^ORMPS2
Q
;
SC ; -- Status changed (verified, expired, suspended, renewed, reinstate)
N OR0,OR3,ZSC,DONE S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3))
I "^1^13^"[(U_$P(OR3,U,3)_U),ORSTS=7 Q ;retain DC status
I $P(OR3,U,3)=5,ORSTS=6 D Q:$G(DONE)
. I $$CHANGED^ORMPS2 S ORNATR="S" D RO^ORMPS2 S DONE=1 Q
. I $P(ZRX,"|",7)="TPN",+$P(OR0,U,11)'=$O(^ORD(100.98,"B","TPN",0)) D
.. N DA,DR,DIE,ORDG S ORDG=+$O(^ORD(100.98,"B","TPN",0))
.. ;four slashes below is OK, basically simulating a direct write of the global for the TO field which has no Input Transform anyway
.. S DA=+ORIFN,DR="23////"_ORDG,DIE="^OR(100," D ^DIE
. I $P(OR3,U,11)=2,$P(OR0,U,12)="I" S ORSTRT=+$P($G(^OR(100,+ORIFN,8,1,0)),U,16) ;use Release Date for inpt renewals
I $P(OR0,U,12)="I",$P(ZRX,"|",4)="R",+$P(ZRX,"|",2)=+ORIFN S ORSTRT=$P(OR0,U,8) ;keep orig start when renewed
I ORSTS=7,ORSTOP S $P(^OR(100,+ORIFN,6),U,6)=ORSTOP ;save exp date
I ORSTS=1 D EXPDT
I $P(OR3,U,3)=3,ORSTS'=3 D
.N ORNATR S ORNATR="I"
.D UPDATE(ORSTS,"RL")
I ($P(OR3,U,3)=3&ORSTS=3)!($P(OR3,U,3)'=3) D
.D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
.D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS)
I ORSTS=$P(OR3,U,3),ORSTOP'=$P(OR0,U,9) D SETALL^ORDD100(+ORIFN) ;AC xrf
S ^OR(100,+ORIFN,4)=PKGIFN
I "^1^13^"[(U_$P(OR3,U,3)_U),"^3^5^6^15^"[(U_ORSTS_U) D ;reinstated
. I $P($G(^OR(100,+ORIFN,8,+$P(OR3,U,7),0)),U,2)="DC" S ^(2)=ORNOW_U_ORWHO ; When^Who reinstated order
. S I="?" F S I=$O(^OR(100,+ORIFN,8,I),-1) Q:'+I I $P(^(I,0),U,15)="" S $P(^OR(100,+ORIFN,3),U,7)=I Q ;138 Finds current action
. K ^OR(100,+ORIFN,6) D SETALL^ORDD100(+ORIFN)
D UPD^ORMPS3 ;update some responses
Q
;
STATUS(X) ; -- HL7 order status
N Y S Y=$S(X="IP":5,X="CM":6,X="DC":1,X="ZE":7,X="HD":3,X="ZX":11,X="RP":12,X="ZZ":15,X="ZS":6,X="ZU":6,1:"")
Q Y
;
DE ; -- Data Errors
Q
;
UA ; -- Unable to accept [ack]
UX ; -- Unable to change [ack]
S:'$L(ORNATR) ORNATR="X" ;Rejected
S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORNOW_U_U_OREASON
I $P($G(^OR(100,+ORIFN,3)),U,11)=2 N ORIG S ORIG=$P(^(3),U,5) S:ORIG $P(^OR(100,ORIG,3),U,6)="" ;remove fwd ptr if pending renewal
D STATUS^ORCSAVE2(+ORIFN,13)
UC ; -- Unable to cancel [ack]
UD ; -- Unable to discontinue [ack]
UH ; -- Unable to hold [ack]
UR ; -- Unable to release hold [ack]
N ORDA S ORDA=+$P(ORIFN,";",2) I ORDA D
. S $P(^OR(100,+ORIFN,8,ORDA,0),U,15)=13 ;request rejected
. S:$L(OREASON) ^OR(100,+ORIFN,8,ORDA,1)=OREASON
Q
;
OC ; -- Cancelled (before pharmacist's verification)
G:ORTYPE="ORR" UA S:ORNATR="A" ORWHO=""
S:'ORSTS ORSTS=13 S:ORSTS=12 ORNATR="S"
S $P(^OR(100,+ORIFN,6),U,1,5)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORWHO_U_ORNOW_U_U_$S((OREASON["16:")!(OREASON["17:"):$P(OREASON,":",2),1:OREASON)
I $P($G(^OR(100,+ORIFN,3)),U,11)=2 N ORIG S ORIG=$P(^(3),U,5) S:ORIG $P(^OR(100,ORIG,3),U,6)="" ;remove fwd ptr when pending renewal cancelled
S ^OR(100,+ORIFN,4)=PKGIFN S:ORSTOP>ORNOW ORSTOP=ORNOW
D EXPDT,UPDATE(ORSTS,"DC")
Q
;
CR ; -- Cancelled [ack]
D EXPDT ;save exp date, if past
D STATUS^ORCSAVE2(+ORIFN,13) S ^OR(100,+ORIFN,4)=PKGIFN
Q
;
OD ; -- Discontinued (cancelled after pharmacist's verification)
S:'ORSTS ORSTS=1 S:ORSTS=12 ORNATR="C"
I ORNATR="A" S ORWHO="" I $G(DGPMT)=3,$$MVT^DGPMOBS(DGPMDA) D XTMP^ORMEVNT ;save order#
S $P(^OR(100,+ORIFN,6),U,1,5)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORWHO_U_ORNOW_U_U_$S((OREASON["16:")!(OREASON["17:"):$P(OREASON,":",2),1:OREASON)
S ^OR(100,+ORIFN,4)=PKGIFN S:ORSTOP>ORNOW ORSTOP=ORNOW
D EXPDT,UPDATE(ORSTS,"DC")
Q
;
DR ; -- Discontinued [ack]
D EXPDT ;save exp date, if past
D STATUS^ORCSAVE2(+ORIFN,1) S ^OR(100,+ORIFN,4)=PKGIFN
Q
;
EXPDT ; -- save exp date when dc'd
N STOP S STOP=$P($G(^OR(100,+ORIFN,0)),U,9)
I STOP,STOP<ORNOW,'$P($G(^OR(100,+ORIFN,6)),U,6) S $P(^(6),U,6)=STOP
Q
;
OH ; -- Held
S:'ORSTS ORSTS=3 D UPDATE(ORSTS,"HD")
Q
;
HR ; -- Held [ack]
D STATUS^ORCSAVE2(+ORIFN,3)
Q
;
RL ; -- Released hold
OE ; -- Released hold
N ORDA S ORDA=+$P(^OR(100,+ORIFN,3),U,7)
I $P($G(^OR(100,+ORIFN,8,ORDA,0)),U,2)="HD" S $P(^(2),U,1,2)=ORNOW_U_ORWHO
S:'$G(ORSTS) ORSTS=6 D UPDATE(ORSTS,"RL")
Q
;
OR ; -- Released / [ack]
S:'ORSTS ORSTS=6 D STATUS^ORCSAVE2(+ORIFN,ORSTS)
D:ORSTRT!ORSTOP DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
Q
;
UPDATE(ORSTS,ORACT) ; -- continue
N ORDA,ORP D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS)
D:ORSTRT!ORSTOP DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
D:$$CREATE^ORX1(ORNATR)!(ORACT="HD")!(ORACT="RL")
. S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORNOW,ORWHO)
. I ORDA'>0 S ORERR="Cannot create new order action" Q
. D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORNOW,ORWHO,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 ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0
D:$G(ORACT)="DC" CANCEL^ORCSEND(+ORIFN)
Q
;
RXO() ; -- RXO segment
N I,X S X="",I=$O(@ORMSG@(+ORC))
I I,$E(@ORMSG@(I),1,3)="RXO" S X=I_U_@ORMSG@(I)
Q X
;
RXE() ; -- RXE segment
N Z,X,I,SEG S X="",I=+ORC
; OR*3.0*480 include multiple lines of RXE segment
F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) I SEG="RXE" S X=I_U_@ORMSG@(I) S Z=0 F S Z=$O(@ORMSG@(I,Z)) Q:'Z S X=X_@ORMSG@(I,Z)
Q X
;
RXR() ; -- RXR segment
N X,I,SEG S X="",I=+RXE
F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="RXR" S X=I_U_@ORMSG@(I) Q
Q X
;
RXC() ; -- [First] RXC segment
N X,I,SEG S X="",I=+RXE
F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="RXC" S X=I Q
Q X
;
ZRX() ; -- ZRX 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="ZRX" S X=I_U_@ORMSG@(I) Q
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORMPS 10774 printed Sep 23, 2025@20:08:24 Page 2
ORMPS ; SLC/MKB/TC - Process Pharmacy ORM msgs ; Aug 28, 2024@09:14:37
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,54,62,86,92,94,116,138,152,141,165,149,213,195,243,306,350,480,609**;Dec 17, 1997;Build 23
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Reference to $$MVT^DGPMOBS in ICR #2664
+5 ; Reference to $$NOW^XLFDT in ICR #10103
+6 ;
EN ; -- entry point
+1 ;S ORERR="Invalid order control code" Q
IF '$LENGTH($TEXT(@ORDCNTRL))
QUIT
+2 IF ORDCNTRL'="SN"
IF ORDCNTRL'="ZC"
IF ORDCNTRL'="ZP"
IF 'ORIFN!('$DATA(^OR(100,+ORIFN,0)))
SET ORERR="Invalid OE/RR order number"
QUIT
+3 NEW ORSTS,RXE,ZRX,ORWHO,ORNOW
+4 ;QT in RXE
SET ORSTS=$$STATUS(ORDSTS)
SET RXE=$$RXE
SET ZRX=$$ZRX
DO QT^ORMPS1
+5 SET ORNOW=+$EXTRACT($$NOW^XLFDT,1,12)
SET ORWHO=+$PIECE(ZRX,"|",6)
if 'ORWHO
SET ORWHO=DUZ
+6 ;no seconds
if ORLOG
SET ORLOG=+$EXTRACT(ORLOG,1,12)
+7 if '$LENGTH(ORNATR)
SET ORNATR=$PIECE(ZRX,"|",3)
if OREASON["^"
SET OREASON=$PIECE(OREASON,U,5)
+8 IF ORNATR="D"
IF '$LENGTH(OREASON)
SET OREASON="DUPLICATE"
+9 DO @ORDCNTRL
+10 QUIT
+11 ;
ZV ; -- Verified
+1 NEW ORUSR,ORVER,ORDA,ORES,ORI
+2 SET ORUSR=+$PIECE(ORC,"|",12)
SET ORVER="N"
if 'ORUSR
QUIT
+3 SET ORDA=+$PIECE($GET(^OR(100,+ORIFN,3)),U,7)
SET ORES(+ORIFN_";"_ORDA)=""
+4 ;already verified
if $PIECE($GET(^OR(100,+ORIFN,8,ORDA,0)),U,8)
QUIT
+5 ;get unverified replaced orders
DO REPLCD^ORCACT1
+6 SET ORI=""
FOR
SET ORI=$ORDER(ORES(ORI))
if ORI=""
QUIT
Begin DoDot:1
+7 SET ORDA=+$PIECE(ORI,";",2)
+8 DO VERIFY^ORCSAVE2(+ORI,ORDA,"N",ORUSR,ORLOG)
End DoDot:1
+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^15^"[(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 ;
XR ; -- Changed as requested [ack]
+1 NEW ORIG
SET ORIG=$PIECE(^OR(100,+ORIFN,3),U,5)
IF ORIG
IF $PIECE(^OR(100,ORIG,3),U,3)'=12
DO STATUS^ORCSAVE2(ORIG,12)
OK ; -- Order accepted, PS order # assigned [ack]
+1 ;PS identifier
SET ^OR(100,+ORIFN,4)=PKGIFN
+2 if ORSTS
DO STATUS^ORCSAVE2(+ORIFN,ORSTS)
+3 QUIT
+4 ;
ZC ; -- convert orders
+1 NEW RXO,RXC,ORDIALOG,ORDG,ORPKG,ORP,ORSIG,ORIG,TYPE,EVNT
+2 IF '$DATA(^VA(200,ORDUZ,0))
SET ORERR="Missing or invalid entering person"
QUIT
+3 IF '$DATA(^VA(200,ORNP,0))
SET ORERR="Missing or invalid ordering provider"
QUIT
+4 IF 'RXE
SET ORERR="Missing or invalid RXE segment"
QUIT
+5 SET RXO=$$RXO
SET RXC=$$RXC
KILL ^TMP("ORWORD",$JOB)
+6 DO @($SELECT(RXC:"IV",$GET(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1")
ZC1 ; continue
+1 ;create
if $DATA(ORERR)
QUIT
IF 'ORIFN!('$DATA(^OR(100,+ORIFN,0)))
Begin DoDot:1
+2 KILL ORIFN
DO SN1
if '$GET(ORIFN)
QUIT
SET ORDCNTRL="SN"
+3 IF ORSTOP
IF ORSTOP<ORNOW
SET $PIECE(^OR(100,ORIFN,3),U)=ORSTOP
End DoDot:1
QUIT
+4 SET ORIFN=+ORIFN
DO RESPONSE^ORCSAVE
KILL ^TMP("ORWORD",$JOB)
+5 SET ^OR(100,ORIFN,4)=PKGIFN
SET $PIECE(^(0),U,5)=+ORDIALOG_";ORD(101.41,"
+6 DO DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP)
if ORSTS
DO STATUS^ORCSAVE2(ORIFN,ORSTS)
+7 QUIT
+8 ;
SN ; -- New backdoor order, return OE# via NA msg
+1 ;change action instead
IF $$FINISHED^ORMPS2
DO RO^ORMPS2
QUIT
+2 NEW RXO,RXC,ORDIALOG,ORDG,ORPKG,ORP,ORSIG,ORIG,TYPE,EVNT,ZSC
+3 IF '$DATA(^VA(200,ORDUZ,0))
SET ORERR="Missing or invalid entering person"
QUIT
+4 IF '$DATA(^VA(200,ORNP,0))
SET ORERR="Missing or invalid ordering provider"
QUIT
+5 ; I '$G(ORL) S ORERR="Missing or invalid patient location" Q
+6 IF 'RXE
SET ORERR="Missing or invalid RXE segment"
QUIT
+7 SET RXO=$$RXO
SET RXC=$$RXC
KILL ^TMP("ORWORD",$JOB),ORIFN
+8 DO @($SELECT(RXC:"IV",$GET(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1")
if $DATA(ORERR)
QUIT
SN1 ; save order
+1 DO EN^ORCSAVE
IF '$GET(ORIFN)
SET ORERR="Cannot create new order"
GOTO SNQ
+2 ;DG1 & ZCL data
DO BDOSTR^ORWDBA3
+3 ;set fwd/bwd ptrs
SET ORIG=+$PIECE(ZRX,"|",2)
SET TYPE=$PIECE(ZRX,"|",4)
IF ORIG
Begin DoDot:1
+4 SET TYPE=$SELECT(TYPE="R":2,1:1)
if '$DATA(^OR(100,ORIG,0))
QUIT
+5 SET $PIECE(^OR(100,ORIFN,3),U,5)=ORIG
SET $PIECE(^(3),U,11)=TYPE
+6 SET $PIECE(^OR(100,ORIG,3),U,6)=ORIFN
SET EVNT=$PIECE(^(0),U,17)
+7 ; Move transfer multiple to new order
MERGE ^OR(100,ORIFN,11)=^OR(100,ORIG,11)
+8 IF $LENGTH(EVNT)
IF TYPE=1
SET $PIECE(^OR(100,ORIFN,0),U,17)=EVNT
+9 ;ck if complex
IF TYPE=2
IF $GET(ORCAT)="I"
SET ORSTRT=ORLOG
DO PARENT^ORMPS3
End DoDot:1
+10 ;1 or 0 instead of [N]SC
IF $GET(ORCAT)="O"
SET ZSC=$$ZSC^ORMPS3
IF ZSC
IF $PIECE(ZSC,"|",2)'?2.3U
SET ^OR(100,ORIFN,5)=$TRANSLATE($PIECE(ZSC,"|",2,9),"|","^")
SN2 DO DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP)
+1 if ORSTS
DO STATUS^ORCSAVE2(ORIFN,ORSTS)
+2 DO RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR)
+3 ; if unsigned edit, leave ORIFN unsigned & mark ORIG as Sig Not Req'd
+4 ;$S('ORIG:1,TYPE'=1:1,$P($G(^OR(100,ORIG,8,1,0)),U,4)'=2:1,1:0)
SET ORSIG=1
+5 if ORSIG
DO SIGSTS^ORCSAVE2(ORIFN,1)
if 'ORSIG
DO SIGN^ORCSAVE2(ORIG,,,5,1)
+6 ;print
IF ORDCNTRL="SN"
Begin DoDot:1
+7 ;CHCS/OP orders
if ORNATR=""
SET $PIECE(^OR(100,ORIFN,8,1,0),U,12)=""
+8 SET ORP(1)=ORIFN_";1"_$SELECT(ORNATR="":"^^^^1",$GET(ORL):"^1",1:"")
+9 IF ORP(1)["^"
DO PRINTS^ORWD1(.ORP,+$GET(ORL))
End DoDot:1
+10 SET ^OR(100,ORIFN,4)=PKGIFN
+11 DO BACKDOOR^ORDEA(ORIFN,ORNP,.ORDIALOG)
SNQ KILL ^TMP("ORWORD",$JOB)
+1 QUIT
+2 ;
XX ; -- Changed (new order not necessary)
+1 ;pending - update when finished
if $PIECE($GET(^OR(100,+ORIFN,3)),U,3)=5
QUIT
+2 ;ck sts/dates only
IF '$$CHANGED^ORMPS2
DO SC
QUIT
RO ; -- Replacement order (finished)
+1 if ORNATR=""
SET ORNATR="S"
DO RO^ORMPS2
+2 QUIT
+3 ;
SC ; -- Status changed (verified, expired, suspended, renewed, reinstate)
+1 NEW OR0,OR3,ZSC,DONE
SET OR0=$GET(^OR(100,+ORIFN,0))
SET OR3=$GET(^(3))
+2 ;retain DC status
IF "^1^13^"[(U_$PIECE(OR3,U,3)_U)
IF ORSTS=7
QUIT
+3 IF $PIECE(OR3,U,3)=5
IF ORSTS=6
Begin DoDot:1
+4 IF $$CHANGED^ORMPS2
SET ORNATR="S"
DO RO^ORMPS2
SET DONE=1
QUIT
+5 IF $PIECE(ZRX,"|",7)="TPN"
IF +$PIECE(OR0,U,11)'=$ORDER(^ORD(100.98,"B","TPN",0))
Begin DoDot:2
+6 NEW DA,DR,DIE,ORDG
SET ORDG=+$ORDER(^ORD(100.98,"B","TPN",0))
+7 ;four slashes below is OK, basically simulating a direct write of the global for the TO field which has no Input Transform anyway
+8 SET DA=+ORIFN
SET DR="23////"_ORDG
SET DIE="^OR(100,"
DO ^DIE
End DoDot:2
+9 ;use Release Date for inpt renewals
IF $PIECE(OR3,U,11)=2
IF $PIECE(OR0,U,12)="I"
SET ORSTRT=+$PIECE($GET(^OR(100,+ORIFN,8,1,0)),U,16)
End DoDot:1
if $GET(DONE)
QUIT
+10 ;keep orig start when renewed
IF $PIECE(OR0,U,12)="I"
IF $PIECE(ZRX,"|",4)="R"
IF +$PIECE(ZRX,"|",2)=+ORIFN
SET ORSTRT=$PIECE(OR0,U,8)
+11 ;save exp date
IF ORSTS=7
IF ORSTOP
SET $PIECE(^OR(100,+ORIFN,6),U,6)=ORSTOP
+12 IF ORSTS=1
DO EXPDT
+13 IF $PIECE(OR3,U,3)=3
IF ORSTS'=3
Begin DoDot:1
+14 NEW ORNATR
SET ORNATR="I"
+15 DO UPDATE(ORSTS,"RL")
End DoDot:1
+16 IF ($PIECE(OR3,U,3)=3&ORSTS=3)!($PIECE(OR3,U,3)'=3)
Begin DoDot:1
+17 DO DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
+18 if ORSTS
DO STATUS^ORCSAVE2(+ORIFN,ORSTS)
End DoDot:1
+19 ;AC xrf
IF ORSTS=$PIECE(OR3,U,3)
IF ORSTOP'=$PIECE(OR0,U,9)
DO SETALL^ORDD100(+ORIFN)
+20 SET ^OR(100,+ORIFN,4)=PKGIFN
+21 ;reinstated
IF "^1^13^"[(U_$PIECE(OR3,U,3)_U)
IF "^3^5^6^15^"[(U_ORSTS_U)
Begin DoDot:1
+22 ; When^Who reinstated order
IF $PIECE($GET(^OR(100,+ORIFN,8,+$PIECE(OR3,U,7),0)),U,2)="DC"
SET ^(2)=ORNOW_U_ORWHO
+23 ;138 Finds current action
SET I="?"
FOR
SET I=$ORDER(^OR(100,+ORIFN,8,I),-1)
if '+I
QUIT
IF $PIECE(^(I,0),U,15)=""
SET $PIECE(^OR(100,+ORIFN,3),U,7)=I
QUIT
+24 KILL ^OR(100,+ORIFN,6)
DO SETALL^ORDD100(+ORIFN)
End DoDot:1
+25 ;update some responses
DO UPD^ORMPS3
+26 QUIT
+27 ;
STATUS(X) ; -- HL7 order status
+1 NEW Y
SET Y=$SELECT(X="IP":5,X="CM":6,X="DC":1,X="ZE":7,X="HD":3,X="ZX":11,X="RP":12,X="ZZ":15,X="ZS":6,X="ZU":6,1:"")
+2 QUIT Y
+3 ;
DE ; -- Data Errors
+1 QUIT
+2 ;
UA ; -- Unable to accept [ack]
UX ; -- Unable to change [ack]
+1 ;Rejected
if '$LENGTH(ORNATR)
SET ORNATR="X"
+2 SET ^OR(100,+ORIFN,6)=$ORDER(^ORD(100.02,"C",ORNATR,0))_U_U_ORNOW_U_U_OREASON
+3 ;remove fwd ptr if pending renewal
IF $PIECE($GET(^OR(100,+ORIFN,3)),U,11)=2
NEW ORIG
SET ORIG=$PIECE(^(3),U,5)
if ORIG
SET $PIECE(^OR(100,ORIG,3),U,6)=""
+4 DO STATUS^ORCSAVE2(+ORIFN,13)
UC ; -- Unable to cancel [ack]
UD ; -- Unable to discontinue [ack]
UH ; -- Unable to hold [ack]
UR ; -- Unable to release hold [ack]
+1 NEW ORDA
SET ORDA=+$PIECE(ORIFN,";",2)
IF ORDA
Begin DoDot:1
+2 ;request rejected
SET $PIECE(^OR(100,+ORIFN,8,ORDA,0),U,15)=13
+3 if $LENGTH(OREASON)
SET ^OR(100,+ORIFN,8,ORDA,1)=OREASON
End DoDot:1
+4 QUIT
+5 ;
OC ; -- Cancelled (before pharmacist's verification)
+1 if ORTYPE="ORR"
GOTO UA
if ORNATR="A"
SET ORWHO=""
+2 if 'ORSTS
SET ORSTS=13
if ORSTS=12
SET ORNATR="S"
+3 SET $PIECE(^OR(100,+ORIFN,6),U,1,5)=$SELECT($LENGTH(ORNATR):$ORDER(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORWHO_U_ORNOW_U_U_$SELECT((OREASON["16:")!(OREASON["17:"):$PIECE(OREASON,":",2),1:OREASON)
+4 ;remove fwd ptr when pending renewal cancelled
IF $PIECE($GET(^OR(100,+ORIFN,3)),U,11)=2
NEW ORIG
SET ORIG=$PIECE(^(3),U,5)
if ORIG
SET $PIECE(^OR(100,ORIG,3),U,6)=""
+5 SET ^OR(100,+ORIFN,4)=PKGIFN
if ORSTOP>ORNOW
SET ORSTOP=ORNOW
+6 DO EXPDT
DO UPDATE(ORSTS,"DC")
+7 QUIT
+8 ;
CR ; -- Cancelled [ack]
+1 ;save exp date, if past
DO EXPDT
+2 DO STATUS^ORCSAVE2(+ORIFN,13)
SET ^OR(100,+ORIFN,4)=PKGIFN
+3 QUIT
+4 ;
OD ; -- Discontinued (cancelled after pharmacist's verification)
+1 if 'ORSTS
SET ORSTS=1
if ORSTS=12
SET ORNATR="C"
+2 ;save order#
IF ORNATR="A"
SET ORWHO=""
IF $GET(DGPMT)=3
IF $$MVT^DGPMOBS(DGPMDA)
DO XTMP^ORMEVNT
+3 SET $PIECE(^OR(100,+ORIFN,6),U,1,5)=$SELECT($LENGTH(ORNATR):$ORDER(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORWHO_U_ORNOW_U_U_$SELECT((OREASON["16:")!(OREASON["17:"):$PIECE(OREASON,":",2),1:OREASON)
+4 SET ^OR(100,+ORIFN,4)=PKGIFN
if ORSTOP>ORNOW
SET ORSTOP=ORNOW
+5 DO EXPDT
DO UPDATE(ORSTS,"DC")
+6 QUIT
+7 ;
DR ; -- Discontinued [ack]
+1 ;save exp date, if past
DO EXPDT
+2 DO STATUS^ORCSAVE2(+ORIFN,1)
SET ^OR(100,+ORIFN,4)=PKGIFN
+3 QUIT
+4 ;
EXPDT ; -- save exp date when dc'd
+1 NEW STOP
SET STOP=$PIECE($GET(^OR(100,+ORIFN,0)),U,9)
+2 IF STOP
IF STOP<ORNOW
IF '$PIECE($GET(^OR(100,+ORIFN,6)),U,6)
SET $PIECE(^(6),U,6)=STOP
+3 QUIT
+4 ;
OH ; -- Held
+1 if 'ORSTS
SET ORSTS=3
DO UPDATE(ORSTS,"HD")
+2 QUIT
+3 ;
HR ; -- Held [ack]
+1 DO STATUS^ORCSAVE2(+ORIFN,3)
+2 QUIT
+3 ;
RL ; -- Released hold
OE ; -- Released hold
+1 NEW ORDA
SET ORDA=+$PIECE(^OR(100,+ORIFN,3),U,7)
+2 IF $PIECE($GET(^OR(100,+ORIFN,8,ORDA,0)),U,2)="HD"
SET $PIECE(^(2),U,1,2)=ORNOW_U_ORWHO
+3 if '$GET(ORSTS)
SET ORSTS=6
DO UPDATE(ORSTS,"RL")
+4 QUIT
+5 ;
OR ; -- Released / [ack]
+1 if 'ORSTS
SET ORSTS=6
DO STATUS^ORCSAVE2(+ORIFN,ORSTS)
+2 if ORSTRT!ORSTOP
DO DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
+3 QUIT
+4 ;
UPDATE(ORSTS,ORACT) ; -- continue
+1 NEW ORDA,ORP
if $GET(ORSTS)
DO STATUS^ORCSAVE2(+ORIFN,ORSTS)
+2 if ORSTRT!ORSTOP
DO DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
+3 if $$CREATE^ORX1(ORNATR)!(ORACT="HD")!(ORACT="RL")
Begin DoDot:1
+4 SET ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORNOW,ORWHO)
+5 IF ORDA'>0
SET ORERR="Cannot create new order action"
QUIT
+6 DO RELEASE^ORCSAVE2(+ORIFN,ORDA,ORNOW,ORWHO,ORNATR)
+7 DO SIGSTS^ORCSAVE2(+ORIFN,ORDA)
+8 IF $GET(ORL)
SET ORP(1)=+ORIFN_";"_ORDA_"^1"
DO PRINTS^ORWD1(.ORP,+ORL)
+9 SET $PIECE(^OR(100,+ORIFN,3),U,7)=ORDA
End DoDot:1
+10 IF ORACT="DC"
IF '$$ACTV^ORX1(ORNATR)
SET $PIECE(^OR(100,+ORIFN,3),U,7)=0
+11 if $GET(ORACT)="DC"
DO CANCEL^ORCSEND(+ORIFN)
+12 QUIT
+13 ;
RXO() ; -- RXO segment
+1 NEW I,X
SET X=""
SET I=$ORDER(@ORMSG@(+ORC))
+2 IF I
IF $EXTRACT(@ORMSG@(I),1,3)="RXO"
SET X=I_U_@ORMSG@(I)
+3 QUIT X
+4 ;
RXE() ; -- RXE segment
+1 NEW Z,X,I,SEG
SET X=""
SET I=+ORC
+2 ; OR*3.0*480 include multiple lines of RXE segment
+3 FOR
SET I=$ORDER(@ORMSG@(I))
if I'>0
QUIT
SET SEG=$EXTRACT(@ORMSG@(I),1,3)
IF SEG="RXE"
SET X=I_U_@ORMSG@(I)
SET Z=0
FOR
SET Z=$ORDER(@ORMSG@(I,Z))
if 'Z
QUIT
SET X=X_@ORMSG@(I,Z)
+4 QUIT X
+5 ;
RXR() ; -- RXR segment
+1 NEW X,I,SEG
SET X=""
SET I=+RXE
+2 FOR
SET I=$ORDER(@ORMSG@(I))
if I'>0
QUIT
SET SEG=$EXTRACT(@ORMSG@(I),1,3)
if SEG="ORC"
QUIT
IF SEG="RXR"
SET X=I_U_@ORMSG@(I)
QUIT
+3 QUIT X
+4 ;
RXC() ; -- [First] RXC segment
+1 NEW X,I,SEG
SET X=""
SET I=+RXE
+2 FOR
SET I=$ORDER(@ORMSG@(I))
if I'>0
QUIT
SET SEG=$EXTRACT(@ORMSG@(I),1,3)
if SEG="ORC"
QUIT
IF SEG="RXC"
SET X=I
QUIT
+3 QUIT X
+4 ;
ZRX() ; -- ZRX 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="ZRX"
SET X=I_U_@ORMSG@(I)
QUIT
+3 QUIT X
