source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMRA.m@ 1540

ORMRA ; SLC/MKB - Process Radiology ORM msgs ;2/21/02  15:44 [3/4/04 10:43am]
 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,53,92,110,136,153,174,195,228**;Dec 17, 1997
 ;DBIA 2968 allows for reading ^DIC(34
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
 D PRECERT^ORWPFSS2
 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 Rediology 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
 D PRECERT^ORWPFSS2
 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
 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)
 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))
 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)
 I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov
 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
 D:ORACT="DC" CANCEL^ORCSEND(+ORIFN)
 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