Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORMPS

ORMPS.m

Go to the documentation of this file.
  1. 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
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. EN ; -- entry point
  1. I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q
  1. I ORDCNTRL'="SN",ORDCNTRL'="ZC",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q
  1. N ORSTS,RXE,ZRX,ORWHO,ORNOW
  1. S ORSTS=$$STATUS(ORDSTS),RXE=$$RXE,ZRX=$$ZRX D QT^ORMPS1 ;QT in RXE
  1. S ORNOW=+$E($$NOW^XLFDT,1,12),ORWHO=+$P(ZRX,"|",6) S:'ORWHO ORWHO=DUZ
  1. S:ORLOG ORLOG=+$E(ORLOG,1,12) ;no seconds
  1. S:'$L(ORNATR) ORNATR=$P(ZRX,"|",3) S:OREASON["^" OREASON=$P(OREASON,U,5)
  1. I ORNATR="D",'$L(OREASON) S OREASON="DUPLICATE"
  1. D @ORDCNTRL
  1. Q
  1. ;
  1. ZV ; -- Verified
  1. N ORUSR,ORVER,ORDA,ORES,ORI
  1. S ORUSR=+$P(ORC,"|",12),ORVER="N" Q:'ORUSR
  1. S ORDA=+$P($G(^OR(100,+ORIFN,3)),U,7),ORES(+ORIFN_";"_ORDA)=""
  1. Q:$P($G(^OR(100,+ORIFN,8,ORDA,0)),U,8) ;already verified
  1. D REPLCD^ORCACT1 ;get unverified replaced orders
  1. S ORI="" F S ORI=$O(ORES(ORI)) Q:ORI="" D
  1. . S ORDA=+$P(ORI,";",2)
  1. . D VERIFY^ORCSAVE2(+ORI,ORDA,"N",ORUSR,ORLOG)
  1. Q
  1. ;
  1. ZP ; -- Purged
  1. Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0))
  1. 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
  1. Q
  1. ;
  1. ZR ; -- Purged as requested [ack]
  1. D DELETE^ORCSAVE2(+ORIFN)
  1. Q
  1. ;
  1. ZU ; -- Unable to purge [ack]
  1. S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ;update Last Activity
  1. Q
  1. ;
  1. XR ; -- Changed as requested [ack]
  1. 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)
  1. OK ; -- Order accepted, PS order # assigned [ack]
  1. S ^OR(100,+ORIFN,4)=PKGIFN ;PS identifier
  1. D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS)
  1. Q
  1. ;
  1. ZC ; -- convert orders
  1. N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORP,ORSIG,ORIG,TYPE,EVNT
  1. I '$D(^VA(200,ORDUZ,0)) S ORERR="Missing or invalid entering person" Q
  1. I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q
  1. I 'RXE S ORERR="Missing or invalid RXE segment" Q
  1. S RXO=$$RXO,RXC=$$RXC K ^TMP("ORWORD",$J)
  1. D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1")
  1. ZC1 ; continue
  1. Q:$D(ORERR) I 'ORIFN!('$D(^OR(100,+ORIFN,0))) D Q ;create
  1. . K ORIFN D SN1 Q:'$G(ORIFN) S ORDCNTRL="SN"
  1. . I ORSTOP,ORSTOP<ORNOW S $P(^OR(100,ORIFN,3),U)=ORSTOP
  1. S ORIFN=+ORIFN D RESPONSE^ORCSAVE K ^TMP("ORWORD",$J)
  1. S ^OR(100,ORIFN,4)=PKGIFN,$P(^(0),U,5)=+ORDIALOG_";ORD(101.41,"
  1. D DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP),STATUS^ORCSAVE2(ORIFN,ORSTS):ORSTS
  1. Q
  1. ;
  1. SN ; -- New backdoor order, return OE# via NA msg
  1. I $$FINISHED^ORMPS2 D RO^ORMPS2 Q ;change action instead
  1. N RXO,RXC,ORDIALOG,ORDG,ORPKG,ORP,ORSIG,ORIG,TYPE,EVNT,ZSC
  1. I '$D(^VA(200,ORDUZ,0)) S ORERR="Missing or invalid entering person" Q
  1. I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q
  1. ; I '$G(ORL) S ORERR="Missing or invalid patient location" Q
  1. I 'RXE S ORERR="Missing or invalid RXE segment" Q
  1. S RXO=$$RXO,RXC=$$RXC K ^TMP("ORWORD",$J),ORIFN
  1. D @($S(RXC:"IV",$G(ORCAT)="I":"UDOSE",1:"OUT")_"^ORMPS1") Q:$D(ORERR)
  1. SN1 ; save order
  1. D EN^ORCSAVE I '$G(ORIFN) S ORERR="Cannot create new order" G SNQ
  1. D BDOSTR^ORWDBA3 ;DG1 & ZCL data
  1. S ORIG=+$P(ZRX,"|",2),TYPE=$P(ZRX,"|",4) I ORIG D ;set fwd/bwd ptrs
  1. . S TYPE=$S(TYPE="R":2,1:1) Q:'$D(^OR(100,ORIG,0))
  1. . S $P(^OR(100,ORIFN,3),U,5)=ORIG,$P(^(3),U,11)=TYPE
  1. . S $P(^OR(100,ORIG,3),U,6)=ORIFN,EVNT=$P(^(0),U,17)
  1. . I $L(EVNT),TYPE=1 S $P(^OR(100,ORIFN,0),U,17)=EVNT
  1. . I TYPE=2,$G(ORCAT)="I" S ORSTRT=ORLOG D PARENT^ORMPS3 ;ck if complex
  1. 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
  1. SN2 D DATES^ORCSAVE2(ORIFN,ORSTRT,ORSTOP)
  1. D:ORSTS STATUS^ORCSAVE2(ORIFN,ORSTS)
  1. D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR)
  1. ; if unsigned edit, leave ORIFN unsigned & mark ORIG as Sig Not Req'd
  1. S ORSIG=1 ;$S('ORIG:1,TYPE'=1:1,$P($G(^OR(100,ORIG,8,1,0)),U,4)'=2:1,1:0)
  1. D SIGSTS^ORCSAVE2(ORIFN,1):ORSIG,SIGN^ORCSAVE2(ORIG,,,5,1):'ORSIG
  1. I ORDCNTRL="SN" D ;print
  1. . S:ORNATR="" $P(^OR(100,ORIFN,8,1,0),U,12)="" ;CHCS/OP orders
  1. . S ORP(1)=ORIFN_";1"_$S(ORNATR="":"^^^^1",$G(ORL):"^1",1:"")
  1. . I ORP(1)["^" D PRINTS^ORWD1(.ORP,+$G(ORL))
  1. S ^OR(100,ORIFN,4)=PKGIFN
  1. D BACKDOOR^ORDEA(ORIFN,ORNP,.ORDIALOG)
  1. SNQ K ^TMP("ORWORD",$J)
  1. Q
  1. ;
  1. XX ; -- Changed (new order not necessary)
  1. Q:$P($G(^OR(100,+ORIFN,3)),U,3)=5 ;pending - update when finished
  1. I '$$CHANGED^ORMPS2 D SC Q ;ck sts/dates only
  1. RO ; -- Replacement order (finished)
  1. S:ORNATR="" ORNATR="S" D RO^ORMPS2
  1. Q
  1. ;
  1. SC ; -- Status changed (verified, expired, suspended, renewed, reinstate)
  1. N OR0,OR3,ZSC,DONE S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3))
  1. I "^1^13^"[(U_$P(OR3,U,3)_U),ORSTS=7 Q ;retain DC status
  1. I $P(OR3,U,3)=5,ORSTS=6 D Q:$G(DONE)
  1. . I $$CHANGED^ORMPS2 S ORNATR="S" D RO^ORMPS2 S DONE=1 Q
  1. . I $P(ZRX,"|",7)="TPN",+$P(OR0,U,11)'=$O(^ORD(100.98,"B","TPN",0)) D
  1. .. N DA,DR,DIE,ORDG S ORDG=+$O(^ORD(100.98,"B","TPN",0))
  1. .. ;four slashes below is OK, basically simlulating a direct write of the global for the TO field which has no Input Transform anyway
  1. .. S DA=+ORIFN,DR="23////"_ORDG,DIE="^OR(100," D ^DIE
  1. . 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
  1. 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
  1. I ORSTS=7,ORSTOP S $P(^OR(100,+ORIFN,6),U,6)=ORSTOP ;save exp date
  1. I ORSTS=1 D EXPDT
  1. I $P(OR3,U,3)=3,ORSTS'=3 D
  1. .N ORNATR S ORNATR="I"
  1. .D UPDATE(ORSTS,"RL")
  1. I ($P(OR3,U,3)=3&ORSTS=3)!($P(OR3,U,3)'=3) D
  1. .D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
  1. .D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS)
  1. I ORSTS=$P(OR3,U,3),ORSTOP'=$P(OR0,U,9) D SETALL^ORDD100(+ORIFN) ;AC xrf
  1. S ^OR(100,+ORIFN,4)=PKGIFN
  1. I "^1^13^"[(U_$P(OR3,U,3)_U),"^3^5^6^15^"[(U_ORSTS_U) D ;reinstated
  1. . I $P($G(^OR(100,+ORIFN,8,+$P(OR3,U,7),0)),U,2)="DC" S ^(2)=ORNOW_U_ORWHO ; When^Who reinstated order
  1. . 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
  1. . K ^OR(100,+ORIFN,6) D SETALL^ORDD100(+ORIFN)
  1. D UPD^ORMPS3 ;update some responses
  1. Q
  1. ;
  1. STATUS(X) ; -- HL7 order status
  1. 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:"")
  1. Q Y
  1. ;
  1. DE ; -- Data Errors
  1. Q
  1. ;
  1. UA ; -- Unable to accept [ack]
  1. UX ; -- Unable to change [ack]
  1. S:'$L(ORNATR) ORNATR="X" ;Rejected
  1. S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORNOW_U_U_OREASON
  1. 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
  1. D STATUS^ORCSAVE2(+ORIFN,13)
  1. UC ; -- Unable to cancel [ack]
  1. UD ; -- Unable to discontinue [ack]
  1. UH ; -- Unable to hold [ack]
  1. UR ; -- Unable to release hold [ack]
  1. N ORDA S ORDA=+$P(ORIFN,";",2) I ORDA D
  1. . S $P(^OR(100,+ORIFN,8,ORDA,0),U,15)=13 ;request rejected
  1. . S:$L(OREASON) ^OR(100,+ORIFN,8,ORDA,1)=OREASON
  1. Q
  1. ;
  1. OC ; -- Cancelled (before pharmacist's verification)
  1. G:ORTYPE="ORR" UA S:ORNATR="A" ORWHO=""
  1. S:'ORSTS ORSTS=13 S:ORSTS=12 ORNATR="S"
  1. 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)
  1. 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
  1. S ^OR(100,+ORIFN,4)=PKGIFN S:ORSTOP>ORNOW ORSTOP=ORNOW
  1. D EXPDT,UPDATE(ORSTS,"DC")
  1. Q
  1. ;
  1. CR ; -- Cancelled [ack]
  1. D EXPDT ;save exp date, if past
  1. D STATUS^ORCSAVE2(+ORIFN,13) S ^OR(100,+ORIFN,4)=PKGIFN
  1. Q
  1. ;
  1. OD ; -- Discontinued (cancelled after pharmacist's verification)
  1. S:'ORSTS ORSTS=1 S:ORSTS=12 ORNATR="C"
  1. I ORNATR="A" S ORWHO="" I $G(DGPMT)=3,$$MVT^DGPMOBS(DGPMDA) D XTMP^ORMEVNT ;save order#
  1. 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)
  1. S ^OR(100,+ORIFN,4)=PKGIFN S:ORSTOP>ORNOW ORSTOP=ORNOW
  1. D EXPDT,UPDATE(ORSTS,"DC")
  1. Q
  1. ;
  1. DR ; -- Discontinued [ack]
  1. D EXPDT ;save exp date, if past
  1. D STATUS^ORCSAVE2(+ORIFN,1) S ^OR(100,+ORIFN,4)=PKGIFN
  1. Q
  1. ;
  1. EXPDT ; -- save exp date when dc'd
  1. N STOP S STOP=$P($G(^OR(100,+ORIFN,0)),U,9)
  1. I STOP,STOP<ORNOW,'$P($G(^OR(100,+ORIFN,6)),U,6) S $P(^(6),U,6)=STOP
  1. Q
  1. ;
  1. OH ; -- Held
  1. S:'ORSTS ORSTS=3 D UPDATE(ORSTS,"HD")
  1. Q
  1. ;
  1. HR ; -- Held [ack]
  1. D STATUS^ORCSAVE2(+ORIFN,3)
  1. Q
  1. ;
  1. RL ; -- Released hold
  1. OE ; -- Released hold
  1. N ORDA S ORDA=+$P(^OR(100,+ORIFN,3),U,7)
  1. I $P($G(^OR(100,+ORIFN,8,ORDA,0)),U,2)="HD" S $P(^(2),U,1,2)=ORNOW_U_ORWHO
  1. S:'$G(ORSTS) ORSTS=6 D UPDATE(ORSTS,"RL")
  1. Q
  1. ;
  1. OR ; -- Released / [ack]
  1. S:'ORSTS ORSTS=6 D STATUS^ORCSAVE2(+ORIFN,ORSTS)
  1. D:ORSTRT!ORSTOP DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
  1. Q
  1. ;
  1. UPDATE(ORSTS,ORACT) ; -- continue
  1. N ORDA,ORP D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS)
  1. D:ORSTRT!ORSTOP DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
  1. D:$$CREATE^ORX1(ORNATR)!(ORACT="HD")!(ORACT="RL")
  1. . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORNOW,ORWHO)
  1. . I ORDA'>0 S ORERR="Cannot create new order action" Q
  1. . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORNOW,ORWHO,ORNATR)
  1. . D SIGSTS^ORCSAVE2(+ORIFN,ORDA)
  1. . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
  1. . S $P(^OR(100,+ORIFN,3),U,7)=ORDA
  1. I ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0
  1. D:$G(ORACT)="DC" CANCEL^ORCSEND(+ORIFN)
  1. Q
  1. ;
  1. RXO() ; -- RXO segment
  1. N I,X S X="",I=$O(@ORMSG@(+ORC))
  1. I I,$E(@ORMSG@(I),1,3)="RXO" S X=I_U_@ORMSG@(I)
  1. Q X
  1. ;
  1. RXE() ; -- RXE segment
  1. N Z,X,I,SEG S X="",I=+ORC
  1. ; OR*3.0*480 include multiple lines of RXE segment
  1. 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)
  1. Q X
  1. ;
  1. RXR() ; -- RXR segment
  1. N X,I,SEG S X="",I=+RXE
  1. 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
  1. Q X
  1. ;
  1. RXC() ; -- [First] RXC segment
  1. N X,I,SEG S X="",I=+RXE
  1. 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
  1. Q X
  1. ;
  1. ZRX() ; -- ZRX segment
  1. N X,I,SEG S X="",I=+ORC
  1. 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
  1. Q X