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
Q
;
;=====================
; 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)
Q
;
;=========================
; $$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
Q
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
