KMPDUT4B ;OAK/RAK; Multi-Lookup Array Selection cont. ;2/17/04 10:48
;;3.0;KMPD;;Jan 22, 2009;Build 42
;
;--------------------------------------------------------------------
; sub-routines to select entries - called from ^KMPDUT4
;--------------------------------------------------------------------
ALL ;all entries selected
Q:'$D(ARRAY)!('$D(DIC)) S MAX=+$G(MAX),SORT=+$G(SORT)
K @ARRAY I DIC S DIC=$G(^DIC(DIC,0,"GL"))
I MAX,($P($G(@(DIC_"0)")),U,4)>MAX) S @ARRAY@(0)="*" Q
N ASKI W " selecting 'All' entries"
F ASKI=0:0 S ASKI=$O(@(DIC_ASKI_")")) Q:'ASKI D SET(ASKI)
Q
DISPLAY ;display entries that have been selected
Q:'$D(DIC) S SORT=+$G(SORT)
I '$D(@ARRAY) W !!,"...no entries have been selected...",! Q
I @ARRAY@(0)="*" W !!,"...'All' entries have been selected...",! Q
D HDR^KMPDUTL4("Selected Entries from "_$P($G(@(DIC_"0)")),U)_" file")
N ASKI,ASKOUT S ASKI="",ASKOUT=1 W !!
F S ASKI=$O(@ARRAY@(ASKI)) Q:ASKI=""!(ASKOUT'=1) I ASKI'=0 D
.I $Y>(IOSL-4) D Q:ASKOUT'=1
..D FTR^KMPDUTL4("",.ASKOUT) Q:ASKOUT'=1
..D HDR^KMPDUTL4("Selected Entries from "_$P($G(@(DIC_"0)")),U)_" file")
..W !!
.W !?7,$S(SORT=1:ASKI,1:@ARRAY@(ASKI))
W !
Q
WILDCARD(X) ;entries with wildcard selected
;--------------------------------------------------------------------
; allow wildcard selections
; examples: A*
; ABC*
; SMITH*
;--------------------------------------------------------------------
Q:$G(X)']""
N ASKI,COUNT,NARRAY,OUT,STR,STR1 S (COUNT,OUT)=0
S MAX=+$G(MAX),SORT=+$G(SORT) S:$G(D)']"" D="B"
S STR=$E(X,1,($F(X,"*")-2)) Q:STR']""
S STR1=STR,NARRAY=DIC_""""_D_""""_")"
;--------------------------------------------------------------------
; if exact match on STR1
;--------------------------------------------------------------------
I $D(@NARRAY@(STR1)) S ASKI=0 D Q
.I STR?.N S NARRAY=DIC_""""_D_""""_","_STR_")"
.E S NARRAY=DIC_""""_D_""""_","_""""_STR_""""_")"
.F S ASKI=$O(@NARRAY@(ASKI)) Q:'ASKI D Q:OUT
..D SET(ASKI) I MAX,(+$G(@ARRAY@(0))=MAX) S OUT=1
;--------------------------------------------------------------------
; if not an exact match
;--------------------------------------------------------------------
F S STR1=$O(@NARRAY@(STR1)) Q:$E(STR1,1,$L(STR))'=STR D Q:OUT
.F ASKI=0:0 S ASKI=$O(@NARRAY@(STR1,ASKI)) Q:'ASKI D Q:OUT
..D SET(ASKI) I MAX,(+$G(@ARRAY@(0))=MAX) S OUT=1
Q
SET(IFN) ;set selected data into array
;--------------------------------------------------------------------
; IFN - internal file number of entry
;--------------------------------------------------------------------
N X,Y S IFN=+$G(IFN),SORT=+$G(SORT) Q:'IFN
Q:'$D(DIC)!('$D(ARRAY))
Q:'$D(@(DIC_IFN_",0)"))!($P($G(^(0)),U)']"")
S X="`"_ASKI,DIC(0)="Z" D ^DIC Q:Y'>0
I SORT=1 S @ARRAY@(Y(0,0))=+Y
E S @ARRAY@(+Y)=Y(0,0)
S @ARRAY@(0)=$G(@ARRAY@(0))+1 W:$X>73 !?7 W "."
Q
; for future use - if unable to use `IFN in call to ^DIC
I SORT=1 S @ARRAY@($P($G(@(DIC_ASKI_",0)")),U))=ASKI
E S @ARRAY@(ASKI)=$P($G(@(DIC_ASKI_",0)")),U)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HKMPDUT4B 3127 printed Nov 22, 2024@16:51:26 Page 2
KMPDUT4B ;OAK/RAK; Multi-Lookup Array Selection cont. ;2/17/04 10:48
+1 ;;3.0;KMPD;;Jan 22, 2009;Build 42
+2 ;
+3 ;--------------------------------------------------------------------
+4 ; sub-routines to select entries - called from ^KMPDUT4
+5 ;--------------------------------------------------------------------
ALL ;all entries selected
+1 if '$DATA(ARRAY)!('$DATA(DIC))
QUIT
SET MAX=+$GET(MAX)
SET SORT=+$GET(SORT)
+2 KILL @ARRAY
IF DIC
SET DIC=$GET(^DIC(DIC,0,"GL"))
+3 IF MAX
IF ($PIECE($GET(@(DIC_"0)")),U,4)>MAX)
SET @ARRAY@(0)="*"
QUIT
+4 NEW ASKI
WRITE " selecting 'All' entries"
+5 FOR ASKI=0:0
SET ASKI=$ORDER(@(DIC_ASKI_")"))
if 'ASKI
QUIT
DO SET(ASKI)
+6 QUIT
DISPLAY ;display entries that have been selected
+1 if '$DATA(DIC)
QUIT
SET SORT=+$GET(SORT)
+2 IF '$DATA(@ARRAY)
WRITE !!,"...no entries have been selected...",!
QUIT
+3 IF @ARRAY@(0)="*"
WRITE !!,"...'All' entries have been selected...",!
QUIT
+4 DO HDR^KMPDUTL4("Selected Entries from "_$PIECE($GET(@(DIC_"0)")),U)_" file")
+5 NEW ASKI,ASKOUT
SET ASKI=""
SET ASKOUT=1
WRITE !!
+6 FOR
SET ASKI=$ORDER(@ARRAY@(ASKI))
if ASKI=""!(ASKOUT'=1)
QUIT
IF ASKI'=0
Begin DoDot:1
+7 IF $Y>(IOSL-4)
Begin DoDot:2
+8 DO FTR^KMPDUTL4("",.ASKOUT)
if ASKOUT'=1
QUIT
+9 DO HDR^KMPDUTL4("Selected Entries from "_$PIECE($GET(@(DIC_"0)")),U)_" file")
+10 WRITE !!
End DoDot:2
if ASKOUT'=1
QUIT
+11 WRITE !?7,$SELECT(SORT=1:ASKI,1:@ARRAY@(ASKI))
End DoDot:1
+12 WRITE !
+13 QUIT
WILDCARD(X) ;entries with wildcard selected
+1 ;--------------------------------------------------------------------
+2 ; allow wildcard selections
+3 ; examples: A*
+4 ; ABC*
+5 ; SMITH*
+6 ;--------------------------------------------------------------------
+7 if $GET(X)']""
QUIT
+8 NEW ASKI,COUNT,NARRAY,OUT,STR,STR1
SET (COUNT,OUT)=0
+9 SET MAX=+$GET(MAX)
SET SORT=+$GET(SORT)
if $GET(D)']""
SET D="B"
+10 SET STR=$EXTRACT(X,1,($FIND(X,"*")-2))
if STR']""
QUIT
+11 SET STR1=STR
SET NARRAY=DIC_""""_D_""""_")"
+12 ;--------------------------------------------------------------------
+13 ; if exact match on STR1
+14 ;--------------------------------------------------------------------
+15 IF $DATA(@NARRAY@(STR1))
SET ASKI=0
Begin DoDot:1
+16 IF STR?.N
SET NARRAY=DIC_""""_D_""""_","_STR_")"
+17 IF '$TEST
SET NARRAY=DIC_""""_D_""""_","_""""_STR_""""_")"
+18 FOR
SET ASKI=$ORDER(@NARRAY@(ASKI))
if 'ASKI
QUIT
Begin DoDot:2
+19 DO SET(ASKI)
IF MAX
IF (+$GET(@ARRAY@(0))=MAX)
SET OUT=1
End DoDot:2
if OUT
QUIT
End DoDot:1
QUIT
+20 ;--------------------------------------------------------------------
+21 ; if not an exact match
+22 ;--------------------------------------------------------------------
+23 FOR
SET STR1=$ORDER(@NARRAY@(STR1))
if $EXTRACT(STR1,1,$LENGTH(STR))'=STR
QUIT
Begin DoDot:1
+24 FOR ASKI=0:0
SET ASKI=$ORDER(@NARRAY@(STR1,ASKI))
if 'ASKI
QUIT
Begin DoDot:2
+25 DO SET(ASKI)
IF MAX
IF (+$GET(@ARRAY@(0))=MAX)
SET OUT=1
End DoDot:2
if OUT
QUIT
End DoDot:1
if OUT
QUIT
+26 QUIT
SET(IFN) ;set selected data into array
+1 ;--------------------------------------------------------------------
+2 ; IFN - internal file number of entry
+3 ;--------------------------------------------------------------------
+4 NEW X,Y
SET IFN=+$GET(IFN)
SET SORT=+$GET(SORT)
if 'IFN
QUIT
+5 if '$DATA(DIC)!('$DATA(ARRAY))
QUIT
+6 if '$DATA(@(DIC_IFN_",0)"))!($PIECE($GET(^(0)),U)']"")
QUIT
+7 SET X="`"_ASKI
SET DIC(0)="Z"
DO ^DIC
if Y'>0
QUIT
+8 IF SORT=1
SET @ARRAY@(Y(0,0))=+Y
+9 IF '$TEST
SET @ARRAY@(+Y)=Y(0,0)
+10 SET @ARRAY@(0)=$GET(@ARRAY@(0))+1
if $X>73
WRITE !?7
WRITE "."
+11 QUIT
+12 ; for future use - if unable to use `IFN in call to ^DIC
+13 IF SORT=1
SET @ARRAY@($PIECE($GET(@(DIC_ASKI_",0)")),U))=ASKI
+14 IF '$TEST
SET @ARRAY@(ASKI)=$PIECE($GET(@(DIC_ASKI_",0)")),U)
