Routine: DIKKUTL2

DIKKUTL2 ;SFISC/MKO-KEY DEFINITION, SOME UTILITIES ;1:25 PM  17 Jul 1998

 ;;22.0;VA FileMan;;Mar 30, 1999

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 ;==================

 ; GET(file,.count)

 ;==================

 ;Returns:

 ; CNT = # keys^file#

 ; CNT(keyName) = key#

 ; CNT(keyName,0) = file#^Name^Priority^UniqIndex

 ; CNT(keyName,seq#) = field#^file#^seq#

GET(FIL,CNT) ;Get information about keys on file FIL

 N FLD,KEY,NAM

 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y

 K CNT S CNT=0

 S NAM="" F  S NAM=$O(^DD("KEY","BB",FIL,NAM)) Q:NAM=""  S KEY=$O(^(NAM,0)) Q:'KEY  D

 . I $G(^DD("KEY",KEY,0))?."^" D  Q

 .. K ^DD("KEY","B",FIL,KEY),^DD("KEY","BB",FIL,NAM,KEY)

 . S CNT=CNT+1

 . S CNT(NAM)=KEY

 . S CNT(NAM,0)=^DD("KEY",KEY,0)

 . S FLD=0 F  S FLD=$O(^DD("KEY",KEY,2,FLD)) Q:'FLD  D

 .. I $D(^DD("KEY",KEY,2,FLD,0))#2,+$P(^(0),U,3) S CNT(NAM,$P(^(0),U,3))=^(0)

 S $P(CNT,U,2)=FIL

 ;=====================

 ; LIST(.count,header)

 ;=====================

 ;List the keys in the CNT array

 ;In:

 ; CNT = Array of keys to print (obtained by GET call above)

 ; HDR = Text to print before listing

 ;        (default is 'Current Indexes[ on [sub]file #xxx]:')

LIST(CNT,HDR) ;

 I '$G(CNT) D  Q

 . W !,"There are no Keys defined on "_$$FSTR^DIKCUTL2($P(CNT,U,2))_"."

 N DIERR,FIL,FILE01,FLD,KEY,MSG,NAM,PRIO,SN,TAG,UI,UITXT

 ;Write header

 S:$G(HDR)="" HDR="Keys defined on "_$$FSTR^DIKCUTL2($P(CNT,U,2))_":"

 W !,HDR

 ;Loop through keys in CNT array

 S NAM="" F  S NAM=$O(CNT(NAM)) Q:NAM=""  D

 . S KEY=CNT(NAM)

 . S FILE01=$P(CNT(NAM,0),U),PRIO=$P(CNT(NAM,0),U,3)

 . S UI=$P(CNT(NAM,0),U,4)

 . I UI]"" D

 .. S UI=$G(^DD("IX",UI,0))

 .. S UITXT=$P(UI,U,2)

 .. S:$P(UI,U)'=$P(UI,U,9) UITXT=UITXT_";  Whole File (#"_$P(UI,U)_")"

 . W !!?2,NAM,?5,$$EXTERNAL^DILFD(.31,1,"",PRIO,"MSG")_" KEY"

 . W:UI]"" ?20,"Uniqueness Index: "_UITXT

. ;

 . ;Loop through fields in key

 . S TAG="Field(s):  "

 . I $O(CNT(NAM,0)) S SN=0 F  S SN=$O(CNT(NAM,SN)) Q:'SN  D

 .. S FLD=$P(CNT(NAM,SN),U),FIL=$P(CNT(NAM,SN),U,2)

 .. W !?9,TAG_SN_") "_$P($G(^DD(FIL,FLD,0)),U)_" (#"_FLD_$S(FIL=FILE01:")",1:", from File #"_FIL)

 .. S TAG=$J("",11)

 ;=========================

 ; $$CHOOSE(.count,prompt)

 ;=========================

 ;Prompt for a key from the DIKKCNT array

 ;In:

 ; .DIKKCNT = Array contain key data (obtained by GET call above)

 ;  DIKCPR  = Action to include with the prompt

 ;Returns:

 ; Key ien (or 0, if none selected)

CHOOSE(DIKKCNT,DIKKPR) ;Choose a key

 Q:'$G(DIKKCNT) 0

 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y

 S DIR(0)="FAO^1:30^K:$D(DIKKCNT(X))[0 X"

 S DIR("A")="Which Key do you wish to "_DIKKPR_"? "

 S:+DIKKCNT=1 DIR("B")=$O(DIKKCNT(0))

 S DIR("?")="^D LIST^DIKKUTL2(.DIKKCNT)"

 W ! D ^DIR I $D(DIRUT) Q 0

 Q DIKKCNT(Y)

 ;===================================================

 ; GETFLD(key#,uniqIndex#,.keyField,.uniqIndexField)

 ;===================================================

 ;Get the fields in key and uniqueness index

 ;In:

 ; KEY    = key ien

 ; UI     = uniqueness index ien

 ;Out:

 ; KEYFLD    = # items in array

 ; KEYFLD(I) = file^field

 ;  UIFLD    = # items in array

 ;  UIFLD(I) = file^field

GETFLD(KEY,UI,KEYFLD,UIFLD) ;

 N I,FIL,FLD,ORD,S

 ;Loop through "S" index on Sequence Number of the Field multiple

 ;of the Key and set the KEYFLD array

 S I=0 K KEYFLD

 I $G(KEY),$D(^DD("KEY",KEY,0))#2 D

 . S S=0 F  S S=$O(^DD("KEY",KEY,2,"S",S)) Q:'S  D

 .. S FLD=$O(^DD("KEY",KEY,2,"S",S,0)) Q:'FLD  S FIL=$O(^(FLD,0)) Q:'FIL

 .. S I=I+1,KEYFLD(I)=FIL_U_FLD

 S KEYFLD=I

 ;Loop through the "AC" index on Subscript Number of the Cross-

 ;Reference Values multiple of the Index file and set the UIFLD

 ;array

 S I=0 K UIFLD

 I $G(UI),$D(^DD("IX",UI,0))#2 D

 . S S=0 F  S S=$O(^DD("IX",UI,11.1,"AC",S)) Q:'S  D

 .. S ORD=$O(^DD("IX",UI,11.1,"AC",S,0)) Q:'ORD

 .. S FIL=$P($G(^DD("IX",UI,11.1,ORD,0)),U,3),FLD=$P($G(^(0)),U,4)

 .. Q:'FIL  Q:'FLD

 .. S I=I+1,UIFLD(I)=FIL_U_FLD

 S UIFLD=I

DIKKUTL2  ;SFISC/MKO-KEY DEFINITION, SOME UTILITIES ;1:25 PM  17 Jul 1998

 +1       ;;22.0;VA FileMan;;Mar 30, 1999

 +2       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

 +4       ;==================

 +5       ; GET(file,.count)

 +6       ;==================

 +7       ;Returns:

 +8       ; CNT = # keys^file#

 +9       ; CNT(keyName) = key#

 +10      ; CNT(keyName,0) = file#^Name^Priority^UniqIndex

 +11      ; CNT(keyName,seq#) = field#^file#^seq#

 +12      ;

GET(FIL,CNT) ;Get information about keys on file FIL

 +1        NEW FLD,KEY,NAM

 +2        NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y

 +3       ;

 +4        KILL CNT

           SET CNT=0

 +5        SET NAM=""

FOR

               SET NAM=$ORDER(^DD("KEY","BB",FIL,NAM))

               IF NAM=""

                   QUIT

               SET KEY=$ORDER(^(NAM,0))

               IF 'KEY

                   QUIT

               Begin DoDot:1

 +6                IF $GET(^DD("KEY",KEY,0))?."^"

                       Begin DoDot:2

 +7                        KILL ^DD("KEY","B",FIL,KEY),^DD("KEY","BB",FIL,NAM,KEY)

                       End DoDot:2

                       QUIT

 +8                SET CNT=CNT+1

 +9                SET CNT(NAM)=KEY

 +10               SET CNT(NAM,0)=^DD("KEY",KEY,0)

 +11               SET FLD=0

FOR

                       SET FLD=$ORDER(^DD("KEY",KEY,2,FLD))

                       IF 'FLD

                           QUIT

                       Begin DoDot:2

 +12                       IF $DATA(^DD("KEY",KEY,2,FLD,0))#2

                               IF +$PIECE(^(0),U,3)

                                   SET CNT(NAM,$PIECE(^(0),U,3))=^(0)

                       End DoDot:2

               End DoDot:1

 +13       SET $PIECE(CNT,U,2)=FIL

 +14       QUIT

 +15      ;

 +16      ;=====================

 +17      ; LIST(.count,header)

 +18      ;=====================

 +19      ;List the keys in the CNT array

 +20      ;In:

 +21      ; CNT = Array of keys to print (obtained by GET call above)

 +22      ; HDR = Text to print before listing

 +23      ;        (default is 'Current Indexes[ on [sub]file #xxx]:')

 +24      ;

LIST(CNT,HDR) ;

 +1        IF '$GET(CNT)

               Begin DoDot:1

 +2                WRITE !,"There are no Keys defined on "_$$FSTR^DIKCUTL2($PIECE(CNT,U,2))_"."

               End DoDot:1

               QUIT

 +3       ;

 +4        NEW DIERR,FIL,FILE01,FLD,KEY,MSG,NAM,PRIO,SN,TAG,UI,UITXT

 +5       ;

 +6       ;Write header

 +7        IF $GET(HDR)=""

               SET HDR="Keys defined on "_$$FSTR^DIKCUTL2($PIECE(CNT,U,2))_":"

 +8        WRITE !,HDR

 +9       ;

 +10      ;Loop through keys in CNT array

 +11       SET NAM=""

FOR

               SET NAM=$ORDER(CNT(NAM))

               IF NAM=""

                   QUIT

               Begin DoDot:1

 +12               SET KEY=CNT(NAM)

 +13               SET FILE01=$PIECE(CNT(NAM,0),U)

                   SET PRIO=$PIECE(CNT(NAM,0),U,3)

 +14               SET UI=$PIECE(CNT(NAM,0),U,4)

 +15               IF UI]""

                       Begin DoDot:2

 +16                       SET UI=$GET(^DD("IX",UI,0))

 +17                       SET UITXT=$PIECE(UI,U,2)

 +18                       IF $PIECE(UI,U)'=$PIECE(UI,U,9)

                               SET UITXT=UITXT_";  Whole File (#"_$PIECE(UI,U)_")"

                       End DoDot:2

 +19               WRITE !!?2,NAM,?5,$$EXTERNAL^DILFD(.31,1,"",PRIO,"MSG")_" KEY"

 +20               IF UI]""

                       WRITE ?20,"Uniqueness Index: "_UITXT

 +21      ;

 +22      ;Loop through fields in key

 +23               SET TAG="Field(s):  "

 +24               IF $ORDER(CNT(NAM,0))

                       SET SN=0

FOR

                           SET SN=$ORDER(CNT(NAM,SN))

                           IF 'SN

                               QUIT

                           Begin DoDot:2

 +25                           SET FLD=$PIECE(CNT(NAM,SN),U)

                               SET FIL=$PIECE(CNT(NAM,SN),U,2)

 +26                           WRITE !?9,TAG_SN_") "_$PIECE($GET(^DD(FIL,FLD,0)),U)_" (#"_FLD_$SELECT(FIL=FILE01:")",1:", from File #"_FIL)

 +27                           SET TAG=$JUSTIFY("",11)

                           End DoDot:2

               End DoDot:1

 +28       QUIT

 +29      ;

 +30      ;=========================

 +31      ; $$CHOOSE(.count,prompt)

 +32      ;=========================

 +33      ;Prompt for a key from the DIKKCNT array

 +34      ;In:

 +35      ; .DIKKCNT = Array contain key data (obtained by GET call above)

 +36      ;  DIKCPR  = Action to include with the prompt

 +37      ;Returns:

 +38      ; Key ien (or 0, if none selected)

 +39      ;

CHOOSE(DIKKCNT,DIKKPR) ;Choose a key

 +1        IF '$GET(DIKKCNT)

               QUIT 0

 +2        NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y

 +3        SET DIR(0)="FAO^1:30^K:$D(DIKKCNT(X))[0 X"

 +4        SET DIR("A")="Which Key do you wish to "_DIKKPR_"? "

 +5        IF +DIKKCNT=1

               SET DIR("B")=$ORDER(DIKKCNT(0))

 +6        SET DIR("?")="^D LIST^DIKKUTL2(.DIKKCNT)"

 +7        WRITE !

           DO ^DIR

           IF $DATA(DIRUT)

               QUIT 0

 +8        QUIT DIKKCNT(Y)

 +9       ;

 +10      ;===================================================

 +11      ; GETFLD(key#,uniqIndex#,.keyField,.uniqIndexField)

 +12      ;===================================================

 +13      ;Get the fields in key and uniqueness index

 +14      ;In:

 +15      ; KEY    = key ien

 +16      ; UI     = uniqueness index ien

 +17      ;Out:

 +18      ; KEYFLD    = # items in array

 +19      ; KEYFLD(I) = file^field

 +20      ;  UIFLD    = # items in array

 +21      ;  UIFLD(I) = file^field

 +22      ;

GETFLD(KEY,UI,KEYFLD,UIFLD) ;

 +1        NEW I,FIL,FLD,ORD,S

 +2       ;

 +3       ;Loop through "S" index on Sequence Number of the Field multiple

 +4       ;of the Key and set the KEYFLD array

 +5        SET I=0

           KILL KEYFLD

 +6        IF $GET(KEY)

               IF $DATA(^DD("KEY",KEY,0))#2

                   Begin DoDot:1

 +7                    SET S=0

FOR

                           SET S=$ORDER(^DD("KEY",KEY,2,"S",S))

                           IF 'S

                               QUIT

                           Begin DoDot:2

 +8                            SET FLD=$ORDER(^DD("KEY",KEY,2,"S",S,0))

                               IF 'FLD

                                   QUIT

                               SET FIL=$ORDER(^(FLD,0))

                               IF 'FIL

                                   QUIT

 +9                            SET I=I+1

                               SET KEYFLD(I)=FIL_U_FLD

                           End DoDot:2

                   End DoDot:1

 +10       SET KEYFLD=I

 +11      ;

 +12      ;Loop through the "AC" index on Subscript Number of the Cross-

 +13      ;Reference Values multiple of the Index file and set the UIFLD

 +14      ;array

 +15       SET I=0

           KILL UIFLD

 +16       IF $GET(UI)

               IF $DATA(^DD("IX",UI,0))#2

                   Begin DoDot:1

 +17                   SET S=0

FOR

                           SET S=$ORDER(^DD("IX",UI,11.1,"AC",S))

                           IF 'S

                               QUIT

                           Begin DoDot:2

 +18                           SET ORD=$ORDER(^DD("IX",UI,11.1,"AC",S,0))

                               IF 'ORD

                                   QUIT

 +19                           SET FIL=$PIECE($GET(^DD("IX",UI,11.1,ORD,0)),U,3)

                               SET FLD=$PIECE($GET(^(0)),U,4)

 +20                           IF 'FIL

                                   QUIT

                               IF 'FLD

                                   QUIT

 +21                           SET I=I+1

                               SET UIFLD(I)=FIL_U_FLD

                           End DoDot:2

                   End DoDot:1

 +22       SET UIFLD=I

 +23       QUIT

DIKKUTL2.m