OCXOCMPG ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Sort Code Segments cont...) ;5/08/01 10:11
;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105**;Dec 17,1997
;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
;
EN(OCXL,OCXCNT) ;
;
N OCXCODE,OCXVAR
D IN^OCXOCMP4(OCXL," ;")
S OCXCODE=""
;
I $L(OCXMCOD) D
.;
.D IN^OCXOCMP4(OCXL," ;")
.D IN^OCXOCMP4(OCXL," ; Run Execute Code")
.D IN^OCXOCMP4(OCXL," ;")
.;
.N NEWVAL,FLDNAME,FCNT,X
.S NEWVAL=OCXMCOD
.F FCNT=1:1 Q:'(NEWVAL["|") S NEWVAL=$P(NEWVAL,"|",1)_"X"_FCNT_$P(NEWVAL,"|",3,$L(NEWVAL,"|"))
.S X=NEWVAL D ^DIM
.I '$D(X) D Q
..N MESG
..S MESG(1)="**** WARNING *****************************************************"
..S MESG(2)=""
..S MESG(3)="The Execute code: "_OCXMCOD
..S MESG(4)=" Rule Format: "_$G(OCXR("R",OCXD1,"MCODE"))
..S MESG(5)=""
..S MESG(6)=" In Rule: ["_(+$G(OCXD0))_"] "_$P($G(^OCXS(860.2,+$G(OCXD0),0)),U,1)
..S MESG(7)=" Relation: ["_(+$G(OCXD1))_"] "_$G(^OCXS(860.2,+$G(OCXD0),"R",+$G(OCXD1),"E"))
..S MESG(8)=""
..S MESG(9)=" Did not pass the mumps syntax check. The code has been disabled."
..S MESG(10)=" This rule may not work correctly until the code is fixed."
..S MESG(11)="******************************************************************"
..S MESG(12)=""
..F FCNT=1:1 Q:'$D(MESG(FCNT)) D IN^OCXOCMP4(OCXL," ;"_MESG(FCNT))
..F FCNT=1:1 Q:'$D(MESG(FCNT)) D MESG(MESG(FCNT))
.;
.D IN^OCXOCMP4(OCXL," "_OCXMCOD)
;
D IN^OCXOCMP4(OCXL," Q:$G(OCXOERR)")
I ($P(OCXNOD0,U,3)),$L(OCXNMSG) D
.D IN^OCXOCMP4(OCXL," ;")
.D IN^OCXOCMP4(OCXL," ; Send Notification")
.D IN^OCXOCMP4(OCXL," ;")
.D IN^OCXOCMP4(OCXL," S (OCXDUZ,OCXDATA)="""",OCXNUM=0")
.D IN^OCXOCMP4(OCXL," I ($G(OCXOSRC)=""GENERIC HL7 MESSAGE ARRAY"") D")
.D IN^OCXOCMP4(OCXL," .S OCXDATA="_$$HL7("ORC",2)_"_""|""_"_$$HL7("ORC",3))
.D IN^OCXOCMP4(OCXL," .S OCXDATA=$TR(OCXDATA,""^"",""@""),OCXNUM=+OCXDATA")
.D IN^OCXOCMP4(OCXL," I ($G(OCXOSRC)=""CPRS ORDER PROTOCOL"") D")
.D IN^OCXOCMP4(OCXL," .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""""")
.D IN^OCXOCMP4(OCXL," .S OCXNUM=+$P(OCXORD,U,2)")
.D IN^OCXOCMP4(OCXL," S:($G(OCXOSRC)=""CPRS ORDER PRESCAN"") OCXNUM=+$P(OCXPSD,""|"",5)")
.D IN^OCXOCMP4(OCXL," S OCXRULE("""_OCXL_""")=""""")
.D IN^OCXOCMP4(OCXL," I $$NEWRULE(DFN,OCXNUM,"_OCXD0_","_OCXD1_","_(+$P(OCXNOD0,U,3))_",OCXNMSG) D I 1")
.D IN^OCXOCMP4(OCXL," .D:($G(OCXTRACE)<5) EN^ORB3("_(+$P(OCXNOD0,U,3))_",DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)")
.I $G(OCXTRACE) D
..D IN^OCXOCMP4(OCXL," .I $G(OCXTRACE) D I 1")
..D IN^OCXOCMP4(OCXL," ..N OCXANS")
..D IN^OCXOCMP4(OCXL," ..W !")
..D IN^OCXOCMP4(OCXL," ..I ($G(OCXTRACE)>5) W !,"" *** TEST MODE - Notification not sent to ORB3 ***""")
..D IN^OCXOCMP4(OCXL," ..E W !,"" *** Notification sent to EN^ORB3 ***""")
..D IN^OCXOCMP4(OCXL," ..W !,"" Notification: "_+$P(OCXNOD0,U,3)_" ("_$P(OCXNOD0,U,3)_")""")
..D IN^OCXOCMP4(OCXL," ..W !,"" DFN: "",DFN")
..D IN^OCXOCMP4(OCXL," ..W !,"" Order Number: "",OCXNUM")
..D IN^OCXOCMP4(OCXL," ..W !,"" Message: "",OCXNMSG")
..D IN^OCXOCMP4(OCXL," ..W !,"" DATA: "",OCXDATA")
..D IN^OCXOCMP4(OCXL," ..W !,"" OCXTRACE: "",OCXTRACE")
..D IN^OCXOCMP4(OCXL," ..W:$D(OCXORD) !,"" OCXORD DATA: "",OCXORD")
..D IN^OCXOCMP4(OCXL," ..I $L($T(LOGAL^OCXDEBUG)) D LOGAL^OCXDEBUG("_OCXD0_","_OCXD1_","_(+$P(OCXNOD0,U,3))_",DFN,OCXNUM,"""",OCXNMSG,.OCXDATA)")
..D IN^OCXOCMP4(OCXL," E I $G(OCXTRACE) W !,||LNTAG||,?30,""Message: Rule already triggered""")
;
I ($P(OCXNOD0,U,2)),$L(OCXCMSG) D
.D IN^OCXOCMP4(OCXL," ;")
.D IN^OCXOCMP4(OCXL," ; Send Order Check Message")
.D IN^OCXOCMP4(OCXL," ;")
.D IN^OCXOCMP4(OCXL," S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG")
;
Q OCXWARN
;
HL7(S,P) ;
;
;Q "$G(OCXODATA("""_S_""","_P_"))"
Q "$G(^TMP(""OCXSWAP"",$J,""OCXODATA"","""_S_""","_P_"))"
;
;
MESG(OCXX) ;
I '$G(OCXAUTO) W !,OCXX
I ($G(OCXAUTO)=1) D BMES^XPDUTL(.OCXX)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXOCMPG 4020 printed Oct 16, 2024@18:25:29 Page 2
OCXOCMPG ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Sort Code Segments cont...) ;5/08/01 10:11
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105**;Dec 17,1997
+2 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
+3 ;
EN(OCXL,OCXCNT) ;
+1 ;
+2 NEW OCXCODE,OCXVAR
+3 DO IN^OCXOCMP4(OCXL," ;")
+4 SET OCXCODE=""
+5 ;
+6 IF $LENGTH(OCXMCOD)
Begin DoDot:1
+7 ;
+8 DO IN^OCXOCMP4(OCXL," ;")
+9 DO IN^OCXOCMP4(OCXL," ; Run Execute Code")
+10 DO IN^OCXOCMP4(OCXL," ;")
+11 ;
+12 NEW NEWVAL,FLDNAME,FCNT,X
+13 SET NEWVAL=OCXMCOD
+14 FOR FCNT=1:1
if '(NEWVAL["|")
QUIT
SET NEWVAL=$PIECE(NEWVAL,"|",1)_"X"_FCNT_$PIECE(NEWVAL,"|",3,$LENGTH(NEWVAL,"|"))
+15 SET X=NEWVAL
DO ^DIM
+16 IF '$DATA(X)
Begin DoDot:2
+17 NEW MESG
+18 SET MESG(1)="**** WARNING *****************************************************"
+19 SET MESG(2)=""
+20 SET MESG(3)="The Execute code: "_OCXMCOD
+21 SET MESG(4)=" Rule Format: "_$GET(OCXR("R",OCXD1,"MCODE"))
+22 SET MESG(5)=""
+23 SET MESG(6)=" In Rule: ["_(+$GET(OCXD0))_"] "_$PIECE($GET(^OCXS(860.2,+$GET(OCXD0),0)),U,1)
+24 SET MESG(7)=" Relation: ["_(+$GET(OCXD1))_"] "_$GET(^OCXS(860.2,+$GET(OCXD0),"R",+$GET(OCXD1),"E"))
+25 SET MESG(8)=""
+26 SET MESG(9)=" Did not pass the mumps syntax check. The code has been disabled."
+27 SET MESG(10)=" This rule may not work correctly until the code is fixed."
+28 SET MESG(11)="******************************************************************"
+29 SET MESG(12)=""
+30 FOR FCNT=1:1
if '$DATA(MESG(FCNT))
QUIT
DO IN^OCXOCMP4(OCXL," ;"_MESG(FCNT))
+31 FOR FCNT=1:1
if '$DATA(MESG(FCNT))
QUIT
DO MESG(MESG(FCNT))
End DoDot:2
QUIT
+32 ;
+33 DO IN^OCXOCMP4(OCXL," "_OCXMCOD)
End DoDot:1
+34 ;
+35 DO IN^OCXOCMP4(OCXL," Q:$G(OCXOERR)")
+36 IF ($PIECE(OCXNOD0,U,3))
IF $LENGTH(OCXNMSG)
Begin DoDot:1
+37 DO IN^OCXOCMP4(OCXL," ;")
+38 DO IN^OCXOCMP4(OCXL," ; Send Notification")
+39 DO IN^OCXOCMP4(OCXL," ;")
+40 DO IN^OCXOCMP4(OCXL," S (OCXDUZ,OCXDATA)="""",OCXNUM=0")
+41 DO IN^OCXOCMP4(OCXL," I ($G(OCXOSRC)=""GENERIC HL7 MESSAGE ARRAY"") D")
+42 DO IN^OCXOCMP4(OCXL," .S OCXDATA="_$$HL7("ORC",2)_"_""|""_"_$$HL7("ORC",3))
+43 DO IN^OCXOCMP4(OCXL," .S OCXDATA=$TR(OCXDATA,""^"",""@""),OCXNUM=+OCXDATA")
+44 DO IN^OCXOCMP4(OCXL," I ($G(OCXOSRC)=""CPRS ORDER PROTOCOL"") D")
+45 DO IN^OCXOCMP4(OCXL," .I $P($G(OCXORD),U,3) S OCXDUZ(+$P(OCXORD,U,3))=""""")
+46 DO IN^OCXOCMP4(OCXL," .S OCXNUM=+$P(OCXORD,U,2)")
+47 DO IN^OCXOCMP4(OCXL," S:($G(OCXOSRC)=""CPRS ORDER PRESCAN"") OCXNUM=+$P(OCXPSD,""|"",5)")
+48 DO IN^OCXOCMP4(OCXL," S OCXRULE("""_OCXL_""")=""""")
+49 DO IN^OCXOCMP4(OCXL," I $$NEWRULE(DFN,OCXNUM,"_OCXD0_","_OCXD1_","_(+$PIECE(OCXNOD0,U,3))_",OCXNMSG) D I 1")
+50 DO IN^OCXOCMP4(OCXL," .D:($G(OCXTRACE)<5) EN^ORB3("_(+$PIECE(OCXNOD0,U,3))_",DFN,OCXNUM,.OCXDUZ,OCXNMSG,.OCXDATA)")
+51 IF $GET(OCXTRACE)
Begin DoDot:2
+52 DO IN^OCXOCMP4(OCXL," .I $G(OCXTRACE) D I 1")
+53 DO IN^OCXOCMP4(OCXL," ..N OCXANS")
+54 DO IN^OCXOCMP4(OCXL," ..W !")
+55 DO IN^OCXOCMP4(OCXL," ..I ($G(OCXTRACE)>5) W !,"" *** TEST MODE - Notification not sent to ORB3 ***""")
+56 DO IN^OCXOCMP4(OCXL," ..E W !,"" *** Notification sent to EN^ORB3 ***""")
+57 DO IN^OCXOCMP4(OCXL," ..W !,"" Notification: "_+$PIECE(OCXNOD0,U,3)_" ("_$PIECE(OCXNOD0,U,3)_")""")
+58 DO IN^OCXOCMP4(OCXL," ..W !,"" DFN: "",DFN")
+59 DO IN^OCXOCMP4(OCXL," ..W !,"" Order Number: "",OCXNUM")
+60 DO IN^OCXOCMP4(OCXL," ..W !,"" Message: "",OCXNMSG")
+61 DO IN^OCXOCMP4(OCXL," ..W !,"" DATA: "",OCXDATA")
+62 DO IN^OCXOCMP4(OCXL," ..W !,"" OCXTRACE: "",OCXTRACE")
+63 DO IN^OCXOCMP4(OCXL," ..W:$D(OCXORD) !,"" OCXORD DATA: "",OCXORD")
+64 DO IN^OCXOCMP4(OCXL," ..I $L($T(LOGAL^OCXDEBUG)) D LOGAL^OCXDEBUG("_OCXD0_","_OCXD1_","_(+$PIECE(OCXNOD0,U,3))_",DFN,OCXNUM,"""",OCXNMSG,.OCXDATA)")
+65 DO IN^OCXOCMP4(OCXL," E I $G(OCXTRACE) W !,||LNTAG||,?30,""Message: Rule already triggered""")
End DoDot:2
End DoDot:1
+66 ;
+67 IF ($PIECE(OCXNOD0,U,2))
IF $LENGTH(OCXCMSG)
Begin DoDot:1
+68 DO IN^OCXOCMP4(OCXL," ;")
+69 DO IN^OCXOCMP4(OCXL," ; Send Order Check Message")
+70 DO IN^OCXOCMP4(OCXL," ;")
+71 DO IN^OCXOCMP4(OCXL," S OCXOCMSG($O(OCXOCMSG(999999),-1)+1)=OCXCMSG")
End DoDot:1
+72 ;
+73 QUIT OCXWARN
+74 ;
HL7(S,P) ;
+1 ;
+2 ;Q "$G(OCXODATA("""_S_""","_P_"))"
+3 QUIT "$G(^TMP(""OCXSWAP"",$J,""OCXODATA"","""_S_""","_P_"))"
+4 ;
+5 ;
MESG(OCXX) ;
+1 IF '$GET(OCXAUTO)
WRITE !,OCXX
+2 IF ($GET(OCXAUTO)=1)
DO BMES^XPDUTL(.OCXX)
+3 QUIT
+4 ;
