- ORMPS ; SLC/MKB/TC - Process Pharmacy ORM msgs ;10/16/14 07:34
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,54,62,86,92,94,116,138,152,141,165,149,213,195,243,306,350,480**;Dec 17, 1997;Build 4
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- 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)
- . 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 simlulating 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 10593 printed Feb 18, 2025@23:58:37 Page 2
- ORMPS ; SLC/MKB/TC - Process Pharmacy ORM msgs ;10/16/14 07:34
- +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**;Dec 17, 1997;Build 4
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- 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 IF $LENGTH(EVNT)
- IF TYPE=1
- SET $PIECE(^OR(100,ORIFN,0),U,17)=EVNT
- +8 ;ck if complex
- IF TYPE=2
- IF $GET(ORCAT)="I"
- SET ORSTRT=ORLOG
- DO PARENT^ORMPS3
- End DoDot:1
- +9 ;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 simlulating 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