- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORMGMRC.m
r613 r623 1 ORMGMRC ; SLC/MKB - Process Consult ORM msgs ;12/13/20062 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,26,68,92,153,174,195,255,243**;Dec 17, 1997;Build 242 3 EN 4 5 6 7 8 9 10 11 12 13 14 ZP 15 16 17 18 19 ZR 20 21 22 23 ZU 24 25 26 27 OK 28 29 30 31 32 33 XX 34 35 36 37 38 39 40 41 42 D PXRMKILL^ORDD100(ORIFN,ORVP,ORLOG); JEH 25543 44 45 46 47 48 49 50 51 D PXRMADD^ORDD100(ORIFN,ORVP,ORLOG); JEH 25552 53 54 55 SN 56 57 58 59 60 61 SN1 62 63 64 65 66 67 68 69 70 71 72 DLG 73 74 75 76 77 78 79 80 81 82 83 84 85 D1 86 87 88 89 90 91 92 93 94 95 96 97 98 99 OBR() 100 101 102 103 104 SC 105 106 107 108 STATUS(X) 109 110 111 RE 112 113 114 115 116 117 118 119 120 121 122 123 UA 124 125 OC 126 127 128 129 UD 130 131 132 133 134 135 OD 136 137 138 139 140 DR 141 142 143 144 UPDATE(ORACT) 145 146 147 148 149 150 151 152 153 154 155 156 157 PTR(X) 158 1 ORMGMRC ; 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 3 EN ; -- 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 ; 14 ZP ; -- 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 ; 19 ZR ; -- Purged as requested [ack] 20 D DELETE^ORCSAVE2(+ORIFN) 21 Q 22 ; 23 ZU ; -- Unable to purge [ack] 24 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity 25 Q 26 ; 27 OK ; -- 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 ; 33 XX ; -- 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 ; 55 SN ; -- 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) 61 SN1 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 ; 72 DLG ; -- 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 85 D1 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 ; 99 OBR() ; -- 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 ; 104 SC ; -- Status changed (i.e. scheduled) 105 S:'$G(ORSTS) ORSTS=6 D STATUS^ORCSAVE2(+ORIFN,ORSTS) ; 6=active 106 Q 107 ; 108 STATUS(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 ; 111 RE ; -- 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 ; 123 UA ; -- Unable to Accept [ack] 124 S ORDUZ="" I '$L(OREASON1),$L(OREASON) S OREASON1=OREASON 125 OC ; -- 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 129 UD ; -- 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 ; 135 OD ; -- 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 ; 140 DR ; -- Discontinued [ack] 141 D STATUS^ORCSAVE2(+ORIFN,1) 142 Q 143 ; 144 UPDATE(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 ; 157 PTR(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 TracChangeset
for help on using the changeset viewer.
