TIULA1.m

TIULA1 ; SLC/JER - More interactive functions ;04-Jun-2012 16:19;DU

 ;;1.0;TEXT INTEGRATION UTILITIES;**75,113,1009,207,1010**;Jun 20, 1997;Build 24

 ;IHS/MSC/MGH Changes made to correspond with IHS division setup

TRAVERSE(DA,RETURN,PARM,TYPE) ; Select Document Type(s)

 N C,I,XQORM,Y N:'$D(LEVEL) LEVEL S LEVEL=+$G(LEVEL)+1

 S:$G(TYPE)']"" TYPE="D"

 S XQORM=DA_";TIU(8925.1,",XQORM(0)=$S($L($G(PARM)):PARM,1:"AD")

 I XQORM(0)["D" S XQORM("H")="W !!,$$CENTER^TIULS(""--- ""_$P(^TIU(8925.1,+DA,0),U,3)_"" ---""),!"

 S XQORM("B")=$G(^DISV(DUZ,"XQORM",DA_";TIU(8925.1,",1))

 S XQORM("A")="Select "_$S(XQORM(0)["D":"Document",1:$P(^TIU(8925.1,+DA,0),U,3))_$S("CD"[$P(^TIU(8925.1,+DA,0),U,4):" Component",1:" Type")_$S(+XQORM(0)'=1:"(s)",1:"")_": "

 D EN^XQORM

 M RETURN(LEVEL)=Y

 S I=0 F  S I=$O(Y(I)) Q:+I'>0  D

 . S J=+$P(Y(I),U,2)

 . I $P(^TIU(8925.1,+J,0),U,4)'=TYPE,$D(^TIU(8925.1,+J,10))'<10 D TRAVERSE(+J,.RETURN,$G(PARM))

 Q

ASKSIG() ; Prompt for ES, return encrypted data

 N ESNAME,ESTITLE,Y S Y=0

 D SIG^XUSESIG I X1']"" S:'$D(X) X=0 D BADSIG^TIULG(X) G ASKX

 S ESNAME=$P($G(^VA(200,DUZ,20)),U,2),ESTITLE=$P($G(^(20)),U,3)

 S Y=1_U_ESNAME_U_ESTITLE

ASKX Q Y

ASKSUBJ() ; Handle query by subject

 N Y

 S Y=$$READ^TIUU("FO","Where SUBJECT CONTAINS")

 Q $$UPPER^TIULS(Y)

ASKLOC() ; Handle query by location

 N Y

 S Y=$$READ^TIUU("P^44:AEMQ","Select HOSPITAL LOCATION")

 Q Y

TYPMATCH(TYPE,CURTYP) ; Check for type match

 N TIUI,TIUY S TIUY=0

 I $L(TYPE,"!")=1,TYPE=CURTYP S TIUY=1

 E  F TIUI=1:1:$L(TYPE,"!") I $P(TYPE,"!",TIUI)=CURTYP S TIUY=1 Q

 Q TIUY

DOCLIST(CLASS,Y,PARM,DFLT) ; Get preferred documents for user

 N TIUDA,XQORM,X

 S TIUDA=+$O(^TIU(8925.98,"AC",DUZ,CLASS,0)),XQORM=TIUDA_";TIU(8925.98,"

 I +TIUDA'>0!(+$O(^XUTL("XQORM",XQORM,0))'>0) S Y=-1 Q

 I $G(DFLT)="LAST" D

 . S DFLT=$O(^DISV(DUZ,"XQORM",XQORM,0))

 . S DFLT=$S(+DFLT:$G(^DISV(DUZ,"XQORM",XQORM,DFLT)),1:"")

 S XQORM(0)=$S(+$P($G(^TIU(8925.98,+TIUDA,10,0)),U,3)=1:"F",1:PARM)

 S XQORM("B")=$S(+$P($G(^TIU(8925.98,+TIUDA,10,0)),U,3)=1:$P($G(^(0)),U,3),1:DFLT)

 I XQORM(0)'["A" S X=XQORM("B")

 S XQORM("A")=$S(CLASS=3:"",1:"Select ")_$S(CLASS=3:"TITLE",1:"Document")_$S(+XQORM(0)'=1:"(s)",1:"")_": "

 I XQORM(0)["D" D

 . N LISTNAME,PERSNAME S LISTNAME=$$PNAME^TIULC1(CLASS)

 . I $E(LISTNAME,$L(LISTNAME))="Y" D

 . . S LISTNAME=$E(LISTNAME,1,($L(LISTNAME)-1))_"IES"

 . I $E(LISTNAME,$L(LISTNAME))="y" D

 . . S LISTNAME=$E(LISTNAME,1,($L(LISTNAME)-1))_"ies"

 . S PERSNAME=$$PERSNAME^TIULC1(DUZ)

 . S LISTNAME=""""_"--- "_LISTNAME_" for "_PERSNAME_" ---"_""""

 . S XQORM("H")="W !!,$$CENTER^TIULS("_LISTNAME_"),!"

 S XQORM("S")="I $$CANPICK^TIULP(+$G(^TIU(8925.98,+DA(1),10,+DA,0)))"

 D EN^XQORM

 Q

SELCAT(Y,PARM,DFLT,TIUOVER) ; Get preferred documents for user

 N TIUI,TIUDA,CATREC,CATLOOK,CATSCRN,CATVAL,XQORM,X ;P75 newed CATVAL

 N TIUT1,TIUT2,TIUTSTR,TIUHOLD

 S TIUI=0

 S XQORM="1;TIU(8925.8,"

 I $G(DFLT)="LAST" D

 . S DFLT=$O(^DISV(DUZ,"XQORM",XQORM,0))

 . S DFLT=$S(+DFLT:$G(^DISV(DUZ,"XQORM",XQORM,DFLT)),1:"")

 S XQORM(0)=$G(PARM,"1A")

 S XQORM("B")=$G(DFLT,"AUTHOR")

 I +$G(ORVP) S XQORM("S")="I $G(^XUTL(""XQORM"",XQORM,+$O(^XUTL(""XQORM"",XQORM,""B"",DA,0)),0))'[""Patient"""

 I XQORM(0)'["A" S X=XQORM("B")

 S XQORM("A")="Select SEARCH CATEGOR"_$S(+XQORM(0)'=1:"IES",1:"Y")_": "

 I XQORM(0)["D" S XQORM("H")="W !!,$$CENTER^TIULS(""--- Search Categories ---""),!"

 D EN^XQORM

 ; BEGIN TIU207

 ; FLAG IF TITLE OR ALL CATEGORIES WERE SELECTED. NEEDED IN HDR^TIURH AS ^TMP("TIUR","TIU OVERRIDE")

 S TIUT1="",TIUTSTR=""

 F  S TIUT1=$O(Y(TIUT1)) Q:TIUT1=""  D

 .I $P(Y(TIUT1),"^",3)="Title" S TIUTSTR=TIUTSTR_"TITLE"

 .I $P(Y(TIUT1),"^",3)="All Categories" S TIUTSTR=TIUTSTR_"ALL"

 I TIUTSTR["TITLE" S TIUOVER=TIUTSTR

 ; IF SPECIFIC CATEGORY AND ALL CATEGORIES WHERE SELECTED THEN REMOVE ALL CATEGORIES.

 I $O(Y(""),-1)>1,TIUTSTR["ALL" D

 .M TIUHOLD=Y K Y

 .S TIUT1="",TIUT2=1

 .F  S TIUT1=$O(TIUHOLD(TIUT1)) Q:TIUT1=""  D

 ..I $P(TIUHOLD(TIUT1),"^",3)="All Categories" Q

 ..S Y(TIUT2)=TIUHOLD(TIUT1)

 ..S Y=TIUT2

 ..S TIUT2=TIUT2+1

 ; END TIU207

 F  S TIUI=$O(Y(TIUI)) Q:+TIUI'>0  D

 . S TIUDA=+$P(Y(TIUI),U,2)

 . S CATREC=$G(^TIU(8925.8,TIUDA,0))

 . S CATSCRN=$G(^TIU(8925.8,TIUDA,1))

 . S CATLOOK=$G(^TIU(8925.8,TIUDA,2))

 . S CATVAL=-1 ;P75

 . I CATLOOK']"",+$P(CATREC,U,4) S CATVAL=$$DICLOOK(CATREC,CATSCRN)

 . I CATLOOK]"" S CATVAL=$$LOOK(CATLOOK)

 . I +CATVAL'=-1,$L(CATVAL) S Y(TIUI)=$P(CATREC,U,2)_U_CATVAL

 . E  K Y(TIUI) S Y=+$G(Y)-1

 Q

DICLOOK(CATEGORY,SCREEN) ; Call ^DIC to get category value

 N DIC,X,Y

 S DIC=+$P(CATEGORY,U,4),DIC(0)="AEMQZ"

 S DIC("A")="Select "_$P(CATEGORY,U)_": "

 I SCREEN]"" X SCREEN

 D ^DIC I +$G(DUOUT),(X="^^") S DIROUT=1

 Q Y

LOOK(LOOKUP) ; Execute LOOKUP CODE

 N X,Y

 X LOOKUP

 Q Y

GETVSIT(DFN) ; Visit selection code

 N X,Y

 I +$G(ORVP),'+$G(DFN) S DFN=+$G(ORVP)

 D MAIN^TIUVISIT(.Y,$G(DFN))

 S Y=$G(Y("VISIT"))

 I +Y,+$P(Y,U,2) S $P(Y,U,2)=$$DATE^TIULS($P(Y,U,2),"MM/DD/YY HR:MIN")

 Q Y

GETTERM(X) ; Get Lexicon term

 N DIC,USEX,Y

 S DIC=757.01,DIC(0)="AEMQZ",DIC("A")="Select PROBLEM: "

 D ^DIC

 I +Y'>0,(X]""),(X'=" "),(X'["^") D

 . S USEX=$$READ^TIUU("Y",">>>  Use "_X,"Yes")

 . I +USEX S Y=1_U_X

 Q Y

GETDIV() ; Get Institution Number and Name

 N TIUDIV,TIUSTN,Y

 ;IHS/MSC/MGH Division changes to be in line with IHS

 ;S TIUDIV=$S($P($G(^DG(43,1,"GL")),U,2):$$MULTDIV,1:$$PRIM^VASITE)

 D DIVGET^XUSRB2(.IHSDIV,DUZ)

 I IHSDIV(2)>1 S TIUDIV=$$MULTDIV

 E  S TIUDIV=$$PRIM^VASITE

 S TIUSTN=$$SITE^VASITE(,TIUDIV)

 ; end of IHS mod

 S TIUSTN=$$SITE^VASITE(,TIUDIV)

 I $P(TIUSTN,U)>0,($P(TIUSTN,U,2)]"") D

 . S Y=$P(TIUSTN,U)_U_$P(TIUSTN,U,2)

 E  D

 . S Y=-1

 Q Y

MULTDIV() ; User selects from active divisions

 N DIR,X,Y

 S DIR(0)="PA^40.8:EM"

 S DIR("A")="Select DIVISION: "

 S DIR("S")="I $$SITE^VASITE(,+Y)>0"

 D ^DIR

 Q +Y

TIULA1    ; SLC/JER - More interactive functions ;04-Jun-2012 16:19;DU

 +1       ;;1.0;TEXT INTEGRATION UTILITIES;**75,113,1009,207,1010**;Jun 20, 1997;Build 24

 +2       ;IHS/MSC/MGH Changes made to correspond with IHS division setup

TRAVERSE(DA,RETURN,PARM,TYPE) ; Select Document Type(s)

 +1        NEW C,I,XQORM,Y

           IF '$DATA(LEVEL)

               NEW LEVEL

           SET LEVEL=+$GET(LEVEL)+1

 +2        IF $GET(TYPE)']""

               SET TYPE="D"

 +3        SET XQORM=DA_";TIU(8925.1,"

           SET XQORM(0)=$SELECT($LENGTH($GET(PARM)):PARM,1:"AD")

 +4        IF XQORM(0)["D"

               SET XQORM("H")="W !!,$$CENTER^TIULS(""--- ""_$P(^TIU(8925.1,+DA,0),U,3)_"" ---""),!"

 +5        SET XQORM("B")=$GET(^DISV(DUZ,"XQORM",DA_";TIU(8925.1,",1))

 +6        SET XQORM("A")="Select "_$SELECT(XQORM(0)["D":"Document",1:$PIECE(^TIU(8925.1,+DA,0),U,3))_$SELECT("CD"[$PIECE(^TIU(8925.1,+DA,0),U,4):" Component",1:" Type")_$SELECT(+XQORM(0)'=1:"(s)",1:"")_": "

 +7        DO EN^XQORM

 +8        MERGE RETURN(LEVEL)=Y

 +9        SET I=0

           FOR 

               SET I=$ORDER(Y(I))

               IF +I'>0

                   QUIT 

               Begin DoDot:1

 +10               SET J=+$PIECE(Y(I),U,2)

 +11               IF $PIECE(^TIU(8925.1,+J,0),U,4)'=TYPE

                       IF $DATA(^TIU(8925.1,+J,10))'<10

                           DO TRAVERSE(+J,.RETURN,$GET(PARM))

               End DoDot:1

 +12       QUIT 

ASKSIG()  ; Prompt for ES, return encrypted data

 +1        NEW ESNAME,ESTITLE,Y

           SET Y=0

 +2        DO SIG^XUSESIG

           IF X1']""

               IF '$DATA(X)

                   SET X=0

               DO BADSIG^TIULG(X)

               GOTO ASKX

 +3        SET ESNAME=$PIECE($GET(^VA(200,DUZ,20)),U,2)

           SET ESTITLE=$PIECE($GET(^(20)),U,3)

 +4        SET Y=1_U_ESNAME_U_ESTITLE

ASKX       QUIT Y

ASKSUBJ() ; Handle query by subject

 +1        NEW Y

 +2        SET Y=$$READ^TIUU("FO","Where SUBJECT CONTAINS")

 +3        QUIT $$UPPER^TIULS(Y)

ASKLOC()  ; Handle query by location

 +1        NEW Y

 +2        SET Y=$$READ^TIUU("P^44:AEMQ","Select HOSPITAL LOCATION")

 +3        QUIT Y

TYPMATCH(TYPE,CURTYP) ; Check for type match

 +1        NEW TIUI,TIUY

           SET TIUY=0

 +2        IF $LENGTH(TYPE,"!")=1

               IF TYPE=CURTYP

                   SET TIUY=1

 +3       IF '$TEST

               FOR TIUI=1:1:$LENGTH(TYPE,"!")

                   IF $PIECE(TYPE,"!",TIUI)=CURTYP

                       SET TIUY=1

                       QUIT 

 +4        QUIT TIUY

DOCLIST(CLASS,Y,PARM,DFLT) ; Get preferred documents for user

 +1        NEW TIUDA,XQORM,X

 +2        SET TIUDA=+$ORDER(^TIU(8925.98,"AC",DUZ,CLASS,0))

           SET XQORM=TIUDA_";TIU(8925.98,"

 +3        IF +TIUDA'>0!(+$ORDER(^XUTL("XQORM",XQORM,0))'>0)

               SET Y=-1

               QUIT 

 +4        IF $GET(DFLT)="LAST"

               Begin DoDot:1

 +5                SET DFLT=$ORDER(^DISV(DUZ,"XQORM",XQORM,0))

 +6                SET DFLT=$SELECT(+DFLT:$GET(^DISV(DUZ,"XQORM",XQORM,DFLT)),1:"")

               End DoDot:1

 +7        SET XQORM(0)=$SELECT(+$PIECE($GET(^TIU(8925.98,+TIUDA,10,0)),U,3)=1:"F",1:PARM)

 +8        SET XQORM("B")=$SELECT(+$PIECE($GET(^TIU(8925.98,+TIUDA,10,0)),U,3)=1:$PIECE($GET(^(0)),U,3),1:DFLT)

 +9        IF XQORM(0)'["A"

               SET X=XQORM("B")

 +10       SET XQORM("A")=$SELECT(CLASS=3:"",1:"Select ")_$SELECT(CLASS=3:"TITLE",1:"Document")_$SELECT(+XQORM(0)'=1:"(s)",1:"")_": "

 +11       IF XQORM(0)["D"

               Begin DoDot:1

 +12               NEW LISTNAME,PERSNAME

                   SET LISTNAME=$$PNAME^TIULC1(CLASS)

 +13               IF $EXTRACT(LISTNAME,$LENGTH(LISTNAME))="Y"

                       Begin DoDot:2

 +14                       SET LISTNAME=$EXTRACT(LISTNAME,1,($LENGTH(LISTNAME)-1))_"IES"

                       End DoDot:2

 +15               IF $EXTRACT(LISTNAME,$LENGTH(LISTNAME))="y"

                       Begin DoDot:2

 +16                       SET LISTNAME=$EXTRACT(LISTNAME,1,($LENGTH(LISTNAME)-1))_"ies"

                       End DoDot:2

 +17               SET PERSNAME=$$PERSNAME^TIULC1(DUZ)

 +18               SET LISTNAME=""""_"--- "_LISTNAME_" for "_PERSNAME_" ---"_""""

 +19               SET XQORM("H")="W !!,$$CENTER^TIULS("_LISTNAME_"),!"

               End DoDot:1

 +20       SET XQORM("S")="I $$CANPICK^TIULP(+$G(^TIU(8925.98,+DA(1),10,+DA,0)))"

 +21       DO EN^XQORM

 +22       QUIT 

SELCAT(Y,PARM,DFLT,TIUOVER) ; Get preferred documents for user

 +1       ;P75 newed CATVAL

           NEW TIUI,TIUDA,CATREC,CATLOOK,CATSCRN,CATVAL,XQORM,X

 +2        NEW TIUT1,TIUT2,TIUTSTR,TIUHOLD

 +3        SET TIUI=0

 +4        SET XQORM="1;TIU(8925.8,"

 +5        IF $GET(DFLT)="LAST"

               Begin DoDot:1

 +6                SET DFLT=$ORDER(^DISV(DUZ,"XQORM",XQORM,0))

 +7                SET DFLT=$SELECT(+DFLT:$GET(^DISV(DUZ,"XQORM",XQORM,DFLT)),1:"")

               End DoDot:1

 +8        SET XQORM(0)=$GET(PARM,"1A")

 +9        SET XQORM("B")=$GET(DFLT,"AUTHOR")

 +10       IF +$GET(ORVP)

               SET XQORM("S")="I $G(^XUTL(""XQORM"",XQORM,+$O(^XUTL(""XQORM"",XQORM,""B"",DA,0)),0))'[""Patient"""

 +11       IF XQORM(0)'["A"

               SET X=XQORM("B")

 +12       SET XQORM("A")="Select SEARCH CATEGOR"_$SELECT(+XQORM(0)'=1:"IES",1:"Y")_": "

 +13       IF XQORM(0)["D"

               SET XQORM("H")="W !!,$$CENTER^TIULS(""--- Search Categories ---""),!"

 +14       DO EN^XQORM

 +15      ; BEGIN TIU207

 +16      ; FLAG IF TITLE OR ALL CATEGORIES WERE SELECTED. NEEDED IN HDR^TIURH AS ^TMP("TIUR","TIU OVERRIDE")

 +17       SET TIUT1=""

           SET TIUTSTR=""

 +18       FOR 

               SET TIUT1=$ORDER(Y(TIUT1))

               IF TIUT1=""

                   QUIT 

               Begin DoDot:1

 +19               IF $PIECE(Y(TIUT1),"^",3)="Title"

                       SET TIUTSTR=TIUTSTR_"TITLE"

 +20               IF $PIECE(Y(TIUT1),"^",3)="All Categories"

                       SET TIUTSTR=TIUTSTR_"ALL"

               End DoDot:1

 +21       IF TIUTSTR["TITLE"

               SET TIUOVER=TIUTSTR

 +22      ; IF SPECIFIC CATEGORY AND ALL CATEGORIES WHERE SELECTED THEN REMOVE ALL CATEGORIES.

 +23       IF $ORDER(Y(""),-1)>1

               IF TIUTSTR["ALL"

                   Begin DoDot:1

 +24                   MERGE TIUHOLD=Y

                       KILL Y

 +25                   SET TIUT1=""

                       SET TIUT2=1

 +26                   FOR 

                           SET TIUT1=$ORDER(TIUHOLD(TIUT1))

                           IF TIUT1=""

                               QUIT 

                           Begin DoDot:2

 +27                           IF $PIECE(TIUHOLD(TIUT1),"^",3)="All Categories"

                                   QUIT 

 +28                           SET Y(TIUT2)=TIUHOLD(TIUT1)

 +29                           SET Y=TIUT2

 +30                           SET TIUT2=TIUT2+1

                           End DoDot:2

                   End DoDot:1

 +31      ; END TIU207

 +32       FOR 

               SET TIUI=$ORDER(Y(TIUI))

               IF +TIUI'>0

                   QUIT 

               Begin DoDot:1

 +33               SET TIUDA=+$PIECE(Y(TIUI),U,2)

 +34               SET CATREC=$GET(^TIU(8925.8,TIUDA,0))

 +35               SET CATSCRN=$GET(^TIU(8925.8,TIUDA,1))

 +36               SET CATLOOK=$GET(^TIU(8925.8,TIUDA,2))

 +37      ;P75

                   SET CATVAL=-1

 +38               IF CATLOOK']""

                       IF +$PIECE(CATREC,U,4)

                           SET CATVAL=$$DICLOOK(CATREC,CATSCRN)

 +39               IF CATLOOK]""

                       SET CATVAL=$$LOOK(CATLOOK)

 +40               IF +CATVAL'=-1

                       IF $LENGTH(CATVAL)

                           SET Y(TIUI)=$PIECE(CATREC,U,2)_U_CATVAL

 +41              IF '$TEST

                       KILL Y(TIUI)

                       SET Y=+$GET(Y)-1

               End DoDot:1

 +42       QUIT 

DICLOOK(CATEGORY,SCREEN) ; Call ^DIC to get category value

 +1        NEW DIC,X,Y

 +2        SET DIC=+$PIECE(CATEGORY,U,4)

           SET DIC(0)="AEMQZ"

 +3        SET DIC("A")="Select "_$PIECE(CATEGORY,U)_": "

 +4        IF SCREEN]""

               XECUTE SCREEN

 +5        DO ^DIC

           IF +$GET(DUOUT)

               IF (X="^^")

                   SET DIROUT=1

 +6        QUIT Y

LOOK(LOOKUP) ; Execute LOOKUP CODE

 +1        NEW X,Y

 +2        XECUTE LOOKUP

 +3        QUIT Y

GETVSIT(DFN) ; Visit selection code

 +1        NEW X,Y

 +2        IF +$GET(ORVP)

               IF '+$GET(DFN)

                   SET DFN=+$GET(ORVP)

 +3        DO MAIN^TIUVISIT(.Y,$GET(DFN))

 +4        SET Y=$GET(Y("VISIT"))

 +5        IF +Y

               IF +$PIECE(Y,U,2)

                   SET $PIECE(Y,U,2)=$$DATE^TIULS($PIECE(Y,U,2),"MM/DD/YY HR:MIN")

 +6        QUIT Y

GETTERM(X) ; Get Lexicon term

 +1        NEW DIC,USEX,Y

 +2        SET DIC=757.01

           SET DIC(0)="AEMQZ"

           SET DIC("A")="Select PROBLEM: "

 +3        DO ^DIC

 +4        IF +Y'>0

               IF (X]"")

                   IF (X'=" ")

                       IF (X'["^")

                           Begin DoDot:1

 +5                            SET USEX=$$READ^TIUU("Y",">>>  Use "_X,"Yes")

 +6                            IF +USEX

                                   SET Y=1_U_X

                           End DoDot:1

 +7        QUIT Y

GETDIV()  ; Get Institution Number and Name

 +1        NEW TIUDIV,TIUSTN,Y

 +2       ;IHS/MSC/MGH Division changes to be in line with IHS

 +3       ;S TIUDIV=$S($P($G(^DG(43,1,"GL")),U,2):$$MULTDIV,1:$$PRIM^VASITE)

 +4        DO DIVGET^XUSRB2(.IHSDIV,DUZ)

 +5        IF IHSDIV(2)>1

               SET TIUDIV=$$MULTDIV

 +6       IF '$TEST

               SET TIUDIV=$$PRIM^VASITE

 +7        SET TIUSTN=$$SITE^VASITE(,TIUDIV)

 +8       ; end of IHS mod

 +9        SET TIUSTN=$$SITE^VASITE(,TIUDIV)

 +10       IF $PIECE(TIUSTN,U)>0

               IF ($PIECE(TIUSTN,U,2)]"")

                   Begin DoDot:1

 +11                   SET Y=$PIECE(TIUSTN,U)_U_$PIECE(TIUSTN,U,2)

                   End DoDot:1

 +12      IF '$TEST

               Begin DoDot:1

 +13               SET Y=-1

               End DoDot:1

 +14       QUIT Y

MULTDIV() ; User selects from active divisions

 +1        NEW DIR,X,Y

 +2        SET DIR(0)="PA^40.8:EM"

 +3        SET DIR("A")="Select DIVISION: "

 +4        SET DIR("S")="I $$SITE^VASITE(,+Y)>0"

 +5        DO ^DIR

 +6        QUIT +Y