ORCMEDT4 ;SLC/MKB-Prompt Editor ;21-Nov-2013 15:18;PLS
;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,95,245,1013**;Dec 17, 1997;Build 2
; Modified - IHS/MSC/PLS - 11/21/2013 - Line DISABLE+2
EN ; -- Enter/edit prompts
N PRMT F S PRMT=+$$PROMPT Q:PRMT'>0 D W !
. I $P($G(^ORD(101.41,PRMT,0)),U,7)=$O(^DIC(9.4,"C","OR",0)) D Q
. . N DIC,DA S DIC="^ORD(101.41,",DA=PRMT D EN^DIQ
. . W !,"This prompt is not editable!"
. D EDIT(PRMT)
Q
;
EDIT(DA) ; -- Edit prompt DA
N DR,DIE,NAME,TEXT,TYPE,DOMAIN,OR0,OR1,ORP
Q:'$G(DA) S OR0=$G(^ORD(101.41,DA,0)),OR1=$G(^(1)),ORP=DA
S NAME=$$NAME(DA) Q:(NAME="@")!(NAME="^") ;deleted or quit
S TEXT=$$DTEXT($P(OR0,U,2)) Q:TEXT="^"
S TYPE=$$DATATYPE($P(OR1,U)) Q:TYPE="^" S DOMAIN=$P(OR1,U,2)
D @$S(TYPE="D"!(TYPE="R"):"DATE",TYPE="F":"TEXT",TYPE="N":"NMBR",TYPE="P":"PTR",TYPE="S":"SET",1:"OTHER") Q:DOMAIN="^"
S $P(^ORD(101.41,DA,1),U,1,2)=TYPE_U_DOMAIN,DIE="^ORD(101.41,"
S DR=$S(NAME'=$P(OR0,U):".01///^S X=NAME;",1:"")_$S(TEXT'=$P(OR0,U,2):"2///^S X=TEXT;",1:"")_"20"_";13" D ^DIE ;95
Q
;
PROMPT() ; -- Find prompt in #101.41
N X,Y,DIC,DLAYGO
S DIC="^ORD(101.41,",DIC(0)="AEQLM",DLAYGO=101.41
S DIC("A")="Select PROMPT: ",DIC("S")="I $P(^(0),U,4)=""P"""
S DIC("DR")="4////P" D ^DIC
Q Y
;
NAME(IFN) ; -- Edit .01 name of dialog IFN
N X,Y,DIR,OLDNAME,ISPQO,NODELETE,DA,DIK,TYPE
S DIR(0)="FAO^3:63",DIR("A")="NAME: "
S OLDNAME=$P($G(^ORD(101.41,IFN,0)),U),ISPQO=0,NODELETE=1
S TYPE=$P($G(^ORD(101.41,IFN,0)),U,4)
I TYPE="Q",$E(OLDNAME,1,6)="ORWDQ " S ISPQO=1
I ISPQO!(TYPE="P") S NODELETE=0 ; OK to delete personal quick orders and prompts
S DIR("B")=OLDNAME
S DIR("?")="Enter a unique name, up to 63 characters in length."
NM I $L($P($G(^ORD(101.41,IFN,0)),U,3))>0 W !,!,"(This "_$$GETITM(IFN)_" has been disabled)"
D ^DIR S:$D(DTOUT)!(X["^") Y="^"
I X="@" D G NM:X=""
. I $D(^ORD(101.41,"AD",IFN)) W $C(7),!,"Cannot delete - currently in use!",! S X="" Q
. I $$INUSE^ORCMEDT5(IFN) W $C(7),!,"Cannot delete - currently an Add Orders Menu!",! S X="" Q
. I NODELETE D DISABLE(IFN) S X="" Q
. I '$$SURE(IFN) S X="" Q ;reask
. N IDX1,IDX2 S IDX1=0
. F S IDX1=$O(^ORD(101.44,"C",IFN,IDX1)) Q:'IDX1 D
. . S IDX2=0
. . F S IDX2=$O(^ORD(101.44,"C",IFN,IDX1,IDX2)) Q:'IDX2 D
. . . S DA=IDX2,DA(1)=IDX1,DIK="^ORD(101.44,"_IDX1_",10," D ^DIK
. K DA S DA=IFN,DIK="^ORD(101.41," D ^DIK W " ...deleted." S (X,Y)="@"
I ISPQO,Y'="^",X'="@",Y'=OLDNAME D G NM
. W $C(7),!,"Cannot rename a personal quick order",!
Q Y
;
GETITM(DLG) ;
N ITM
S ITM=$P($G(^ORD(101.41,DLG,0)),U,4)
I ITM="Q",$E($P($G(^ORD(101.41,IFN,0)),U),1,6)="ORWDQ " Q "personal quick order"
S ITM=$S(ITM="P":"prompt",ITM="D":"dialog",ITM="Q":"quick order",ITM="O":"order set",ITM="A":"action",ITM="M":"menu",1:"item")
Q ITM
;
SURE(DLG) ; -- Are you sure?
N X,Y,DIR,ITM,DA
S ITM=$$GETITM(DLG)
S DIR(0)="YA",DIR("A")="Are you sure you want to delete this "_ITM_"? "
S DIR("?")="Enter YES if you want to delete this "_ITM_" from the file, or NO to quit."
D ^DIR
Q +Y
;
DISABLE(DLG) ; Disable item - return true if disabled
N DIR,X,Y,ITM,DA,DR,DIE,DIDEL,DISABLED
;IHS/MSC/PLS - 11/21/2013
;W $C(7),!,!,"Deletion not allowed outside of FileMan."
W $C(7),!,!,"Deletion not allowed, please inactivate."
S ITM=$$GETITM(DLG)
S DISABLED=$L($P($G(^ORD(101.41,IFN,0)),U,3))>0
S DIR(0)="YA"
I DISABLED D I 1
. S DIR("A",1)="This "_ITM_" is already disabled."
. S DIR("A")="Would you like to edit the disable message? "
. S DIR("?")="Enter YES if you want to edit the disabled message, or NO to quit."
. S DIR("B")="NO"
E D
. S DIR("A")="Would you like to disable this "_ITM_"? "
. S DIR("?")="Enter YES if you want to disable this "_ITM_", or NO to quit."
. S DIR("B")="YES"
D ^DIR
I '+Y Q
W !,"Enter disable message:"
S DA=DLG,DR="3",DIE="^ORD(101.41,"
D ^DIE
Q
;
DTEXT(X) ; -- Enter/edit display text of prompt
N Y,DIR
S DIR(0)="FA^3:63",DIR("A")="TEXT OF PROMPT: " S:$L($G(X)) DIR("B")=X
S DIR("?")="Enter the text of this prompt, including any punctuation and spaces"
D ^DIR S:$D(DTOUT) Y="^"
Q Y
;
DATATYPE(X) ; -- Returns desired datatype for prompt
N DIR,Y S DIR("A")="TYPE OF PROMPT: "
S DIR(0)="SAM^D:date/time;R:relative date/time;F:free text;N:numeric;S:set of codes;P:pointer to a file;Y:yes/no;W:word processing;"
S:$L($G(X)) DIR("B")=$P($P(DIR(0),X_":",2),";")
S DIR("?")="Select the type of data to be entered at this prompt"
D ^DIR S:$D(DTOUT) Y="^"
Q Y
;
DATE ; -- date parameters
N X,Y,DIR,ORX,ORT,ORS,ORR
S X=$P(DOMAIN,":",3),ORX=X["X",ORT=X["T",ORS=X["S",ORR=X["R",DIR(0)="YA"
; Still need to handle Earliest and Latest dates allowed
S DIR("A")="CAN DATE BE IMPRECISE? ",DIR("B")=$S(ORX:"NO",1:"YES")
D ^DIR S ORX='Y I $D(DUOUT)!($D(DTOUT)) S DOMAIN="^" Q
S DIR("A")="CAN TIME OF DAY BE ENTERED? ",DIR("B")=$S(ORT:"YES",1:"NO")
D ^DIR I $D(DUOUT)!($D(DTOUT)) S DOMAIN="^" Q
S ORT=Y I 'Y S (ORS,ORR)=0 G DQ
S DIR("A")="CAN SECONDS BE ENTERED? ",DIR("B")=$S(ORS:"YES",1:"NO")
D ^DIR S ORS=Y I $D(DUOUT)!($D(DTOUT)) S DOMAIN="^" Q
S DIR("A")="IS TIME REQUIRED? ",DIR("B")=$S(ORR:"YES",1:"NO")
D ^DIR S ORR=Y I $D(DUOUT)!($D(DTOUT)) S DOMAIN="^" Q
DQ S DOMAIN="::E"_$S(ORX:"X",1:"")_$S(ORT:"T",1:"")_$S(ORS:"S",1:"")_$S(ORR:"R",1:"")
Q
;
TEXT ; -- free text
N X,Y,DIR
S DIR(0)="NAO^1:245",DIR("A")="MINIMUM LENGTH: "
S:+DOMAIN DIR("B")=+DOMAIN
D ^DIR I $D(DTOUT)!($D(DUOUT)) S DOMAIN="^" Q
S $P(DOMAIN,":")=Y,DIR("A")="MAXIMUM LENGTH: " K DIR("B")
S:$P(DOMAIN,":",2) DIR("B")=$P(DOMAIN,":",2)
D ^DIR I $D(DUOUT)!($D(DTOUT)) S DOMAIN="^" Q
S $P(DOMAIN,":",2)=Y
; Opt pattern match ??
Q
;
NMBR ; -- numeric
N X,Y,DIR,STR
S DIR(0)="NAO^::"_+$P(DOMAIN,":",3),DIR("A")="INCLUSIVE LOWER BOUND: ",DIR("B")=+DOMAIN ;95
D ^DIR I $D(DTOUT)!($D(DUOUT)) S DOMAIN="^" Q
S STR=Y,DIR(0)="NAO^"_Y_"::"_+$P(DOMAIN,":",3),DIR("A")="INCLUSIVE UPPER BOUND: ",DIR("B")=+$P(DOMAIN,":",2) ;95
D ^DIR I $D(DTOUT)!($D(DUOUT)) S DOMAIN="^" Q
S STR=STR_":"_Y,DIR(0)="NAO",DIR("A")="MAXIMUM NUMBER OF FRACTIONAL DIGITS: ",DIR("B")=+$P(DOMAIN,":",3) ;95
D ^DIR I $D(DUOUT)!($D(DTOUT)) S DOMAIN="^" Q
S DOMAIN=STR_":"_Y
Q
;
PTR ; -- pointer
I DUZ(0)="@"!($L(DOMAIN)&'DOMAIN) D ROOT Q ; allow file root
N X,Y,DIR,DIE,DR,FILE,STR,SCR
S DIR(0)="PA^1:AEQM",DIR("A")="POINT TO WHICH FILE: "
S:$L(DOMAIN) DIR("B")=$$FILENAME(+DOMAIN)
D ^DIR I $D(DUOUT)!($D(DTOUT)) S DOMAIN="^" Q
S FILE=+Y,STR=$P(DOMAIN,":",2) S:'$L(STR) STR="EQ"
S DOMAIN=FILE_":"_STR
Q
;
ROOT ; -- pointer via file root
N X,Y,DIR,STR
S DIR(0)="FA^1:100",DIR("A")="POINT TO WHICH FILE: "
S DIR("?")="Enter the file or subfile by name, file number, or global root (without the leading '^')."
S:$L(DOMAIN) DIR("B")=$S(+DOMAIN:$$FILENAME(+DOMAIN),1:$P(DOMAIN,":"))
RT1 D ^DIR I $D(DTOUT)!$D(DUOUT) S DOMAIN="^" Q
I $L(DOMAIN),$L(X),X=$G(DIR("B")) S Y=$P(DOMAIN,":") G RTQ ; default
I +Y=Y S X=$$FILENAME(+Y) I $L(X) W " "_X G RTQ ; valid file number
I $L(Y),+Y'=Y D G:$D(Y) RTQ ; valid root or name
. I "(,"[$E(Y,$L(Y)) Q:$D(@(U_Y_"0)")) ; valid file root
. S DIC=1,DIC(0)="EQ",X=Y D ^DIC S:Y>0 Y=+Y K:Y'>0 Y
W $C(7),!,"Invalid file!" G RT1
RTQ S STR=$P(DOMAIN,":",2),DOMAIN=Y_":"_$S($L(STR):STR,1:"EQ")
Q
;
SET ; -- set of codes
N I,ORI,ORJ,ITEM,X,Y,ORQUIT,NEWLNG S ORJ=0
F I=1:1:$L(DOMAIN,";") S:$P(DOMAIN,";",I)'="" ITEM(I)=$P(DOMAIN,";",I)
S ORI=0 F S ORI=$O(ITEM(ORI)) Q:ORI'>0 D SETEDIT Q:$G(ORQUIT)!(Y="")
I $G(ORQUIT) S DOMAIN="^" Q
S ORI=ORJ F S ORI=ORI+1 D SETEDIT Q:$G(ORQUIT)!(Y="") ; new codes
I $G(ORQUIT) S DOMAIN="^" Q
; now done editing, rebuild DOMAIN
S I=0,DOMAIN="" F S I=$O(ITEM(I)) Q:I'>0 S NEWLNG=$L(DOMAIN)+$L(ITEM(I))+1 S:NEWLNG'>235 DOMAIN=DOMAIN_ITEM(I)_";" I NEWLNG>235 W $C(7),!,"Domain too long - unable to store all codes." H 2 Q
Q
SETEDIT ; -- edit each item in DOMAIN
N DIR,TEXT,CODE S DIR(0)="FAO^1:5",DIR("A")="INTERNALLY-STORED CODE: "
S CODE=$P($G(ITEM(ORI)),":"),TEXT=$P($G(ITEM(ORI)),":",2),ORJ=ORI
S:$L(CODE) DIR("B")=CODE
D ^DIR S:$D(DUOUT)!($D(DTOUT)) ORQUIT=1 Q:$G(ORQUIT)!(X="")
I X="@" K ITEM(ORI) Q
S CODE=X W " WILL STAND FOR: " W:$L(TEXT) TEXT_"// "
SE1 R Y:DTIME I '$T!(Y["^") S ORQUIT=1 Q
S:Y="" Y=TEXT I "@"[Y W $C(7),!," Required value!",!,"'"_CODE_"' WILL STAND FOR: " W:$L(TEXT) TEXT_"// " G SE1
S TEXT=Y,ITEM(ORI)=CODE_":"_TEXT
Q
;
OTHER ; -- no parameters needed
S DOMAIN=""
Q
;
FILENAME(FNUM) ; -- Returns name of file FNUM
N ORY,Y D:$G(FNUM) FILE^DID(+FNUM,,"NAME","ORY")
S Y=$G(ORY("NAME"))
Q Y
ORCMEDT4 ;SLC/MKB-Prompt Editor ;21-Nov-2013 15:18;PLS
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,95,245,1013**;Dec 17, 1997;Build 2
+2 ; Modified - IHS/MSC/PLS - 11/21/2013 - Line DISABLE+2
EN ; -- Enter/edit prompts
+1 NEW PRMT
FOR
SET PRMT=+$$PROMPT
IF PRMT'>0
QUIT
Begin DoDot:1
+2 IF $PIECE($GET(^ORD(101.41,PRMT,0)),U,7)=$ORDER(^DIC(9.4,"C","OR",0))
Begin DoDot:2
+3 NEW DIC,DA
SET DIC="^ORD(101.41,"
SET DA=PRMT
DO EN^DIQ
+4 WRITE !,"This prompt is not editable!"
End DoDot:2
QUIT
+5 DO EDIT(PRMT)
End DoDot:1
WRITE !
+6 QUIT
+7 ;
EDIT(DA) ; -- Edit prompt DA
+1 NEW DR,DIE,NAME,TEXT,TYPE,DOMAIN,OR0,OR1,ORP
+2 IF '$GET(DA)
QUIT
SET OR0=$GET(^ORD(101.41,DA,0))
SET OR1=$GET(^(1))
SET ORP=DA
+3 ;deleted or quit
SET NAME=$$NAME(DA)
IF (NAME="@")!(NAME="^")
QUIT
+4 SET TEXT=$$DTEXT($PIECE(OR0,U,2))
IF TEXT="^"
QUIT
+5 SET TYPE=$$DATATYPE($PIECE(OR1,U))
IF TYPE="^"
QUIT
SET DOMAIN=$PIECE(OR1,U,2)
+6 DO @$SELECT(TYPE="D"!(TYPE="R"):"DATE",TYPE="F":"TEXT",TYPE="N":"NMBR",TYPE="P":"PTR",TYPE="S":"SET",1:"OTHER")
IF DOMAIN="^"
QUIT
+7 SET $PIECE(^ORD(101.41,DA,1),U,1,2)=TYPE_U_DOMAIN
SET DIE="^ORD(101.41,"
+8 ;95
SET DR=$SELECT(NAME'=$PIECE(OR0,U):".01///^S X=NAME;",1:"")_$SELECT(TEXT'=$PIECE(OR0,U,2):"2///^S X=TEXT;",1:"")_"20"_";13"
DO ^DIE
+9 QUIT
+10 ;
PROMPT() ; -- Find prompt in #101.41
+1 NEW X,Y,DIC,DLAYGO
+2 SET DIC="^ORD(101.41,"
SET DIC(0)="AEQLM"
SET DLAYGO=101.41
+3 SET DIC("A")="Select PROMPT: "
SET DIC("S")="I $P(^(0),U,4)=""P"""
+4 SET DIC("DR")="4////P"
DO ^DIC
+5 QUIT Y
+6 ;
NAME(IFN) ; -- Edit .01 name of dialog IFN
+1 NEW X,Y,DIR,OLDNAME,ISPQO,NODELETE,DA,DIK,TYPE
+2 SET DIR(0)="FAO^3:63"
SET DIR("A")="NAME: "
+3 SET OLDNAME=$PIECE($GET(^ORD(101.41,IFN,0)),U)
SET ISPQO=0
SET NODELETE=1
+4 SET TYPE=$PIECE($GET(^ORD(101.41,IFN,0)),U,4)
+5 IF TYPE="Q"
IF $EXTRACT(OLDNAME,1,6)="ORWDQ "
SET ISPQO=1
+6 ; OK to delete personal quick orders and prompts
IF ISPQO!(TYPE="P")
SET NODELETE=0
+7 SET DIR("B")=OLDNAME
+8 SET DIR("?")="Enter a unique name, up to 63 characters in length."
NM IF $LENGTH($PIECE($GET(^ORD(101.41,IFN,0)),U,3))>0
WRITE !,!,"(This "_$$GETITM(IFN)_" has been disabled)"
+1 DO ^DIR
IF $DATA(DTOUT)!(X["^")
SET Y="^"
+2 IF X="@"
Begin DoDot:1
+3 IF $DATA(^ORD(101.41,"AD",IFN))
WRITE $CHAR(7),!,"Cannot delete - currently in use!",!
SET X=""
QUIT
+4 IF $$INUSE^ORCMEDT5(IFN)
WRITE $CHAR(7),!,"Cannot delete - currently an Add Orders Menu!",!
SET X=""
QUIT
+5 IF NODELETE
DO DISABLE(IFN)
SET X=""
QUIT
+6 ;reask
IF '$$SURE(IFN)
SET X=""
QUIT
+7 NEW IDX1,IDX2
SET IDX1=0
+8 FOR
SET IDX1=$ORDER(^ORD(101.44,"C",IFN,IDX1))
IF 'IDX1
QUIT
Begin DoDot:2
+9 SET IDX2=0
+10 FOR
SET IDX2=$ORDER(^ORD(101.44,"C",IFN,IDX1,IDX2))
IF 'IDX2
QUIT
Begin DoDot:3
+11 SET DA=IDX2
SET DA(1)=IDX1
SET DIK="^ORD(101.44,"_IDX1_",10,"
DO ^DIK
End DoDot:3
End DoDot:2
+12 KILL DA
SET DA=IFN
SET DIK="^ORD(101.41,"
DO ^DIK
WRITE " ...deleted."
SET (X,Y)="@"
End DoDot:1
IF X=""
GOTO NM
+13 IF ISPQO
IF Y'="^"
IF X'="@"
IF Y'=OLDNAME
Begin DoDot:1
+14 WRITE $CHAR(7),!,"Cannot rename a personal quick order",!
End DoDot:1
GOTO NM
+15 QUIT Y
+16 ;
GETITM(DLG) ;
+1 NEW ITM
+2 SET ITM=$PIECE($GET(^ORD(101.41,DLG,0)),U,4)
+3 IF ITM="Q"
IF $EXTRACT($PIECE($GET(^ORD(101.41,IFN,0)),U),1,6)="ORWDQ "
QUIT "personal quick order"
+4 SET ITM=$SELECT(ITM="P":"prompt",ITM="D":"dialog",ITM="Q":"quick order",ITM="O":"order set",ITM="A":"action",ITM="M":"menu",1:"item")
+5 QUIT ITM
+6 ;
SURE(DLG) ; -- Are you sure?
+1 NEW X,Y,DIR,ITM,DA
+2 SET ITM=$$GETITM(DLG)
+3 SET DIR(0)="YA"
SET DIR("A")="Are you sure you want to delete this "_ITM_"? "
+4 SET DIR("?")="Enter YES if you want to delete this "_ITM_" from the file, or NO to quit."
+5 DO ^DIR
+6 QUIT +Y
+7 ;
DISABLE(DLG) ; Disable item - return true if disabled
+1 NEW DIR,X,Y,ITM,DA,DR,DIE,DIDEL,DISABLED
+2 ;IHS/MSC/PLS - 11/21/2013
+3 ;W $C(7),!,!,"Deletion not allowed outside of FileMan."
+4 WRITE $CHAR(7),!,!,"Deletion not allowed, please inactivate."
+5 SET ITM=$$GETITM(DLG)
+6 SET DISABLED=$LENGTH($PIECE($GET(^ORD(101.41,IFN,0)),U,3))>0
+7 SET DIR(0)="YA"
+8 IF DISABLED
Begin DoDot:1
+9 SET DIR("A",1)="This "_ITM_" is already disabled."
+10 SET DIR("A")="Would you like to edit the disable message? "
+11 SET DIR("?")="Enter YES if you want to edit the disabled message, or NO to quit."
+12 SET DIR("B")="NO"
End DoDot:1
IF 1
+13 IF '$TEST
Begin DoDot:1
+14 SET DIR("A")="Would you like to disable this "_ITM_"? "
+15 SET DIR("?")="Enter YES if you want to disable this "_ITM_", or NO to quit."
+16 SET DIR("B")="YES"
End DoDot:1
+17 DO ^DIR
+18 IF '+Y
QUIT
+19 WRITE !,"Enter disable message:"
+20 SET DA=DLG
SET DR="3"
SET DIE="^ORD(101.41,"
+21 DO ^DIE
+22 QUIT
+23 ;
DTEXT(X) ; -- Enter/edit display text of prompt
+1 NEW Y,DIR
+2 SET DIR(0)="FA^3:63"
SET DIR("A")="TEXT OF PROMPT: "
IF $LENGTH($GET(X))
SET DIR("B")=X
+3 SET DIR("?")="Enter the text of this prompt, including any punctuation and spaces"
+4 DO ^DIR
IF $DATA(DTOUT)
SET Y="^"
+5 QUIT Y
+6 ;
DATATYPE(X) ; -- Returns desired datatype for prompt
+1 NEW DIR,Y
SET DIR("A")="TYPE OF PROMPT: "
+2 SET DIR(0)="SAM^D:date/time;R:relative date/time;F:free text;N:numeric;S:set of codes;P:pointer to a file;Y:yes/no;W:word processing;"
+3 IF $LENGTH($GET(X))
SET DIR("B")=$PIECE($PIECE(DIR(0),X_":",2),";")
+4 SET DIR("?")="Select the type of data to be entered at this prompt"
+5 DO ^DIR
IF $DATA(DTOUT)
SET Y="^"
+6 QUIT Y
+7 ;
DATE ; -- date parameters
+1 NEW X,Y,DIR,ORX,ORT,ORS,ORR
+2 SET X=$PIECE(DOMAIN,":",3)
SET ORX=X["X"
SET ORT=X["T"
SET ORS=X["S"
SET ORR=X["R"
SET DIR(0)="YA"
+3 ; Still need to handle Earliest and Latest dates allowed
+4 SET DIR("A")="CAN DATE BE IMPRECISE? "
SET DIR("B")=$SELECT(ORX:"NO",1:"YES")
+5 DO ^DIR
SET ORX='Y
IF $DATA(DUOUT)!($DATA(DTOUT))
SET DOMAIN="^"
QUIT
+6 SET DIR("A")="CAN TIME OF DAY BE ENTERED? "
SET DIR("B")=$SELECT(ORT:"YES",1:"NO")
+7 DO ^DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
SET DOMAIN="^"
QUIT
+8 SET ORT=Y
IF 'Y
SET (ORS,ORR)=0
GOTO DQ
+9 SET DIR("A")="CAN SECONDS BE ENTERED? "
SET DIR("B")=$SELECT(ORS:"YES",1:"NO")
+10 DO ^DIR
SET ORS=Y
IF $DATA(DUOUT)!($DATA(DTOUT))
SET DOMAIN="^"
QUIT
+11 SET DIR("A")="IS TIME REQUIRED? "
SET DIR("B")=$SELECT(ORR:"YES",1:"NO")
+12 DO ^DIR
SET ORR=Y
IF $DATA(DUOUT)!($DATA(DTOUT))
SET DOMAIN="^"
QUIT
DQ SET DOMAIN="::E"_$SELECT(ORX:"X",1:"")_$SELECT(ORT:"T",1:"")_$SELECT(ORS:"S",1:"")_$SELECT(ORR:"R",1:"")
+1 QUIT
+2 ;
TEXT ; -- free text
+1 NEW X,Y,DIR
+2 SET DIR(0)="NAO^1:245"
SET DIR("A")="MINIMUM LENGTH: "
+3 IF +DOMAIN
SET DIR("B")=+DOMAIN
+4 DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
SET DOMAIN="^"
QUIT
+5 SET $PIECE(DOMAIN,":")=Y
SET DIR("A")="MAXIMUM LENGTH: "
KILL DIR("B")
+6 IF $PIECE(DOMAIN,"
SET DIR("B")=$PIECE(DOMAIN,":",2)
+7 DO ^DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
SET DOMAIN="^"
QUIT
+8 SET $PIECE(DOMAIN,":",2)=Y
+9 ; Opt pattern match ??
+10 QUIT
+11 ;
NMBR ; -- numeric
+1 NEW X,Y,DIR,STR
+2 ;95
SET DIR(0)="NAO^::"_+$PIECE(DOMAIN,":",3)
SET DIR("A")="INCLUSIVE LOWER BOUND: "
SET DIR("B")=+DOMAIN
+3 DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
SET DOMAIN="^"
QUIT
+4 ;95
SET STR=Y
SET DIR(0)="NAO^"_Y_"::"_+$PIECE(DOMAIN,":",3)
SET DIR("A")="INCLUSIVE UPPER BOUND: "
SET DIR("B")=+$PIECE(DOMAIN,":",2)
+5 DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
SET DOMAIN="^"
QUIT
+6 ;95
SET STR=STR_":"_Y
SET DIR(0)="NAO"
SET DIR("A")="MAXIMUM NUMBER OF FRACTIONAL DIGITS: "
SET DIR("B")=+$PIECE(DOMAIN,":",3)
+7 DO ^DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
SET DOMAIN="^"
QUIT
+8 SET DOMAIN=STR_":"_Y
+9 QUIT
+10 ;
PTR ; -- pointer
+1 ; allow file root
IF DUZ(0)="@"!($LENGTH(DOMAIN)&'DOMAIN)
DO ROOT
QUIT
+2 NEW X,Y,DIR,DIE,DR,FILE,STR,SCR
+3 SET DIR(0)="PA^1:AEQM"
SET DIR("A")="POINT TO WHICH FILE: "
+4 IF $LENGTH(DOMAIN)
SET DIR("B")=$$FILENAME(+DOMAIN)
+5 DO ^DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
SET DOMAIN="^"
QUIT
+6 SET FILE=+Y
SET STR=$PIECE(DOMAIN,":",2)
IF '$LENGTH(STR)
SET STR="EQ"
+7 SET DOMAIN=FILE_":"_STR
+8 QUIT
+9 ;
ROOT ; -- pointer via file root
+1 NEW X,Y,DIR,STR
+2 SET DIR(0)="FA^1:100"
SET DIR("A")="POINT TO WHICH FILE: "
+3 SET DIR("?")="Enter the file or subfile by name, file number, or global root (without the leading '^')."
+4 IF $LENGTH(DOMAIN)
SET DIR("B")=$SELECT(+DOMAIN:$$FILENAME(+DOMAIN),1:$PIECE(DOMAIN,":"))
RT1 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET DOMAIN="^"
QUIT
+1 ; default
IF $LENGTH(DOMAIN)
IF $LENGTH(X)
IF X=$GET(DIR("B"))
SET Y=$PIECE(DOMAIN,":")
GOTO RTQ
+2 ; valid file number
IF +Y=Y
SET X=$$FILENAME(+Y)
IF $LENGTH(X)
WRITE " "_X
GOTO RTQ
+3 ; valid root or name
IF $LENGTH(Y)
IF +Y'=Y
Begin DoDot:1
+4 ; valid file root
IF "(,"[$EXTRACT(Y,$LENGTH(Y))
IF $DATA(@(U_Y_"0)"))
QUIT
+5 SET DIC=1
SET DIC(0)="EQ"
SET X=Y
DO ^DIC
IF Y>0
SET Y=+Y
IF Y'>0
KILL Y
End DoDot:1
IF $DATA(Y)
GOTO RTQ
+6 WRITE $CHAR(7),!,"Invalid file!"
GOTO RT1
RTQ SET STR=$PIECE(DOMAIN,":",2)
SET DOMAIN=Y_":"_$SELECT($LENGTH(STR):STR,1:"EQ")
+1 QUIT
+2 ;
SET ; -- set of codes
+1 NEW I,ORI,ORJ,ITEM,X,Y,ORQUIT,NEWLNG
SET ORJ=0
+2 FOR I=1:1:$LENGTH(DOMAIN,";")
IF $PIECE(DOMAIN,";",I)'=""
SET ITEM(I)=$PIECE(DOMAIN,";",I)
+3 SET ORI=0
FOR
SET ORI=$ORDER(ITEM(ORI))
IF ORI'>0
QUIT
DO SETEDIT
IF $GET(ORQUIT)!(Y="")
QUIT
+4 IF $GET(ORQUIT)
SET DOMAIN="^"
QUIT
+5 ; new codes
SET ORI=ORJ
FOR
SET ORI=ORI+1
DO SETEDIT
IF $GET(ORQUIT)!(Y="")
QUIT
+6 IF $GET(ORQUIT)
SET DOMAIN="^"
QUIT
+7 ; now done editing, rebuild DOMAIN
+8 SET I=0
SET DOMAIN=""
FOR
SET I=$ORDER(ITEM(I))
IF I'>0
QUIT
SET NEWLNG=$LENGTH(DOMAIN)+$LENGTH(ITEM(I))+1
IF NEWLNG'>235
SET DOMAIN=DOMAIN_ITEM(I)_";"
IF NEWLNG>235
WRITE $CHAR(7),!,"Domain too long - unable to store all codes."
HANG 2
QUIT
+9 QUIT
SETEDIT ; -- edit each item in DOMAIN
+1 NEW DIR,TEXT,CODE
SET DIR(0)="FAO^1:5"
SET DIR("A")="INTERNALLY-STORED CODE: "
+2 SET CODE=$PIECE($GET(ITEM(ORI)),":")
SET TEXT=$PIECE($GET(ITEM(ORI)),":",2)
SET ORJ=ORI
+3 IF $LENGTH(CODE)
SET DIR("B")=CODE
+4 DO ^DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
SET ORQUIT=1
IF $GET(ORQUIT)!(X="")
QUIT
+5 IF X="@"
KILL ITEM(ORI)
QUIT
+6 SET CODE=X
WRITE " WILL STAND FOR: "
IF $LENGTH(TEXT)
WRITE TEXT_"// "
SE1 READ Y:DTIME
IF '$TEST!(Y["^")
SET ORQUIT=1
QUIT
+1 IF Y=""
SET Y=TEXT
IF "@"[Y
WRITE $CHAR(7),!," Required value!",!,"'"_CODE_"' WILL STAND FOR: "
IF $LENGTH(TEXT)
WRITE TEXT_"// "
GOTO SE1
+2 SET TEXT=Y
SET ITEM(ORI)=CODE_":"_TEXT
+3 QUIT
+4 ;
OTHER ; -- no parameters needed
+1 SET DOMAIN=""
+2 QUIT
+3 ;
FILENAME(FNUM) ; -- Returns name of file FNUM
+1 NEW ORY,Y
IF $GET(FNUM)
DO FILE^DID(+FNUM,,"NAME","ORY")
+2 SET Y=$GET(ORY("NAME"))
+3 QUIT Y
