Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: MAGDHOWE

MAGDHOWE.m

Go to the documentation of this file. 
  1. MAGDHOWE ;WOIFO/PMK/JSJ - Clinical Specialty MWL & HL7 Editor ; Apr 27, 2022@11:43:08
  1.  ;;3.0;IMAGING;**138,231,278**;Mar 19, 2002;Build 138
  1.  ;; Per VA Directive 6402, this routine should not be modified.
  1.  ;; +---------------------------------------------------------------+
  1.  ;; | Property of the US Government.                                |
  1.  ;; | No permission to copy or redistribute this software is given. |
  1.  ;; | Use of unreleased versions of this software requires the user |
  1.  ;; | to execute a written test agreement with the VistA Imaging    |
  1.  ;; | Development Office of the Department of Veterans Affairs,     |
  1.  ;; | telephone (301) 734-0100.                                     |
  1.  ;; | The Food and Drug Administration classifies this software as  |
  1.  ;; | a medical device.  As such, it may not be changed in any way. |
  1.  ;; | Modifications to this software may result in an adulterated   |
  1.  ;; | medical device under 21CFR820, the use of which is considered |
  1.  ;; | to be a violation of US Federal Statutes.                     |
  1.  ;; +---------------------------------------------------------------+
  1.  ;;
  1.  ;
  1.  ; Supported IA #2053 reference UPDATE^DIE subroutine call
  1.  ; Supported IA #10013 reference ^DIK subroutine call
  1.  ; Supported IA #2056 reference $$GET1^DIQ function call
  1.  ; Supported IA #2056 reference GETS^DIQ subroutine call
  1.  ; Private IA #7095 to read GMRC PROCEDURE file (#123.3)
  1.  ; Controlled IA #4171 to read REQUEST SERVICES file (#123.5)
  1.  ; Supported IA #10026 reference ^DIR subroutine call
  1.  ;
  1. ENTRY ; entry point from menu
  1.  N CHANGE,CHOICE,CLINIC,CPT,HL7SUBLIST,IEN,IENS,IPROCIDX,ISPECIDX,LOCATION
  1.  N MSG,OPTION,PROCEDURE,PROMPT,SERVICE,QRSCP,X
  1.  N DIERR,IENS,MAGERR,MAGFDA,MAGIENS
  1.  S CHANGE=0 ; use for counting updates
  1.  S (MSG(1),MSG(3))=""
  1.  S MSG(2)="       CLINICAL SPECIALTY DICOM & HL7 file (#2006.5831) Editor"
  1.  W !! D HEADING^MAGDTRDX(.MSG)
  1.  W !!,"Add/Edit a Consult or a Procedure?"
  1.  S OPTION(1)="1:Consult"
  1.  S OPTION(2)="2:Procedure"
  1.  S OPTION(3)="3:Display the existing dictionary"
  1.  S OPTION(4)="4:Quit"
  1.  S PROMPT="Enter an option"
  1.  S X=$$CHOOSE(PROMPT,"",.CHOICE,.OPTION) Q:X<0
  1.  ;
  1.  I CHOICE=4 Q
  1.  D CHOICE G ENTRY
  1.  Q
  1. CHOICE ; option driver
  1.  I CHOICE=3 D WORKLIST^MAGDTRDX W !,"-- End of File --",!! Q
  1.  ;
  1.  I CHOICE=1 D  Q:X<0  ; add a consult (PROCEDURE=0)
  1.  . S X=$$CONSULT(.SERVICE,.PROCEDURE)
  1.  . Q
  1.  E  D  Q:X<0  ; add a procedure within a service
  1.  . S X=$$PROC(.PROCEDURE,.SERVICE)
  1.  . Q
  1.  S IEN=$$IREQUEST^MAGDHOW1(+SERVICE,+PROCEDURE)
  1.  I IEN D  Q
  1.  . W !!,"An entry for the "
  1.  . I PROCEDURE="" W $P(SERVICE,"^",2)," consult"
  1.  . E  D
  1.  . . W $P(PROCEDURE,"^",2)," procedure"
  1.  . . W !,"for the ",$P(SERVICE,"^",2)," service"
  1.  . . Q
  1.  . W !,"is already on file."
  1.  . D UPDATE(IEN)
  1.  . Q
  1.  ;
  1.  S X=$$ISPECIDX(.ISPECIDX) Q:X<0
  1.  S X=$$IPROCIDX(.IPROCIDX) Q:X<0
  1.  S X=$$LOCATION(.LOCATION) Q:X<0
  1.  S X=$$CPT(.CPT) Q:X<0
  1.  S X=$$HL7SUBL(.HL7SUBLIST) Q:X<0
  1.  S X=$$QRSCP(.QRSCP) Q:X<0
  1.  S X=$$CLINIC(.CLINIC) Q:X<0
  1.  ;
  1.  D DISPLAY
  1.  ;
  1.  W !!
  1.  S X=$$YESNO("Create this entry","n",.CHOICE) Q:X<-1
  1.  I CHOICE'="YES" W " -- entry not created" Q
  1.  ;
  1.  ; create the entry
  1.  S IENS="+1,"
  1.  S MAGFDA(2006.5831,IENS,.01)=$P(SERVICE,"^",1)    ; REQUEST SERVICE (-> 123.5)
  1.  S MAGFDA(2006.5831,IENS,2)=$P(PROCEDURE,"^",1)    ; PROCEDURE (-> 123.3)
  1.  S MAGFDA(2006.5831,IENS,3)=$P(ISPECIDX,"^",1)     ; SPECIALTY INDEX (-> 2005.84)
  1.  S MAGFDA(2006.5831,IENS,4)=$P(IPROCIDX,"^",1)     ; PROCEDURE INDEX (-> 2005.85)
  1.  S MAGFDA(2006.5831,IENS,5)=$P(LOCATION,"^",1)     ; LOCATION (-> 4) 
  1.  S MAGFDA(2006.5831,IENS,6)=$P(CPT,"^",1)          ; CPT (-> 81)
  1.  S MAGFDA(2006.5831,IENS,7)=$P(HL7SUBLIST,"^",1)   ; HL7 HL0 SUBSCRIBER LIST (-> 779.4)
  1.  S MAGFDA(2006.5831,IENS,8)=$P(QRSCP,"^",1)        ; Query/Retrieve Provider
  1.  D UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
  1.  I $D(DIERR) W !!,"*** Entry NOT Created ***" Q
  1.  E  W " -- entry created"
  1.  S IEN=MAGIENS(1)
  1.  ; output the CLINIC
  1.  S I=0 F  S I=$O(CLINIC(I)) Q:'I  D
  1.   . N DIERR,MAGERR,MAGFDA,MAGIENS
  1.   . S MAGFDA(2006.58311,"+1,"_IEN_",",.01)=$P(CLINIC(I),"^",1)
  1.   . D UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
  1.   . Q
  1.  ;
  1.  Q
  1.  ;
  1. UPDATE(IEN) ; delete or update the consult or procedure
  1.  N CLINIC,CPT,HL7SUBLIST,I,IPROCIDX,ISPECIDX,LOCATION,PROCEDURE,SERVICE,X
  1.  S X=^MAG(2006.5831,IEN,0)
  1.  S SERVICE=$P(X,"^",1),PROCEDURE=$P(X,"^",2)
  1.  S SERVICE=SERVICE_"^"_$$GET1^DIQ(123.5,SERVICE,.01)
  1.  S PROCEDURE=PROCEDURE_"^"_$$GET1^DIQ(123.3,PROCEDURE,.01)
  1.  S ISPECIDX=$$GETVALUE(2005.84,$P(X,"^",3),".01;3")
  1.  S IPROCIDX=$$GETVALUE(2005.85,$P(X,"^",4),".01;3")
  1.  S LOCATION=$$GETVALUE(4,$P(X,"^",5),".01;99")
  1.  S CPT=$$GETVALUE(81,$P(X,"^",6),".01;2")
  1.  S HL7SUBLIST=$$GETVALUE(779.4,$P(X,"^",7),".01")
  1.  S QRSCP=$P(X,"^",8),QRSCP=QRSCP_"^"_QRSCP ; ien same as name
  1.  S I=0 F  S I=$O(^MAG(2006.5831,IEN,1,I)) Q:'I  D
  1.  . S CLINIC(I)=$$GETVALUE(44,^MAG(2006.5831,IEN,1,I,0),".01")
  1.  . Q
  1.  D DISPLAY
  1.  ;
  1.  S X=$$YESNO("Change this entry","n",.CHOICE) Q:X<-1
  1.  I CHOICE'="YES" W " -- entry not changed" Q
  1.  W !
  1.  S X=$$YESNO("Delete the entire entry","n",.CHOICE) Q:X<-1
  1.  I CHOICE="YES" D  Q  ; delete the entire entry
  1.  . N DA,DIK
  1.  . S DIK="^MAG(2006.5831,",DA=IEN
  1.  . D ^DIK
  1.  . W " -- entry deleted"
  1.  . Q
  1.  W " -- entry not deleted"
  1.  ;
  1.  D UPDATE1 ; update the entry
  1.  Q
  1.  ;
  1. UPDATE1 ; update a the consult or procedure
  1.  N DIERR,IENS,MAGERR,MAGFDA,MAGIENS,X
  1.  ;
  1.  S X=$$ISPECIDX(.ISPECIDX) Q:X<0
  1.  S X=$$IPROCIDX(.IPROCIDX) Q:X<0
  1.  S X=$$LOCATION(.LOCATION) Q:X<0
  1.  S X=$$CPT(.CPT) Q:X<0
  1.  S X=$$HL7SUBL(.HL7SUBLIST) Q:X<0
  1.  S X=$$QRSCP(.QRSCP) Q:X<0
  1.  S X=$$CLINIC(.CLINIC) Q:X<0
  1.  ;
  1.  I CHANGE=0 W !!,"No changes" Q
  1.  ;
  1.  D DISPLAY
  1.  ;
  1.  W !
  1.  S X=$$YESNO("Update this entry","n",.CHOICE) Q:X<-1
  1.  I CHOICE'="YES" W " -- entry not updated" Q
  1.  ;
  1.  ; update the entry
  1.  S IENS=IEN_","
  1.  S MAGFDA(2006.5831,IENS,3)=$P(ISPECIDX,"^",1)     ; SPECIALTY INDEX (-> 2005.84)
  1.  S MAGFDA(2006.5831,IENS,4)=$P(IPROCIDX,"^",1)     ; PROCEDURE INDEX (-> 2005.85)
  1.  S MAGFDA(2006.5831,IENS,5)=$P(LOCATION,"^",1)     ; LOCATION (-> 4) 
  1.  S MAGFDA(2006.5831,IENS,6)=$P(CPT,"^",1)          ; CPT (-> 81)
  1.  S MAGFDA(2006.5831,IENS,7)=$P(HL7SUBLIST,"^",1)   ; HL7 HL0 SUBSCRIBER LIST (-> 779.4)
  1.  S MAGFDA(2006.5831,IENS,8)=$P(QRSCP,"^",1)        ; Query/Retrieve Provider
  1.  D UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
  1.  I $D(DIERR) W !!,"*** Entry NOT Updated ***"
  1.  E  W !!,"Entry Updated"
  1.  ;
  1.  ; update the CLINIC
  1.  S I=0 F  S I=$O(^MAG(2006.5831,IEN,1,I)) Q:'I  D
  1.  . N DIK,DA ; delete the old CLINIC
  1.  . S DA(1)=IEN,DA=I,DIK="^MAG(2006.5831,"_DA(1)_",1," D ^DIK
  1.  . Q
  1.  S I=0 F  S I=$O(CLINIC(I)) Q:'I  D
  1.   . N DIERR,MAGERR,MAGFDA,MAGIENS
  1.   . S MAGFDA(2006.58311,"+1,"_IEN_",",.01)=$P(CLINIC(I),"^",1)
  1.   . D UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
  1.   . Q
  1.  Q
  1.  ;
  1. CONSULT(SERVICE,PROCEDURE) ;
  1.  S PROCEDURE=""
  1.  Q $$LOOKUP(.SERVICE,"Request Service",123.5,".01",1)
  1.  ;
  1. PROC(PROCEDURE,SERVICE) ;
  1.  N A,CHOICE,I,J,OPTION,OPTIONIEN,X
  1.  S X=$$LOOKUP(.PROCEDURE,"Procedure",123.3,".01",1)
  1.  I X<0 Q X  ; lookup failed
  1.  D GETS^DIQ(123.3,+PROCEDURE,"**","EI","A")
  1.  S I="" F J=1:1 S I=$O(A(123.32,I)) Q:I=""  D
  1.  . S OPTION(J)=J_":"_A(123.32,I,.01,"E")
  1.  . S OPTIONIEN(J)=A(123.32,I,.01,"I")
  1.  . Q
  1.  S I=$O(OPTION(""))
  1.  I I="" D  Q -1
  1.  . W !,"No RELATED SERVICE on file"
  1.  I $O(OPTION(I))="" D
  1.  . S SERVICE=OPTIONIEN(I)_"^"_$P(OPTION(I),":",2)
  1.  . W !,"Request Service: ",$P(OPTION(I),":",2)
  1.  . Q
  1.  E  D
  1.  . S PROMPT="Select the Request Service from the list"
  1.  . S X=$$CHOOSE(PROMPT,"",.CHOICE,.OPTION) Q:X<0
  1.  . S SERVICE=OPTIONIEN(CHOICE)_"^"_$P(OPTION(CHOICE),":",2)
  1.  . Q
  1.  Q X
  1.  ;
  1. ISPECIDX(ISPECIDX) ;
  1.  Q $$LOOKUP(.ISPECIDX,"Imaging Specialty Index",2005.84,".01;3",1)
  1.  ;
  1. IPROCIDX(IPROCIDX) ;
  1.  Q $$LOOKUP(.IPROCIDX,"Imaging Procedure Index",2005.85,".01;3",0)
  1.  ;
  1. LOCATION(LOCATION) ;
  1.  Q $$LOOKUP(.LOCATION,"Acquisition Institution",4,"99;.01",1)
  1.  ;
  1. HL7SUBL(HL7SUBLIST) ;
  1.  Q $$LOOKUP(.HL7SUBLIST,"HL7 (Optimized) Subscription List",779.4,".01",0)
  1.  ;
  1. QRSCP(QRSCP) ;
  1.  Q $$LOOKUP(.QRSCP,"Query/Retrieve Provider",2006.587,,0)
  1.  ;
  1. CPT(CPT) ;
  1.  I $G(CPT)="",+PROCEDURE D  ; lookup CPT in Medicine Package
  1.  . N A,MCAR6972 ; PROCEDURE/SUBSPECIALTY file (#697.2)
  1.  . S MCAR6972=$$GET1^DIQ(123.3,+PROCEDURE,.05,"I")
  1.  . I MCAR6972 D
  1.  . . D GETS^DIQ(697.2,MCAR6972,"**","I","A")
  1.  . . Q:'$D(A(697.21,"1,2,",.01,"I"))  ; no CPT code
  1.  . . S CPT=A(697.21,"1,2,",.01,"I") ; get first CPT code
  1.  . . S CPT=CPT_"^"_$$GET1^DIQ(81,+CPT,.01) ; CPT code
  1.  . . S CPT=CPT_"^"_$$GET1^DIQ(81,+CPT,2) ; CPT name
  1.  . . Q
  1.  . Q
  1.  Q $$LOOKUP(.CPT,"CPT Code",81,".01;2",0)
  1.  ;
  1. CLINIC(CLINIC) ;
  1.  N DONE,I,J,TMP,X
  1.  S J=0
  1.  W !
  1.  I $D(CLINIC) D
  1.  . S I=0 F  S I=$O(CLINIC(I)) Q:'I  D
  1.  . . S DONE=0 F  D  Q:DONE
  1.  . . . W !,"Clinic: ",$$P(CLINIC(I))," ",$TR($J("",40-$X)," ","-")," Remove this clinic? n// "
  1.  . . . R X:DTIME E  S X="^"
  1.  . . . I X["^" S DONE=-1,I=99999 Q 
  1.  . . . I X="" S X="NO" W X
  1.  . . . I "YyNn"'[$E(X) W !,"Enter YES to keep the clinic or NO to remove it." Q
  1.  . . . I "Yy"[$E(X) W " -- removed" S CHANGE=CHANGE+1
  1.  . . . E  S J=J+1,TMP(CLINIC(I))=""
  1.  . . . S DONE=1
  1.  . . . Q
  1.  . . Q
  1.  . W !
  1.  . Q
  1.  F I=J+1:1 D  Q:X<1
  1.  . N NEWCLINIC
  1.  . S X=$$LOOKUP(.NEWCLINIC,"Clinic #"_I,44,".01",0) Q:X<1
  1.  . I $D(TMP(NEWCLINIC)) W " -- already there" S I=I-1 Q
  1.  . S TMP(NEWCLINIC)="",CHANGE=CHANGE+1
  1.  . Q
  1.  K CLINIC ; remove any duplicates
  1.  S (I,J)=0 F  S I=$O(TMP(I)) Q:'I  S J=J+1,CLINIC(J)=I
  1.  Q 1
  1.  ;
  1. LOOKUP(ITEM,NAME,FILE,FIELDS,REQUIRED) ; lookup entry
  1.  N A,DIR,DONE,I,RETURN,TMP,X,Y,DTOUT  ;P278 JSJ add TMP
  1.  ;
  1.  S DONE=0
  1.  ;
  1.  I $D(ITEM) D  Q:DONE DONE
  1.  . W !!,NAME,": ",$$P(ITEM)
  1.  . S X=$$YESNO("Change this value","n",.CHOICE) Q:X<-1
  1.  . I CHOICE'="YES" S DONE=1 Q
  1.  . S CHANGE=CHANGE+1
  1.  . Q
  1.  ;
  1.  I FILE=2006.587 D  Q RETURN ; special code for Query/Retrieve Provider
  1.  . N DEFAULT
  1.  . S DEFAULT=$P($G(ITEM),"^",2)
  1.  . I DEFAULT'="" D
  1.  . . S X=$$YESNO("Delete the Query/Retrieve Provider","n",.CHOICE) Q:X<-1
  1.  . . I CHOICE="YES" S ITEM="",RETURN=1,DONE=1
  1.  . . Q
  1.  . E  D
  1.  . . S X=$$YESNO("Specify a Query/Retrieve Provider","n",.CHOICE) Q:X<-1
  1.  . . I CHOICE'="YES" S ITEM="",RETURN=1,DONE=1
  1.  . . Q
  1.  . I DONE Q  ; don't want a Query/Retrieve Provider
  1.  . W !
  1.  . S ITEM=$$PICKSCP^MAGDSTQ9(DEFAULT,"Q/R")
  1.  . I ITEM="" S RETURN=-1 Q
  1.  . S ITEM=ITEM_"^"_ITEM,RETURN=1
  1.  . Q
  1.  ;
  1.  S DIR("A")="Enter the "_NAME ; prompt
  1.  S DIR("B")=$P($G(ITEM),"^",2) I DIR("B")="" K DIR("B") ; default
  1.  S $P(DIR(0),"^",1)=$S(REQUIRED:"P",1:"PO")
  1.  S $P(DIR(0),"^",2)=FILE_":EMZ"
  1.  I FILE="2005.85" D BLDPXLST   ;P278 - for procedure list, only display/allow procedures linked to the selected specialty
  1.  D ^DIR
  1.  I $G(DTOUT) Q -1  ;P278 JSJ handle timeout to prevent passing through required field
  1.  I Y="^" Q -1
  1.  I Y="^^" Q -2
  1.  I Y=-1 S ITEM="" Q 0
  1.  I FILE="2005.85",Y]"" S Y=$G(TMP(Y),-999)  ;P278 JSJ
  1.  S ITEM=$$GETVALUE(FILE,+Y,FIELDS)
  1.  Q 1
  1.  ;
  1. GETVALUE(FILE,IEN,FIELDS) ;
  1.  N I,VALUE
  1.  S VALUE=IEN
  1.  F I=1:1:$L(FIELDS,";") D
  1.  . S VALUE=VALUE_"^"_$$GET1^DIQ(FILE,IEN,$P(FIELDS,";",I))
  1.  . Q
  1.  Q VALUE
  1.  ;
  1. BLDPXLST ;build alpha sorted procedure list filtered by specialty ;P278 added sub
  1.  NEW J,LLIST,NAME
  1.  S $P(DIR(0),"^",1)=$S(REQUIRED:"SA",1:"SAO")  ;change to 'set of codes'
  1.  S DIR("A")=DIR("A")_": "  ;keep colon at end of prompt
  1.  K DIR("L"),TMP
  1.  S DIR("L")=""
  1.  S NAME="",J=0
  1.  S LLIST=""
  1.  F  S NAME=$O(^MAG(2005.85,"B",NAME)) Q:NAME=""  D
  1.  . N NONE,ND0,OK,SPEC,FOUND S FOUND=0,OK="",SPEC=0
  1.  . Q:'$G(ISPECIDX)
  1.  . S SPEC=+ISPECIDX D SPEC^MAGSIXGT
  1.  . S IEN=$O(^MAG(2005.85,"B",NAME,""),-1) Q:'IEN
  1.  . I $O(^MAG(2005.85,IEN,1,"B",""))="" S FOUND=2
  1.  . I 'FOUND N SPECX S (FOUND,SPECX)=0 D  Q:'FOUND
  1.  .. F  S SPECX=$O(OK(3,SPECX)) Q:'SPECX!FOUND  I $D(^MAG(2005.85,IEN,1,"B",SPECX)) S FOUND=1
  1.  . Q:'FOUND
  1.  . S ND0=$G(^MAG(2005.85,IEN,0)) Q:$P(ND0,"^",3)="I"
  1.  . S J=J+1
  1.  . S DIR("L",J)="   "_J_" "_NAME
  1.  . S $P(LLIST,";",J)=J_":"_NAME
  1.  . S TMP(J)=IEN
  1.  S $P(DIR(0),"^",2)=LLIST
  1.  Q
  1.  ;
  1. DISPLAY ; Display data
  1.  N I,X
  1.  W !
  1.  W !,"        Request Service = ",$$P(SERVICE)
  1.  W !,"              Procedure = ",$$P(PROCEDURE)
  1.  W !,"        Specialty Index = ",$$P(ISPECIDX)
  1.  W !,"        Procedure Index = ",$$P(IPROCIDX)
  1.  W !,"               Worklist = ",$P(ISPECIDX,"^",3)
  1.  I IPROCIDX W "/",$P(IPROCIDX,"^",3)
  1.  W " (",$P(ISPECIDX,"^",2)
  1.  I IPROCIDX W "/",$P(IPROCIDX,"^",2)
  1.  W ")"
  1.  W !,"            Acquired at = ",$$P(LOCATION)
  1.  W !,"               CPT Code = ",$$P(CPT)
  1.  W !,"    HL7 Subscriber List = ",$$P(HL7SUBLIST)
  1.  W !,"Query/Retrieve Provider = ",$$P(QRSCP)
  1.  S I=0 F  S I=$O(CLINIC(I)) Q:'I  D
  1.  . W !,"                 Clinic = ",$$P(CLINIC(I))
  1.  . Q
  1.  W !
  1.  ; output Associated Stop Code(s) if any
  1.  D GETS^DIQ(123.5,+SERVICE,"**","E","X")
  1.  I $D(X(123.5688)) D
  1.  . S I="" F  S I=$O(X(123.5688,I)) Q:I=""  D
  1.  . . W !,"Associated Stop Code = ",X(123.5688,I,.01,"E")
  1.  . . Q
  1.  . Q
  1.  E  D
  1.  . W !,"Warning: No Associated Stop Codes are defined for this Request Service."
  1.  . W !,"         Use CONSULT ASSOCIATED STOP CODE menu option to define them."
  1.  W !
  1.  Q
  1.  ;
  1. P(X) ;
  1.  N Z
  1.  S Z=$P(X,"^",2)
  1.  I $P(X,"^",3)'="" S Z=Z_" -- "_$P(X,"^",3)
  1.  Q Z
  1.  ;
  1. YESNO(PROMPT,DEFAULT,CHOICE) ; generic YES/NO question driver
  1.  N DIR,DIRUT,DIROUT,X,Y
  1.  S DIR(0)="Y" S DIR("A")=PROMPT M DIR("A")=PROMPT
  1.  I $G(DEFAULT)'="" S DIR("B")=DEFAULT
  1.  D ^DIR
  1.  I $D(DIROUT) Q -2
  1.  I $D(DIRUT) Q -1
  1.  S CHOICE=Y(0)
  1.  Q 1
  1.  ;
  1. CHOOSE(PROMPT,DEFAULT,CHOICE,OPTION) ; generic question driver
  1.  N DIR,DIRUT,DIROUT,I,X,Y
  1.  S DIR(0)="S^",I=0
  1.  F  S I=$O(OPTION(I)) Q:'I  D
  1.  . S DIR(0)=DIR(0)_$S(I>1:";",1:"")_OPTION(I)
  1.  . Q
  1.  S DIR("A")=PROMPT
  1.  I $G(DEFAULT)'="" S DIR("B")=DEFAULT
  1.  D ^DIR
  1.  I $D(DIROUT) Q -2
  1.  I $D(DIRUT) Q -1
  1.  S CHOICE=Y
  1.  Q 1