OCXOED06 ;SLC/RJS,CLA - Rule Editor (Rule Element Relation Options) ;11/20/01 13:39
;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105**;Dec 17,1997
;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
;
;
S ;
;
Q
EN(OCXR0,OCXR1,OCXRD,OCXACT) ;
;
;
;
N OCXTHLN,OCXTNLN,OCXTRLN,OCXTULN,OCXTNLN
;
;
S OCXOPT=$$GETOPT^OCXOEDT(.OCXACT) Q:(OCXOPT=U) 1 X:$L(OCXOPT) OCXOPT
;
Q:'$D(^OCXS(860.2,OCXR0,"R",OCXR1)) 1
;
Q 0
;
;
EDREL(OCXR0,OCXR1) ;
;
N OCXDA,X,OCXRD,OCXFLD,PAUSE
S PAUSE=0,OCXDA(1)=OCXR0,OCXDA=OCXR1,X=$$DIE("^OCXS(860.2,"_OCXR0_",""R"",",.OCXDA,"1;2;3;4;5;6;7;8;9")
Q:'$D(^OCXS(860.2,OCXR0,"R",OCXR1))
;
; Check for valid Datafield names
;
K OCXRD S OCXRD="" D GETDATA^OCXOED05(OCXR0,OCXR1,.OCXRD)
F OCXFLD=5,6,8,9 D
.N NEWVAL,OLDVAL,FLDNAME
.S FLDNAME=$S((OCXFLD=5):"Notification Message",(OCXFLD=6):"Order Check Message",1:"")
.S OLDVAL=$G(OCXRD("REL",OCXR1,OCXFLD,"E")) Q:'$L(OLDVAL)
.S NEWVAL=$$SCREEN^OCXOED12(OLDVAL,FLDNAME) Q:(NEWVAL=OLDVAL)
.S OCXDA(1)=OCXR0,OCXDA=OCXR1,X=$$DIE("^OCXS(860.2,"_OCXR0_",""R"",",.OCXDA,OCXFLD_"///"_NEWVAL)
;
; Check for valid Mumps Code
;
W !!," Mumps Code Check",!!
K OCXRD S OCXRD="" D GETDATA^OCXOED05(OCXR0,OCXR1,.OCXRD)
F OCXFLD=9 D
.N NEWVAL,OLDVAL,FLDNAME,FCNT,X
.S FLDNAME=$S((OCXFLD=9):"Execute Code",1:"")
.S OLDVAL=$G(OCXRD("REL",OCXR1,OCXFLD,"E")) Q:'$L(OLDVAL)
.S PAUSE=1
.S NEWVAL=OLDVAL
.F FCNT=1:1 Q:'(NEWVAL["|") S NEWVAL=$P(NEWVAL,"|",1)_"X"_FCNT_$P(NEWVAL,"|",3,$L(NEWVAL,"|"))
.W !,FLDNAME,": ",OLDVAL
.S X=NEWVAL D ^DIM
.I '$D(X) D Q
..W !
..W !,"**WARNING** The mumps code: ",OLDVAL
..W !," Did not pass the mumps syntax check. Please verify that this is valid"
..W !,"mumps code before you run the compiler."
.W !,?10," Code OK !!"
;
S:PAUSE X=$$PAUSE
;
Q
;
;
PAUSE() N X W !!," Press <enter> to continue... " R X:DTIME W ! Q ((X[U)*10)
;
;
;
READ(OCXZ0,OCXZA,OCXZB,OCXZL) ;
N OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
Q:'$L($G(OCXZ0)) U
S DIR(0)=OCXZ0
S:$L($G(OCXZA)) DIR("A")=OCXZA
S:$L($G(OCXZB)) DIR("B")=OCXZB
F OCXLINE=1:1:($G(OCXZL)-1) W !
D ^DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIRUT)!$D(DIROUT) Q U
Q Y
;
DIE(DIE,DA,DR) ;
;
D RM(IOM) N DUOUT,DTOUT,DIC S DIC=DIE D ^DIE D RM(0) Q:$G(DTOUT) 0 Q:$G(DUOUT) 0 Q 1
;
RM(X) X ^%ZOSF("RM") Q
;
DIC(OCXDIC,OCXDIC0,OCXDICA,OCXX,OCXDICS,OCXDR,DA) ;
;
N DIC,X,Y
S DIC=$G(OCXDIC) Q:'$L(DIC) -1
S DIC(0)=$G(OCXDIC0) S:$L($G(OCXX)) X=OCXX
S:$L($G(OCXDICS)) DIC("S")=OCXDICS
S:$L($G(OCXDICA)) DIC("A")=OCXDICA
S:$L($G(OCXDR)) DIC("DR")=OCXDR
D ^DIC Q:(Y<1) 0 Q Y
;
INVALID(X) ;
;
N OCXFN
;
F OCXFN=1:1 Q:'(X["|") D Q:'$L(X)
.N OCXDF
.S OCXDF=$P(X,"|",2)
.I '$L(OCXDF) S X="" Q
.I '$O(^OCXS(860.4,"B",OCXDF,0)),'$O(^OCXS(860.4,"C",OCXDF,0)) S X="" Q
.S X=$P(X,"|",1)_"DFLD"_OCXFN_$P(X,"|",3,$L(X,"|"))
;
Q:'$L(X) 1
;
D ^DIM
;
Q '$L($G(X))
;
ETEST ;
;
N D0,D1,EXP
;
S D0=0 F S D0=$O(^OCXS(860.2,D0)) Q:'D0 D
.W !,$P(^OCXS(860.2,D0,0),U,1)
.S D1=0 F S D1=$O(^OCXS(860.2,D0,"R",D1)) Q:'D1 D
..S EXP=$G(^OCXS(860.2,D0,"R",D1,"MCODE"))
..Q:'$L(EXP)
..W !,?10,D1," ",EXP
..I $$INVALID(EXP) W " ** Invalid Code ** "
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXOED06 3263 printed Apr 09, 2024@21:30:13 Page 2
OCXOED06 ;SLC/RJS,CLA - Rule Editor (Rule Element Relation Options) ;11/20/01 13:39
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32,105**;Dec 17,1997
+2 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
+3 ;
+4 ;
S ;
+1 ;
+2 QUIT
EN(OCXR0,OCXR1,OCXRD,OCXACT) ;
+1 ;
+2 ;
+3 ;
+4 NEW OCXTHLN,OCXTNLN,OCXTRLN,OCXTULN,OCXTNLN
+5 ;
+6 ;
+7 SET OCXOPT=$$GETOPT^OCXOEDT(.OCXACT)
if (OCXOPT=U)
QUIT 1
if $LENGTH(OCXOPT)
XECUTE OCXOPT
+8 ;
+9 if '$DATA(^OCXS(860.2,OCXR0,"R",OCXR1))
QUIT 1
+10 ;
+11 QUIT 0
+12 ;
+13 ;
EDREL(OCXR0,OCXR1) ;
+1 ;
+2 NEW OCXDA,X,OCXRD,OCXFLD,PAUSE
+3 SET PAUSE=0
SET OCXDA(1)=OCXR0
SET OCXDA=OCXR1
SET X=$$DIE("^OCXS(860.2,"_OCXR0_",""R"",",.OCXDA,"1;2;3;4;5;6;7;8;9")
+4 if '$DATA(^OCXS(860.2,OCXR0,"R",OCXR1))
QUIT
+5 ;
+6 ; Check for valid Datafield names
+7 ;
+8 KILL OCXRD
SET OCXRD=""
DO GETDATA^OCXOED05(OCXR0,OCXR1,.OCXRD)
+9 FOR OCXFLD=5,6,8,9
Begin DoDot:1
+10 NEW NEWVAL,OLDVAL,FLDNAME
+11 SET FLDNAME=$SELECT((OCXFLD=5):"Notification Message",(OCXFLD=6):"Order Check Message",1:"")
+12 SET OLDVAL=$GET(OCXRD("REL",OCXR1,OCXFLD,"E"))
if '$LENGTH(OLDVAL)
QUIT
+13 SET NEWVAL=$$SCREEN^OCXOED12(OLDVAL,FLDNAME)
if (NEWVAL=OLDVAL)
QUIT
+14 SET OCXDA(1)=OCXR0
SET OCXDA=OCXR1
SET X=$$DIE("^OCXS(860.2,"_OCXR0_",""R"",",.OCXDA,OCXFLD_"///"_NEWVAL)
End DoDot:1
+15 ;
+16 ; Check for valid Mumps Code
+17 ;
+18 WRITE !!," Mumps Code Check",!!
+19 KILL OCXRD
SET OCXRD=""
DO GETDATA^OCXOED05(OCXR0,OCXR1,.OCXRD)
+20 FOR OCXFLD=9
Begin DoDot:1
+21 NEW NEWVAL,OLDVAL,FLDNAME,FCNT,X
+22 SET FLDNAME=$SELECT((OCXFLD=9):"Execute Code",1:"")
+23 SET OLDVAL=$GET(OCXRD("REL",OCXR1,OCXFLD,"E"))
if '$LENGTH(OLDVAL)
QUIT
+24 SET PAUSE=1
+25 SET NEWVAL=OLDVAL
+26 FOR FCNT=1:1
if '(NEWVAL["|")
QUIT
SET NEWVAL=$PIECE(NEWVAL,"|",1)_"X"_FCNT_$PIECE(NEWVAL,"|",3,$LENGTH(NEWVAL,"|"))
+27 WRITE !,FLDNAME,": ",OLDVAL
+28 SET X=NEWVAL
DO ^DIM
+29 IF '$DATA(X)
Begin DoDot:2
+30 WRITE !
+31 WRITE !,"**WARNING** The mumps code: ",OLDVAL
+32 WRITE !," Did not pass the mumps syntax check. Please verify that this is valid"
+33 WRITE !,"mumps code before you run the compiler."
End DoDot:2
QUIT
+34 WRITE !,?10," Code OK !!"
End DoDot:1
+35 ;
+36 if PAUSE
SET X=$$PAUSE
+37 ;
+38 QUIT
+39 ;
+40 ;
PAUSE() NEW X
WRITE !!," Press <enter> to continue... "
READ X:DTIME
WRITE !
QUIT ((X[U)*10)
+1 ;
+2 ;
+3 ;
READ(OCXZ0,OCXZA,OCXZB,OCXZL) ;
+1 NEW OCXLINE,DIR,DTOUT,DUOUT,DIRUT,DIROUT
+2 if '$LENGTH($GET(OCXZ0))
QUIT U
+3 SET DIR(0)=OCXZ0
+4 if $LENGTH($GET(OCXZA))
SET DIR("A")=OCXZA
+5 if $LENGTH($GET(OCXZB))
SET DIR("B")=OCXZB
+6 FOR OCXLINE=1:1:($GET(OCXZL)-1)
WRITE !
+7 DO ^DIR
+8 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)!$DATA(DIROUT)
QUIT U
+9 QUIT Y
+10 ;
DIE(DIE,DA,DR) ;
+1 ;
+2 DO RM(IOM)
NEW DUOUT,DTOUT,DIC
SET DIC=DIE
DO ^DIE
DO RM(0)
if $GET(DTOUT)
QUIT 0
if $GET(DUOUT)
QUIT 0
QUIT 1
+3 ;
RM(X) XECUTE ^%ZOSF("RM")
QUIT
+1 ;
DIC(OCXDIC,OCXDIC0,OCXDICA,OCXX,OCXDICS,OCXDR,DA) ;
+1 ;
+2 NEW DIC,X,Y
+3 SET DIC=$GET(OCXDIC)
if '$LENGTH(DIC)
QUIT -1
+4 SET DIC(0)=$GET(OCXDIC0)
if $LENGTH($GET(OCXX))
SET X=OCXX
+5 if $LENGTH($GET(OCXDICS))
SET DIC("S")=OCXDICS
+6 if $LENGTH($GET(OCXDICA))
SET DIC("A")=OCXDICA
+7 if $LENGTH($GET(OCXDR))
SET DIC("DR")=OCXDR
+8 DO ^DIC
if (Y<1)
QUIT 0
QUIT Y
+9 ;
INVALID(X) ;
+1 ;
+2 NEW OCXFN
+3 ;
+4 FOR OCXFN=1:1
if '(X["|")
QUIT
Begin DoDot:1
+5 NEW OCXDF
+6 SET OCXDF=$PIECE(X,"|",2)
+7 IF '$LENGTH(OCXDF)
SET X=""
QUIT
+8 IF '$ORDER(^OCXS(860.4,"B",OCXDF,0))
IF '$ORDER(^OCXS(860.4,"C",OCXDF,0))
SET X=""
QUIT
+9 SET X=$PIECE(X,"|",1)_"DFLD"_OCXFN_$PIECE(X,"|",3,$LENGTH(X,"|"))
End DoDot:1
if '$LENGTH(X)
QUIT
+10 ;
+11 if '$LENGTH(X)
QUIT 1
+12 ;
+13 DO ^DIM
+14 ;
+15 QUIT '$LENGTH($GET(X))
+16 ;
ETEST ;
+1 ;
+2 NEW D0,D1,EXP
+3 ;
+4 SET D0=0
FOR
SET D0=$ORDER(^OCXS(860.2,D0))
if 'D0
QUIT
Begin DoDot:1
+5 WRITE !,$PIECE(^OCXS(860.2,D0,0),U,1)
+6 SET D1=0
FOR
SET D1=$ORDER(^OCXS(860.2,D0,"R",D1))
if 'D1
QUIT
Begin DoDot:2
+7 SET EXP=$GET(^OCXS(860.2,D0,"R",D1,"MCODE"))
+8 if '$LENGTH(EXP)
QUIT
+9 WRITE !,?10,D1," ",EXP
+10 IF $$INVALID(EXP)
WRITE " ** Invalid Code ** "
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
