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