- 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