ORCMEDT4.m

ORCMEDT4 ;SLC/MKB-Prompt Editor ;10/08/19  16:41

 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,95,245,313,389,397,377**;Dec 17, 1997;Build 582

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

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

 . S NODELETE=$$PTRCHK(IFN,"ORDLG PTRS") I NODELETE D

 . . N CONTINUE W $C(7),!,"Cannot delete - other file entries point to this order dialog!",!

 . . S CONTINUE=$$CONT D:CONTINUE'["^" PTRRPT("ORDLG PTRS",IFN)

 . 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",!

 K ^TMP($J,"ORDLG PTRS")

 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

 ;W $C(7),!,!,"Deletion not allowed outside of FileMan."

 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 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

PTRCHK(DLG,ARRNAME) ; --check for pointers to order dialog

 K ^TMP($J,ARRNAME)

 N AREPTRS,INC S AREPTRS=0

 I +$G(DLG) D

 .D APIONE^PXRMDLR3(ARRNAME,DLG,"ORD(101.41,",0)

 .I $D(^TMP($J,ARRNAME)) D

 ..;restructure data from PXRM API for report output to match format used in PTRRPT

 ..N IDX,IDX2,ORPXIEN,ORPXNAME S (IDX,IDX2)=0

 ..F  S IDX=$O(^TMP($J,ARRNAME,DLG_";ORD(101.41,",IDX)) Q:+$G(IDX)=0  D

 ...F  S IDX2=$O(^TMP($J,ARRNAME,DLG_";ORD(101.41,",IDX,IDX2)) Q:+$G(IDX2)=0  D

 ....Q:$P(^TMP($J,ARRNAME,DLG_";ORD(101.41,",IDX,IDX2),":")="Dialog"  ;skip the top level reminder dialog

 ....S ORPXNAME=^TMP($J,ARRNAME,DLG_";ORD(101.41,",IDX,IDX2) ;"  Dialog Element: TEST QO AS FINDING"

 ....Q:$P(ORPXNAME,":")'["Group"&($P(ORPXNAME,":")'["Element")

 ....S ORPXNAME=$P(ORPXNAME,":",2) ; " TEST QO AS FINDING"

 ....S ORPXNAME=$E(ORPXNAME,2,99) ; "TEST QO AS FINDING"

 ....S ORPXIEN=$O(^PXRMD(801.41,"B",ORPXNAME,""))

 ....S ^TMP($J,ARRNAME,801.41,ORPXIEN)=ORPXNAME

 .D OR100(DLG,ARRNAME)

 .D ORD10098(DLG,ARRNAME)

 S AREPTRS=$D(^TMP($J,ARRNAME))

 Q +AREPTRS

 ;

PTRRPT(ARRNAME,ORIFN) ; --show list of pointers to order dialog

 N FILENUM,ITEMIEN,IEN,TAB,ITEM,LINCNT,CONTINUE S (FILENUM,ITEMIEN,IEN,CONTINUE)="",LINCNT=0

 F FILENUM=100.98,801.41,100 D

 .I $D(^TMP($J,ARRNAME,FILENUM)) D

 ..W @IOF S (CONTINUE,ITEMIEN)=""

 ..W !,$P(^ORD(101.41,ORIFN,0),U)_" is pointed to by:"

 ..W !,"FILE  ",?13,"IEN",?23,"NAME"

 ..W !,$$REPEAT^XLFSTR("-",27)

 ..F  S ITEMIEN=$O(^TMP($J,ARRNAME,FILENUM,ITEMIEN)) Q:ITEMIEN=""!(CONTINUE["^")  D

 ...S ITEM=^TMP($J,ARRNAME,FILENUM,ITEMIEN)

 ...W !,$S(FILENUM=100:"ORDER",FILENUM=100.98:"DISPLAY GRP",FILENUM=801.41:"REMINDER DLG",1:FILENUM),?13,ITEMIEN

 ...W ?23,$S(FILENUM=100:"N/A",1:ITEM)

 ...S LINCNT=LINCNT+1

 ...I LINCNT#20=0 S CONTINUE=$$CONT I CONTINUE'["^" D HDR

 ...Q:CONTINUE["^"

 ..Q:$G(CONTINUE)="^"  S CONTINUE=$$CONT Q:CONTINUE["^"

 K ^TMP($J,ARRNAME)

 Q

 ;

OR100(DLG,ARR) ;100

 N ORIFN,TEMP

 S TEMP=DLG_";ORD(101.41,",ORIFN=""

 I $D(^OR(100,"C",TEMP)) D

 .F  S ORIFN=$O(^OR(100,"C",TEMP,ORIFN)) Q:ORIFN=""  D

 ..Q:$D(^OR(100,ORIFN))=0

 ..I $P(^OR(100,ORIFN,0),U,5)=TEMP D  ;if DIALOG has pointer to order dialog

 ...S ^TMP($J,ARR,100,ORIFN)=$P(^OR(100,ORIFN,0),U,5)

 S ORIFN=""

 I $D(^OR(100,"D",TEMP)) D

 .F  S ORIFN=$O(^OR(100,"D",TEMP,ORIFN)) Q:ORIFN=""  D

 ..Q:$D(^OR(100,ORIFN))=0

 ..I $P(^OR(100,ORIFN,3),U,4)=TEMP D  ;if ITEM ORDERED has pointer to order dialog

 ...S ^TMP($J,ARR,100,ORIFN)=$P(^OR(100,ORIFN,3),U,4)

 Q

 ;

ORD10098(DLG,ARR) ;100.98

 N DISGRP,DISIEN S DISGRP="",DISIEN=""

 F  S DISGRP=$O(^ORD(100.98,"B",DISGRP)) Q:DISGRP=""  D

 .F  S DISIEN=$O(^ORD(100.98,"B",DISGRP,DISIEN)) Q:DISIEN=""  D

 ..Q:^ORD(100.98,"B",DISGRP,DISIEN)=1  ;second B x-ref entry for SHORT NAME, Q to avoid duplicates in results

 ..I $P(^ORD(100.98,DISIEN,0),U,4)=DLG D  ;if DEFAULT DIALOG has pointer to order dialog

 ...S ^TMP($J,ARR,100.98,DISIEN)=$P(^ORD(100.98,DISIEN,0),U)

 Q

 ;

HDR ;header

 W @IOF

 W !,"FILE  ",?13,"IEN",?23,"NAME"

 W !,$$REPEAT^XLFSTR("-",27)

 Q

CONT() ; -- gives user a chance to read output from pointer check

 N X,Y,DIR

 S DIR(0)="FO",DIR("A")="Press any key to continue reviewing pointer report"

 S DIR("?")="Enter any key to continue; enter ^ to exit."

 D ^DIR

 Q X

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ORCMEDT4   12155     printed  Mar 13, 2025@21:33:35                                                                                                                                                                                                   Page 2

ORCMEDT4  ;SLC/MKB-Prompt Editor ;10/08/19  16:41

 +1       ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,95,245,313,389,397,377**;Dec 17, 1997;Build 582

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

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                SET NODELETE=$$PTRCHK(IFN,"ORDLG PTRS")

                   IF NODELETE

                       Begin DoDot:2

 +6                        NEW CONTINUE

                           WRITE $CHAR(7),!,"Cannot delete - other file entries point to this order dialog!",!

 +7                        SET CONTINUE=$$CONT

                           if CONTINUE'["^"

                               DO PTRRPT("ORDLG PTRS",IFN)

                       End DoDot:2

 +8                IF NODELETE

                       DO DISABLE(IFN)

                       SET X=""

                       QUIT 

 +9       ;reask

                   IF '$$SURE(IFN)

                       SET X=""

                       QUIT 

 +10               NEW IDX1,IDX2

                   SET IDX1=0

 +11               FOR 

                       SET IDX1=$ORDER(^ORD(101.44,"C",IFN,IDX1))

                       if 'IDX1

                           QUIT 

                       Begin DoDot:2

 +12                       SET IDX2=0

 +13                       FOR 

                               SET IDX2=$ORDER(^ORD(101.44,"C",IFN,IDX1,IDX2))

                               if 'IDX2

                                   QUIT 

                               Begin DoDot:3

 +14                               SET DA=IDX2

                                   SET DA(1)=IDX1

                                   SET DIK="^ORD(101.44,"_IDX1_",10,"

                                   DO ^DIK

                               End DoDot:3

                       End DoDot:2

 +15               KILL DA

                   SET DA=IFN

                   SET DIK="^ORD(101.41,"

                   DO ^DIK

                   WRITE "  ...deleted."

                   SET (X,Y)="@"

               End DoDot:1

               if X=""

                   GOTO NM

 +16       IF ISPQO

               IF Y'="^"

                   IF X'="@"

                       IF Y'=OLDNAME

                           Begin DoDot:1

 +17                           WRITE $CHAR(7),!,"Cannot rename a personal quick order",!

                           End DoDot:1

                           GOTO NM

 +18       KILL ^TMP($JOB,"ORDLG PTRS")

 +19       QUIT Y

 +20      ;

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       ;W $C(7),!,!,"Deletion not allowed outside of FileMan."

 +3        SET ITM=$$GETITM(DLG)

 +4        SET DISABLED=$LENGTH($PIECE($GET(^ORD(101.41,IFN,0)),U,3))>0

 +5        SET DIR(0)="YA"

 +6        IF DISABLED

               Begin DoDot:1

 +7                SET DIR("A",1)="This "_ITM_" is already disabled."

 +8                SET DIR("A")="Would you like to edit the disable message? "

 +9                SET DIR("?")="Enter YES if you want to edit the disabled message, or NO to quit."

 +10               SET DIR("B")="NO"

               End DoDot:1

               IF 1

 +11      IF '$TEST

               Begin DoDot:1

 +12               SET DIR("A")="Would you like to disable this "_ITM_"? "

 +13               SET DIR("?")="Enter YES if you want to disable this "_ITM_", or NO to quit."

 +14               SET DIR("B")="YES"

               End DoDot:1

 +15       DO ^DIR

 +16       IF '+Y

               QUIT 

 +17       WRITE !,"Enter disable message:"

 +18       SET DA=DLG

           SET DR="3"

           SET DIE="^ORD(101.41,"

 +19       DO ^DIE

 +20       QUIT 

 +21      ;

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