XBLFAM.m

XBLFAM ;IHS/SET/GTH - LISTS FILE ATTRIBUTES FOR MODELING ; [ 04/18/2003  9:05 AM ]

 ;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997

 ;IHS/SET/GTH XB*3*9 10/29/2002 New routine.

 ; This routine lists the following file attributes, useful for

 ; moving to a spreadsheet, or other desktop ap, for database

 ; modeling activities:

 ;

 ; File #, File Name, Field #, Field Label, Field type, Desc/Help.,

 ;    Min Length, Max Length

 ; The output is one line of data per field, semi-colon delimited.

 ;

 ; NOTE:  Fields marked for deletion with a "*" preceeding the label

 ;        are -not- processed.

 ;

 ; Thanks to George T. Huggins for the original routine.

 ;

START ;

 ; --- Display routine description.

 D HOME^%ZIS,DT^DICRW

 KILL ^UTILITY($J)

 S ^UTILITY($J,"XBLFAM")=""

 D EN^XBRPTL

 KILL ^UTILITY($J)

 ;

 ; --- Start processing.

 NEW QFLG

 S QFLG=0

 ;

 ; --- Get file(s).

 D ^XBDSET

 Q:'$D(^UTILITY("XBDSET",$J))

 ;

 ; --- Select device.

 W !

 S %ZIS="Q",ZTSAVE("^UTILITY(""XBDSET"",$J,")=""

 D EN^XUTMDEVQ("EN^XBLFAM","List Attributes for Modeling",.ZTSAVE,.%ZIS)

 D EN^XBVK("ZT")

 Q

 ;

EN ;EP - From TaskMan.

 ;

 ; --- Main loop:  thru selected file(s).

 NEW F,X

 ;

 ; F:File #

 ;

 S F=0

 F  S F=$O(^UTILITY("XBDSET",$J,F)) Q:F'=+F  D PAGE Q:QFLG  D FIELDS(F) Q:QFLG

 D ^%ZISC

 Q

 ; --- End main loop.

FIELDS(F) ; Process fields in File F.

 ; Field #, File #, File Name, Field Label, Field type, Desc/Help.

 NEW X,XB

 S X=""

 F XB=0:0 S XB=$O(^DD(F,XB)) Q:'(XB=+XB)  D  D:$Y>(IOSL-3) PAGE Q:QFLG

 . I $E($P($G(^DD(F,XB,0)),"^",1))="*" Q  ; field is deprecated.

 . I $P(^DD(F,XB,0),"^",2) W $$OUTLINE,! D FIELDS(+$P(^DD(F,XB,0),"^",2)) Q  ; Recurse sub-file.

 . W $$OUTLINE,!

 . Q

 Q

 ; -------------------------------------------------------

OUTLINE() ;

 ; File #, File Name, Field #, Field Label, Field type, Desc/Help.,

 ;    Min Length, Max Length

 Q F_";"_$$FNAME^XBFUNC(F)_";"_XB_";"_$P($G(^DD(F,XB,0)),"^",1)_";"_$$TYPE($P($G(^DD(F,XB,0)),"^",2))_";"_$$HP(F,XB)_$$DESC(F,XB)_$$TDESC(F,XB)_";"_$$MINL(F,XB)_";"_$$MAXL(F,XB)_";"

 ; -------------------------------------------------------

PAGE ; PAGE BREAK

 NEW F,G,N,X

 I IO=IO(0),$E(IOST,1,2)="C-" S QFLG='$$DIR^XBDIR("E") I 'QFLG W @IOF

 Q

 ; -------------------------------------------------------

MINL(N,F) ; Return minimum length

 NEW X

 S X=$P(^DD(N,F,0),"^",2)

 I X Q "-"

 I '(X["F") Q "-"

 S X=$P(^DD(N,F,0),"^",5,99)

 Q +$E(X,$F(X,"$L(X)<"),$L(X))

 ; -------------------------------------------------------

MAXL(N,F) ; Return maximum length

 NEW X

 S X=$P(^DD(N,F,0),"^",2)

 I X Q "-"

 I '(X["F") Q "-"

 S X=$P(^DD(N,F,0),"^",5,99)

 Q +$E(X,$F(X,"$L(X)>"),$L(X))

 ; -------------------------------------------------------

NUMBER(F) ;;.001;NUMBER

 Q F  ; well, duh

 ; -------------------------------------------------------

LABEL(N,F) ;;.01;LABEL

 Q $P($G(^DD(N,F,0)),"^",1)

 ; -------------------------------------------------------

TITLE(N,F) ;;.1;TITLE

 Q $P($G(^DD(N,F,.1)),"^",1)

 ; -------------------------------------------------------

 ;;.12;VARIABLE POINTER  (multiple)

 ; -------------------------------------------------------

 ;;.2;SPECIFIER

 ; -------------------------------------------------------

 ;;.23;LENGTH

 ; -------------------------------------------------------

 ;;.24;DECIMAL DEFAULT

 ; -------------------------------------------------------

TYPE(P) ;PEP;.25;TYPE

 ; Return TYPE of field. Input is the 2nd piece of the 0th node.

 I P Q "<SUBFILE>"

 NEW W

 F W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","WORD-PROCESSING","K","Z" I P[$E(W) Q

 I W="SET" S W=W_" <"_$TR($P($G(^DD(F,XB,0)),"^",3),";","|")_">"

 I W="POINTER" S W=W_" to "_$$FNAME^XBFUNC(+$P(P,"P",2))_" file"

 Q $S(W'="Z":W,1:"??")

 ; -------------------------------------------------------

 ;;.26;COMPUTE ALGORITHM

 ; -------------------------------------------------------

 ;;.27;SUB-FIELDS

 ; -------------------------------------------------------

 ;;.28;MULTIPLE-VALUED

 ; -------------------------------------------------------

 ;;.29;DEPTH OF SUB-FIELD

 ; -------------------------------------------------------

 ;;.3;POINTER

 ; -------------------------------------------------------

GSL(N,F) ;;.4;GLOBAL SUBSCRIPT LOCATION

 Q 0

 ; -------------------------------------------------------

IT(N,F) ;;.5;INPUT TRANSFORM

 Q $P($G(^DD(N,F,0)),"^",5,99)

 ; -------------------------------------------------------

 ;;1;CROSS-REFERENCE  (multiple)

 ; -------------------------------------------------------

AUDIT(N,F) ;;1.1;AUDIT

 Q $G(^DD(N,F,"AUDIT"))

 ; -------------------------------------------------------

 ;;1.2;AUDIT CONDITION

 ; -------------------------------------------------------

OT(N,F) ;;2;OUTPUT TRANSFORM

 Q $G(^DD(N,F,2.1))

 ; -------------------------------------------------------

HP(N,F) ;;3;'HELP'-PROMPT

 NEW X

 S X=$G(^DD(N,F,3))

 I '$L(X) Q ""

 Q "HELP-PROMPT("_$G(^DD(N,F,3))_")"

 ; -------------------------------------------------------

XH(N,F) ;;4;XECUTABLE 'HELP'

 Q $G(^DD(N,F,4))

 ; -------------------------------------------------------

RA(N,F) ;;8;READ ACCESS (OPTIONAL)

 Q $G(^DD(N,F,8))

 ; -------------------------------------------------------

DA(N,F) ;;8.5;DELETE ACCESS (OPTIONAL)

 Q $G(^DD(N,F,8.5))

 ; -------------------------------------------------------

WA(N,F) ;;9;WRITE ACCESS (OPTIONAL)

 Q $G(^DD(N,F,9))

 ; -------------------------------------------------------

 ;;9.01;COMPUTED FIELDS USED

 ; -------------------------------------------------------

SRC(N,F) ;;10;SOURCE

 Q $G(^DD(N,F,10))

 ; -------------------------------------------------------

 ;;11;DESTINATION  (multiple)

 ; -------------------------------------------------------

 ;;12;POINTER SCREEN

 ; -------------------------------------------------------

 ;;12.1;CODE TO SET POINTER SCREEN

 ; -------------------------------------------------------

 ;;12.2;EXPRESSION FOR POINTER SCREEN

 ; -------------------------------------------------------

 ;;20;GROUP  (multiple)

 ; -------------------------------------------------------

DESC(N,F) ;;21;DESCRIPTION  (word-processing)

 ; Field DESCRIPTION and Help-Prompt. N=File, F=Field

 NEW X,XB

 S X=""

 F XB=0:0 S XB=$O(^DD(N,F,21,XB)) Q:'XB  S X=X_$G(^(XB,0))

 I '$L(X) Q ""

 Q "DESCRIPTION("_X_")"

 ; -------------------------------------------------------

TDESC(N,F) ;;23;TECHNICAL DESCRIPTION  (word-processing)

 NEW X,XB

 S X=""

 F XB=0:0 S XB=$O(^DD(N,F,23,XB)) Q:'XB  S X=X_$G(^(XB,0))

 I '$L(X) Q ""

 Q "TECH_DESCRIPTION("_X_")"

 ; -------------------------------------------------------

DFLE(N,F) ;;50;DATE FIELD LAST EDITED

 Q $$FMTE^XLFDT($G(^DD(N,F,"DT")))

 ; -------------------------------------------------------

 ;;999;TRIGGERED-BY POINTER  (multiple)

 ; -------------------------------------------------------

 ;

XBLFAM    ;IHS/SET/GTH - LISTS FILE ATTRIBUTES FOR MODELING ; [ 04/18/2003  9:05 AM ]

 +1       ;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997

 +2       ;IHS/SET/GTH XB*3*9 10/29/2002 New routine.

 +3       ; This routine lists the following file attributes, useful for

 +4       ; moving to a spreadsheet, or other desktop ap, for database

 +5       ; modeling activities:

 +6       ;

 +7       ; File #, File Name, Field #, Field Label, Field type, Desc/Help.,

 +8       ;    Min Length, Max Length

 +9       ; The output is one line of data per field, semi-colon delimited.

 +10      ;

 +11      ; NOTE:  Fields marked for deletion with a "*" preceeding the label

 +12      ;        are -not- processed.

 +13      ;

 +14      ; Thanks to George T. Huggins for the original routine.

 +15      ;

START     ;

 +1       ; --- Display routine description.

 +2        DO HOME^%ZIS

           DO DT^DICRW

 +3        KILL ^UTILITY($JOB)

 +4        SET ^UTILITY($JOB,"XBLFAM")=""

 +5        DO EN^XBRPTL

 +6        KILL ^UTILITY($JOB)

 +7       ;

 +8       ; --- Start processing.

 +9        NEW QFLG

 +10       SET QFLG=0

 +11      ;

 +12      ; --- Get file(s).

 +13       DO ^XBDSET

 +14       IF '$DATA(^UTILITY("XBDSET",$JOB))

               QUIT 

 +15      ;

 +16      ; --- Select device.

 +17       WRITE !

 +18       SET %ZIS="Q"

           SET ZTSAVE("^UTILITY(""XBDSET"",$J,")=""

 +19       DO EN^XUTMDEVQ("EN^XBLFAM","List Attributes for Modeling",.ZTSAVE,.%ZIS)

 +20       DO EN^XBVK("ZT")

 +21       QUIT 

 +22      ;

EN        ;EP - From TaskMan.

 +1       ;

 +2       ; --- Main loop:  thru selected file(s).

 +3        NEW F,X

 +4       ;

 +5       ; F:File #

 +6       ;

 +7        SET F=0

 +8        FOR 

               SET F=$ORDER(^UTILITY("XBDSET",$JOB,F))

               IF F'=+F

                   QUIT 

               DO PAGE

               IF QFLG

                   QUIT 

               DO FIELDS(F)

               IF QFLG

                   QUIT 

 +9        DO ^%ZISC

 +10       QUIT 

 +11      ; --- End main loop.

FIELDS(F) ; Process fields in File F.

 +1       ; Field #, File #, File Name, Field Label, Field type, Desc/Help.

 +2        NEW X,XB

 +3        SET X=""

 +4        FOR XB=0:0

               SET XB=$ORDER(^DD(F,XB))

               IF '(XB=+XB)

                   QUIT 

               Begin DoDot:1

 +5       ; field is deprecated.

                   IF $EXTRACT($PIECE($GET(^DD(F,XB,0)),"^",1))="*"

                       QUIT 

 +6       ; Recurse sub-file.

                   IF $PIECE(^DD(F,XB,0),"^",2)

                       WRITE $$OUTLINE,!

                       DO FIELDS(+$PIECE(^DD(F,XB,0),"^",2))

                       QUIT 

 +7                WRITE $$OUTLINE,!

 +8                QUIT 

               End DoDot:1

               IF $Y>(IOSL-3)

                   DO PAGE

               IF QFLG

                   QUIT 

 +9        QUIT 

 +10      ; -------------------------------------------------------

OUTLINE() ;

 +1       ; File #, File Name, Field #, Field Label, Field type, Desc/Help.,

 +2       ;    Min Length, Max Length

 +3        QUIT F_";"_$$FNAME^XBFUNC(F)_";"_XB_";"_$PIECE($GET(^DD(F,XB,0)),"^",1)_";"_$$TYPE($PIECE($GET(^DD(F,XB,0)),"^",2))_";"_$$HP(F,XB)_$$DESC(F,XB)_$$TDESC(F,XB)_";"_$$MINL(F,XB)_";"_$$MAXL(F,XB)_";"

 +4       ; -------------------------------------------------------

PAGE      ; PAGE BREAK

 +1        NEW F,G,N,X

 +2        IF IO=IO(0)

               IF $EXTRACT(IOST,1,2)="C-"

                   SET QFLG='$$DIR^XBDIR("E")

                   IF 'QFLG

                       WRITE @IOF

 +3        QUIT 

 +4       ; -------------------------------------------------------

MINL(N,F) ; Return minimum length

 +1        NEW X

 +2        SET X=$PIECE(^DD(N,F,0),"^",2)

 +3        IF X

               QUIT "-"

 +4        IF '(X["F")

               QUIT "-"

 +5        SET X=$PIECE(^DD(N,F,0),"^",5,99)

 +6        QUIT +$EXTRACT(X,$FIND(X,"$L(X)<"),$LENGTH(X))

 +7       ; -------------------------------------------------------

MAXL(N,F) ; Return maximum length

 +1        NEW X

 +2        SET X=$PIECE(^DD(N,F,0),"^",2)

 +3        IF X

               QUIT "-"

 +4        IF '(X["F")

               QUIT "-"

 +5        SET X=$PIECE(^DD(N,F,0),"^",5,99)

 +6        QUIT +$EXTRACT(X,$FIND(X,"$L(X)>"),$LENGTH(X))

 +7       ; -------------------------------------------------------

NUMBER(F) ;;.001;NUMBER

 +1       ; well, duh

           QUIT F

 +2       ; -------------------------------------------------------

LABEL(N,F) ;;.01;LABEL

 +1        QUIT $PIECE($GET(^DD(N,F,0)),"^",1)

 +2       ; -------------------------------------------------------

TITLE(N,F) ;;.1;TITLE

 +1        QUIT $PIECE($GET(^DD(N,F,.1)),"^",1)

 +2       ; -------------------------------------------------------

 +3       ;;.12;VARIABLE POINTER  (multiple)

 +4       ; -------------------------------------------------------

 +5       ;;.2;SPECIFIER

 +6       ; -------------------------------------------------------

 +7       ;;.23;LENGTH

 +8       ; -------------------------------------------------------

 +9       ;;.24;DECIMAL DEFAULT

 +10      ; -------------------------------------------------------

TYPE(P)   ;PEP;.25;TYPE

 +1       ; Return TYPE of field. Input is the 2nd piece of the 0th node.

 +2        IF P

               QUIT "<SUBFILE>"

 +3        NEW W

 +4        FOR W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","WORD-PROCESSING","K","Z"

               IF P[$EXTRACT(W)

                   QUIT 

 +5        IF W="SET"

               SET W=W_" <"_$TRANSLATE($PIECE($GET(^DD(F,XB,0)),"^",3),";","|")_">"

 +6        IF W="POINTER"

               SET W=W_" to "_$$FNAME^XBFUNC(+$PIECE(P,"P",2))_" file"

 +7        QUIT $SELECT(W'="Z":W,1:"??")

 +8       ; -------------------------------------------------------

 +9       ;;.26;COMPUTE ALGORITHM

 +10      ; -------------------------------------------------------

 +11      ;;.27;SUB-FIELDS

 +12      ; -------------------------------------------------------

 +13      ;;.28;MULTIPLE-VALUED

 +14      ; -------------------------------------------------------

 +15      ;;.29;DEPTH OF SUB-FIELD

 +16      ; -------------------------------------------------------

 +17      ;;.3;POINTER

 +18      ; -------------------------------------------------------

GSL(N,F)  ;;.4;GLOBAL SUBSCRIPT LOCATION

 +1        QUIT 0

 +2       ; -------------------------------------------------------

IT(N,F)   ;;.5;INPUT TRANSFORM

 +1        QUIT $PIECE($GET(^DD(N,F,0)),"^",5,99)

 +2       ; -------------------------------------------------------

 +3       ;;1;CROSS-REFERENCE  (multiple)

 +4       ; -------------------------------------------------------

AUDIT(N,F) ;;1.1;AUDIT

 +1        QUIT $GET(^DD(N,F,"AUDIT"))

 +2       ; -------------------------------------------------------

 +3       ;;1.2;AUDIT CONDITION

 +4       ; -------------------------------------------------------

OT(N,F)   ;;2;OUTPUT TRANSFORM

 +1        QUIT $GET(^DD(N,F,2.1))

 +2       ; -------------------------------------------------------

HP(N,F)   ;;3;'HELP'-PROMPT

 +1        NEW X

 +2        SET X=$GET(^DD(N,F,3))

 +3        IF '$LENGTH(X)

               QUIT ""

 +4        QUIT "HELP-PROMPT("_$GET(^DD(N,F,3))_")"

 +5       ; -------------------------------------------------------

XH(N,F)   ;;4;XECUTABLE 'HELP'

 +1        QUIT $GET(^DD(N,F,4))

 +2       ; -------------------------------------------------------

RA(N,F)   ;;8;READ ACCESS (OPTIONAL)

 +1        QUIT $GET(^DD(N,F,8))

 +2       ; -------------------------------------------------------

DA(N,F)   ;;8.5;DELETE ACCESS (OPTIONAL)

 +1        QUIT $GET(^DD(N,F,8.5))

 +2       ; -------------------------------------------------------

WA(N,F)   ;;9;WRITE ACCESS (OPTIONAL)

 +1        QUIT $GET(^DD(N,F,9))

 +2       ; -------------------------------------------------------

 +3       ;;9.01;COMPUTED FIELDS USED

 +4       ; -------------------------------------------------------

SRC(N,F)  ;;10;SOURCE

 +1        QUIT $GET(^DD(N,F,10))

 +2       ; -------------------------------------------------------

 +3       ;;11;DESTINATION  (multiple)

 +4       ; -------------------------------------------------------

 +5       ;;12;POINTER SCREEN

 +6       ; -------------------------------------------------------

 +7       ;;12.1;CODE TO SET POINTER SCREEN

 +8       ; -------------------------------------------------------

 +9       ;;12.2;EXPRESSION FOR POINTER SCREEN

 +10      ; -------------------------------------------------------

 +11      ;;20;GROUP  (multiple)

 +12      ; -------------------------------------------------------

DESC(N,F) ;;21;DESCRIPTION  (word-processing)

 +1       ; Field DESCRIPTION and Help-Prompt. N=File, F=Field

 +2        NEW X,XB

 +3        SET X=""

 +4        FOR XB=0:0

               SET XB=$ORDER(^DD(N,F,21,XB))

               IF 'XB

                   QUIT 

               SET X=X_$GET(^(XB,0))

 +5        IF '$LENGTH(X)

               QUIT ""

 +6        QUIT "DESCRIPTION("_X_")"

 +7       ; -------------------------------------------------------

TDESC(N,F) ;;23;TECHNICAL DESCRIPTION  (word-processing)

 +1        NEW X,XB

 +2        SET X=""

 +3        FOR XB=0:0

               SET XB=$ORDER(^DD(N,F,23,XB))

               IF 'XB

                   QUIT 

               SET X=X_$GET(^(XB,0))

 +4        IF '$LENGTH(X)

               QUIT ""

 +5        QUIT "TECH_DESCRIPTION("_X_")"

 +6       ; -------------------------------------------------------

DFLE(N,F) ;;50;DATE FIELD LAST EDITED

 +1        QUIT $$FMTE^XLFDT($GET(^DD(N,F,"DT")))

 +2       ; -------------------------------------------------------

 +3       ;;999;TRIGGERED-BY POINTER  (multiple)

 +4       ; -------------------------------------------------------

 +5       ;