- OCXODSP4 ;SLC/RJS,CLA - Rule Display (Display a MetaDictionary Link) ;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(OCXLINK,OCXTAB,OCXRM,OCXCON) ;
- ;
- N OCXD0,OCXD1,OCXD,OCXRD,OCXE,OCXSUB,OCXPAR,OCXSP,OCXMAX
- ;
- I '$L(OCXLINK) W !! D FIELD("Metadictionary Link:"," ** ERROR ** Link not found ",OCXTAB,OCXRM)
- ;
- S OCXD0=$O(^OCXS(863.3,"B",OCXLINK,0))
- I 'OCXD0 W !! D FIELD("Metadictionary Link:"," '"_OCXLINK_"' ** ERROR ** Link not found ",OCXTAB,OCXRM)
- S OCXTAB=+$G(OCXTAB)
- ;
- S OCXRD="" D DIQ("^OCXS(863.3,",OCXD0,.OCXRD)
- F OCXSUB="PAR" S OCXD1=0 F S OCXD1=$O(^OCXS(863.3,OCXD0,OCXSUB,OCXD1)) Q:'OCXD1 D
- .S OCXD(0)=OCXD0,OCXD=OCXD1 D DIQ("^OCXS(863.3,"_OCXD0_","""_OCXSUB_""",",.OCXD,.OCXRD)
- ;
- W !
- W ! D FIELD("Metadictionary Link:",OCXRD(863.3,OCXD0,.01,"E"),OCXTAB,OCXRM)
- W ! D FIELD(" Attribute:",OCXRD(863.3,OCXD0,.05,"E"),OCXTAB,OCXRM)
- W ! D FIELD(" Data Type:",$$DTYP(OCXRD(863.3,OCXD0,.05,"I")),OCXTAB,OCXRM)
- ;
- S (OCXMAX,OCXD1)=0 F S OCXD1=$O(OCXRD(863.32,OCXD1)) Q:'OCXD1 D
- .I $D(OCXRD(863.32,OCXD1,.01,"E")),$D(OCXRD(863.32,OCXD1,1,"E")) D
- ..N PARNAME S PARNAME=OCXRD(863.32,OCXD1,.01,"E") S:($L(PARNAME)>OCXMAX) OCXMAX=$L(PARNAME)+2
- ;
- S OCXSP="",$P(OCXSP," ",OCXMAX+10)=" ",OCXD1=0 F S OCXD1=$O(OCXRD(863.32,OCXD1)) Q:'OCXD1 D
- .I $D(OCXRD(863.32,OCXD1,.01,"E")),$D(OCXRD(863.32,OCXD1,1,"E")) D
- ..N PARNAME,PARVAL S PARNAME=OCXRD(863.32,OCXD1,.01,"E"),PARVAL=OCXRD(863.32,OCXD1,1,"E")
- ..S PARNAME=$E(OCXSP,$L(PARNAME),OCXMAX)_PARNAME W ! D FIELD(PARNAME_":",PARVAL,OCXTAB,OCXRM)
- ;
- Q
- ;
- DTYP(ATTR) ;
- ;
- N OCXDTYP,PARNUM
- Q:'ATTR " ** ATTRIBUTE NOT DEFINED ** "
- Q:'$D(^OCXS(863.4,ATTR,0)) " ** ATTRIBUTE '"_ATTR_"' NOT DEFINED ** "
- S OCXDTYP=$O(^OCXS(863.8,"B","DATA TYPE",0)) Q:'OCXDTYP " ** NOT IN PARAMETER FILE **"
- S PARNUM=$O(^OCXS(863.4,ATTR,"PAR","B",OCXDTYP,0)) Q:'PARNUM " ** DATA TYPE NOT SPECIFIED **"
- S OCXDTYP=$G(^OCXS(863.4,ATTR,"PAR",PARNUM,"VAL")) Q:'$L(OCXDTYP) " ** DATA TYPE NOT SPECIFIED **"
- Q OCXDTYP
- ;
- 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
- ;
- MULT(OCXD0,OCXTAB,OCXRM) ;
- ;
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXODSP4 3329 printed Feb 18, 2025@23:51:48 Page 2
- OCXODSP4 ;SLC/RJS,CLA - Rule Display (Display a MetaDictionary Link) ;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(OCXLINK,OCXTAB,OCXRM,OCXCON) ;
- +1 ;
- +2 NEW OCXD0,OCXD1,OCXD,OCXRD,OCXE,OCXSUB,OCXPAR,OCXSP,OCXMAX
- +3 ;
- +4 IF '$LENGTH(OCXLINK)
- WRITE !!
- DO FIELD("Metadictionary Link:"," ** ERROR ** Link not found ",OCXTAB,OCXRM)
- +5 ;
- +6 SET OCXD0=$ORDER(^OCXS(863.3,"B",OCXLINK,0))
- +7 IF 'OCXD0
- WRITE !!
- DO FIELD("Metadictionary Link:"," '"_OCXLINK_"' ** ERROR ** Link not found ",OCXTAB,OCXRM)
- +8 SET OCXTAB=+$GET(OCXTAB)
- +9 ;
- +10 SET OCXRD=""
- DO DIQ("^OCXS(863.3,",OCXD0,.OCXRD)
- +11 FOR OCXSUB="PAR"
- SET OCXD1=0
- FOR
- SET OCXD1=$ORDER(^OCXS(863.3,OCXD0,OCXSUB,OCXD1))
- if 'OCXD1
- QUIT
- Begin DoDot:1
- +12 SET OCXD(0)=OCXD0
- SET OCXD=OCXD1
- DO DIQ("^OCXS(863.3,"_OCXD0_","""_OCXSUB_""",",.OCXD,.OCXRD)
- End DoDot:1
- +13 ;
- +14 WRITE !
- +15 WRITE !
- DO FIELD("Metadictionary Link:",OCXRD(863.3,OCXD0,.01,"E"),OCXTAB,OCXRM)
- +16 WRITE !
- DO FIELD(" Attribute:",OCXRD(863.3,OCXD0,.05,"E"),OCXTAB,OCXRM)
- +17 WRITE !
- DO FIELD(" Data Type:",$$DTYP(OCXRD(863.3,OCXD0,.05,"I")),OCXTAB,OCXRM)
- +18 ;
- +19 SET (OCXMAX,OCXD1)=0
- FOR
- SET OCXD1=$ORDER(OCXRD(863.32,OCXD1))
- if 'OCXD1
- QUIT
- Begin DoDot:1
- +20 IF $DATA(OCXRD(863.32,OCXD1,.01,"E"))
- IF $DATA(OCXRD(863.32,OCXD1,1,"E"))
- Begin DoDot:2
- +21 NEW PARNAME
- SET PARNAME=OCXRD(863.32,OCXD1,.01,"E")
- if ($LENGTH(PARNAME)>OCXMAX)
- SET OCXMAX=$LENGTH(PARNAME)+2
- End DoDot:2
- End DoDot:1
- +22 ;
- +23 SET OCXSP=""
- SET $PIECE(OCXSP," ",OCXMAX+10)=" "
- SET OCXD1=0
- FOR
- SET OCXD1=$ORDER(OCXRD(863.32,OCXD1))
- if 'OCXD1
- QUIT
- Begin DoDot:1
- +24 IF $DATA(OCXRD(863.32,OCXD1,.01,"E"))
- IF $DATA(OCXRD(863.32,OCXD1,1,"E"))
- Begin DoDot:2
- +25 NEW PARNAME,PARVAL
- SET PARNAME=OCXRD(863.32,OCXD1,.01,"E")
- SET PARVAL=OCXRD(863.32,OCXD1,1,"E")
- +26 SET PARNAME=$EXTRACT(OCXSP,$LENGTH(PARNAME),OCXMAX)_PARNAME
- WRITE !
- DO FIELD(PARNAME_":",PARVAL,OCXTAB,OCXRM)
- End DoDot:2
- End DoDot:1
- +27 ;
- +28 QUIT
- +29 ;
- DTYP(ATTR) ;
- +1 ;
- +2 NEW OCXDTYP,PARNUM
- +3 if 'ATTR
- QUIT " ** ATTRIBUTE NOT DEFINED ** "
- +4 if '$DATA(^OCXS(863.4,ATTR,0))
- QUIT " ** ATTRIBUTE '"_ATTR_"' NOT DEFINED ** "
- +5 SET OCXDTYP=$ORDER(^OCXS(863.8,"B","DATA TYPE",0))
- if 'OCXDTYP
- QUIT " ** NOT IN PARAMETER FILE **"
- +6 SET PARNUM=$ORDER(^OCXS(863.4,ATTR,"PAR","B",OCXDTYP,0))
- if 'PARNUM
- QUIT " ** DATA TYPE NOT SPECIFIED **"
- +7 SET OCXDTYP=$GET(^OCXS(863.4,ATTR,"PAR",PARNUM,"VAL"))
- if '$LENGTH(OCXDTYP)
- QUIT " ** DATA TYPE NOT SPECIFIED **"
- +8 QUIT OCXDTYP
- +9 ;
- 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 ;
- MULT(OCXD0,OCXTAB,OCXRM) ;
- +1 ;
- +2 QUIT
- +3 ;
