DIR.m

DIR ;SFISC/XAK - READER, HELP ;3NOV2016

 ;;22.2;VA FileMan;**4,2**;Jan 05, 2016;Build 139

 ;;Per VA Directive 6402, this routine should not be modified.

 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.

 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.

 ;;Licensed under the terms of the Apache License, Version 2.0.

 ;;GFT;**30,170,999,1004,1037,1038,1044,1046**

 ;

 N %,%A,%B,%B1,%B2,%B3,%BA,%C,%E,%G,%H,%I,%J,%N,%P,%S,%T,%W,%X,%Y,A0,C,D,DD,DDH,DDQ,DDSV,DG,DH,DIC,DIFLD,DIRO,DO,DP,DQ,DU,DZ,X1,XQH,DIX,DIY,DISYS,%BU,%J1,%A0,%W0,%D1,%D2,%DT,%K,%M,DIRCOUNT

 S:$D(DDH)[0 DDH=0 Q:'$D(DIR(0))  D ^DIR2 G Q:%T=""

 I $D(DIR("V"))#2 D ^DIR1 S DDER=%E G Q

A I $D(DDM) K:DDM DDQ S:'DDM DDQ=$G(DDSHBX,IOSL-7) ;RETURN TO THIS LINE AFTER A "?" HELP

 I $G(DDH) D LIST^DDSU

 D W:%A'["V" I $D(DDS),$D(DIR0) S DDACT=Y I DDO=.5 S DDM=1 G Q

TOOMANY S DIRCOUNT=$G(DIRCOUNT)+1 I DIRCOUNT>49 S (X,Y)=U,(DUOUT,DIRUT)=1 G Q

 I %A'["V",%E D QUES S A0="" D MSG D:$G(DDH) LIST^DDSU G A

 I $D(DTOUT) K Y S DIRUT=1,Y="" G Q

 I %T'="E",X?1."^".E K Y S (DUOUT,DIRUT)=1,Y=X S:X="^^" DIROUT=1 S:%T="Y" %=-1 G Q

 I %T'="E","@"[X,%A["O" S Y="",DIRUT=1 S:%T="P" Y=-1 G Q

 I %A'["O","@"[X,%T'="E" S A0=$C(7)_%A0 D MSG G A ;IF NOT OPTIONAL, A RESPONSE IS REQUIRED,  SO LOOP!

 I $D(DDS),$D(DIR0),DIR0N G Q

 I $D(%G),$D(DIR("B")),X=DIR("B") S Y=%G G Q

X I X'?1."?" K DDQ D ^DIR1 D

 .I $D(DICQRETA) S DIR0N=1,%E=0,X="",DDACT=DICQRETA K DICQRETA Q

 .I '%E,$P(DIR(0),U,3)]"" S %X=X D  S:'$D(X) %E=1 S X=%X ;^DIR1 will evaluate input

 ..N %A,%B,%B1,%B2,%B3,%E,%N,%P,%T,%X,%W,%W0

 ..X $P(DIR(0),U,3,99) ;INPUT TRANSFORM if any

 I %A["V" K:%E Y G Q

 I X'?1."?",'%E G Q ;If no error or "?", quit

 D QUES:%E'<0&'$G(DUOUT)&'$G(DTOUT) S A0="" D MSG D:$G(DDH) LIST^DDSU ;**170

 ;VARIABLES DICQRETV & DICQRETA ARE SET IN DDSU ROUTINE

 I $D(DICQRETV) S (X,DIR0A)=DICQRETV,DDSREPNT=1,DDACT="" K DICQRETV,DICQRETA G X ;RETURN VALUE from drop-down list is sent back for evaluation (and echoing)

 I $D(DICQRETA) S DIR0N=1,DDACT=DICQRETA K DICQRETA G Q

 G A

 ;

 ;

 ;

W ; write the prompt and read the user's response.  Called from A+2 above

 S %W=%W0,%N=$E(%W)=U

SCREEN K DTOUT,DUOUT,DIRUT,DIROUT S %E=0 I $D(DDS),$D(DIR0) D ^DIR0 Q:'$D(DIR("PRE"))  X DIR("PRE") S:'$D(X) %E=1,X="" Q  ;READ in DIR01 via DIR0

 I %T="S",%A'["A",%A'["B" D S

 I $D(DIR("A"))=11 F %=0:0 S %=$O(DIR("A",%)) Q:%'>0  W !,DIR("A",%)

 W ! W:$L(%P) %P

 I $L($G(DIR("B")))>19,%A'["r",%T'="D",%T'="S",(%B'["D"&%T)!'%T,%B'["P"!'$P(%A,",",2) W DIR("B") S Y=DIR("B") D RW^DIR2 S:X="" X=DIR("B") Q  ;NOV2009: NO REPLACE-WITH FOR POINTERS

DIRB N DIRB I $D(DIR("B")) S DIRB=DIR("B") D  W DIRB_"// " ;**

 .I %T="Y",$G(DUZ("LANG"))>1,$G(%B)]"" N X S X=$F("YN",$$UP^DILIBF($E(DIRB))) S:X DIRB=$P($P(%B,";",X-1),":",2) ;YES/NO in FOREIGN LANGUAGE

 R X:$S($D(DIR("T")):DIR("T"),'$D(DTIME):300,1:DTIME) I '$T S DTOUT=1 ;>>>HERE IS THE READER'S 'READ'!<<<

 I $D(DIR("PRE")) X DIR("PRE") I '$D(X) S %E=1,X="" Q

 I X="",$D(DIRB) S X=DIRB I %T'="D",%B'["D"&%T W X

 I X'?.ANP S X="?"

 Q

 ;

QU I %E!(X="?")!($O(^DD(%B1,%B2,21,0))'>0) K %Y S A0="" D MSG S X1=$$HELP^DIALOGZ(%B1,%B2) D   I $D(^DD(%B1,%B2,12)) S X1=^(12) D  ;** FIELD HELP FOR A FIELD-TYPE QUESTION

 .S %J=75,%Y=1 D W1

 N DIPB,DIPA

 S DIPB=$P(^DD(%B1,%B2,0),U,2) I $D(^(4)) S A0=^(4),A0(0)=1 D MSG

 I DIPB["t" S A0=$$XHELP^DIETLIBF(%B1,%B2),A0(0)=1 D MSG N DIPB,%T S (%T,DIPB)="S" D  ;XECUTABLE HELP FOR EXTENDED DATA TYPE

 .I DIPB="S" S $P(%B3,U,3)=$$GETPROP^DIETLIBF(%B1,%B2,"SET OF CODES")

 I X?1"??".E D

 . I $D(DDS) N DDC,DDSQ S DDC=7

 . S A0="" D MSG S %C=0

 . F  S %C=$O(^DD(%B1,%B2,21,%C)) Q:'%C!$D(DDSQ)  S A0=^(%C,0) D

 .. I $D(DDS),$G(DDH),'(DDH#DDC) D LIST^DDSU Q:$D(DDSQ)

 .. D MSG

 I %B["P" K DO S DIC=U_$P(%B3,U,3),DIC(0)="M"_$E("L",%B'["'") D AST:%B["*",DQ

 I %B["D" S %DT=$P($P(%B3,U,5,99),"%DT=""",2) I %DT]"" S %DT=$P(%DT,"""") D HELP^%DTC ;EXTENDED TYPE LIKE 'YEAR' SHOULDN'T GIVE STANDARD DATE HELP MESSAGE

FLDSET I %B["S" D  ;SET-VALUED PROMPT

 .D SETSCR(%B1,%B2) S A0=$$EZBLD^DIALOG(8068)_" " D MSG

 .I $D(^DD(%B1,%B2,0)),$G(DUZ("LANG"))>1 N %B3 S $P(%B3,U,3)=$$SETIN^DIALOGZ

 .F %C=1:1 S Y=$P($P(%B3,U,3),";",%C) Q:Y=""  D

 ..S %I=$P(Y,":",2),Y=$P(Y,":") I 1 X:$D(DIC("S")) DIC("S") E  Q

 ..I $G(DDS),$G(DDSMOUSY) S DDH=$G(DDH)+1,DDH(DDH,"XT")="W ! D WRITMOUS("""_Y_""") W ""    "" D WRITMOUS("""_%I_""")" Q  ;MOUSE REMEMBERS SET VALUES

 ..S A0=Y_$E("         ",$L(Y)+1,999)_%I D MSG

 I %B["V" S A0="" D MSG S X1=X,DU=%B1,D=%B2,DZ=X D V^DIEQ S X=X1

 Q

 ;

AST F %=" D ^DIC"," D IX^DIC"," D MIX^DIC1" S Y=$F(%B3,%),%=$L(%)+1 Q:Y

 Q:'Y

 I $D(DDS) S A0=" " D MSG

 X $P($E(%B3,1,Y-%),U,5,99)

 Q

 ;

SETSCR(DIRFIL,DIRFLD) ;SET UP DIC("S")

 Q:'$D(^DD(DIRFIL,DIRFLD,12.1))

 X ^(12.1)

 Q:$G(DUZ("LANG"))'>1!'$D(DIC("S"))

 S DIC("S",1.007)=$P(^DD(DIRFIL,DIRFLD,0),U,3),DIC("S",0)=";"_$$SETIN^DIALOGZ,DIC("S",2.007)=DIC("S")

 S DIC("S")="N S,I S S=DIC(""S"",0),I=$L($E(S,1,$F(S,"";""_Y_"":"")),"";"")-1,S=$P($P(DIC(""S"",1.007),"";"",I),"":"") N Y S Y=S X DIC(""S"",2.007)"

 Q

 ;

 ;

DQ N %W K DICQRETV

 S:$D(D)[0 D="B" S (X1,DZ)=X D DQ^DICQ S DDSV=DIC K DD,% S:$D(X1) X=X1

 Q

 ;

QUES ;

 I %T D QU I $D(DICQRETV)!$D(DICQRETA) Q

 I X="??",$D(DIR("??")) D:$P(DIR("??"),U)]"" HF S:$P(DIR("??"),U,2)]"" A0(0)=1,A0=$P(DIR("??"),U,2,99) D:$P(DIR("??"),U,2)]"" MSG Q

 I X="??",%T="D" D  Q

 . N DIHELP,DIJUNK,DILINE,DIROOT

 . D DT^DILF(%DT,"?",.DIJUNK,"","DIROOT")

 . S A0="" D MSG

 . F DILINE=1:1:DIHELP S A0=DIROOT("DIHELP",DILINE) D MSG

 I %T="P" S DIC=%B1,DIC(0)=%B2 S:$D(DIR("S"))#2 DIC("S")=DIR("S") D DQ K DIC("S")

 I '%N S A0="" D MSG

 I X'["?" W $C(7)

 I %N S A0(0)=1,A0=$E(%W,2,999) D MSG

 D:'%N WRAP:%W]"" I %T["S",(%A["A"!(%A["B")) D S

 Q

 ;

WRAP I $D(DIR("?"))=11 F %I=1:1 Q:'$D(DIR("?",%I))  S A0=DIR("?",%I) D MSG

 K %Y S %J=$S($G(IOM,80)>6:$G(IOM,80)-6,IOM>1:IOM,1:2),%Y=1 S X1=$S(($D(DIR("?"))&'%N):DIR("?"),1:%W)

 I '%N,$D(DIR("?"))'=11,$E(X1,$L(X1))'="." S X1=X1_"."

W1 I $L(X1)<%J S %Y(%Y)=X1

 E  D  G W1

 . I $E(X1,1,%J-1)'?.E1P.E S %I=%J-1

 . E  F %I=%J-1:-1:1 Q:$E(X1,%I)?1P

 . S %Y(%Y)=$E(X1,1,%I),X1=$E(X1,%I+1,999),%Y=%Y+1

 F %I=1:1:%Y S A0=%Y(%I) D MSG

 I $D(DDS),%T="S" D

SET . S A0=$$EZBLD^DIALOG(8068) D MSG

 . F %I=1:1 Q:$P(%B,";",%I,999)=""  D

 .. S %Y=$P(%B,";",%I),Y=$P(%Y,":") Q:Y=""

 .. I $D(DIR("S"))#2 X DIR("S") E  Q

 ..I $G(DDS),$G(DDSMOUSY) S DDH=$G(DDH)+1,DDH(DDH,"XT")="D WRITMOUS("""_Y_""") W ""   "" D WRITMOUS("""_$P(%Y,":",2)_""")" Q  ;MOUSE REMEMBERS FORM-ONLY SET VALUE!

 .. S A0=Y_$J("",9-$L(Y))_$P(%Y,":",2) D MSG

 K %Y,%,X1

 Q

HF S XQH=$P(DIR("??"),U) N %A,%B,%E,DIR D EN1^XQH

 Q

MSG ;WRITE OUT 'A0'

 I $D(DDS),A0]"" D

 . S DDH=$G(DDH)+1

 . I $D(A0)>9 S DDH(DDH,"T")="",DDH=DDH+1,DDH(DDH,"X")=A0

 . E  S DDH(DDH,"T")=A0

 I '$D(DDS),$D(A0)>9 W:$X ! X A0

 I '$D(DDS),$D(A0)=1 W !,A0

 K A0

 Q

 ;

 ;

S W:$G(X)'?1."?"!(%A["A") !

 I $D(DIR("L"))#2 D

 . I $D(DIR("L"))=11 F %=0:0 S %=$O(DIR("L",%)) Q:%'>0  W !,DIR("L",%)

 . W !,DIR("L")

 E  I %B'[":",$O(DIR("C",""))]"" D

 . W !?5,$$EZBLD^DIALOG(8046),! ;**

 . S %I="" F  S %I=$O(DIR("C",%I)) Q:%I=""  D

 .. S Y=$P(DIR("C",%I),":")

 .. I $D(DIR("S"))#2 X DIR("S") E  Q

 .. W !?10,Y,?20,$P(DIR("C",%I),":",2)

 E  D

 . W !?5,$$EZBLD^DIALOG(8046),! ;**

 . F %I=1:1 Q:$P(%B,";",%I,999)=""  D

 .. S Y=$P($P(%B,";",%I),":") Q:'$L($P(%B,";",%I,999))

 .. I $D(DIR("S"))#2 X DIR("S") E  Q

 .. W !?10,Y,?20,$P($P(%B,";",%I),":",2)

 W:%A'["A" !

 Q

Q G ^DIRQ

 ;

 ;#8068  Choose from

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DIR   7524     printed  Mar 13, 2025@21:58:37                                                                                                                                                                                                         Page 2

DIR       ;SFISC/XAK - READER, HELP ;3NOV2016

 +1       ;;22.2;VA FileMan;**4,2**;Jan 05, 2016;Build 139

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.

 +4       ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.

 +5       ;;Licensed under the terms of the Apache License, Version 2.0.

 +6       ;;GFT;**30,170,999,1004,1037,1038,1044,1046**

 +7       ;

 +8        NEW %,%A,%B,%B1,%B2,%B3,%BA,%C,%E,%G,%H,%I,%J,%N,%P,%S,%T,%W,%X,%Y,A0,C,D,DD,DDH,DDQ,DDSV,DG,DH,DIC,DIFLD,DIRO,DO,DP,DQ,DU,DZ,X1,XQH,DIX,DIY,DISYS,%BU,%J1,%A0,%W0,%D1,%D2,%DT,%K,%M,DIRCOUNT

 +9        if $DATA(DDH)[0

               SET DDH=0

           if '$DATA(DIR(0))

               QUIT 

           DO ^DIR2

           if %T=""

               GOTO Q

 +10       IF $DATA(DIR("V"))#2

               DO ^DIR1

               SET DDER=%E

               GOTO Q

A         ;RETURN TO THIS LINE AFTER A "?" HELP

           IF $DATA(DDM)

               if DDM

                   KILL DDQ

               if 'DDM

                   SET DDQ=$GET(DDSHBX,IOSL-7)

 +1        IF $GET(DDH)

               DO LIST^DDSU

 +2        if %A'["V"

               DO W

           IF $DATA(DDS)

               IF $DATA(DIR0)

                   SET DDACT=Y

                   IF DDO=.5

                       SET DDM=1

                       GOTO Q

TOOMANY    SET DIRCOUNT=$GET(DIRCOUNT)+1

           IF DIRCOUNT>49

               SET (X,Y)=U

               SET (DUOUT,DIRUT)=1

               GOTO Q

 +1        IF %A'["V"

               IF %E

                   DO QUES

                   SET A0=""

                   DO MSG

                   if $GET(DDH)

                       DO LIST^DDSU

                   GOTO A

 +2        IF $DATA(DTOUT)

               KILL Y

               SET DIRUT=1

               SET Y=""

               GOTO Q

 +3        IF %T'="E"

               IF X?1."^".E

                   KILL Y

                   SET (DUOUT,DIRUT)=1

                   SET Y=X

                   if X="^^"

                       SET DIROUT=1

                   if %T="Y"

                       SET %=-1

                   GOTO Q

 +4        IF %T'="E"

               IF "@"[X

                   IF %A["O"

                       SET Y=""

                       SET DIRUT=1

                       if %T="P"

                           SET Y=-1

                       GOTO Q

 +5       ;IF NOT OPTIONAL, A RESPONSE IS REQUIRED,  SO LOOP!

           IF %A'["O"

               IF "@"[X

                   IF %T'="E"

                       SET A0=$CHAR(7)_%A0

                       DO MSG

                       GOTO A

 +6        IF $DATA(DDS)

               IF $DATA(DIR0)

                   IF DIR0N

                       GOTO Q

 +7        IF $DATA(%G)

               IF $DATA(DIR("B"))

                   IF X=DIR("B")

                       SET Y=%G

                       GOTO Q

X          IF X'?1."?"

               KILL DDQ

               DO ^DIR1

               Begin DoDot:1

 +1                IF $DATA(DICQRETA)

                       SET DIR0N=1

                       SET %E=0

                       SET X=""

                       SET DDACT=DICQRETA

                       KILL DICQRETA

                       QUIT 

 +2       ;^DIR1 will evaluate input

                   IF '%E

                       IF $PIECE(DIR(0),U,3)]""

                           SET %X=X

                           Begin DoDot:2

 +3                            NEW %A,%B,%B1,%B2,%B3,%E,%N,%P,%T,%X,%W,%W0

 +4       ;INPUT TRANSFORM if any

                               XECUTE $PIECE(DIR(0),U,3,99)

                           End DoDot:2

                           if '$DATA(X)

                               SET %E=1

                           SET X=%X

               End DoDot:1

 +5        IF %A["V"

               if %E

                   KILL Y

               GOTO Q

 +6       ;If no error or "?", quit

           IF X'?1."?"

               IF '%E

                   GOTO Q

 +7       ;**170

           if %E'<0&'$GET(DUOUT)&'$GET(DTOUT)

               DO QUES

           SET A0=""

           DO MSG

           if $GET(DDH)

               DO LIST^DDSU

 +8       ;VARIABLES DICQRETV & DICQRETA ARE SET IN DDSU ROUTINE

 +9       ;RETURN VALUE from drop-down list is sent back for evaluation (and echoing)

           IF $DATA(DICQRETV)

               SET (X,DIR0A)=DICQRETV

               SET DDSREPNT=1

               SET DDACT=""

               KILL DICQRETV,DICQRETA

               GOTO X

 +10       IF $DATA(DICQRETA)

               SET DIR0N=1

               SET DDACT=DICQRETA

               KILL DICQRETA

               GOTO Q

 +11       GOTO A

 +12      ;

 +13      ;

 +14      ;

W         ; write the prompt and read the user's response.  Called from A+2 above

 +1        SET %W=%W0

           SET %N=$EXTRACT(%W)=U

SCREEN    ;READ in DIR01 via DIR0

           KILL DTOUT,DUOUT,DIRUT,DIROUT

           SET %E=0

           IF $DATA(DDS)

               IF $DATA(DIR0)

                   DO ^DIR0

                   if '$DATA(DIR("PRE"))

                       QUIT 

                   XECUTE DIR("PRE")

                   if '$DATA(X)

                       SET %E=1

                       SET X=""

                   QUIT 

 +1        IF %T="S"

               IF %A'["A"

                   IF %A'["B"

                       DO S

 +2        IF $DATA(DIR("A"))=11

               FOR %=0:0

                   SET %=$ORDER(DIR("A",%))

                   if %'>0

                       QUIT 

                   WRITE !,DIR("A",%)

 +3        WRITE !

           if $LENGTH(%P)

               WRITE %P

 +4       ;NOV2009: NO REPLACE-WITH FOR POINTERS

           IF $LENGTH($GET(DIR("B")))>19

               IF %A'["r"

                   IF %T'="D"

                       IF %T'="S"

                           IF (%B'["D"&%T)!'%T

                               IF %B'["P"!'$PIECE(%A,",",2)

                                   WRITE DIR("B")

                                   SET Y=DIR("B")

                                   DO RW^DIR2

                                   if X=""

                                       SET X=DIR("B")

                                   QUIT 

DIRB      ;**

           NEW DIRB

           IF $DATA(DIR("B"))

               SET DIRB=DIR("B")

               Begin DoDot:1

 +1       ;YES/NO in FOREIGN LANGUAGE

                   IF %T="Y"

                       IF $GET(DUZ("LANG"))>1

                           IF $GET(%B)]""

                               NEW X

                               SET X=$FIND("YN",$$UP^DILIBF($EXTRACT(DIRB)))

                               if X

                                   SET DIRB=$PIECE($PIECE(%B,";",X-1),":",2)

               End DoDot:1

               WRITE DIRB_"// "

 +2       ;>>>HERE IS THE READER'S 'READ'!<<<

           READ X:$SELECT($DATA(DIR("T")):DIR("T"),'$DATA(DTIME):300,1:DTIME)

           IF '$TEST

               SET DTOUT=1

 +3        IF $DATA(DIR("PRE"))

               XECUTE DIR("PRE")

               IF '$DATA(X)

                   SET %E=1

                   SET X=""

                   QUIT 

 +4        IF X=""

               IF $DATA(DIRB)

                   SET X=DIRB

                   IF %T'="D"

                       IF %B'["D"&%T

                           WRITE X

 +5        IF X'?.ANP

               SET X="?"

 +6        QUIT 

 +7       ;

QU        ;** FIELD HELP FOR A FIELD-TYPE QUESTION

           IF %E!(X="?")!($ORDER(^DD(%B1,%B2,21,0))'>0)

               KILL %Y

               SET A0=""

               DO MSG

               SET X1=$$HELP^DIALOGZ(%B1,%B2)

               Begin DoDot:1

 +1                SET %J=75

                   SET %Y=1

                   DO W1

               End DoDot:1

               IF $DATA(^DD(%B1,%B2,12))

                   SET X1=^(12)

                   Begin DoDot:1

                   End DoDot:1

 +2        NEW DIPB,DIPA

 +3        SET DIPB=$PIECE(^DD(%B1,%B2,0),U,2)

           IF $DATA(^(4))

               SET A0=^(4)

               SET A0(0)=1

               DO MSG

 +4       ;XECUTABLE HELP FOR EXTENDED DATA TYPE

           IF DIPB["t"

               SET A0=$$XHELP^DIETLIBF(%B1,%B2)

               SET A0(0)=1

               DO MSG

               NEW DIPB,%T

               SET (%T,DIPB)="S"

               Begin DoDot:1

 +5                IF DIPB="S"

                       SET $PIECE(%B3,U,3)=$$GETPROP^DIETLIBF(%B1,%B2,"SET OF CODES")

               End DoDot:1

 +6        IF X?1"??".E

               Begin DoDot:1

 +7                IF $DATA(DDS)

                       NEW DDC,DDSQ

                       SET DDC=7

 +8                SET A0=""

                   DO MSG

                   SET %C=0

 +9                FOR 

                       SET %C=$ORDER(^DD(%B1,%B2,21,%C))

                       if '%C!$DATA(DDSQ)

                           QUIT 

                       SET A0=^(%C,0)

                       Begin DoDot:2

 +10                       IF $DATA(DDS)

                               IF $GET(DDH)

                                   IF '(DDH#DDC)

                                       DO LIST^DDSU

                                       if $DATA(DDSQ)

                                           QUIT 

 +11                       DO MSG

                       End DoDot:2

               End DoDot:1

 +12       IF %B["P"

               KILL DO

               SET DIC=U_$PIECE(%B3,U,3)

               SET DIC(0)="M"_$EXTRACT("L",%B'["'")

               if %B["*"

                   DO AST

               DO DQ

 +13      ;EXTENDED TYPE LIKE 'YEAR' SHOULDN'T GIVE STANDARD DATE HELP MESSAGE

           IF %B["D"

               SET %DT=$PIECE($PIECE(%B3,U,5,99),"%DT=""",2)

               IF %DT]""

                   SET %DT=$PIECE(%DT,"""")

                   DO HELP^%DTC

FLDSET    ;SET-VALUED PROMPT

           IF %B["S"

               Begin DoDot:1

 +1                DO SETSCR(%B1,%B2)

                   SET A0=$$EZBLD^DIALOG(8068)_" "

                   DO MSG

 +2                IF $DATA(^DD(%B1,%B2,0))

                       IF $GET(DUZ("LANG"))>1

                           NEW %B3

                           SET $PIECE(%B3,U,3)=$$SETIN^DIALOGZ

 +3                FOR %C=1:1

                       SET Y=$PIECE($PIECE(%B3,U,3),";",%C)

                       if Y=""

                           QUIT 

                       Begin DoDot:2

 +4                        SET %I=$PIECE(Y,":",2)

                           SET Y=$PIECE(Y,":")

                           IF 1

                               if $DATA(DIC("S"))

                                   XECUTE DIC("S")

                              IF '$TEST

                                   QUIT 

 +5       ;MOUSE REMEMBERS SET VALUES

                           IF $GET(DDS)

                               IF $GET(DDSMOUSY)

                                   SET DDH=$GET(DDH)+1

                                   SET DDH(DDH,"XT")="W ! D WRITMOUS("""_Y_""") W ""    "" D WRITMOUS("""_%I_""")"

                                   QUIT 

 +6                        SET A0=Y_$EXTRACT("         ",$LENGTH(Y)+1,999)_%I

                           DO MSG

                       End DoDot:2

               End DoDot:1

 +7        IF %B["V"

               SET A0=""

               DO MSG

               SET X1=X

               SET DU=%B1

               SET D=%B2

               SET DZ=X

               DO V^DIEQ

               SET X=X1

 +8        QUIT 

 +9       ;

AST        FOR %=" D ^DIC"," D IX^DIC"," D MIX^DIC1"

               SET Y=$FIND(%B3,%)

               SET %=$LENGTH(%)+1

               if Y

                   QUIT 

 +1        if 'Y

               QUIT 

 +2        IF $DATA(DDS)

               SET A0=" "

               DO MSG

 +3        XECUTE $PIECE($EXTRACT(%B3,1,Y-%),U,5,99)

 +4        QUIT 

 +5       ;

SETSCR(DIRFIL,DIRFLD) ;SET UP DIC("S")

 +1        if '$DATA(^DD(DIRFIL,DIRFLD,12.1))

               QUIT 

 +2        XECUTE ^(12.1)

 +3        if $GET(DUZ("LANG"))'>1!'$DATA(DIC("S"))

               QUIT 

 +4        SET DIC("S",1.007)=$PIECE(^DD(DIRFIL,DIRFLD,0),U,3)

           SET DIC("S",0)=";"_$$SETIN^DIALOGZ

           SET DIC("S",2.007)=DIC("S")

 +5        SET DIC("S")="N S,I S S=DIC(""S"",0),I=$L($E(S,1,$F(S,"";""_Y_"":"")),"";"")-1,S=$P($P(DIC(""S"",1.007),"";"",I),"":"") N Y S Y=S X DIC(""S"",2.007)"

 +6        QUIT 

 +7       ;

 +8       ;

DQ         NEW %W

           KILL DICQRETV

 +1        if $DATA(D)[0

               SET D="B"

           SET (X1,DZ)=X

           DO DQ^DICQ

           SET DDSV=DIC

           KILL DD,%

           if $DATA(X1)

               SET X=X1

 +2        QUIT 

 +3       ;

QUES      ;

 +1        IF %T

               DO QU

               IF $DATA(DICQRETV)!$DATA(DICQRETA)

                   QUIT 

 +2        IF X="??"

               IF $DATA(DIR("??"))

                   if $PIECE(DIR("??"),U)]""

                       DO HF

                   if $PIECE(DIR("??"),U,2)]""

                       SET A0(0)=1

                       SET A0=$PIECE(DIR("??"),U,2,99)

                   if $PIECE(DIR("??"),U,2)]""

                       DO MSG

                   QUIT 

 +3        IF X="??"

               IF %T="D"

                   Begin DoDot:1

 +4                    NEW DIHELP,DIJUNK,DILINE,DIROOT

 +5                    DO DT^DILF(%DT,"?",.DIJUNK,"","DIROOT")

 +6                    SET A0=""

                       DO MSG

 +7                    FOR DILINE=1:1:DIHELP

                           SET A0=DIROOT("DIHELP",DILINE)

                           DO MSG

                   End DoDot:1

                   QUIT 

 +8        IF %T="P"

               SET DIC=%B1

               SET DIC(0)=%B2

               if $DATA(DIR("S"))#2

                   SET DIC("S")=DIR("S")

               DO DQ

               KILL DIC("S")

 +9        IF '%N

               SET A0=""

               DO MSG

 +10       IF X'["?"

               WRITE $CHAR(7)

 +11       IF %N

               SET A0(0)=1

               SET A0=$EXTRACT(%W,2,999)

               DO MSG

 +12       if '%N

               if %W]""

                   DO WRAP

           IF %T["S"

               IF (%A["A"!(%A["B"))

                   DO S

 +13       QUIT 

 +14      ;