KMPDUT4C ;OAK/RAK; Multi-Lookup cont. ;2/17/04 10:48
;;3.0;KMPD;;Jan 22, 2009;Build 42
;
HELP ;--help text
N OUT
W !!?7,"Enter '?D' to display entries selected so far."
I $G(OPTION)'["S" W !!?7,"Select '*' for all entries or"
W !
G:$G(OPTION)'["W" HELPM
W !?7,"Select entries by typing one or more characters and then the '*'"
W !
W !?7," Example: 'A*' - will select all entries begging with"
W !?7," the letter 'A'"
W !?7," 'SMITH*' - will select all entries begging with"
W !?7," 'SMITH'"
W !!!
D FTR^KMPDUTL4("Press <RET> to continue, '^' to exit Help",.OUT)
I 'OUT W !!! Q
W !!!
HELPM ;help text for minus sign
W !?7,"You may remove entries that have been selected so far by"
W !?7,"entering a minus sign (-) before the entry to be removed"
W !
W !?7," Example: '-JONES,JANE' - will remove the entry 'JONES,JANE'"
W !?7," from the array"
W !?7," '-SMITH*' - will remove all entries beginning with"
W !?7," 'SMITH' from the array"
W !
W !?7," ************************************************"
W !?7," *** It is important to note that using the ***"
W !?7," *** minus sign (-) only removes entries from ***"
W !?7," *** the array storing the selected entries, ***"
W !?7," *** it DOES NOT remove any entries from the ***"
W !?7," *** look-up file ***"
W !?7," ************************************************"
W !!!
D FTR^KMPDUTL4("Press <RET> to continue: ")
W !!!
Q
MINUS(X) ;de-select entries
;--------------------------------------------------------------------
;--------------------------------------------------------------------
Q:'$D(@ARRAY) S X=$G(X) Q:$E(X)'="-" S X=$E(X,2,$L(X))
I X="*" K @ARRAY Q
I X["*" S STR=$E(X,1,($F(X,"*")-2))
E S STR=X
Q:STR']"" S STR1=STR
;--------------------------------------------------------------------
; if exact match on STR1
;--------------------------------------------------------------------
I SORT=1,($D(@ARRAY@(STR1))) D Q
.K @ARRAY@(STR1) S @ARRAY@(0)=$G(@ARRAY@(0))-1 W:$X>73 !?7 W "."
;--------------------------------------------------------------------
; if wildcard
;--------------------------------------------------------------------
I SORT=1,(X["*") D Q
.F S STR1=$O(@ARRAY@(STR1)) Q:$E(STR1,1,$L(STR))'=STR D
..K @ARRAY@(STR1) S @ARRAY@(0)=$G(@ARRAY@(0))-1 W:$X>73 !?7 W "."
Q:SORT
I X'["*" S ASKI=0 D Q
.F S ASKI=$O(@ARRAY@(ASKI)) Q:'ASKI I @ARRAY@(ASKI)=STR1 D
..K @ARRAY@(ASKI) S @ARRAY@(0)=$G(@ARRAY@(0))-1 W:$X>73 !?7 W "."
I X["*" S ASKI=0 D Q
.F S ASKI=$O(@ARRAY@(ASKI)) Q:'ASKI I $E(@ARRAY@(ASKI),1,$L(STR))=STR D
..K @ARRAY@(ASKI) S @ARRAY@(0)=$G(@ARRAY@(0))-1 W:$X>73 !?7 W "."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HKMPDUT4C 2902 printed Apr 09, 2024@20:46:29 Page 2
KMPDUT4C ;OAK/RAK; Multi-Lookup cont. ;2/17/04 10:48
+1 ;;3.0;KMPD;;Jan 22, 2009;Build 42
+2 ;
HELP ;--help text
+1 NEW OUT
+2 WRITE !!?7,"Enter '?D' to display entries selected so far."
+3 IF $GET(OPTION)'["S"
WRITE !!?7,"Select '*' for all entries or"
+4 WRITE !
+5 if $GET(OPTION)'["W"
GOTO HELPM
+6 WRITE !?7,"Select entries by typing one or more characters and then the '*'"
+7 WRITE !
+8 WRITE !?7," Example: 'A*' - will select all entries begging with"
+9 WRITE !?7," the letter 'A'"
+10 WRITE !?7," 'SMITH*' - will select all entries begging with"
+11 WRITE !?7," 'SMITH'"
+12 WRITE !!!
+13 DO FTR^KMPDUTL4("Press <RET> to continue, '^' to exit Help",.OUT)
+14 IF 'OUT
WRITE !!!
QUIT
+15 WRITE !!!
HELPM ;help text for minus sign
+1 WRITE !?7,"You may remove entries that have been selected so far by"
+2 WRITE !?7,"entering a minus sign (-) before the entry to be removed"
+3 WRITE !
+4 WRITE !?7," Example: '-JONES,JANE' - will remove the entry 'JONES,JANE'"
+5 WRITE !?7," from the array"
+6 WRITE !?7," '-SMITH*' - will remove all entries beginning with"
+7 WRITE !?7," 'SMITH' from the array"
+8 WRITE !
+9 WRITE !?7," ************************************************"
+10 WRITE !?7," *** It is important to note that using the ***"
+11 WRITE !?7," *** minus sign (-) only removes entries from ***"
+12 WRITE !?7," *** the array storing the selected entries, ***"
+13 WRITE !?7," *** it DOES NOT remove any entries from the ***"
+14 WRITE !?7," *** look-up file ***"
+15 WRITE !?7," ************************************************"
+16 WRITE !!!
+17 DO FTR^KMPDUTL4("Press <RET> to continue: ")
+18 WRITE !!!
+19 QUIT
MINUS(X) ;de-select entries
+1 ;--------------------------------------------------------------------
+2 ;--------------------------------------------------------------------
+3 if '$DATA(@ARRAY)
QUIT
SET X=$GET(X)
if $EXTRACT(X)'="-"
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+4 IF X="*"
KILL @ARRAY
QUIT
+5 IF X["*"
SET STR=$EXTRACT(X,1,($FIND(X,"*")-2))
+6 IF '$TEST
SET STR=X
+7 if STR']""
QUIT
SET STR1=STR
+8 ;--------------------------------------------------------------------
+9 ; if exact match on STR1
+10 ;--------------------------------------------------------------------
+11 IF SORT=1
IF ($DATA(@ARRAY@(STR1)))
Begin DoDot:1
+12 KILL @ARRAY@(STR1)
SET @ARRAY@(0)=$GET(@ARRAY@(0))-1
if $X>73
WRITE !?7
WRITE "."
End DoDot:1
QUIT
+13 ;--------------------------------------------------------------------
+14 ; if wildcard
+15 ;--------------------------------------------------------------------
+16 IF SORT=1
IF (X["*")
Begin DoDot:1
+17 FOR
SET STR1=$ORDER(@ARRAY@(STR1))
if $EXTRACT(STR1,1,$LENGTH(STR))'=STR
QUIT
Begin DoDot:2
+18 KILL @ARRAY@(STR1)
SET @ARRAY@(0)=$GET(@ARRAY@(0))-1
if $X>73
WRITE !?7
WRITE "."
End DoDot:2
End DoDot:1
QUIT
+19 if SORT
QUIT
+20 IF X'["*"
SET ASKI=0
Begin DoDot:1
+21 FOR
SET ASKI=$ORDER(@ARRAY@(ASKI))
if 'ASKI
QUIT
IF @ARRAY@(ASKI)=STR1
Begin DoDot:2
+22 KILL @ARRAY@(ASKI)
SET @ARRAY@(0)=$GET(@ARRAY@(0))-1
if $X>73
WRITE !?7
WRITE "."
End DoDot:2
End DoDot:1
QUIT
+23 IF X["*"
SET ASKI=0
Begin DoDot:1
+24 FOR
SET ASKI=$ORDER(@ARRAY@(ASKI))
if 'ASKI
QUIT
IF $EXTRACT(@ARRAY@(ASKI),1,$LENGTH(STR))=STR
Begin DoDot:2
+25 KILL @ARRAY@(ASKI)
SET @ARRAY@(0)=$GET(@ARRAY@(0))-1
if $X>73
WRITE !?7
WRITE "."
End DoDot:2
End DoDot:1
QUIT
+26 QUIT
