source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMRA.m@ 1520

Last change on this file since 1520 was 623, checked in by George Lilly, 15 years ago

revised back to 6/30/08 version

File size: 8.3 KB
Line 
1ORMRA ; SLC/MKB - Process Radiology ORM msgs ;2/21/02 15:44 [3/4/04 10:43am]
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,53,92,110,136,153,174,195,228**;Dec 17, 1997
3 ;DBIA 2968 allows for reading ^DIC(34
4EN ; -- entry point for RA messages
5 I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q
6 I ORDCNTRL'="SN",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q
7 S OREASON=$S($P(OREASON,U,6)="99RAR":$P(OREASON,U,5),1:$P(OREASON,U,2))
8 S:'ORDUZ ORDUZ=DUZ S:'ORLOG ORLOG=+$E($$NOW^XLFDT,1,12)
9 D @ORDCNTRL
10 Q
11 ;
12ZP ; -- Purged
13 Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0)) K ^OR(100,+ORIFN,4)
14 ; - Set status=lapsed, if still active
15 I "^3^5^6^8^"[(U_$P($G(^OR(100,+ORIFN,3)),U,3)_U) D STATUS^ORCSAVE2(ORIFN,14)
16 Q
17 ;
18ZR ; -- Purged as requested [ack]
19 D DELETE^ORCSAVE2(+ORIFN)
20 Q
21 ;
22ZU ; -- Unable to purge [ack]
23 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity
24 Q
25 ;
26OK ; -- Order accepted, RA order # assigned [ack]
27 N ORSTS,OBR S ^OR(100,+ORIFN,4)=PKGIFN,ORSTS=5 ; 5=pending
28 ; Ck if also scheduled, else quit
29 S OBR=$O(@ORMSG@(+ORC)) G:'OBR OKQ G:$E(@ORMSG@(OBR),1,3)'="OBR" OKQ
30 S ORSTRT=$$FMDATE^ORM($P(@ORMSG@(OBR),"|",37))
31 D:ORSTRT DATES^ORCSAVE2(+ORIFN,ORSTRT)
32OKQ D STATUS^ORCSAVE2(ORIFN,ORSTS)
33 ;Save the Radiology pre-certification Account Reference in the PV1
34 ;segment of the HL7 message from the Radiology package to the Order
35 ;File (#100). Support for Patch OR*3.0*228
36 D PRECERT^ORWPFSS2
37 Q
38 ;
39XX ; -- Change order
40 N ORDIALOG,ORDG,ORDA,ORX,ORP S:'$L(ORNATR) ORNATR="S"
41 D DLG Q:$D(ORERR) Q:'$D(ORDIALOG) S ORIFN=+ORIFN
42 S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,OREASON,ORLOG,ORDUZ)
43 I ORDA'>0 S ORERR="Cannot create new order action" Q
44 ; -Update sts of order to active, last action to dc/edit:
45 S ORX=+$P($G(^OR(100,ORIFN,3)),U,7)
46 S:$P($G(^OR(100,ORIFN,8,ORX,0)),U,15)="" $P(^(0),U,15)=12
47 S $P(^OR(100,ORIFN,3),U,7)=ORDA D STATUS^ORCSAVE2(ORIFN,6)
48 D RELEASE^ORCSAVE2(ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
49 ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd
50 S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0)
51 D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG
52 ; -Update responses, get/save new order text:
53 K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA)
54 S $P(^OR(100,ORIFN,8,ORDA,0),U,14)=ORDA
55 I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
56 Q
57 ;
58SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg
59 N ORDIALOG,ORDG,ORP K ^TMP("ORWORD",$J) S:'$L(ORNATR) ORNATR="W"
60 I ORDUZ,'$D(^VA(200,ORDUZ,0)) S ORERR="Invalid entering person" Q
61 I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q
62 I '$G(ORL) S ORERR="Missing or invalid patient location" Q
63 D DLG Q:$D(ORERR) Q:'$D(ORDIALOG)
64SNQ D EN^ORCSAVE K ^TMP("ORWORD",$J)
65 I '$G(ORIFN) S ORERR="Cannot create new order" Q
66 ;Save DG1 and ZCL segments of HL7 message from backdoor orders
67 D BDOSTR^ORWDBA3
68 ;Save the Rediology pre-certification Account Reference in the PV1
69 ;segment of the HL7 message from the Radiology package to the Order
70 ;File (#100). Support for Patch OR*3.0*228
71 D PRECERT^ORWPFSS2
72 D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1)
73 D STATUS^ORCSAVE2(ORIFN,5) S ^OR(100,ORIFN,4)=PKGIFN
74 I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy
75 Q
76 ;
77DLG ; -- Build ORDIALOG() from msg
78 N OBR,OI,MODS,J,X,Y,ILOC,MODE,CH,CHI,OBX,NTE
79 S ORDIALOG=$O(^ORD(101.41,"AB","RA OERR EXAM",0))
80 D GETDLG1^ORCD(ORDIALOG)
81 S ORDIALOG($$PTR("CATEGORY"),1)=$G(ORCAT)
82 S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT
83 S ORDIALOG($$PTR("URGENCY"),1)=ORURG
84 S:$P(ORC,"|",12) ORDIALOG($$PTR("PROVIDER"),1)=+$P(ORC,"|",12)
85D1 S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q
86 S OI=$$ORDITEM^ORM($P(@ORMSG@(OBR),"|",5))
87 I 'OI S ORERR="Invalid procedure" Q
88 S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
89 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
90 S MODS=$P(@ORMSG@(OBR),"|",19) I $L(MODS) D
91 . 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
92 S ILOC=+$P(@ORMSG@(OBR),"|",20),MODE=$P(@ORMSG@(OBR),"|",31)
93 S:ILOC ORDIALOG($$PTR("IMAGING LOCATION"),1)=ILOC
94 S ORDIALOG($$PTR("MODE OF TRANSPORT"),1)=$S(MODE="WALK":"A",MODE="CART":"S",1:$E(MODE))
95 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
96D2 ; might the procedure be scheduled at this point ?? Not in spec
97 S CH=$$PTR("WORD PROCESSING 1"),CHI=0
98 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
99 . N NAME,VALUE,X0 S VALUE=$P(@ORMSG@(OBX),"|",6)
100 . S NAME=$$UP^XLFSTR($P($P(@ORMSG@(OBX),"|",4),U,2))
101 . 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
102 . I NAME="RESEARCH SOURCE" S ORDIALOG($$PTR(NAME),1)=VALUE,ORDIALOG($$PTR("CATEGORY"),1)="R" Q
103 . I NAME="PREGNANT" S ORDIALOG($$PTR(NAME),1)=VALUE Q
104 . I NAME="PRE-OP SCHEDULED DATE/TIME" S ORDIALOG($$PTR(NAME),1)=$$FMDATE^ORM(VALUE) Q
105 . S CHI=CHI+1,^TMP("ORWORD",$J,CH,1,CHI,0)=VALUE
106 S:CHI ^TMP("ORWORD",$J,CH,1,0)="^^"_CHI_U_CHI_U_DT_U,ORDIALOG(CH,1)="^TMP(""ORWORD"",$J,"_CH_",1)"
107 Q
108 ;
109PTR(X) ; -- Returns ptr to prompt in Order Dialog file #101.41
110 Q +$O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0))
111 ;
112SC ; -- Status changed (scheduled, registered, or unverified)
113 N ORSTS,OBR,OR3 ;110
114 S ORSTS=$S(ORDSTS="ZR":6,ORDSTS="ZU":6,1:8),OR3=$G(^OR(100,+ORIFN,3)) ;110
115 G:ORSTS=6 SCQ ;136 Done if active, else get scheduled data
116 S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q
117 S ORSTRT=$$FMDATE^ORM($P(@ORMSG@(OBR),"|",37))
118 D:ORSTRT DATES^ORCSAVE2(+ORIFN,ORSTRT)
119 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
120SCQ D STATUS^ORCSAVE2(ORIFN,ORSTS)
121 Q
122 ;
123RE ; -- Completed, w/results
124 N I,SEG,OBX
125 D STATUS^ORCSAVE2(ORIFN,2)
126 S OBX="" D ;get Results D/T [from OBR]
127 . N DA,DR,DIE,X,Y,OBR
128 . S DA=+ORIFN,DIE="^OR(100,",OBR=+$O(@ORMSG@(+ORC)),X=""
129 . I OBR,$E($G(@ORMSG@(OBR)),1,3)="OBR" S X=$P(@ORMSG@(OBR),"|",23)
130 . S DR="71////"_$S(X:$$FMDATE^ORM(X),1:+$E($$NOW^XLFDT,1,12)) D ^DIE
131 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
132 S $P(^OR(100,+ORIFN,7),U,2)=$S($P(OBX,"|",9)="A":1,1:"")
133 S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4)
134 I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov
135 Q
136 ;
137OH ; -- Held
138 D UPDATE(3,"HD")
139 Q
140 ;
141OC ; -- Cancelled/Unable to accept [ack]
142UA ; -- Unable to accept [ack]
143 S:'$L(ORNATR) ORNATR="X" ;Rejected
144 S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_U_ORLOG_U_U_OREASON
145 D STATUS^ORCSAVE2(ORIFN,13)
146UD ; -- Unable to discontinue [ack]
147 N DA S DA=+$P(ORIFN,";",2) I DA D
148 . S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;Request rejected
149 . S:$L(OREASON) ^OR(100,+ORIFN,8,DA,1)=OREASON
150 Q
151 ;
152OD ; -- Discontinued
153 S:$G(DGPMT) ORDUZ="" ;auto-dc on movement
154 S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON
155 D UPDATE(1,"DC")
156 Q
157 ;
158DR ; -- Discontinued [ack]
159 D STATUS^ORCSAVE2(ORIFN,1)
160 Q
161 ;
162UPDATE(ORSTS,ORACT) ; -- continue processing
163 N ORX,ORDA,ORP D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS)
164 S ORX=$$CREATE^ORX1(ORNATR) D:ORX
165 . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON,ORLOG,ORDUZ)
166 . I ORDA'>0 S ORERR="Cannot create new order action" Q
167 . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
168 . D SIGSTS^ORCSAVE2(+ORIFN,ORDA)
169 . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
170 . S $P(^OR(100,+ORIFN,3),U,7)=ORDA
171 I 'ORX D ;no new action created
172 . I ORACT="DC" S:'$$ACTV^ORX1(ORNATR) $P(^OR(100,+ORIFN,3),U,7)=0 Q
173 . S:ORACT="HD"&$L(OREASON) ^OR(100,+ORIFN,8,1,1)=OREASON ;pend/sch only
174 D:ORACT="DC" CANCEL^ORCSEND(+ORIFN)
175 Q
176 ;
177RL ;Release hold --entire section added with patch 110
178 S ^OR(100,+ORIFN,8,$P(OR3,U,7),2)=ORLOG_"^"_ORDUZ ;Set release hold date/time and release hold user
179 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
180 I $G(ORSTS)="" S ORSTS=6
181 D UPDATE(ORSTS,"RL")
182 Q
Note: See TracBrowser for help on using the repository browser.