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

ORMRA.m

Go to the documentation of this file. 
  1. ORMRA ; SLC/MKB/RV - Process Radiology ORM msgs ;15-Feb-2012 10:26;PLS
  1.  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,53,92,110,136,153,174,195,228,243,296,1010**;Dec 17, 1997;Build 47
  1.  ;DBIA 2968 allows for reading ^DIC(34
  1.  ; Modified - IHS/MSC/PLS - 02/15/2012 - Lines OKQ+4, SNQ+7
  1. EN ; -- entry point for RA messages
  1.  I '$L($T(@ORDCNTRL)) Q  ;S ORERR="Invalid order control code" Q
  1.  I ORDCNTRL'="SN",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q
  1.  S OREASON=$S($P(OREASON,U,6)="99RAR":$P(OREASON,U,5),1:$P(OREASON,U,2))
  1.  S:'ORDUZ ORDUZ=DUZ S:'ORLOG ORLOG=+$E($$NOW^XLFDT,1,12)
  1.  D @ORDCNTRL
  1.  Q
  1.  ;
  1. ZP ; -- Purged
  1.  Q:'ORIFN  Q:'$D(^OR(100,+ORIFN,0))  K ^OR(100,+ORIFN,4)
  1.  ; - Set status=lapsed, if still active
  1.  I "^3^5^6^8^"[(U_$P($G(^OR(100,+ORIFN,3)),U,3)_U) D STATUS^ORCSAVE2(ORIFN,14)
  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. OK ; -- Order accepted, RA order # assigned [ack]
  1.  N ORSTS,OBR S ^OR(100,+ORIFN,4)=PKGIFN,ORSTS=5 ; 5=pending
  1.  ; Ck if also scheduled, else quit
  1.  S OBR=$O(@ORMSG@(+ORC)) G:'OBR OKQ G:$E(@ORMSG@(OBR),1,3)'="OBR" OKQ
  1.  S ORSTRT=$$FMDATE^ORM($P(@ORMSG@(OBR),"|",37))
  1.  D:ORSTRT DATES^ORCSAVE2(+ORIFN,ORSTRT)
  1. OKQ D STATUS^ORCSAVE2(ORIFN,ORSTS)
  1.  ;Save the Radiology pre-certification Account Reference in the PV1
  1.  ;segment of the HL7 message from the Radiology package to the Order
  1.  ;File (#100). Support for Patch OR*3.0*228
  1.  ;I +$$SWSTAT^IBBAPI() D PRECERT^ORWPFSS2  ;IA #4663 ; IHS/MSC/PLS - 02/15/2012 commented out
  1.  Q
  1.  ;
  1. XX ; -- Change order
  1.  N ORDIALOG,ORDG,ORDA,ORX,ORP S:'$L(ORNATR) ORNATR="S"
  1.  D DLG Q:$D(ORERR)  Q:'$D(ORDIALOG)  S ORIFN=+ORIFN
  1.  S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,OREASON,ORLOG,ORDUZ)
  1.  I ORDA'>0 S ORERR="Cannot create new order action" Q
  1.  ; -Update sts of order to active, last action to dc/edit:
  1.  S ORX=+$P($G(^OR(100,ORIFN,3)),U,7)
  1.  S:$P($G(^OR(100,ORIFN,8,ORX,0)),U,15)="" $P(^(0),U,15)=12
  1.  S $P(^OR(100,ORIFN,3),U,7)=ORDA D STATUS^ORCSAVE2(ORIFN,6)
  1.  D RELEASE^ORCSAVE2(ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
  1.  ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd
  1.  S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0)
  1.  D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG
  1.  ; -Update responses, get/save new order text:
  1.  K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA)
  1.  S $P(^OR(100,ORIFN,8,ORDA,0),U,14)=ORDA
  1.  I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
  1.  Q
  1.  ;
  1. SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg
  1.  N ORDIALOG,ORDG,ORP K ^TMP("ORWORD",$J) S:'$L(ORNATR) ORNATR="W"
  1.  I ORDUZ,'$D(^VA(200,ORDUZ,0)) S ORERR="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.  D DLG Q:$D(ORERR)  Q:'$D(ORDIALOG)
  1. SNQ D EN^ORCSAVE K ^TMP("ORWORD",$J)
  1.  I '$G(ORIFN) S ORERR="Cannot create new order" Q
  1.  ;Save DG1 and ZCL segments of HL7 message from backdoor orders
  1.  D BDOSTR^ORWDBA3
  1.  ;Save the Radiology pre-certification Account Reference in the PV1
  1.  ;segment of the HL7 message from the Radiology package to the Order
  1.  ;File (#100). Support for Patch OR*3.0*228
  1.  ;I +$$SWSTAT^IBBAPI() D PRECERT^ORWPFSS2  ;IA #4663  ;IHS/MSC/PLS - 02/15/2012 commented out
  1.  D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1)
  1.  D STATUS^ORCSAVE2(ORIFN,5) S ^OR(100,ORIFN,4)=PKGIFN
  1.  I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy
  1.  Q
  1.  ;
  1. DLG ; -- Build ORDIALOG() from msg
  1.  N OBR,OI,MODS,J,X,Y,ILOC,MODE,CH,CHI,OBX,NTE,REASON
  1.  S ORDIALOG=$O(^ORD(101.41,"AB","RA OERR EXAM",0))
  1.  D GETDLG1^ORCD(ORDIALOG)
  1.  S ORDIALOG($$PTR("CATEGORY"),1)=$G(ORCAT)
  1.  S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT
  1.  S ORDIALOG($$PTR("URGENCY"),1)=ORURG
  1.  S:$P(ORC,"|",12) ORDIALOG($$PTR("PROVIDER"),1)=+$P(ORC,"|",12)
  1. D1 S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q
  1.  S OI=$$ORDITEM^ORM($P(@ORMSG@(OBR),"|",5))
  1.  I 'OI S ORERR="Invalid procedure" Q
  1.  S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
  1.  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
  1.  S MODS=$P(@ORMSG@(OBR),"|",19) I $L(MODS) D
  1.  . 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
  1.  S ILOC=+$P(@ORMSG@(OBR),"|",20),MODE=$P(@ORMSG@(OBR),"|",31),REASON=$P($P(@ORMSG@(OBR),"|",32),U,2)
  1.  S:ILOC ORDIALOG($$PTR("IMAGING LOCATION"),1)=ILOC
  1.  S ORDIALOG($$PTR("MODE OF TRANSPORT"),1)=$S(MODE="WALK":"A",MODE="CART":"S",1:$E(MODE))
  1.  S:$L(REASON) ORDIALOG($$PTR("STUDY REASON"),1)=REASON
  1.  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
  1. D2 ; might the procedure be scheduled at this point ??  Not in spec
  1.  S CH=$$PTR("WORD PROCESSING 1"),CHI=0
  1.  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
  1.  . N NAME,VALUE,X0 S VALUE=$P(@ORMSG@(OBX),"|",6)
  1.  . S NAME=$$UP^XLFSTR($P($P(@ORMSG@(OBX),"|",4),U,2))
  1.  . 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
  1.  . I NAME="RESEARCH SOURCE" S ORDIALOG($$PTR(NAME),1)=VALUE,ORDIALOG($$PTR("CATEGORY"),1)="R" Q
  1.  . I NAME="PREGNANT" S ORDIALOG($$PTR(NAME),1)=VALUE Q
  1.  . I NAME="PRE-OP SCHEDULED DATE/TIME" S ORDIALOG($$PTR(NAME),1)=$$FMDATE^ORM(VALUE) Q
  1.  . S CHI=CHI+1,^TMP("ORWORD",$J,CH,1,CHI,0)=VALUE
  1.  S:CHI ^TMP("ORWORD",$J,CH,1,0)="^^"_CHI_U_CHI_U_DT_U,ORDIALOG(CH,1)="^TMP(""ORWORD"",$J,"_CH_",1)"
  1.  Q
  1.  ;
  1. PTR(X) ; -- Returns ptr to prompt in Order Dialog file #101.41
  1.  Q +$O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0))
  1.  ;
  1. SC ; -- Status changed (scheduled, registered, or unverified)
  1.  N ORSTS,OBR,OR3 ;110
  1.  S ORSTS=$S(ORDSTS="ZR":6,ORDSTS="ZU":6,1:8),OR3=$G(^OR(100,+ORIFN,3)) ;110
  1.  G:ORSTS=6 SCQ ;136  Done if active, else get scheduled data
  1.  S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q
  1.  S ORSTRT=$$FMDATE^ORM($P(@ORMSG@(OBR),"|",37))
  1.  D:ORSTRT DATES^ORCSAVE2(+ORIFN,ORSTRT)
  1.  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
  1. SCQ D STATUS^ORCSAVE2(ORIFN,ORSTS)
  1.  Q
  1.  ;
  1. RE ; -- Completed, w/results
  1.  N I,SEG,OBX
  1.  D STATUS^ORCSAVE2(ORIFN,2)
  1.  S OBX="" D  ;get Results D/T [from OBR]
  1.  . N DA,DR,DIE,X,Y,OBR
  1.  . S DA=+ORIFN,DIE="^OR(100,",OBR=+$O(@ORMSG@(+ORC)),X=""
  1.  . I OBR,$E($G(@ORMSG@(OBR)),1,3)="OBR" S X=$P(@ORMSG@(OBR),"|",23)
  1.  . S DR="71////"_$S(X:$$FMDATE^ORM(X),1:+$E($$NOW^XLFDT,1,12)) D ^DIE
  1.  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
  1.  S $P(^OR(100,+ORIFN,7),U,2)=$S($P(OBX,"|",9)="A":1,1:"")
  1.  S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4)
  1.  I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov
  1.  Q
  1.  ;
  1. OH ; -- Held
  1.  D UPDATE(3,"HD")
  1.  Q
  1.  ;
  1. OC ; -- Cancelled/Unable to accept [ack]
  1. UA ; -- Unable to accept [ack]
  1.  S:'$L(ORNATR) ORNATR="X" ;Rejected
  1.  S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORLOG_U_U_OREASON
  1.  D STATUS^ORCSAVE2(ORIFN,13)
  1. UD ; -- Unable to discontinue [ack]
  1.  N DA S DA=+$P(ORIFN,";",2) I DA D
  1.  . S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;Request rejected
  1.  . S:$L(OREASON) ^OR(100,+ORIFN,8,DA,1)=OREASON
  1.  Q
  1.  ;
  1. OD ; -- Discontinued
  1.  S:$G(DGPMT) ORDUZ="" ;auto-dc on movement
  1.  S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON
  1.  D UPDATE(1,"DC")
  1.  Q
  1.  ;
  1. DR ; -- Discontinued [ack]
  1.  D STATUS^ORCSAVE2(ORIFN,1)
  1.  Q
  1.  ;
  1. UPDATE(ORSTS,ORACT) ; -- continue processing
  1.  N ORX,ORDA,ORP D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS)
  1.  S ORX=$$CREATE^ORX1(ORNATR) D:ORX
  1.  . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORLOG,ORDUZ)
  1.  . I ORDA'>0 S ORERR="Cannot create new order action" Q
  1.  . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORLOG,ORDUZ,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 'ORX D  ;no new action created
  1.  . ;I ORACT="DC" S:'$$ACTV^ORX1(ORNATR) $P(^OR(100,+ORIFN,3),U,7)=0 Q
  1.  . S:ORACT="HD"&$L(OREASON) ^OR(100,+ORIFN,8,1,1)=OREASON ;pend/sch only
  1.  I ORACT="DC" D CANCEL^ORCSEND(+ORIFN) S:'$$ACTV^ORX1(ORNATR) $P(^OR(100,+ORIFN,3),U,7)=0
  1.  Q
  1.  ;
  1. RL ;Release hold --entire section added with patch 110
  1.  S ^OR(100,+ORIFN,8,$P(OR3,U,7),2)=ORLOG_"^"_ORDUZ  ;Set release hold date/time and release hold user
  1.  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
  1.  I $G(ORSTS)="" S ORSTS=6
  1.  D UPDATE(ORSTS,"RL")
  1.  Q