DDEX.m

DDEX ;SLC/MKB - Entity DD utilities ;AUG 1, 2018  12:37

 ;;22.2;VA FileMan;**9,21**;Jan 05, 2016;Build 4

 ;;Per VA Directive 6402, this routine should not be modified.

 Q

 ;

TREE ;Look back up tree to make sure item is not ancestor (input xform)

 ;From: 1.51,.08 Entry: DA(1),X

 N DDEDA,DDED

 S DDEDA=DA(1) K:X=DDEDA X

 D TREE1

 Q

TREE1 F DDED=0:0 Q:'$D(X)  S DDED=$O(^DDE("AD",DDEDA,DDED)) Q:DDED'>0  K:DDED=X X Q:'$D(X)  D TREE2

 Q

TREE2 N DDEDA S DDEDA=DDED N DDED D TREE1

 Q

 ;

FLDLST ; -- ??help for FIELD# [DDEFN set in ScreenMan form]

 N FN,DIC,DO,X

 S FN=$G(DDEFN) S:'FN FN=$P($G(^DDE(DA(1),1,DA,0)),U,4) Q:'FN

 S DIC="^DD("_FN_",",DIC(0)="EQ",X="??" D ^DIC

 Q

 ;

CHKNAME ;Input transform for .01 field in ENTITY file (#1.5) ;p21

 I $D(DIC(0))#2,DIC(0)'["E" Q

 I $D(^DDE("B",X)) D EN^DDIOL("  Duplicate names are not allowed.") K X Q

 N %,%1 S %1=""

 D NAME I %1="" D EN^DDIOL("Not a known package or a local namespace.") Q

 D EN^DDIOL("  Located in the "_$E(X,1,%)_" ("_%1_") namespace.") Q

 Q

 ;

NAME ;check name X as PREFIX (#1) in PACKAGE file (#9.4)

 I $E(X,1)="Z" S %=1,%1="Local" Q

 F %=4:-1:2 G:$D(^DIC(9.4,"C",$E(X,1,%))) NAMEOK

 I $E(X,1)="A" S %=1,%1="Local" Q

 Q

 ;

NAMEOK S %1=$O(^DIC(9.4,"C",$E(X,1,%),0)) I %1,$G(^DIC(9.4,%1,0))]"" S %1=$P(^(0),U,1) Q

 S %1="" Q

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DDEX   1328     printed  Apr 09, 2024@21:51:49                                                                                                                                                                                                        Page 2

DDEX      ;SLC/MKB - Entity DD utilities ;AUG 1, 2018  12:37

 +1       ;;22.2;VA FileMan;**9,21**;Jan 05, 2016;Build 4

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3        QUIT 

 +4       ;

TREE      ;Look back up tree to make sure item is not ancestor (input xform)

 +1       ;From: 1.51,.08 Entry: DA(1),X

 +2        NEW DDEDA,DDED

 +3        SET DDEDA=DA(1)

           if X=DDEDA

               KILL X

 +4        DO TREE1

 +5        QUIT 

TREE1      FOR DDED=0:0

               if '$DATA(X)

                   QUIT 

               SET DDED=$ORDER(^DDE("AD",DDEDA,DDED))

               if DDED'>0

                   QUIT 

               if DDED=X

                   KILL X

               if '$DATA(X)

                   QUIT 

               DO TREE2

 +1        QUIT 

TREE2      NEW DDEDA

           SET DDEDA=DDED

           NEW DDED

           DO TREE1

 +1        QUIT 

 +2       ;

FLDLST    ; -- ??help for FIELD# [DDEFN set in ScreenMan form]

 +1        NEW FN,DIC,DO,X

 +2        SET FN=$GET(DDEFN)

           if 'FN

               SET FN=$PIECE($GET(^DDE(DA(1),1,DA,0)),U,4)

           if 'FN

               QUIT 

 +3        SET DIC="^DD("_FN_","

           SET DIC(0)="EQ"

           SET X="??"

           DO ^DIC

 +4        QUIT 

 +5       ;

CHKNAME   ;Input transform for .01 field in ENTITY file (#1.5) ;p21

 +1        IF $DATA(DIC(0))#2

               IF DIC(0)'["E"

                   QUIT 

 +2        IF $DATA(^DDE("B",X))

               DO EN^DDIOL("  Duplicate names are not allowed.")

               KILL X

               QUIT 

 +3        NEW %,%1

           SET %1=""

 +4        DO NAME

           IF %1=""

               DO EN^DDIOL("Not a known package or a local namespace.")

               QUIT 

 +5        DO EN^DDIOL("  Located in the "_$EXTRACT(X,1,%)_" ("_%1_") namespace.")

           QUIT 

 +6        QUIT 

 +7       ;

NAME      ;check name X as PREFIX (#1) in PACKAGE file (#9.4)

 +1        IF $EXTRACT(X,1)="Z"

               SET %=1

               SET %1="Local"

               QUIT 

 +2        FOR %=4:-1:2

               if $DATA(^DIC(9.4,"C",$EXTRACT(X,1,%)))

                   GOTO NAMEOK

 +3        IF $EXTRACT(X,1)="A"

               SET %=1

               SET %1="Local"

               QUIT 

 +4        QUIT 

 +5       ;

NAMEOK     SET %1=$ORDER(^DIC(9.4,"C",$EXTRACT(X,1,%),0))

           IF %1

               IF $GET(^DIC(9.4,%1,0))]""

                   SET %1=$PIECE(^(0),U,1)

                   QUIT 

 +1        SET %1=""

           QUIT 

 +2       ;