XBSFGBL.m

XBSFGBL(S,G,F) ; IHS/ADC/GTH - RETURN SUBFILE GLOBAL REFERENCE ; [ 02/07/97   3:02 PM ]

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

 ;

 ; NOTE TO PROGRAMMERS;  Use entry point EN.  Do not use the

 ; first line of this routine, as pending initiatives in MDC

 ; might make a formal list on the first line of a routine

 ; invalid.  GTH 07-10-95

 ;

 ; Given a file or subfile number and global reference form,

 ; this routine will return the global reference in the form

 ; specified.

 ;

 ; F (form) is optional but if passed should equal 1 or 2.

 ; If F is not passed the default form will be 1.

 ;

 ;   F = 1 will be in the form ^GLOBAL(DA(2),11,DA(1),11,DA,

 ;   F = 2 will be in the form ^GLOBAL(D0,11,D1,11,D2,

 ;

 ; Formal list:

 ;

 ; 1) S = subfile number (call by value)

 ; 2) G = global reference (call by reference)

 ; 3) F = global reference form (call by value)

 ;

 ; *** NO ERROR CHECKING DONE ***

 ;

START ;

 ; D = Field

 ; I = Counter

 ; L = Level

 ; N = Node

 ; P = Parent

 ;

 NEW D,I,L,N,P

 ;

 S G="",L=1

 I '$D(^DD(S,0,"UP")) D NOPARENT Q

 D BACKUP

 S G=^DIC(P,0,"GL")

 I $G(F)=2 D  S G=G_"D"_(I+1)_"," I 1

 . F I=0:1 S G=G_"D"_I_","_N(99-L)_",",L=L-1 Q:L=0

 . Q

 E  D  S G=G_"DA,"

 . F L=L:-1:0 Q:L=0  S G=G_"DA("_L_"),"_N(99-L)_","

 . Q

 Q

 ;

BACKUP ; BACKUP TREE

 S P=^DD(S,0,"UP")

 S D=$O(^DD(P,"SB",S,""))

 S N(99-L)=$P($P(^DD(P,D,0),"^",4),";",1)

 S:N(99-L)'=+N(99-L) N(99-L)=""""_N(99-L)_""""

 I $D(^DD(P,0,"UP")) S S=P,L=L+1 D BACKUP

 Q

 ;

NOPARENT ; for no parent

 S G=^DIC(S,0,"GL")

 I $G(F)=2 S G=G_"D0" I 1

 E  S G=G_"DA,"

 Q

 ;

DIC(S) ;PEP - Extrinsic entry to return root global from FILE number

 NEW G

 D EN(S,.G)

 S G=$P(G,"DA,")

 Q G

 ;

EN(S,G,F) ;PEP - RETURN SUBFILE GLOBAL REFERENCE

 G START

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

XBSFGBL(S,G,F) ; IHS/ADC/GTH - RETURN SUBFILE GLOBAL REFERENCE ; [ 02/07/97   3:02 PM ]

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

 +2       ;

 +3       ; NOTE TO PROGRAMMERS;  Use entry point EN.  Do not use the

 +4       ; first line of this routine, as pending initiatives in MDC

 +5       ; might make a formal list on the first line of a routine

 +6       ; invalid.  GTH 07-10-95

 +7       ;

 +8       ; Given a file or subfile number and global reference form,

 +9       ; this routine will return the global reference in the form

 +10      ; specified.

 +11      ;

 +12      ; F (form) is optional but if passed should equal 1 or 2.

 +13      ; If F is not passed the default form will be 1.

 +14      ;

 +15      ;   F = 1 will be in the form ^GLOBAL(DA(2),11,DA(1),11,DA,

 +16      ;   F = 2 will be in the form ^GLOBAL(D0,11,D1,11,D2,

 +17      ;

 +18      ; Formal list:

 +19      ;

 +20      ; 1) S = subfile number (call by value)

 +21      ; 2) G = global reference (call by reference)

 +22      ; 3) F = global reference form (call by value)

 +23      ;

 +24      ; *** NO ERROR CHECKING DONE ***

 +25      ;

START     ;

 +1       ; D = Field

 +2       ; I = Counter

 +3       ; L = Level

 +4       ; N = Node

 +5       ; P = Parent

 +6       ;

 +7        NEW D,I,L,N,P

 +8       ;

 +9        SET G=""

           SET L=1

 +10       IF '$DATA(^DD(S,0,"UP"))

               DO NOPARENT

               QUIT 

 +11       DO BACKUP

 +12       SET G=^DIC(P,0,"GL")

 +13       IF $GET(F)=2

               Begin DoDot:1

 +14               FOR I=0:1

                       SET G=G_"D"_I_","_N(99-L)_","

                       SET L=L-1

                       IF L=0

                           QUIT 

 +15               QUIT 

               End DoDot:1

               SET G=G_"D"_(I+1)_","

               IF 1

 +16      IF '$TEST

               Begin DoDot:1

 +17               FOR L=L:-1:0

                       IF L=0

                           QUIT 

                       SET G=G_"DA("_L_"),"_N(99-L)_","

 +18               QUIT 

               End DoDot:1

               SET G=G_"DA,"

 +19       QUIT 

 +20      ;

BACKUP    ; BACKUP TREE

 +1        SET P=^DD(S,0,"UP")

 +2        SET D=$ORDER(^DD(P,"SB",S,""))

 +3        SET N(99-L)=$PIECE($PIECE(^DD(P,D,0),"^",4),";",1)

 +4        IF N(99-L)'=+N(99-L)

               SET N(99-L)=""""_N(99-L)_""""

 +5        IF $DATA(^DD(P,0,"UP"))

               SET S=P

               SET L=L+1

               DO BACKUP

 +6        QUIT 

 +7       ;

NOPARENT  ; for no parent

 +1        SET G=^DIC(S,0,"GL")

 +2        IF $GET(F)=2

               SET G=G_"D0"

               IF 1

 +3       IF '$TEST

               SET G=G_"DA,"

 +4        QUIT 

 +5       ;

DIC(S)    ;PEP - Extrinsic entry to return root global from FILE number

 +1        NEW G

 +2        DO EN(S,.G)

 +3        SET G=$PIECE(G,"DA,")

 +4        QUIT G

 +5       ;

EN(S,G,F) ;PEP - RETURN SUBFILE GLOBAL REFERENCE

 +1        GOTO START

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