- 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 Jan 18, 2025@02:42:28 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)