OCXODSP2 ;SLC/RJS,CLA - Rule Display (Display an Element) ;10/29/98 12:37
;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
;
EN(OCXD0,OCXTAB,OCXRM) ;
;
N OCXD1,OCXD,OCXRD,OCXE,OCXSUB,OCXDF
;
S OCXTAB=+$G(OCXTAB) S:'$G(OCXD0) OCXD0=+$$DIC("^OCXS(860.3,","AEMQ") Q:'OCXD0
;
S OCXRD="" D DIQ("^OCXS(860.3,",OCXD0,.OCXRD)
F OCXSUB="COND" S OCXD1=0 F S OCXD1=$O(^OCXS(860.3,OCXD0,OCXSUB,OCXD1)) Q:'OCXD1 D
.S OCXD(0)=OCXD0,OCXD=OCXD1 D DIQ("^OCXS(860.3,"_OCXD0_","""_OCXSUB_""",",.OCXD,.OCXRD)
;
W !
W ! D FIELD("Event-Element Name:",$G(OCXRD(860.3,OCXD0,.01,"E")),OCXTAB,OCXRM)
W ! D FIELD(" Data Context:",$G(OCXRD(860.3,OCXD0,.02,"E")),OCXTAB,OCXRM)
W ! D FIELD(" Compiled Routine:",$G(OCXRD(860.3,OCXD0,3,"E")),OCXTAB,OCXRM)
;
S OCXD1=0 F S OCXD1=$O(OCXRD(860.31,OCXD1)) Q:'OCXD1 D
.N OUTSTR,OCXE,PARNUM,OCXFLD
.S PARNUM=$$PARNUM(+$G(OCXRD(860.31,OCXD1,2,"I")))
.S OUTSTR=""
.I '$D(OCXRD(860.31,OCXD1,1,"E")) S OUTSTR="** Error ** Primary Data Field Missing "
.I '$D(OCXRD(860.31,OCXD1,2,"E")) S OUTSTR="** Error ** Operator Missing "
.I (PARNUM=1) D
..Q:'$D(OCXRD(860.31,OCXD1,1,"E")) Q:'$D(OCXRD(860.31,OCXD1,2,"E"))
..S OUTSTR="|"_OCXRD(860.31,OCXD1,1,"E")_"| is '"_OCXRD(860.31,OCXD1,2,"E")_"'"
.I (PARNUM=2) D
..N FLD2
..Q:'$D(OCXRD(860.31,OCXD1,1,"E")) Q:'$D(OCXRD(860.31,OCXD1,2,"E"))
..I $D(OCXRD(860.31,OCXD1,3,"E")) S FLD2="'"_OCXRD(860.31,OCXD1,3,"E")_"'"
..E I $D(OCXRD(860.31,OCXD1,4,"E")) S FLD2="("_OCXRD(860.31,OCXD1,4,"E")_")"
..E S OUTSTR="** Error ** Second Value Missing "
..S OUTSTR="|"_OCXRD(860.31,OCXD1,1,"E")_"| "_OCXRD(860.31,OCXD1,2,"E")_" "_FLD2
.I (PARNUM=3) D
..N FLD2,FLD3
..Q:'$D(OCXRD(860.31,OCXD1,1,"E")) Q:'$D(OCXRD(860.31,OCXD1,2,"E"))
..I $D(OCXRD(860.31,OCXD1,3,"E")) S FLD2="'"_OCXRD(860.31,OCXD1,3,"E")_"'"
..E I $D(OCXRD(860.31,OCXD1,4,"E")) S FLD2="|"_OCXRD(860.31,OCXD1,4,"E")_"|"
..E S OUTSTR="** Error ** Second Value Missing "
..I $D(OCXRD(860.31,OCXD1,3.1,"E")) S FLD3="'"_OCXRD(860.31,OCXD1,3.1,"E")_"'"
..E I $D(OCXRD(860.31,OCXD1,5,"E")) S FLD3="|"_OCXRD(860.31,OCXD1,5,"E")_"|"
..E S OUTSTR="** Error ** Third Value Missing "
..S OUTSTR="|"_OCXRD(860.31,OCXD1,1,"E")_"| "_OCXRD(860.31,OCXD1,2,"E")_" "_FLD2_" and "_FLD3
.;
.F OCXFLD=1,4,5 S:$D(OCXRD(860.31,OCXD1,OCXFLD,"I")) OCXDF(OCXRD(860.31,OCXD1,OCXFLD,"I"))=""
.;
.W ! D FIELD(" Expression #"_(+$G(OCXRD(860.31,OCXD1,.01,"E")))_": IF ",OUTSTR,OCXTAB,OCXRM)
;
S OCXDF=0 F S OCXDF=$O(OCXDF(OCXDF)) Q:'OCXDF D EN^OCXODSP3(OCXDF,OCXTAB+OCXOFF,OCXRM,+$G(OCXRD(860.3,OCXD0,.02,"I")))
;
Q
;
PARNUM(OCXOPER) ;
;
N OCXPF,OCXPFN
S OCXPF=$O(^OCXS(863.9,+OCXOPER,"PAR","B","OCXO GENERATE CODE FUNCTION",0)) Q:'OCXPF 0
S OCXPF=$G(^OCXS(863.9,+OCXOPER,"PAR",+OCXPF,"VAL"))
Q:'$L(OCXPF) 0
I OCXPF S OCXPFN=OCXPF
E S OCXPFN=0 F S OCXPFN=$O(^OCXS(863.7,"B",$E(OCXPF,1,30),OCXPFN)) Q:'OCXPFN Q:($P($G(^OCXS(863.7,+OCXPFN,0)),U,1)=OCXPF)
Q:'OCXPFN 0 Q +$O(^OCXS(863.7,+OCXPFN,"PAR",999),-1)
;
FIELD(TITLE,STRING,TAB,MARGIN) ;
;
W ?TAB,TITLE
;
N PTR,SUBSTR,STRLEN
;
S STRLEN=MARGIN-($L(TITLE)+TAB)-5
S SUBSTR="" F PTR=1:1:$L(STRING," ") D
.I ($L(SUBSTR)>STRLEN) W ?(TAB+$L(TITLE)+1),SUBSTR W:$L($P(STRING," ",PTR+1)) ! S SUBSTR=""
.S:$L(SUBSTR) SUBSTR=SUBSTR_" " S SUBSTR=SUBSTR_$P(STRING," ",PTR)
W:$L(SUBSTR) ?(TAB+$L(TITLE)+1),SUBSTR
Q
;
DIC(OCXDIC,OCXDIC0,OCXDICA,OCXX,OCXDICS,OCXDR) ;
;
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
;
;
DIQ(DIC,DA,OCXARY) ;
;
N DR,DIQ S DR=".01:99999",DIQ="OCXARY(",DIQ(0)="IEN" D EN^DIQ1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXODSP2 3866 printed Apr 09, 2024@21:38:56 Page 2
OCXODSP2 ;SLC/RJS,CLA - Rule Display (Display an Element) ;10/29/98 12:37
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
+2 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
+3 ;
EN(OCXD0,OCXTAB,OCXRM) ;
+1 ;
+2 NEW OCXD1,OCXD,OCXRD,OCXE,OCXSUB,OCXDF
+3 ;
+4 SET OCXTAB=+$GET(OCXTAB)
if '$GET(OCXD0)
SET OCXD0=+$$DIC("^OCXS(860.3,","AEMQ")
if 'OCXD0
QUIT
+5 ;
+6 SET OCXRD=""
DO DIQ("^OCXS(860.3,",OCXD0,.OCXRD)
+7 FOR OCXSUB="COND"
SET OCXD1=0
FOR
SET OCXD1=$ORDER(^OCXS(860.3,OCXD0,OCXSUB,OCXD1))
if 'OCXD1
QUIT
Begin DoDot:1
+8 SET OCXD(0)=OCXD0
SET OCXD=OCXD1
DO DIQ("^OCXS(860.3,"_OCXD0_","""_OCXSUB_""",",.OCXD,.OCXRD)
End DoDot:1
+9 ;
+10 WRITE !
+11 WRITE !
DO FIELD("Event-Element Name:",$GET(OCXRD(860.3,OCXD0,.01,"E")),OCXTAB,OCXRM)
+12 WRITE !
DO FIELD(" Data Context:",$GET(OCXRD(860.3,OCXD0,.02,"E")),OCXTAB,OCXRM)
+13 WRITE !
DO FIELD(" Compiled Routine:",$GET(OCXRD(860.3,OCXD0,3,"E")),OCXTAB,OCXRM)
+14 ;
+15 SET OCXD1=0
FOR
SET OCXD1=$ORDER(OCXRD(860.31,OCXD1))
if 'OCXD1
QUIT
Begin DoDot:1
+16 NEW OUTSTR,OCXE,PARNUM,OCXFLD
+17 SET PARNUM=$$PARNUM(+$GET(OCXRD(860.31,OCXD1,2,"I")))
+18 SET OUTSTR=""
+19 IF '$DATA(OCXRD(860.31,OCXD1,1,"E"))
SET OUTSTR="** Error ** Primary Data Field Missing "
+20 IF '$DATA(OCXRD(860.31,OCXD1,2,"E"))
SET OUTSTR="** Error ** Operator Missing "
+21 IF (PARNUM=1)
Begin DoDot:2
+22 if '$DATA(OCXRD(860.31,OCXD1,1,"E"))
QUIT
if '$DATA(OCXRD(860.31,OCXD1,2,"E"))
QUIT
+23 SET OUTSTR="|"_OCXRD(860.31,OCXD1,1,"E")_"| is '"_OCXRD(860.31,OCXD1,2,"E")_"'"
End DoDot:2
+24 IF (PARNUM=2)
Begin DoDot:2
+25 NEW FLD2
+26 if '$DATA(OCXRD(860.31,OCXD1,1,"E"))
QUIT
if '$DATA(OCXRD(860.31,OCXD1,2,"E"))
QUIT
+27 IF $DATA(OCXRD(860.31,OCXD1,3,"E"))
SET FLD2="'"_OCXRD(860.31,OCXD1,3,"E")_"'"
+28 IF '$TEST
IF $DATA(OCXRD(860.31,OCXD1,4,"E"))
SET FLD2="("_OCXRD(860.31,OCXD1,4,"E")_")"
+29 IF '$TEST
SET OUTSTR="** Error ** Second Value Missing "
+30 SET OUTSTR="|"_OCXRD(860.31,OCXD1,1,"E")_"| "_OCXRD(860.31,OCXD1,2,"E")_" "_FLD2
End DoDot:2
+31 IF (PARNUM=3)
Begin DoDot:2
+32 NEW FLD2,FLD3
+33 if '$DATA(OCXRD(860.31,OCXD1,1,"E"))
QUIT
if '$DATA(OCXRD(860.31,OCXD1,2,"E"))
QUIT
+34 IF $DATA(OCXRD(860.31,OCXD1,3,"E"))
SET FLD2="'"_OCXRD(860.31,OCXD1,3,"E")_"'"
+35 IF '$TEST
IF $DATA(OCXRD(860.31,OCXD1,4,"E"))
SET FLD2="|"_OCXRD(860.31,OCXD1,4,"E")_"|"
+36 IF '$TEST
SET OUTSTR="** Error ** Second Value Missing "
+37 IF $DATA(OCXRD(860.31,OCXD1,3.1,"E"))
SET FLD3="'"_OCXRD(860.31,OCXD1,3.1,"E")_"'"
+38 IF '$TEST
IF $DATA(OCXRD(860.31,OCXD1,5,"E"))
SET FLD3="|"_OCXRD(860.31,OCXD1,5,"E")_"|"
+39 IF '$TEST
SET OUTSTR="** Error ** Third Value Missing "
+40 SET OUTSTR="|"_OCXRD(860.31,OCXD1,1,"E")_"| "_OCXRD(860.31,OCXD1,2,"E")_" "_FLD2_" and "_FLD3
End DoDot:2
+41 ;
+42 FOR OCXFLD=1,4,5
if $DATA(OCXRD(860.31,OCXD1,OCXFLD,"I"))
SET OCXDF(OCXRD(860.31,OCXD1,OCXFLD,"I"))=""
+43 ;
+44 WRITE !
DO FIELD(" Expression #"_(+$GET(OCXRD(860.31,OCXD1,.01,"E")))_": IF ",OUTSTR,OCXTAB,OCXRM)
End DoDot:1
+45 ;
+46 SET OCXDF=0
FOR
SET OCXDF=$ORDER(OCXDF(OCXDF))
if 'OCXDF
QUIT
DO EN^OCXODSP3(OCXDF,OCXTAB+OCXOFF,OCXRM,+$GET(OCXRD(860.3,OCXD0,.02,"I")))
+47 ;
+48 QUIT
+49 ;
PARNUM(OCXOPER) ;
+1 ;
+2 NEW OCXPF,OCXPFN
+3 SET OCXPF=$ORDER(^OCXS(863.9,+OCXOPER,"PAR","B","OCXO GENERATE CODE FUNCTION",0))
if 'OCXPF
QUIT 0
+4 SET OCXPF=$GET(^OCXS(863.9,+OCXOPER,"PAR",+OCXPF,"VAL"))
+5 if '$LENGTH(OCXPF)
QUIT 0
+6 IF OCXPF
SET OCXPFN=OCXPF
+7 IF '$TEST
SET OCXPFN=0
FOR
SET OCXPFN=$ORDER(^OCXS(863.7,"B",$EXTRACT(OCXPF,1,30),OCXPFN))
if 'OCXPFN
QUIT
if ($PIECE($GET(^OCXS(863.7,+OCXPFN,0)),U,1)=OCXPF)
QUIT
+8 if 'OCXPFN
QUIT 0
QUIT +$ORDER(^OCXS(863.7,+OCXPFN,"PAR",999),-1)
+9 ;
FIELD(TITLE,STRING,TAB,MARGIN) ;
+1 ;
+2 WRITE ?TAB,TITLE
+3 ;
+4 NEW PTR,SUBSTR,STRLEN
+5 ;
+6 SET STRLEN=MARGIN-($LENGTH(TITLE)+TAB)-5
+7 SET SUBSTR=""
FOR PTR=1:1:$LENGTH(STRING," ")
Begin DoDot:1
+8 IF ($LENGTH(SUBSTR)>STRLEN)
WRITE ?(TAB+$LENGTH(TITLE)+1),SUBSTR
if $LENGTH($PIECE(STRING," ",PTR+1))
WRITE !
SET SUBSTR=""
+9 if $LENGTH(SUBSTR)
SET SUBSTR=SUBSTR_" "
SET SUBSTR=SUBSTR_$PIECE(STRING," ",PTR)
End DoDot:1
+10 if $LENGTH(SUBSTR)
WRITE ?(TAB+$LENGTH(TITLE)+1),SUBSTR
+11 QUIT
+12 ;
DIC(OCXDIC,OCXDIC0,OCXDICA,OCXX,OCXDICS,OCXDR) ;
+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 ;
+10 ;
DIQ(DIC,DA,OCXARY) ;
+1 ;
+2 NEW DR,DIQ
SET DR=".01:99999"
SET DIQ="OCXARY("
SET DIQ(0)="IEN"
DO EN^DIQ1
+3 QUIT
+4 ;
