LRUTIL1 ;DALOI/JDB -- Lab Utilities ;06/12/09 15:31
;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
;
Q
;
SELECT(DIC,OUT,FNAME,SELS,SORT,NOALL,MODE) ;
; Package replacement for FIRST^VAUTOMA
; Allows user to select multiple entries from a file.
; Inputs
; DIC :<byref> Standard DIC array
; OUT :<byref> See Outputs below
; FNAME :<opt> Filename to use for "Select " prompt
; : FNAME="" and DIC=# then uses File's Name
; SELS :<opt> How many selections user may make. dflt=20
; SORT :<opt> Numeric or Alpha sort? N or A -or- 0 or 1
; NOALL ;<opt> If 1 then user cannot select "ALL"
; MODE :<opt> Behave like FIRST^VAUTOMA or not (1 or 0)
; : dflt=0 (not) (see Outputs below for info)
; Outputs
; Returns the # of records selected
; OUT : Array that holds the records selected
; : MODE=0 OUT=total selected or OUT="*" (ALL)
; : SORT=0 -> OUT(select seq)=IEN
; : SORT=1 -> OUT(alpha seq)=IEN
; :
; : MODE=1 (VAUTOMA mode) OUT="" or OUT=1 (ALL)
; : SORT=0 -> OUT(IEN)=.01 field
; : SORT=1 -> OUT(.01 field)=IEN
;
N X,Y,CNT,STOP,DIR,DELSEL,NODE,I,TMPNM,LRDIC
N DTOUT,DUOUT,DIRUT,DIROUT,DIERR
;
S FNAME=$G(FNAME)
S SELS=$G(SELS,20)
S NOALL=$G(NOALL)
S SORT=$G(SORT)
S MODE=$G(MODE)
I SORT="A" S SORT=1
I SORT="N" S SORT=0
K OUT
K DIC("B")
S (STOP,CNT)=0
S TMPNM="LRUTIL1"
I FNAME="" I DIC D ;
. K DATA,DIERR
. D FILE^DID(DIC,"","NAME","DATA","ERR")
. Q:'$D(DATA)
. S FNAME=DATA("NAME")
. K DATA,DIERR
;
K ^TMP(TMPNM,$J)
I 'NOALL S DIC("B")="ALL" S DIR("B")=DIC("B")
I $G(DIC(0))="" S DIC(0)="EQMZ"
F D Q:STOP Q:CNT'<SELS ;
. I 'CNT D ;
. . S X=$G(DIC("A"))
. . I X="" S X="Select "_FNAME
. . S DIR("A")=X
. . S DIR(0)="FO"
. . S DIR("?")="^D HELP^LRUTIL1"
. ;
. I CNT=1 D ;
. . K DIR("B")
. . S DIR(0)="FAO"
. . S X=$G(DIC("A"))
. . I X="" S X=FNAME
. . Q:X?1"Select another "0.E
. . S DIR("A")="Select another "_X_": "
. ;
. K LRDIC M LRDIC=DIC ;save DIC for ^DIR's help processor
. D ^DIR
. I $D(DTOUT)!$D(DUOUT)!$D(DIROUT) K OUT S CNT=0 S STOP=1 Q
. I 'NOALL I Y="ALL" K OUT S CNT="*" S STOP=1 Q
. S DELSEL=0
. I $E(Y)="-" D ;
. . S DELSEL=1
. . S Y=$E(X,2,$L(Y))
. I Y="" S STOP=1 Q
. S X=Y
. D ^DIC
. I $D(LRDIC("W")) S DIC("W")=LRDIC("W") ; restore DIC("W") - it's killed in DIC calls.
. I $D(DTOUT)!$D(DUOUT) K OUT S CNT=0 S STOP=1 Q
. I Y>0 D ;
. . S NODE="^TMP(TMPNM,$J,1,0,+Y)"
. . I SORT=1 S NODE="^TMP(TMPNM,$J,1,$P(Y,""^"",2),+Y)"
. . I 'DELSEL I '$D(@NODE) D ;
. . . S CNT=CNT+1
. . . S @NODE=CNT
. . . S ^TMP(TMPNM,$J,2,"B",$P(Y,"^",2),+Y)=""
. . . S ^TMP(TMPNM,$J,2,"C",+Y)=$P(Y,"^",2)
. . I DELSEL D ;
. . . I $D(@NODE) S CNT=CNT-1 S:CNT<0 CNT=0
. . . K @NODE
. . . K ^TMP(TMPNM,$J,2,"B",$P(Y,"^",2),+Y)
. . . K ^TMP(TMPNM,$J,2,"C",+Y)
. . ;
. ;
;
I $D(^TMP(TMPNM,$J,1)) D ;
. S NODE="^TMP(TMPNM,$J,1)"
. S I=0
. F S NODE=$Q(@NODE) Q:NODE="" Q:$QS(NODE,3)'=1 Q:$QS(NODE,2)'=$J Q:$QS(NODE,1)'=TMPNM D ;
. . S I=I+1
. . I 'MODE I SORT S OUT(I)=$QS(NODE,5) Q
. . I MODE I SORT S OUT($QS(NODE,4))=$QS(NODE,5) Q
. . I 'SORT S OUT(0,@NODE)=$QS(NODE,5)
. ;
;
I $D(OUT(0)) D ;
. S I=0
. F S I=$O(OUT(0,I)) Q:'I D ; I=CNT
. . S X=OUT(0,I) ;IEN
. . I 'MODE S OUT(I)=X
. . I MODE S OUT(X)=^TMP(TMPNM,$J,2,"C",X)
. ;
;
K OUT(0)
K ^TMP(TMPNM,$J)
;
; Update OUT with status based on value of MODE.
I MODE D ;
. I CNT=0 K OUT S OUT=""
. I CNT>0 S OUT=""
. I CNT="*" K OUT S OUT=1
;
I 'MODE D
. I CNT=0 K OUT S OUT=""
. I CNT>0 S OUT=CNT
. I CNT="*" K OUT S OUT=CNT
;
Q CNT
;
;
HELP ;
; Displays "?" help info. For use with above.
; Expects SELS,NOALL,FNAME,CNT,TMPNM,LRDIC
N LRX,DIC
W !,"ENTER up to ",SELS,":"
I 'CNT&'NOALL W !?5,"- <return> for all ",FNAME,"s, or"
W !?5,"- a ",FNAME," or <return> after all selections made."
I CNT D ;
. W !?5,"- An entry preceded by a minus [-] sign to remove entry from list."
. W !,"NOTE, you have already selected:"
. S LRX=""
. F S LRX=$O(^TMP(TMPNM,$J,2,"B",LRX)) Q:LRX="" D ;
. . W !?8,LRX
. W !
. ;
; now show selectable entries
; X is from the ^DIR call ($E(X)="?")
; DIC isnt avail here because ^DIR News it.
I $D(LRDIC) M DIC=LRDIC
D ^DIC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRUTIL1 4412 printed Oct 16, 2024@18:22:59 Page 2
LRUTIL1 ;DALOI/JDB -- Lab Utilities ;06/12/09 15:31
+1 ;;5.2;LAB SERVICE;**350**;Sep 27, 1994;Build 230
+2 ;
+3 QUIT
+4 ;
SELECT(DIC,OUT,FNAME,SELS,SORT,NOALL,MODE) ;
+1 ; Package replacement for FIRST^VAUTOMA
+2 ; Allows user to select multiple entries from a file.
+3 ; Inputs
+4 ; DIC :<byref> Standard DIC array
+5 ; OUT :<byref> See Outputs below
+6 ; FNAME :<opt> Filename to use for "Select " prompt
+7 ; : FNAME="" and DIC=# then uses File's Name
+8 ; SELS :<opt> How many selections user may make. dflt=20
+9 ; SORT :<opt> Numeric or Alpha sort? N or A -or- 0 or 1
+10 ; NOALL ;<opt> If 1 then user cannot select "ALL"
+11 ; MODE :<opt> Behave like FIRST^VAUTOMA or not (1 or 0)
+12 ; : dflt=0 (not) (see Outputs below for info)
+13 ; Outputs
+14 ; Returns the # of records selected
+15 ; OUT : Array that holds the records selected
+16 ; : MODE=0 OUT=total selected or OUT="*" (ALL)
+17 ; : SORT=0 -> OUT(select seq)=IEN
+18 ; : SORT=1 -> OUT(alpha seq)=IEN
+19 ; :
+20 ; : MODE=1 (VAUTOMA mode) OUT="" or OUT=1 (ALL)
+21 ; : SORT=0 -> OUT(IEN)=.01 field
+22 ; : SORT=1 -> OUT(.01 field)=IEN
+23 ;
+24 NEW X,Y,CNT,STOP,DIR,DELSEL,NODE,I,TMPNM,LRDIC
+25 NEW DTOUT,DUOUT,DIRUT,DIROUT,DIERR
+26 ;
+27 SET FNAME=$GET(FNAME)
+28 SET SELS=$GET(SELS,20)
+29 SET NOALL=$GET(NOALL)
+30 SET SORT=$GET(SORT)
+31 SET MODE=$GET(MODE)
+32 IF SORT="A"
SET SORT=1
+33 IF SORT="N"
SET SORT=0
+34 KILL OUT
+35 KILL DIC("B")
+36 SET (STOP,CNT)=0
+37 SET TMPNM="LRUTIL1"
+38 ;
IF FNAME=""
IF DIC
Begin DoDot:1
+39 KILL DATA,DIERR
+40 DO FILE^DID(DIC,"","NAME","DATA","ERR")
+41 if '$DATA(DATA)
QUIT
+42 SET FNAME=DATA("NAME")
+43 KILL DATA,DIERR
End DoDot:1
+44 ;
+45 KILL ^TMP(TMPNM,$JOB)
+46 IF 'NOALL
SET DIC("B")="ALL"
SET DIR("B")=DIC("B")
+47 IF $GET(DIC(0))=""
SET DIC(0)="EQMZ"
+48 ;
FOR
Begin DoDot:1
+49 ;
IF 'CNT
Begin DoDot:2
+50 SET X=$GET(DIC("A"))
+51 IF X=""
SET X="Select "_FNAME
+52 SET DIR("A")=X
+53 SET DIR(0)="FO"
+54 SET DIR("?")="^D HELP^LRUTIL1"
End DoDot:2
+55 ;
+56 ;
IF CNT=1
Begin DoDot:2
+57 KILL DIR("B")
+58 SET DIR(0)="FAO"
+59 SET X=$GET(DIC("A"))
+60 IF X=""
SET X=FNAME
+61 if X?1"Select another "0.E
QUIT
+62 SET DIR("A")="Select another "_X_": "
End DoDot:2
+63 ;
+64 ;save DIC for ^DIR's help processor
KILL LRDIC
MERGE LRDIC=DIC
+65 DO ^DIR
+66 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
KILL OUT
SET CNT=0
SET STOP=1
QUIT
+67 IF 'NOALL
IF Y="ALL"
KILL OUT
SET CNT="*"
SET STOP=1
QUIT
+68 SET DELSEL=0
+69 ;
IF $EXTRACT(Y)="-"
Begin DoDot:2
+70 SET DELSEL=1
+71 SET Y=$EXTRACT(X,2,$LENGTH(Y))
End DoDot:2
+72 IF Y=""
SET STOP=1
QUIT
+73 SET X=Y
+74 DO ^DIC
+75 ; restore DIC("W") - it's killed in DIC calls.
IF $DATA(LRDIC("W"))
SET DIC("W")=LRDIC("W")
+76 IF $DATA(DTOUT)!$DATA(DUOUT)
KILL OUT
SET CNT=0
SET STOP=1
QUIT
+77 ;
IF Y>0
Begin DoDot:2
+78 SET NODE="^TMP(TMPNM,$J,1,0,+Y)"
+79 IF SORT=1
SET NODE="^TMP(TMPNM,$J,1,$P(Y,""^"",2),+Y)"
+80 ;
IF 'DELSEL
IF '$DATA(@NODE)
Begin DoDot:3
+81 SET CNT=CNT+1
+82 SET @NODE=CNT
+83 SET ^TMP(TMPNM,$JOB,2,"B",$PIECE(Y,"^",2),+Y)=""
+84 SET ^TMP(TMPNM,$JOB,2,"C",+Y)=$PIECE(Y,"^",2)
End DoDot:3
+85 ;
IF DELSEL
Begin DoDot:3
+86 IF $DATA(@NODE)
SET CNT=CNT-1
if CNT<0
SET CNT=0
+87 KILL @NODE
+88 KILL ^TMP(TMPNM,$JOB,2,"B",$PIECE(Y,"^",2),+Y)
+89 KILL ^TMP(TMPNM,$JOB,2,"C",+Y)
End DoDot:3
+90 ;
End DoDot:2
+91 ;
End DoDot:1
if STOP
QUIT
if CNT'<SELS
QUIT
+92 ;
+93 ;
IF $DATA(^TMP(TMPNM,$JOB,1))
Begin DoDot:1
+94 SET NODE="^TMP(TMPNM,$J,1)"
+95 SET I=0
+96 ;
FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
if $QSUBSCRIPT(NODE,3)'=1
QUIT
if $QSUBSCRIPT(NODE,2)'=$JOB
QUIT
if $QSUBSCRIPT(NODE,1)'=TMPNM
QUIT
Begin DoDot:2
+97 SET I=I+1
+98 IF 'MODE
IF SORT
SET OUT(I)=$QSUBSCRIPT(NODE,5)
QUIT
+99 IF MODE
IF SORT
SET OUT($QSUBSCRIPT(NODE,4))=$QSUBSCRIPT(NODE,5)
QUIT
+100 IF 'SORT
SET OUT(0,@NODE)=$QSUBSCRIPT(NODE,5)
End DoDot:2
+101 ;
End DoDot:1
+102 ;
+103 ;
IF $DATA(OUT(0))
Begin DoDot:1
+104 SET I=0
+105 ; I=CNT
FOR
SET I=$ORDER(OUT(0,I))
if 'I
QUIT
Begin DoDot:2
+106 ;IEN
SET X=OUT(0,I)
+107 IF 'MODE
SET OUT(I)=X
+108 IF MODE
SET OUT(X)=^TMP(TMPNM,$JOB,2,"C",X)
End DoDot:2
+109 ;
End DoDot:1
+110 ;
+111 KILL OUT(0)
+112 KILL ^TMP(TMPNM,$JOB)
+113 ;
+114 ; Update OUT with status based on value of MODE.
+115 ;
IF MODE
Begin DoDot:1
+116 IF CNT=0
KILL OUT
SET OUT=""
+117 IF CNT>0
SET OUT=""
+118 IF CNT="*"
KILL OUT
SET OUT=1
End DoDot:1
+119 ;
+120 IF 'MODE
Begin DoDot:1
+121 IF CNT=0
KILL OUT
SET OUT=""
+122 IF CNT>0
SET OUT=CNT
+123 IF CNT="*"
KILL OUT
SET OUT=CNT
End DoDot:1
+124 ;
+125 QUIT CNT
+126 ;
+127 ;
HELP ;
+1 ; Displays "?" help info. For use with above.
+2 ; Expects SELS,NOALL,FNAME,CNT,TMPNM,LRDIC
+3 NEW LRX,DIC
+4 WRITE !,"ENTER up to ",SELS,":"
+5 IF 'CNT&'NOALL
WRITE !?5,"- <return> for all ",FNAME,"s, or"
+6 WRITE !?5,"- a ",FNAME," or <return> after all selections made."
+7 ;
IF CNT
Begin DoDot:1
+8 WRITE !?5,"- An entry preceded by a minus [-] sign to remove entry from list."
+9 WRITE !,"NOTE, you have already selected:"
+10 SET LRX=""
+11 ;
FOR
SET LRX=$ORDER(^TMP(TMPNM,$JOB,2,"B",LRX))
if LRX=""
QUIT
Begin DoDot:2
+12 WRITE !?8,LRX
End DoDot:2
+13 WRITE !
+14 ;
End DoDot:1
+15 ; now show selectable entries
+16 ; X is from the ^DIR call ($E(X)="?")
+17 ; DIC isnt avail here because ^DIR News it.
+18 IF $DATA(LRDIC)
MERGE DIC=LRDIC
+19 DO ^DIC
+20 QUIT
