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