XDRDEDT.m

XDRDEDT ;SF-IRMFO/REM - EDIT STATUS FIELD IN FILE 15 ;10/10/08  13:38

 ;;7.3;TOOLKIT;**23,43,113**;Apr 25, 1995;Build 5

 ;;Per VHA Directive 2004-038, this routine should not be modified.

EN ;;

 N XDRFIL,X,X1,X2,N1,N2,XDRDELET,XDROSTAT

EN2 K DIE,DIC

 S XDRFIL=$$FILE^XDRDPICK() Q:XDRFIL'>0  S XDRGLB=$G(^DIC(XDRFIL,0,"GL")) Q:XDRGLB=""

 F  D  Q:DA'>0

 . S DIC="^VA(15,",DIC(0)="AEQZ",DIC("S")="I $$SCRN^XDRDEDT(+Y,XDRGLB)"

 . S DIC("A")="Select an Entry to "_$S($D(XDRDELET):"DELETE: ",1:"RESET TO POTENTIAL DUPLICATES: ")

 . D ^DIC S DA=+Y Q:DA<0

 . I $P(^VA(15,DA,0),U,4)<2 S X1=+^VA(15,DA,0),X2=+$P(^(0),U,2)

 . E  S X1=+$P(^VA(15,DA,0),U,2),X2=+^(0)

 . S N1=$P(@(XDRGLB_X1_",0)"),U),N2=$P(@(XDRGLB_X2_",0)"),U)

 . S N1=$$PEELNAM(N1),N2=$$PEELNAM(N2)

 . W !!!,"  Duplicate Record File Entry ",DA," for the ",$P(^DIC(XDRFIL,0),U)," FILE"

 . ; XT*7.3*113 changed to call $$GET1^DIQ instead of EN^DIQ

 . S XDROSTAT=$$GET1^DIQ(15,DA_",",.03)

 . W !?10,X1,?20,N1,!?10,X2,?20,N2,!!?10,"Currently listed as ",XDROSTAT,!!

 . S DIR(0)="Y",DIR("A")="Do you really want to "_$S($D(XDRDELET):"DELETE THIS DUPLICATE RECORD ENTRY",1:"RESET to POTENTIAL DUPLICATE"),DIR("B")="NO"

 . D ^DIR Q:Y'>0

 . D NAME(DA)

 . I $D(XDRDELET) D

 . . N DIK

 . . S DIK="^VA(15," D ^DIK

 . I '$D(XDRDELET) D

 . . K DIE S DIE="^VA(15,",DR=".03///P;.04///@;.05///@;.07///@;.08///@;.1///@;.13///@;.14///@;" D ^DIE K DIE

 . . S:$D(DUZ) $P(^VA(15,DA,0),U,12)=DUZ

 . . K ^VA(15,DA,2)

 . . K ^VA(15,DA,3)

 . W !!,"   ",$S($D(XDRDELET):"Entry DELETED!",1:"Status RESET to POTENTIAL DUPLICATE RECORD."),!!,*7

 . ; If PATIENT and previous status was VERIFIED, NOT A DUPLICATE, inactivate entry

 . ; on the MPI DO NOT LINK file 985.28. - (new with XT*7.3*113)

 . I XDROSTAT'="VERIFIED, NOT A DUPLICATE" Q

 . Q:XDRFIL'=2

 . ; Quit if routine ^MPIFDNL is not loaded

 . S X="MPIFDNL" X ^%ZOSF("TEST") Q:'$T

 . S X=^VA(15,DA,0)

 . D CALLRPC^MPIFDNL(DUZ,DUZ(2),+X,+$P(X,U,2),1)

 . Q

 K DA,DR,DIC,DIE

 Q

SCRN(DA,GLOBAL) ;Screen for verified dup. or verified not dup.

 I $P(^(0),U,5)>1 Q 0 ; But don't take merged or merge in progress!

 I '$D(XDRDELET),$P(^(0),U,3)="P"!($P(^(0),U,3)="O") Q 0 ; DON'T NEED TO SET BACK

 I (U_$P($P(^(0),U),";",2))'=GLOBAL Q 0 ; Take only the specified file

 ;I $P(^(0),U,3)="V" Q 1

 ;I $P(^(0),U,3)="N" Q 1

 Q 1

 ;

NAME(DA) ;

 N X,X1,X2,N,N1,N2

 S X=^VA(15,DA,0),X1=+X,X2=+$P(X,U,2),X=$P($P(X,U),";",2)

 S N1=$P($G(@(U_X_X1_",0)")),U)

 S N2=$P($G(@(U_X_X2_",0)")),U)

 S N=$$PEELNAM(N1)

 I N'=N1 S $P(@(U_X_X1_",0)"),U)=N

 S N=$$PEELNAM(N2)

 I N'=N2 S $P(@(U_X_X2_",0)"),U)=N

 Q

PEELNAM(NAME) ;

 F  Q:NAME'["MERGING INTO"  S NAME=$P($P(NAME,"(",2,10),")",1,$L(NAME,")")-1)

 Q NAME

 ;

DELETE ;

 N XDRFIL,X,X1,X2,N1,N2,XDRDELET

 S XDRDELET=1

 D EN2

 Q

 ;

LOOKUP(FILE) ; FIND PAIRS IN DUPLICATE RECORD FILE

 N FILENAM,NAME,NAME1,NAME2,NAMEA,XDRDIC,DIR,Y,I,J,XDR1,IEN,N,X,FILID,IEN1

 S FILENAM=$P(^DIC(FILE,0),U) I FILENAM="" G NOFILE

 S XDRDIC=$G(^DIC(FILE,0,"GL")) I XDRDIC="" G NOFILE

 S XDRDIC=";"_$E(XDRDIC,2,99)

 ;

LOOK1 K DIR S DIR("A")="Select "_FILENAM,DIR(0)="FO^2" D ^DIR K DIR ; GET PART OF A NAME

 I X="" Q -1

 I $D(DIRUT)!(Y="^") Q -1

 ;

 ; GET A LIST OF NAMES IN THE FILE STARTING WITH THE USERS INPUT AND WHICH HAVE AN IEN THAT IS

 ; IN THE DUPLICATE RECORD FILE

 ;

 S NAME=$NA(^TMP($J,"XDRLIST")) K @NAME

 D FIND^DIC(FILE,"","","",X,"","B^BS5^SSN","I $D(^VA(15,""B"",(Y_XDRDIC)))","",NAME)

 ;

 S NAME1=$NA(@NAME@("DILIST"))

 ;

 ; NOW GO THROUGH THE LIST OF MATCHING NAMES AND CHECK FOR THOSE WHICH HAVE THE DESIRED STATUS

 ;    USE THE DATA UNDER THE 2 NODE WHICH IS THE IEN

 ;

 F I=0:0 S I=$O(@NAME1@(2,I)) Q:I'>0  S IEN=^(I) D

 . S XDR1=IEN_XDRDIC

 . F J=0:0 S J=$O(^VA(15,"B",XDR1,J)) Q:J'>0  I $P(^VA(15,J,0),U,3)="P" Q

 . ; IF NOT AT LEAST ONE WITH THE DESIRED STATUS, THEN REMOVE IT FROM THE ARRAY

 . I J'>0 F J=1,2,"ID" K @NAME1@(J,I)

 . Q

 ;

 S J=$O(@NAME1@(2,0)) I J'>0 G NONAME

 ;

 S NAME2=$NA(^TMP($J,"XDRLI1")) K @NAME2

 S N=0 F I=0:0 S I=$O(@NAME1@(1,I)) Q:I'>0  D

 . S N=N+1

 . S X=@NAME1@(1,I)_" [ien="_@NAME1@(2,I)_"]" F J=0:0 S J=$O(@NAME1@("ID",I,J)) Q:J'>0  S FILID(J)="" S X=X_"  "_@NAME1@("ID",I,J)

 . S @NAME2@(N)=X,@NAME2@(N,"IEN")=@NAME1@(2,I)

 S X=$$ASK(NAME2) I X'>0 G NONAME

 I N>1 W @NAME2@(X)

 S IEN1=@NAME2@(X,"IEN")_XDRDIC K @NAME2,@NAME

 S X=$$PAIR(IEN1,"FILID") I X'>0 G NONAME

 Q X

 ;

PAIR(IENDIC,IDARR) ;

 N FILE,IEN,NAME,XDRN,IEN2,XDRX1,XDRJ,XDRX

 S NAME=$NA(^TMP($J,"XDRPAIR")) K @NAME

 S FILE=+$P(@(U_$P(IENDIC,";",2)_"0)"),U,2),XDRN=0

 F IEN=0:0 S IEN=$O(^VA(15,"B",IENDIC,IEN)) Q:IEN'>0  I $P(^VA(15,IEN,0),U,3)="P" D

 . S XDRN=XDRN+1

 . S XDRX=^VA(15,IEN,0)

 . S IEN2=$P(XDRX,U) I IEN2=IENDIC S IEN2=$P(XDRX,U,2)

 . S IEN2=+IEN2,IENS=IEN2_","

 . S XDRX1=$$GET1^DIQ(FILE,IENS,.01)_" [iens="_IEN2_"]"

 . F XDRJ=0:0 S XDRJ=$O(@IDARR@(XDRJ)) Q:XDRJ'>0  S XDRX1=XDRX1_"  "_$$GET1^DIQ(FILE,IENS,XDRJ)

 . S @NAME@(XDRN)=XDRX1,@NAME@(XDRN,"IEN")=IEN

 I XDRN>1 W !!,"This entry is paired with more than one other record.",!,"Select which pair from the following list:",!

 S XDRX=$$ASK(NAME) I XDRX>0 S XDRX=@NAME@(XDRX,"IEN")

 K @NAME

 Q XDRX

 ;

ASK(ARRAY) ;

 N N,I,N1,NCHOICE

 W !

 S N=0 F I=0:0 S I=$O(@ARRAY@(I)) Q:I'>0  S N=N+1

 I N'>1 S I=+$O(@ARRAY@(0)) W:I>0 @ARRAY@(I) Q I

 I N>5 W "There are "_N_" choices.",!!

 S N1=0,NCHOICE=0

 F I=0:0 S I=$O(@ARRAY@(I)) Q:I'>0  S N1=N1+1 W !,N1,".  ",@ARRAY@(I) I '(N1#5) S NCHOICE=$$ASKEM(N1,N) Q:NCHOICE  Q:$D(DIRUT)

 I 'NCHOICE,'$D(DIRUT) S NCHOICE=$$ASKEM(N1,N1)

 Q NCHOICE

 ;

ASKEM(NCUR,NMAX) ;

 N DIR,Y

 W !! I NCUR<NMAX W !,"Choose from 1 to "_NCUR S DIR("A")="Or return to continue: ",DIR(0)="NO^1:"_NCUR

 E  S DIR("A")="Choose from 1 to "_NCUR,DIR(0)="N^1:"_NCUR

 D ^DIR W ! I $D(DIRUT),'$D(DTOUT),'$D(DUOUT) K DIRUT

 Q $S(Y>0:Y,1:0)

 ;

NOFILE ;

 W !,"FILE ",FILE," NOT FOUND",$C(7),!!

 Q -1

 ;

NONAME ;

 W $C(7),"??"

 G LOOK1

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---XDRDEDT   5968     printed  Feb 19, 2025@00:05:28                                                                                                                                                                                                     Page 2

XDRDEDT   ;SF-IRMFO/REM - EDIT STATUS FIELD IN FILE 15 ;10/10/08  13:38

 +1       ;;7.3;TOOLKIT;**23,43,113**;Apr 25, 1995;Build 5

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

EN        ;;

 +1        NEW XDRFIL,X,X1,X2,N1,N2,XDRDELET,XDROSTAT

EN2        KILL DIE,DIC

 +1        SET XDRFIL=$$FILE^XDRDPICK()

           if XDRFIL'>0

               QUIT 

           SET XDRGLB=$GET(^DIC(XDRFIL,0,"GL"))

           if XDRGLB=""

               QUIT 

 +2        FOR 

               Begin DoDot:1

 +3                SET DIC="^VA(15,"

                   SET DIC(0)="AEQZ"

                   SET DIC("S")="I $$SCRN^XDRDEDT(+Y,XDRGLB)"

 +4                SET DIC("A")="Select an Entry to "_$SELECT($DATA(XDRDELET):"DELETE: ",1:"RESET TO POTENTIAL DUPLICATES: ")

 +5                DO ^DIC

                   SET DA=+Y

                   if DA<0

                       QUIT 

 +6                IF $PIECE(^VA(15,DA,0),U,4)<2

                       SET X1=+^VA(15,DA,0)

                       SET X2=+$PIECE(^(0),U,2)

 +7               IF '$TEST

                       SET X1=+$PIECE(^VA(15,DA,0),U,2)

                       SET X2=+^(0)

 +8                SET N1=$PIECE(@(XDRGLB_X1_",0)"),U)

                   SET N2=$PIECE(@(XDRGLB_X2_",0)"),U)

 +9                SET N1=$$PEELNAM(N1)

                   SET N2=$$PEELNAM(N2)

 +10               WRITE !!!,"  Duplicate Record File Entry ",DA," for the ",$PIECE(^DIC(XDRFIL,0),U)," FILE"

 +11      ; XT*7.3*113 changed to call $$GET1^DIQ instead of EN^DIQ

 +12               SET XDROSTAT=$$GET1^DIQ(15,DA_",",.03)

 +13               WRITE !?10,X1,?20,N1,!?10,X2,?20,N2,!!?10,"Currently listed as ",XDROSTAT,!!

 +14               SET DIR(0)="Y"

                   SET DIR("A")="Do you really want to "_$SELECT($DATA(XDRDELET):"DELETE THIS DUPLICATE RECORD ENTRY",1:"RESET to POTENTIAL DUPLICATE")

                   SET DIR("B")="NO"

 +15               DO ^DIR

                   if Y'>0

                       QUIT 

 +16               DO NAME(DA)

 +17               IF $DATA(XDRDELET)

                       Begin DoDot:2

 +18                       NEW DIK

 +19                       SET DIK="^VA(15,"

                           DO ^DIK

                       End DoDot:2

 +20               IF '$DATA(XDRDELET)

                       Begin DoDot:2

 +21                       KILL DIE

                           SET DIE="^VA(15,"

                           SET DR=".03///P;.04///@;.05///@;.07///@;.08///@;.1///@;.13///@;.14///@;"

                           DO ^DIE

                           KILL DIE

 +22                       if $DATA(DUZ)

                               SET $PIECE(^VA(15,DA,0),U,12)=DUZ

 +23                       KILL ^VA(15,DA,2)

 +24                       KILL ^VA(15,DA,3)

                       End DoDot:2

 +25               WRITE !!,"   ",$SELECT($DATA(XDRDELET):"Entry DELETED!",1:"Status RESET to POTENTIAL DUPLICATE RECORD."),!!,*7

 +26      ; If PATIENT and previous status was VERIFIED, NOT A DUPLICATE, inactivate entry

 +27      ; on the MPI DO NOT LINK file 985.28. - (new with XT*7.3*113)

 +28               IF XDROSTAT'="VERIFIED, NOT A DUPLICATE"

                       QUIT 

 +29               if XDRFIL'=2

                       QUIT 

 +30      ; Quit if routine ^MPIFDNL is not loaded

 +31               SET X="MPIFDNL"

                   XECUTE ^%ZOSF("TEST")

                   if '$TEST

                       QUIT 

 +32               SET X=^VA(15,DA,0)

 +33               DO CALLRPC^MPIFDNL(DUZ,DUZ(2),+X,+$PIECE(X,U,2),1)

 +34               QUIT 

               End DoDot:1

               if DA'>0

                   QUIT 

 +35       KILL DA,DR,DIC,DIE

 +36       QUIT 

SCRN(DA,GLOBAL) ;Screen for verified dup. or verified not dup.

 +1       ; But don't take merged or merge in progress!

           IF $PIECE(^(0),U,5)>1

               QUIT 0

 +2       ; DON'T NEED TO SET BACK

           IF '$DATA(XDRDELET)

               IF $PIECE(^(0),U,3)="P"!($PIECE(^(0),U,3)="O")

                   QUIT 0

 +3       ; Take only the specified file

           IF (U_$PIECE($PIECE(^(0),U),";",2))'=GLOBAL

               QUIT 0

 +4       ;I $P(^(0),U,3)="V" Q 1

 +5       ;I $P(^(0),U,3)="N" Q 1

 +6        QUIT 1

 +7       ;

NAME(DA)  ;

 +1        NEW X,X1,X2,N,N1,N2

 +2        SET X=^VA(15,DA,0)

           SET X1=+X

           SET X2=+$PIECE(X,U,2)

           SET X=$PIECE($PIECE(X,U),";",2)

 +3        SET N1=$PIECE($GET(@(U_X_X1_",0)")),U)

 +4        SET N2=$PIECE($GET(@(U_X_X2_",0)")),U)

 +5        SET N=$$PEELNAM(N1)

 +6        IF N'=N1

               SET $PIECE(@(U_X_X1_",0)"),U)=N

 +7        SET N=$$PEELNAM(N2)

 +8        IF N'=N2

               SET $PIECE(@(U_X_X2_",0)"),U)=N

 +9        QUIT 

PEELNAM(NAME) ;

 +1        FOR 

               if NAME'["MERGING INTO"

                   QUIT 

               SET NAME=$PIECE($PIECE(NAME,"(",2,10),")",1,$LENGTH(NAME,")")-1)

 +2        QUIT NAME

 +3       ;

DELETE    ;

 +1        NEW XDRFIL,X,X1,X2,N1,N2,XDRDELET

 +2        SET XDRDELET=1

 +3        DO EN2

 +4        QUIT 

 +5       ;

LOOKUP(FILE) ; FIND PAIRS IN DUPLICATE RECORD FILE

 +1        NEW FILENAM,NAME,NAME1,NAME2,NAMEA,XDRDIC,DIR,Y,I,J,XDR1,IEN,N,X,FILID,IEN1

 +2        SET FILENAM=$PIECE(^DIC(FILE,0),U)

           IF FILENAM=""

               GOTO NOFILE

 +3        SET XDRDIC=$GET(^DIC(FILE,0,"GL"))

           IF XDRDIC=""

               GOTO NOFILE

 +4        SET XDRDIC=";"_$EXTRACT(XDRDIC,2,99)

 +5       ;

LOOK1     ; GET PART OF A NAME

           KILL DIR

           SET DIR("A")="Select "_FILENAM

           SET DIR(0)="FO^2"

           DO ^DIR

           KILL DIR

 +1        IF X=""

               QUIT -1

 +2        IF $DATA(DIRUT)!(Y="^")

               QUIT -1

 +3       ;

 +4       ; GET A LIST OF NAMES IN THE FILE STARTING WITH THE USERS INPUT AND WHICH HAVE AN IEN THAT IS

 +5       ; IN THE DUPLICATE RECORD FILE

 +6       ;

 +7        SET NAME=$NAME(^TMP($JOB,"XDRLIST"))

           KILL @NAME

 +8        DO FIND^DIC(FILE,"","","",X,"","B^BS5^SSN","I $D(^VA(15,""B"",(Y_XDRDIC)))","",NAME)

 +9       ;

 +10       SET NAME1=$NAME(@NAME@("DILIST"))

 +11      ;

 +12      ; NOW GO THROUGH THE LIST OF MATCHING NAMES AND CHECK FOR THOSE WHICH HAVE THE DESIRED STATUS

 +13      ;    USE THE DATA UNDER THE 2 NODE WHICH IS THE IEN

 +14      ;

 +15       FOR I=0:0

               SET I=$ORDER(@NAME1@(2,I))

               if I'>0

                   QUIT 

               SET IEN=^(I)

               Begin DoDot:1

 +16               SET XDR1=IEN_XDRDIC

 +17               FOR J=0:0

                       SET J=$ORDER(^VA(15,"B",XDR1,J))

                       if J'>0

                           QUIT 

                       IF $PIECE(^VA(15,J,0),U,3)="P"

                           QUIT 

 +18      ; IF NOT AT LEAST ONE WITH THE DESIRED STATUS, THEN REMOVE IT FROM THE ARRAY

 +19               IF J'>0

                       FOR J=1,2,"ID"

                           KILL @NAME1@(J,I)

 +20               QUIT 

               End DoDot:1

 +21      ;

 +22       SET J=$ORDER(@NAME1@(2,0))

           IF J'>0

               GOTO NONAME

 +23      ;

 +24       SET NAME2=$NAME(^TMP($JOB,"XDRLI1"))

           KILL @NAME2

 +25       SET N=0

           FOR I=0:0

               SET I=$ORDER(@NAME1@(1,I))

               if I'>0

                   QUIT 

               Begin DoDot:1

 +26               SET N=N+1

 +27               SET X=@NAME1@(1,I)_" [ien="_@NAME1@(2,I)_"]"

                   FOR J=0:0

                       SET J=$ORDER(@NAME1@("ID",I,J))

                       if J'>0

                           QUIT 

                       SET FILID(J)=""

                       SET X=X_"  "_@NAME1@("ID",I,J)

 +28               SET @NAME2@(N)=X

                   SET @NAME2@(N,"IEN")=@NAME1@(2,I)

               End DoDot:1

 +29       SET X=$$ASK(NAME2)

           IF X'>0

               GOTO NONAME

 +30       IF N>1

               WRITE @NAME2@(X)

 +31       SET IEN1=@NAME2@(X,"IEN")_XDRDIC

           KILL @NAME2,@NAME

 +32       SET X=$$PAIR(IEN1,"FILID")

           IF X'>0

               GOTO NONAME

 +33       QUIT X

 +34      ;

PAIR(IENDIC,IDARR) ;

 +1        NEW FILE,IEN,NAME,XDRN,IEN2,XDRX1,XDRJ,XDRX

 +2        SET NAME=$NAME(^TMP($JOB,"XDRPAIR"))

           KILL @NAME

 +3        SET FILE=+$PIECE(@(U_$PIECE(IENDIC,";",2)_"0)"),U,2)

           SET XDRN=0

 +4        FOR IEN=0:0

               SET IEN=$ORDER(^VA(15,"B",IENDIC,IEN))

               if IEN'>0

                   QUIT 

               IF $PIECE(^VA(15,IEN,0),U,3)="P"

                   Begin DoDot:1

 +5                    SET XDRN=XDRN+1

 +6                    SET XDRX=^VA(15,IEN,0)

 +7                    SET IEN2=$PIECE(XDRX,U)

                       IF IEN2=IENDIC

                           SET IEN2=$PIECE(XDRX,U,2)

 +8                    SET IEN2=+IEN2

                       SET IENS=IEN2_","

 +9                    SET XDRX1=$$GET1^DIQ(FILE,IENS,.01)_" [iens="_IEN2_"]"

 +10                   FOR XDRJ=0:0

                           SET XDRJ=$ORDER(@IDARR@(XDRJ))

                           if XDRJ'>0

                               QUIT 

                           SET XDRX1=XDRX1_"  "_$$GET1^DIQ(FILE,IENS,XDRJ)

 +11                   SET @NAME@(XDRN)=XDRX1

                       SET @NAME@(XDRN,"IEN")=IEN

                   End DoDot:1

 +12       IF XDRN>1

               WRITE !!,"This entry is paired with more than one other record.",!,"Select which pair from the following list:",!

 +13       SET XDRX=$$ASK(NAME)

           IF XDRX>0

               SET XDRX=@NAME@(XDRX,"IEN")

 +14       KILL @NAME

 +15       QUIT XDRX

 +16      ;

ASK(ARRAY) ;

 +1        NEW N,I,N1,NCHOICE

 +2        WRITE !

 +3        SET N=0

           FOR I=0:0

               SET I=$ORDER(@ARRAY@(I))

               if I'>0

                   QUIT 

               SET N=N+1

 +4        IF N'>1

               SET I=+$ORDER(@ARRAY@(0))

               if I>0

                   WRITE @ARRAY@(I)

               QUIT I

 +5        IF N>5

               WRITE "There are "_N_" choices.",!!

 +6        SET N1=0

           SET NCHOICE=0

 +7        FOR I=0:0

               SET I=$ORDER(@ARRAY@(I))

               if I'>0

                   QUIT 

               SET N1=N1+1

               WRITE !,N1,".  ",@ARRAY@(I)

               IF '(N1#5)

                   SET NCHOICE=$$ASKEM(N1,N)

                   if NCHOICE

                       QUIT 

                   if $DATA(DIRUT)

                       QUIT 

 +8        IF 'NCHOICE

               IF '$DATA(DIRUT)

                   SET NCHOICE=$$ASKEM(N1,N1)

 +9        QUIT NCHOICE

 +10      ;

ASKEM(NCUR,NMAX) ;

 +1        NEW DIR,Y

 +2        WRITE !!

           IF NCUR<NMAX

               WRITE !,"Choose from 1 to "_NCUR

               SET DIR("A")="Or return to continue: "

               SET DIR(0)="NO^1:"_NCUR

 +3       IF '$TEST

               SET DIR("A")="Choose from 1 to "_NCUR

               SET DIR(0)="N^1:"_NCUR

 +4        DO ^DIR

           WRITE !

           IF $DATA(DIRUT)

               IF '$DATA(DTOUT)

                   IF '$DATA(DUOUT)

                       KILL DIRUT

 +5        QUIT $SELECT(Y>0:Y,1:0)

 +6       ;

NOFILE    ;

 +1        WRITE !,"FILE ",FILE," NOT FOUND",$CHAR(7),!!

 +2        QUIT -1

 +3       ;

NONAME    ;

 +1        WRITE $CHAR(7),"??"

 +2        GOTO LOOK1

 +3       ;