source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMGMRC.m@ 1476

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

revised back to 6/30/08 version
File size: 7.0 KB
RevLine 
[623]1ORMGMRC ; SLC/MKB - Process Consult ORM msgs ;7/14/04 13:29
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,26,68,92,153,174,195,255**;Dec 17, 1997
3EN ; -- entry point for GMRC messges
4 I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q
5 I ORDCNTRL'="SN",ORDCNTRL'="ZP",'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q
6 S:ORDCNTRL="OC"&(ORTYPE="ORR") ORDCNTRL="UA" ;new code
7 N ORSTS,OREASON1,NTE S ORSTS=$$STATUS(ORDSTS)
8 S:'ORLOG ORLOG=$$NOW^XLFDT S:'ORDUZ ORDUZ=DUZ S:$G(DGPMT) ORDUZ=""
9 S OREASON=$P(OREASON,U,5),NTE=$O(@ORMSG@(+ORC)),OREASON1=""
10 I NTE,$E(@ORMSG@(NTE),1,3)="NTE" S OREASON1=$P(@ORMSG@(NTE),"|",4)
11 D @ORDCNTRL
12 Q
13 ;
14ZP ; -- Purged
15 Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0))
16 K ^OR(100,+ORIFN,4) I "^3^5^6^8^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,14) ; Remove pkg reference, sts=lapsed if still active
17 Q
18 ;
19ZR ; -- Purged as requested [ack]
20 D DELETE^ORCSAVE2(+ORIFN)
21 Q
22 ;
23ZU ; -- Unable to purge [ack]
24 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity
25 Q
26 ;
27OK ; -- Order accepted, GMRC order # assigned [ack]
28 S ^OR(100,+ORIFN,4)=PKGIFN S:'$G(ORSTS) ORSTS=5
29 D STATUS^ORCSAVE2(+ORIFN,ORSTS) ; 5=pending
30 D DATES^ORCSAVE2(+ORIFN,+$E($$NOW^XLFDT,1,12))
31 Q
32 ;
33XX ; -- Change order
34 N ORDIALOG,ORDG,ORDA,ORX,ORP,ORSIG S:'$L(ORNATR) ORNATR="S"
35 D DLG Q:$D(ORERR) Q:'$D(ORDIALOG) S ORIFN=+ORIFN
36 S ORDA=$$ACTION^ORCSAVE("XX",ORIFN,ORNP,OREASON1,ORLOG,ORDUZ)
37 I ORDA'>0 S ORERR="Cannot create new order action" Q
38 ; -Update sts of order to active, last action to dc/edit:
39 S ORX=+$P($G(^OR(100,ORIFN,3)),U,7) S:ORX'>0 ORX=+$O(^(8,ORDA),-1)
40 I $D(^OR(100,ORIFN,8,ORX,0)),$P(^(0),U,15)="" S $P(^(0),U,15)=12
41 S $P(^OR(100,ORIFN,3),U,7)=ORDA D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS)
42 D PXRMKILL^ORDD100(ORIFN,ORVP,ORLOG) ; JEH 255
43 D RELEASE^ORCSAVE2(ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
44 ; -If unsigned edit, leave XX unsigned & mark ORX as Sig Not Req'd
45 S ORSIG=$S($P($G(^OR(100,ORIFN,8,ORX,0)),U,4)'=2:1,1:0)
46 D SIGSTS^ORCSAVE2(ORIFN,ORDA):ORSIG,SIGN^ORCSAVE2(ORIFN,,,5,ORX):'ORSIG
47 ; -Update responses, get/save new order text:
48 K ^OR(100,ORIFN,4.5) D RESPONSE^ORCSAVE,ORDTEXT^ORCSAVE1(ORIFN_";"_ORDA)
49 S $P(^OR(100,ORIFN,8,ORDA,0),U,14)=ORDA
50 K:OREASON="RESUBMIT" ^OR(100,ORIFN,6) ;clear previous DC data
51 D PXRMADD^ORDD100(ORIFN,ORVP,ORLOG) ; JEH 255
52 I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
53 Q
54 ;
55SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg
56 N ORDIALOG,ORDG,ORP K ^TMP("ORWORD",$J) S:'$L(ORNATR) ORNATR="W"
57 I '$D(^VA(200,ORNP,0)) S ORERR="Missing or invalid ordering provider" Q
58 I ORDUZ,'$D(^VA(200,ORDUZ,0)) S ORERR="Invalid entering person" Q
59 I '$G(ORL) S ORERR="Missing or invalid patient location" Q
60 D DLG Q:$D(ORERR) Q:'$D(ORDIALOG)
61SN1 D EN^ORCSAVE K ^TMP("ORWORD",$J) ; setting status, xrefs
62 I '$G(ORIFN) S ORERR="Cannot create new order" Q
63 ;Save DG1 and ZCL segments of HL7 message from backdoor orders
64 D BDOSTR^ORWDBA3
65 D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1)
66 S:'ORSTRT ORSTRT=$$NOW^XLFDT D DATES^ORCSAVE2(+ORIFN,ORSTRT)
67 D:$G(ORSTS) STATUS^ORCSAVE2(ORIFN,ORSTS)
68 I $G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL) ; chart copy
69 S ^OR(100,ORIFN,4)=PKGIFN
70 Q
71 ;
72DLG ; -- Build ORDIALOG(),ORDG from msg
73 N OBR,USID,TYPE,OI,ZSV,J,OBX,WP,I
74 S OBR=$$OBR I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q
75 S USID=$P(@ORMSG@(OBR),"|",5),TYPE=$S(USID["99CON":"CONSULT",1:"REQUEST")
76 S ORDIALOG=$O(^ORD(101.41,"AB","GMRCOR "_TYPE,0))
77 D GETDLG1^ORCD(ORDIALOG)
78 S ORDIALOG($$PTR("URGENCY"),1)=ORURG
79 S OI=$$ORDITEM^ORM(USID) I 'OI S ORERR="Invalid consult or procedure" Q
80 S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
81 S ZSV=$O(@ORMSG@(OBR)) I ZSV,$E(@ORMSG@(ZSV),1,3)="ZSV" D
82 . N X1,X2 S X1=$P(@ORMSG@(ZSV),"|",2),X2=$P(@ORMSG@(ZSV),"|",3)
83 . I TYPE="REQUEST" S ORDIALOG($$PTR("REQUEST SERVICE"),1)=+$P(X1,U,4)
84 . I TYPE="CONSULT",$L(X2) S ORDIALOG($$PTR("FREE TEXT OI"),1)=X2
85D1 S ORDIALOG($$PTR("CATEGORY"),1)=$G(ORCAT)
86 S J=$P(@ORMSG@(OBR),"|",19),ORDIALOG($$PTR("PLACE OF CONSULTATION"),1)=$S(J="OC":"C",1:J)
87 S ORDIALOG($$PTR("PROVIDER"),1)=$P(@ORMSG@(OBR),"|",20)
88 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
89 . N SEG,NAME,VALUE S SEG=@ORMSG@(OBX)
90 . S NAME=$$UP^XLFSTR($P($P(SEG,"|",4),U,2)),VALUE=$P(SEG,"|",6)
91 . I NAME="PROVISIONAL DIAGNOSIS" D Q
92 .. S:$P(SEG,"|",3)="CE" ORDIALOG($$PTR("CODE"),1)=$P(VALUE,U),VALUE=$P(VALUE,U,2)
93 .. S ORDIALOG($$PTR("FREE TEXT"),1)=VALUE
94 . S WP=$$PTR("WORD PROCESSING 1"),I=1,^TMP("ORWORD",$J,WP,1,I,0)=VALUE
95 . S J=0 F S J=$O(@ORMSG@(OBX,J)) Q:J'>0 S I=I+1,^TMP("ORWORD",$J,WP,1,I,0)=@ORMSG@(OBX,J)
96 S:$G(I) ^TMP("ORWORD",$J,WP,1,0)="^^"_I_U_I_U_DT_U,ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)"
97 Q
98 ;
99OBR() ; -- Return subscript of RXE segment
100 N X,I,SEG S X="",I=+ORC
101 F S I=$O(@ORMSG@(I)) Q:I'>0 S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" I SEG="OBR" S X=I Q
102 Q X
103 ;
104SC ; -- Status changed (i.e. scheduled)
105 S:'$G(ORSTS) ORSTS=6 D STATUS^ORCSAVE2(+ORIFN,ORSTS) ; 6=active
106 Q
107 ;
108STATUS(X) ; -- Returns ptr to Order Status file #100.01
109 Q $S(X="DC":1,X="CM":2,X="HD":3,X="IP":5,X="SC":6,X="A":9,X="RP":12,X="CA":13,X="ZC":8,1:5)
110 ;
111RE ; -- Completed, w/results
112 N I,SEG,DA,DR,DIE,X,Y
113 S:'$G(ORSTS) ORSTS=2 D STATUS^ORCSAVE2(+ORIFN,ORSTS)
114 S X="",DA=+ORIFN,DIE="^OR(100,"
115 S DR="71////"_+$E($$NOW^XLFDT,1,12) D ^DIE
116 S I=+ORC,X="" 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",$P(SEG,"|",4)["SIG FINDINGS" S X=$P(SEG,"|",6) Q
117 S $P(^OR(100,DA,7),U,2)=$S(X="Y":1,1:"")
118 S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4)
119 I $P(ORC,"|",17)["MAINTENANCE" Q ;group update - no CM ack needed
120 I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov
121 Q
122 ;
123UA ; -- Unable to Accept [ack]
124 S ORDUZ="" I '$L(OREASON1),$L(OREASON) S OREASON1=OREASON
125OC ; -- Cancelled/Denied
126 S:'$L(ORNATR) ORNATR="X" ;Rejected
127 S ^OR(100,+ORIFN,6)=$O(^ORD(100.02,"C",ORNATR,0))_U_ORDUZ_U_ORLOG_U_U_OREASON1
128 D STATUS^ORCSAVE2(+ORIFN,13) I ORDCNTRL="OC" D UPDATE("DC") Q
129UD ; -- Unable to discontinue [ack]
130 N DA S DA=$P(ORIFN,";",2) I DA D
131 . S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;request rejected
132 . S:$L(OREASON1) ^OR(100,+ORIFN,8,DA,1)=OREASON1
133 Q
134 ;
135OD ; -- Discontinued
136 S ^OR(100,+ORIFN,6)=$S($L(ORNATR):$O(^ORD(100.02,"C",ORNATR,0)),1:"")_U_ORDUZ_U_ORLOG_U_U_OREASON1
137 D STATUS^ORCSAVE2(+ORIFN,1),UPDATE("DC"):$L(ORNATR)
138 Q
139 ;
140DR ; -- Discontinued [ack]
141 D STATUS^ORCSAVE2(+ORIFN,1)
142 Q
143 ;
144UPDATE(ORACT) ; -- continue processing
145 N ORX,ORDA,ORP
146 S ORX=$$CREATE^ORX1(ORNATR) D:ORX
147 . S ORDA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,OREASON1,ORLOG,ORDUZ)
148 . I ORDA'>0 S ORERR="Cannot create new order action" Q
149 . D RELEASE^ORCSAVE2(+ORIFN,ORDA,ORLOG,ORDUZ,ORNATR)
150 . D SIGSTS^ORCSAVE2(+ORIFN,ORDA)
151 . I $G(ORL) S ORP(1)=+ORIFN_";"_ORDA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
152 . S $P(^OR(100,+ORIFN,3),U,7)=ORDA
153 I 'ORX,ORACT="DC",'$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0
154 D:$G(ORACT)="DC" CANCEL^ORCSEND(+ORIFN)
155 Q
156 ;
157PTR(X) ; -- Returns ptr to prompt in Order Dialog file #101.41
158 Q $O(^ORD(101.41,"AB",$E("OR GTX "_X,1,63),0))
Note: See TracBrowser for help on using the repository browser.