GMRCTU1 ; SLC/KR Get DD Info ; [11/8/99 1:57pm]
;;3.0;CONSULT/REQUEST TRACKING;**9**;Dec 27, 1997
;
INFO(FILE,FIELD,ORA) ;
;
; DIC Global Root for <FILE>
; LOC Global Subscript Location (#;#) for <FIELD>
;
; INFO(<file #>,<field #>,.ARRAY)
;
; Returns
;
; ARRAY("DIC",0)=Global Root
; ARRAY("DIC",1)=File Root
; ARRAY("DIC",2)=Subfile Root
; ARRAY("DIC",..)=Subfile Root
; ARRAY("FILE")=Target File/Subfile Number
; ARRAY("FIELD")=Target Field
; ARRAY("NAME")=Target Field Name
; ARRAY("LOC")=Subscript and Piece
;
N DIC,LOC,SUB,SUBI,SFS,SNS S (DIC,LOC)="",FILE=+($G(FILE)),FIELD=+($G(FIELD))
Q:FILE=0!(FIELD=0) Q:'$D(^DD(FILE))
S ORA("FILE")=FILE,ORA("FIELD")=FIELD
D GETDD
S:$L(DIC) ORA("DIC",0)=$P(DIC,"(",1)_"(",ORA("DIC",1)=DIC
S:$L($G(SFS)) ORA("DIC",1,"P")=SFS
S:$L(LOC) ORA("LOC")=LOC
Q
GETDD ; Get file roots from DD
;
; FILE Current File #
; FIELD Current Field #
; DIC Current Global Root
; LOC Current Global Subscript Location (#;#)
; ARY( Temporay Storage Array (contains DD)
; ORA( Output Array
;
N ARY M ARY(FILE,FIELD,0)=^DD(FILE,FIELD,0)
M ARY(FILE,0,"UP")=^DD(FILE,0,"UP")
S ORA("NAME")=$P($G(ARY(FILE,FIELD,0)),"^",1)
S:'$L($G(LOC))&($D(ARY(FILE,FIELD,0))) LOC=$P(ARY(FILE,FIELD,0),"^",4)
D CURRDD:'$D(ARY(FILE,0,"UP")),NEXTDD:$D(ARY(FILE,0,"UP"))
Q
CURRDD ; Current DD
;
; FILE Current File #
; DIC Current Global Root
; SFS Subfile Specifier Array
; ARY( Temporary Storage Array (contains DD)
;
S DIC=$$ROOT^DILFD(FILE,0,"GL")
S SFS=$P($$ROOT^DILFD(FILE,0),"^",2)
Q
NEXTDD ; Next DD Level (for subfiles)
;
; OLDFILE Previous File #
; OLDFIELD Previous Field #
; OLDDIC Previous Global Root
; OLDLOC Previous Global Subscript Location (#;#)
; FILE Current File #
; FIELD Current Field #
; DIC Current Global Root
; SNS Subfile Number and Subfile Specifier
; LOC Current Global Subscript Location (#;#)
; ARY( Temporay Storage Array (contains DD)
; ORA( Output Array
; SUB( Subscript Array
; SFS( Subfile Specifier Array
; SUBI Subscript Counter
; SS Subscript
; DA Internal Entry Number Array
; CT1 Miscellaneous Counter #1
; CT2 Miscellaneous Counter #2
;
N FILE2,FIELD2,DIC2,LOC2,CT1,CT2
S LOC2=LOC,(FILE2,FIELD2)=FILE N FILE,FIELD,DIC
S FILE=$G(ARY(FILE2,0,"UP"))
N ARY M ARY(FILE,"SB",FIELD2)=^DD(FILE,"SB",FIELD2)
S FIELD=$O(ARY(FILE,"SB",FILE2,0))
M ARY(FILE,FIELD,0)=^DD(FILE,FIELD,0)
S SNS=$P($G(ARY(FILE,FIELD,0)),"^",2)
S SUBI=+($O(SUB(" "),-1)),SUBI=SUBI+1
S SUB(SUBI)=$P($P($G(ARY(FILE,FIELD,0)),"^",4),";",1),DIC=""
S SFS(SUBI)=SNS
D GETDD
S LOC=LOC2 I $L(DIC) D
. S ORA("DIC",0)=$P(DIC,"(",1)_"(",ORA("DIC",1)=DIC
. N DA,SS F CT1=SUBI:-1:1 S DA="DA("_CT1_")",DIC=DIC_DA_"," D
. . F CT2=SUBI:-1:1 D
. . . S SS=$G(SUB(CT2)),DIC=DIC_SS_",",ORA("DIC",(CT2+1))=DIC S:$L($G(SFS(CT2))) ORA("DIC",(CT2+1),"P")=$G(SFS(CT2))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMRCTU1 3402 printed Dec 13, 2024@01:47:42 Page 2
GMRCTU1 ; SLC/KR Get DD Info ; [11/8/99 1:57pm]
+1 ;;3.0;CONSULT/REQUEST TRACKING;**9**;Dec 27, 1997
+2 ;
INFO(FILE,FIELD,ORA) ;
+1 ;
+2 ; DIC Global Root for <FILE>
+3 ; LOC Global Subscript Location (#;#) for <FIELD>
+4 ;
+5 ; INFO(<file #>,<field #>,.ARRAY)
+6 ;
+7 ; Returns
+8 ;
+9 ; ARRAY("DIC",0)=Global Root
+10 ; ARRAY("DIC",1)=File Root
+11 ; ARRAY("DIC",2)=Subfile Root
+12 ; ARRAY("DIC",..)=Subfile Root
+13 ; ARRAY("FILE")=Target File/Subfile Number
+14 ; ARRAY("FIELD")=Target Field
+15 ; ARRAY("NAME")=Target Field Name
+16 ; ARRAY("LOC")=Subscript and Piece
+17 ;
+18 NEW DIC,LOC,SUB,SUBI,SFS,SNS
SET (DIC,LOC)=""
SET FILE=+($GET(FILE))
SET FIELD=+($GET(FIELD))
+19 if FILE=0!(FIELD=0)
QUIT
if '$DATA(^DD(FILE))
QUIT
+20 SET ORA("FILE")=FILE
SET ORA("FIELD")=FIELD
+21 DO GETDD
+22 if $LENGTH(DIC)
SET ORA("DIC",0)=$PIECE(DIC,"(",1)_"("
SET ORA("DIC",1)=DIC
+23 if $LENGTH($GET(SFS))
SET ORA("DIC",1,"P")=SFS
+24 if $LENGTH(LOC)
SET ORA("LOC")=LOC
+25 QUIT
GETDD ; Get file roots from DD
+1 ;
+2 ; FILE Current File #
+3 ; FIELD Current Field #
+4 ; DIC Current Global Root
+5 ; LOC Current Global Subscript Location (#;#)
+6 ; ARY( Temporay Storage Array (contains DD)
+7 ; ORA( Output Array
+8 ;
+9 NEW ARY
MERGE ARY(FILE,FIELD,0)=^DD(FILE,FIELD,0)
+10 MERGE ARY(FILE,0,"UP")=^DD(FILE,0,"UP")
+11 SET ORA("NAME")=$PIECE($GET(ARY(FILE,FIELD,0)),"^",1)
+12 if '$LENGTH($GET(LOC))&($DATA(ARY(FILE,FIELD,0)))
SET LOC=$PIECE(ARY(FILE,FIELD,0),"^",4)
+13 if '$DATA(ARY(FILE,0,"UP"))
DO CURRDD
if $DATA(ARY(FILE,0,"UP"))
DO NEXTDD
+14 QUIT
CURRDD ; Current DD
+1 ;
+2 ; FILE Current File #
+3 ; DIC Current Global Root
+4 ; SFS Subfile Specifier Array
+5 ; ARY( Temporary Storage Array (contains DD)
+6 ;
+7 SET DIC=$$ROOT^DILFD(FILE,0,"GL")
+8 SET SFS=$PIECE($$ROOT^DILFD(FILE,0),"^",2)
+9 QUIT
NEXTDD ; Next DD Level (for subfiles)
+1 ;
+2 ; OLDFILE Previous File #
+3 ; OLDFIELD Previous Field #
+4 ; OLDDIC Previous Global Root
+5 ; OLDLOC Previous Global Subscript Location (#;#)
+6 ; FILE Current File #
+7 ; FIELD Current Field #
+8 ; DIC Current Global Root
+9 ; SNS Subfile Number and Subfile Specifier
+10 ; LOC Current Global Subscript Location (#;#)
+11 ; ARY( Temporay Storage Array (contains DD)
+12 ; ORA( Output Array
+13 ; SUB( Subscript Array
+14 ; SFS( Subfile Specifier Array
+15 ; SUBI Subscript Counter
+16 ; SS Subscript
+17 ; DA Internal Entry Number Array
+18 ; CT1 Miscellaneous Counter #1
+19 ; CT2 Miscellaneous Counter #2
+20 ;
+21 NEW FILE2,FIELD2,DIC2,LOC2,CT1,CT2
+22 SET LOC2=LOC
SET (FILE2,FIELD2)=FILE
NEW FILE,FIELD,DIC
+23 SET FILE=$GET(ARY(FILE2,0,"UP"))
+24 NEW ARY
MERGE ARY(FILE,"SB",FIELD2)=^DD(FILE,"SB",FIELD2)
+25 SET FIELD=$ORDER(ARY(FILE,"SB",FILE2,0))
+26 MERGE ARY(FILE,FIELD,0)=^DD(FILE,FIELD,0)
+27 SET SNS=$PIECE($GET(ARY(FILE,FIELD,0)),"^",2)
+28 SET SUBI=+($ORDER(SUB(" "),-1))
SET SUBI=SUBI+1
+29 SET SUB(SUBI)=$PIECE($PIECE($GET(ARY(FILE,FIELD,0)),"^",4),";",1)
SET DIC=""
+30 SET SFS(SUBI)=SNS
+31 DO GETDD
+32 SET LOC=LOC2
IF $LENGTH(DIC)
Begin DoDot:1
+33 SET ORA("DIC",0)=$PIECE(DIC,"(",1)_"("
SET ORA("DIC",1)=DIC
+34 NEW DA,SS
FOR CT1=SUBI:-1:1
SET DA="DA("_CT1_")"
SET DIC=DIC_DA_","
Begin DoDot:2
+35 FOR CT2=SUBI:-1:1
Begin DoDot:3
+36 SET SS=$GET(SUB(CT2))
SET DIC=DIC_SS_","
SET ORA("DIC",(CT2+1))=DIC
if $LENGTH($GET(SFS(CT2)))
SET ORA("DIC",(CT2+1),"P")=$GET(SFS(CT2))
End DoDot:3
End DoDot:2
End DoDot:1
+37 QUIT
