- 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
- ;
- 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 ;