QAQSELCT ;HISC/DAD-GENERIC FILE ENTRY SELECTOR ;2/11/94 12:29
;;1.7;QM Integration Module;;07/25/1995
;
;*** SELECTS A GROUP OF RECORDS FROM A FILE ***
;
;REQUIRES:
; QAQDIC = FILE NUMBER OR GLOBAL ROOT
; QAQDIC(0) = DIC(0) STRING
; QAQUTIL = NODE TO STORE DATA UNDER IN ^UTILITY($J,QAQUTIL,
;OPTIONAL:
; QAQDIC("A") = DIC("A") STRING
; QAQDIC("B") = DIC("B") STRING
; QAQDIC("S") = DIC("S") STRING
; QAQDIC("W") = DIC("W") STRING
;RETURNS:
; QAQQUIT = $S(UP_ARROW_OUT:1 , NOTHING_SELECTED:1 , 1:0)
; ^UTILITY($J,QAQUTIL,EXTERNAL_.01_FIELD_DATA,IEN) = ""
EN1 ;
S QAQQUIT=0 I ($D(QAQDIC)[0)!($D(QAQDIC(0))[0)!($D(QAQUTIL)[0) S QAQQUIT=1 G EXIT
I (QAQDIC="")!(QAQDIC(0)="")!(QAQUTIL="") S QAQQUIT=1 G EXIT
D K S DIC=QAQDIC I DIC S (QAQDIC,DIC)=$S($D(^DIC(DIC,0,"GL"))#2:^("GL"),1:"") I DIC="" S QAQQUIT=1 G EXIT
S DIC(0)=QAQDIC(0),DIC(0)=$TR(DIC(0),"AL") S:DIC(0)'["Z" DIC(0)=DIC(0)_"Z" S QAQDIC(0)=DIC(0)
D DO^DIC1 S QAQFNUM=+DO(2),QAQFNAME=$P(DO,"^"),QAQFLD01=$P(^DD(QAQFNUM,.01,0),"^"),QAQFSCR=$S($D(DO("SCR"))#2:DO("SCR"),1:"") K DO
S QAQFLD01("S")=QAQFLD01_$S($E(QAQFLD01,$L(QAQFLD01))?1L:"s",1:"S")
F X="A","B","S","W" S QAQDIC(X)=$S($D(QAQDIC(X))#2:QAQDIC(X),1:"")
S:QAQDIC("A")="" QAQDIC("A")="Select "_QAQFNAME_" "_QAQFLD01_": "
S QAQALL=0,QAQNUM=1 K ^UTILITY($J,QAQUTIL) D HOME^%ZIS
1 D SETDIC W !!,$S(QAQNUM>1:"Another one: ",1:DIC("A")),$S((QAQNUM=1)&(QAQDIC("B")]""):QAQDIC("B")_"// ",1:"")
R X:DTIME S:('$T)!($E(X)="^") QAQQUIT=1 G:QAQQUIT EXIT S:(QAQNUM=1)&(X="")&(QAQDIC("B")]"") X=QAQDIC("B") G:X="" EXIT S QAQDSEL=$S(X?1"-"1.E:1,1:0) S:QAQDSEL X=$E(X,2,$L(X))
I $L(X),$L(X)<4,"Aa"[$E(X),"Ll"[$E(X,2),"Ll"[$E(X,3) D ALL G EXIT:QAQQUIT,1:QAQALL
D HELP:$E(X)="?",^DIC K DIC G:+Y'>0 1
I $$CHKFLD(QAQFNUM)["D" D
. N %DT,X
. S QAQD0=Y,X=Y(0,0),%DT="ST" D ^%DT S Y(0,0)=Y,Y=QAQD0
. Q
I 'QAQDSEL,'$D(^UTILITY($J,QAQUTIL,$E(Y(0,0),1,63),+Y)) S ^(+Y)="",QAQNUM=QAQNUM+1
I QAQDSEL,$D(^UTILITY($J,QAQUTIL,$E(Y(0,0),1,63),+Y)) K ^(+Y) S QAQNUM=QAQNUM-$S(QAQNUM>0:1,1:0)
G 1
EXIT ;
S QAQQUIT=$S(QAQQUIT:1,$O(^UTILITY($J,QAQUTIL,""))="":1,1:0) K QAQDIC,QAQUTIL
K K %,C,D0,DA,DIC,DIK,DIR,DO,QAQ,QAQALL,QAQD0,QAQDSEL,QAQDT,QAQFLD01,QAQFNAME,QAQFNUM,QAQFSCR,QAQLINE,QAQNUM,X,Y
Q
ALL ;
S QAQ="By '"_X_"' do you mean all "_$S($G(QAQFSCR)]"":"",$G(QAQDIC("S"))]"":"",1:$P(@(QAQDIC_"0)"),"^",4)_" ")_QAQFNAME_" "_QAQFLD01("S") D WRAP
S %=1 D YN^DICN S QAQALL=$S(%=1:1,1:0) S:%=-1 QAQQUIT=1 I '% W !?7,"Answer Y(es) if you want all of the ",QAQFLD01("S"),",",!?7,"otherwise answer N(o)" G ALL
I QAQQUIT!'QAQALL W:'QAQQUIT !!,X Q
N X F QAQD0=0:0 S QAQD0=$O(@(QAQDIC_"QAQD0)")) Q:QAQD0'>0 D AL
W:QAQNUM=1 " ??",*7
Q
AL I QAQFSCR]"" D SETDIC I $D(@(QAQDIC_"QAQD0,0)"))#2 S (D0,DA,Y)=QAQD0 X QAQFSCR Q:'$T
I QAQDIC("S")]"" D SETDIC I $D(@(QAQDIC_"QAQD0,0)"))#2 S (D0,DA,Y)=QAQD0 X DIC("S") Q:'$T
S Y=$P($G(@(QAQDIC_"QAQD0,0)")),"^"),C=$P(^DD(QAQFNUM,.01,0),"^",2) Q:Y=""
D Y^DIQ
I $$CHKFLD(QAQFNUM)["D" D
. N %DT,X
. S X=Y,%DT="ST" D ^%DT
. Q
S ^UTILITY($J,QAQUTIL,$E(Y,1,63),QAQD0)="",QAQNUM=QAQNUM+1
Q
HELP ;
N X S QAQ="Select a "_QAQFNAME_" "_QAQFLD01_" from the displayed list." D WRAP
W !?5,"To deselect a ",QAQFLD01," type a minus sign (-)",!?5,"in front of it, e.g. -",QAQFLD01,".",!?5,"To get all ",QAQFLD01("S")," type ALL."
G:$O(^UTILITY($J,QAQUTIL,""))="" HLP
SHOW S QAQLINE=$Y,QAQ="" W !!,"You have already selected:"
F S QAQ=$O(^UTILITY($J,QAQUTIL,QAQ)) Q:QAQ=""!QAQQUIT F QAQD0=0:0 S QAQD0=$O(^UTILITY($J,QAQUTIL,QAQ,QAQD0)) Q:QAQD0'>0!QAQQUIT D SHO
HLP W ! S QAQQUIT=0
Q
SHO S QAQ(0)=QAQ
I $$CHKFLD(QAQFNUM)["D" D
. N Y
. S Y=QAQ(0) X ^DD("DD") S QAQ(0)=Y
. Q
I QAQDIC(0)["N" W !?3,QAQD0,?15,QAQ(0)
E W !?3,QAQ(0)
D SETDIC I $D(DIC("W"))#2,DIC("W")]"",$D(@(QAQDIC_"QAQD0,0)"))#2 S (D0,DA,Y)=QAQD0 X DIC("W")
I $Y>(IOSL+QAQLINE-3) D PAUSE S QAQLINE=$Y
Q
WRAP ;
W ! F S Y=$L($E(QAQ,1,IOM-20)," ") W !?5,$P(QAQ," ",1,Y) S QAQ=$P(QAQ," ",Y+1,999) Q:QAQ=""
Q
PAUSE ;
K DIR S DIR(0)="E" D ^DIR K DIR S QAQQUIT=$S(Y:0,1:1)
Q
SETDIC ;
K DIC,DO S DIC=QAQDIC
F X="0","A","B","S","W" I QAQDIC(X)]"" S DIC(X)=QAQDIC(X)
D DO^DIC1
Q
CHKFLD(X) ;
N A S A=$P($G(^DD(X,.01,0)),"^",2)
I A["P" F S A=$$CHKFLD($TR(A,$TR(A,".0123456789"))) Q:A'["P"
Q A
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAQSELCT 4337 printed Jan 18, 2025@03:32:36 Page 2
QAQSELCT ;HISC/DAD-GENERIC FILE ENTRY SELECTOR ;2/11/94 12:29
+1 ;;1.7;QM Integration Module;;07/25/1995
+2 ;
+3 ;*** SELECTS A GROUP OF RECORDS FROM A FILE ***
+4 ;
+5 ;REQUIRES:
+6 ; QAQDIC = FILE NUMBER OR GLOBAL ROOT
+7 ; QAQDIC(0) = DIC(0) STRING
+8 ; QAQUTIL = NODE TO STORE DATA UNDER IN ^UTILITY($J,QAQUTIL,
+9 ;OPTIONAL:
+10 ; QAQDIC("A") = DIC("A") STRING
+11 ; QAQDIC("B") = DIC("B") STRING
+12 ; QAQDIC("S") = DIC("S") STRING
+13 ; QAQDIC("W") = DIC("W") STRING
+14 ;RETURNS:
+15 ; QAQQUIT = $S(UP_ARROW_OUT:1 , NOTHING_SELECTED:1 , 1:0)
+16 ; ^UTILITY($J,QAQUTIL,EXTERNAL_.01_FIELD_DATA,IEN) = ""
EN1 ;
+1 SET QAQQUIT=0
IF ($DATA(QAQDIC)[0)!($DATA(QAQDIC(0))[0)!($DATA(QAQUTIL)[0)
SET QAQQUIT=1
GOTO EXIT
+2 IF (QAQDIC="")!(QAQDIC(0)="")!(QAQUTIL="")
SET QAQQUIT=1
GOTO EXIT
+3 DO K
SET DIC=QAQDIC
IF DIC
SET (QAQDIC,DIC)=$SELECT($DATA(^DIC(DIC,0,"GL"))#2:^("GL"),1:"")
IF DIC=""
SET QAQQUIT=1
GOTO EXIT
+4 SET DIC(0)=QAQDIC(0)
SET DIC(0)=$TRANSLATE(DIC(0),"AL")
if DIC(0)'["Z"
SET DIC(0)=DIC(0)_"Z"
SET QAQDIC(0)=DIC(0)
+5 DO DO^DIC1
SET QAQFNUM=+DO(2)
SET QAQFNAME=$PIECE(DO,"^")
SET QAQFLD01=$PIECE(^DD(QAQFNUM,.01,0),"^")
SET QAQFSCR=$SELECT($DATA(DO("SCR"))#2:DO("SCR"),1:"")
KILL DO
+6 SET QAQFLD01("S")=QAQFLD01_$SELECT($EXTRACT(QAQFLD01,$LENGTH(QAQFLD01))?1L:"s",1:"S")
+7 FOR X="A","B","S","W"
SET QAQDIC(X)=$SELECT($DATA(QAQDIC(X))#2:QAQDIC(X),1:"")
+8 if QAQDIC("A")=""
SET QAQDIC("A")="Select "_QAQFNAME_" "_QAQFLD01_": "
+9 SET QAQALL=0
SET QAQNUM=1
KILL ^UTILITY($JOB,QAQUTIL)
DO HOME^%ZIS
1 DO SETDIC
WRITE !!,$SELECT(QAQNUM>1:"Another one: ",1:DIC("A")),$SELECT((QAQNUM=1)&(QAQDIC("B")]""):QAQDIC("B")_"// ",1:"")
+1 READ X:DTIME
if ('$TEST)!($EXTRACT(X)="^")
SET QAQQUIT=1
if QAQQUIT
GOTO EXIT
if (QAQNUM=1)&(X="")&(QAQDIC("B")]"")
SET X=QAQDIC("B")
if X=""
GOTO EXIT
SET QAQDSEL=$SELECT(X?1"-"1.E:1,1:0)
if QAQDSEL
SET X=$EXTRACT(X,2,$LENGTH(X))
+2 IF $LENGTH(X)
IF $LENGTH(X)<4
IF "Aa"[$EXTRACT(X)
IF "Ll"[$EXTRACT(X,2)
IF "Ll"[$EXTRACT(X,3)
DO ALL
if QAQQUIT
GOTO EXIT
if QAQALL
GOTO 1
+3 if $EXTRACT(X)="?"
DO HELP
DO ^DIC
KILL DIC
if +Y'>0
GOTO 1
+4 IF $$CHKFLD(QAQFNUM)["D"
Begin DoDot:1
+5 NEW %DT,X
+6 SET QAQD0=Y
SET X=Y(0,0)
SET %DT="ST"
DO ^%DT
SET Y(0,0)=Y
SET Y=QAQD0
+7 QUIT
End DoDot:1
+8 IF 'QAQDSEL
IF '$DATA(^UTILITY($JOB,QAQUTIL,$EXTRACT(Y(0,0),1,63),+Y))
SET ^(+Y)=""
SET QAQNUM=QAQNUM+1
+9 IF QAQDSEL
IF $DATA(^UTILITY($JOB,QAQUTIL,$EXTRACT(Y(0,0),1,63),+Y))
KILL ^(+Y)
SET QAQNUM=QAQNUM-$SELECT(QAQNUM>0:1,1:0)
+10 GOTO 1
EXIT ;
+1 SET QAQQUIT=$SELECT(QAQQUIT:1,$ORDER(^UTILITY($JOB,QAQUTIL,""))="":1,1:0)
KILL QAQDIC,QAQUTIL
K KILL %,C,D0,DA,DIC,DIK,DIR,DO,QAQ,QAQALL,QAQD0,QAQDSEL,QAQDT,QAQFLD01,QAQFNAME,QAQFNUM,QAQFSCR,QAQLINE,QAQNUM,X,Y
+1 QUIT
ALL ;
+1 SET QAQ="By '"_X_"' do you mean all "_$SELECT($GET(QAQFSCR)]"":"",$GET(QAQDIC("S"))]"":"",1:$PIECE(@(QAQDIC_"0)"),"^",4)_" ")_QAQFNAME_" "_QAQFLD01("S")
DO WRAP
+2 SET %=1
DO YN^DICN
SET QAQALL=$SELECT(%=1:1,1:0)
if %=-1
SET QAQQUIT=1
IF '%
WRITE !?7,"Answer Y(es) if you want all of the ",QAQFLD01("S"),",",!?7,"otherwise answer N(o)"
GOTO ALL
+3 IF QAQQUIT!'QAQALL
if 'QAQQUIT
WRITE !!,X
QUIT
+4 NEW X
FOR QAQD0=0:0
SET QAQD0=$ORDER(@(QAQDIC_"QAQD0)"))
if QAQD0'>0
QUIT
DO AL
+5 if QAQNUM=1
WRITE " ??",*7
+6 QUIT
AL IF QAQFSCR]""
DO SETDIC
IF $DATA(@(QAQDIC_"QAQD0,0)"))#2
SET (D0,DA,Y)=QAQD0
XECUTE QAQFSCR
if '$TEST
QUIT
+1 IF QAQDIC("S")]""
DO SETDIC
IF $DATA(@(QAQDIC_"QAQD0,0)"))#2
SET (D0,DA,Y)=QAQD0
XECUTE DIC("S")
if '$TEST
QUIT
+2 SET Y=$PIECE($GET(@(QAQDIC_"QAQD0,0)")),"^")
SET C=$PIECE(^DD(QAQFNUM,.01,0),"^",2)
if Y=""
QUIT
+3 DO Y^DIQ
+4 IF $$CHKFLD(QAQFNUM)["D"
Begin DoDot:1
+5 NEW %DT,X
+6 SET X=Y
SET %DT="ST"
DO ^%DT
+7 QUIT
End DoDot:1
+8 SET ^UTILITY($JOB,QAQUTIL,$EXTRACT(Y,1,63),QAQD0)=""
SET QAQNUM=QAQNUM+1
+9 QUIT
HELP ;
+1 NEW X
SET QAQ="Select a "_QAQFNAME_" "_QAQFLD01_" from the displayed list."
DO WRAP
+2 WRITE !?5,"To deselect a ",QAQFLD01," type a minus sign (-)",!?5,"in front of it, e.g. -",QAQFLD01,".",!?5,"To get all ",QAQFLD01("S")," type ALL."
+3 if $ORDER(^UTILITY($JOB,QAQUTIL,""))=""
GOTO HLP
SHOW SET QAQLINE=$Y
SET QAQ=""
WRITE !!,"You have already selected:"
+1 FOR
SET QAQ=$ORDER(^UTILITY($JOB,QAQUTIL,QAQ))
if QAQ=""!QAQQUIT
QUIT
FOR QAQD0=0:0
SET QAQD0=$ORDER(^UTILITY($JOB,QAQUTIL,QAQ,QAQD0))
if QAQD0'>0!QAQQUIT
QUIT
DO SHO
HLP WRITE !
SET QAQQUIT=0
+1 QUIT
SHO SET QAQ(0)=QAQ
+1 IF $$CHKFLD(QAQFNUM)["D"
Begin DoDot:1
+2 NEW Y
+3 SET Y=QAQ(0)
XECUTE ^DD("DD")
SET QAQ(0)=Y
+4 QUIT
End DoDot:1
+5 IF QAQDIC(0)["N"
WRITE !?3,QAQD0,?15,QAQ(0)
+6 IF '$TEST
WRITE !?3,QAQ(0)
+7 DO SETDIC
IF $DATA(DIC("W"))#2
IF DIC("W")]""
IF $DATA(@(QAQDIC_"QAQD0,0)"))#2
SET (D0,DA,Y)=QAQD0
XECUTE DIC("W")
+8 IF $Y>(IOSL+QAQLINE-3)
DO PAUSE
SET QAQLINE=$Y
+9 QUIT
WRAP ;
+1 WRITE !
FOR
SET Y=$LENGTH($EXTRACT(QAQ,1,IOM-20)," ")
WRITE !?5,$PIECE(QAQ," ",1,Y)
SET QAQ=$PIECE(QAQ," ",Y+1,999)
if QAQ=""
QUIT
+2 QUIT
PAUSE ;
+1 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
SET QAQQUIT=$SELECT(Y:0,1:1)
+2 QUIT
SETDIC ;
+1 KILL DIC,DO
SET DIC=QAQDIC
+2 FOR X="0","A","B","S","W"
IF QAQDIC(X)]""
SET DIC(X)=QAQDIC(X)
+3 DO DO^DIC1
+4 QUIT
CHKFLD(X) ;
+1 NEW A
SET A=$PIECE($GET(^DD(X,.01,0)),"^",2)
+2 IF A["P"
FOR
SET A=$$CHKFLD($TRANSLATE(A,$TRANSLATE(A,".0123456789")))
if A'["P"
QUIT
+3 QUIT A
