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 ---[H[J[2J[HORCMEDT4 12155 printed Dec 13, 2024@02:28:38 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
+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 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
PTRCHK(DLG,ARRNAME) ; --check for pointers to order dialog
+1 KILL ^TMP($JOB,ARRNAME)
+2 NEW AREPTRS,INC
SET AREPTRS=0
+3 IF +$GET(DLG)
Begin DoDot:1
+4 DO APIONE^PXRMDLR3(ARRNAME,DLG,"ORD(101.41,",0)
+5 IF $DATA(^TMP($JOB,ARRNAME))
Begin DoDot:2
+6 ;restructure data from PXRM API for report output to match format used in PTRRPT
+7 NEW IDX,IDX2,ORPXIEN,ORPXNAME
SET (IDX,IDX2)=0
+8 FOR
SET IDX=$ORDER(^TMP($JOB,ARRNAME,DLG_";ORD(101.41,",IDX))
if +$GET(IDX)=0
QUIT
Begin DoDot:3
+9 FOR
SET IDX2=$ORDER(^TMP($JOB,ARRNAME,DLG_";ORD(101.41,",IDX,IDX2))
if +$GET(IDX2)=0
QUIT
Begin DoDot:4
+10 ;skip the top level reminder dialog
if $PIECE(^TMP($JOB,ARRNAME,DLG_";ORD(101.41,",IDX,IDX2),"
QUIT
+11 ;" Dialog Element: TEST QO AS FINDING"
SET ORPXNAME=^TMP($JOB,ARRNAME,DLG_";ORD(101.41,",IDX,IDX2)
+12 if $PIECE(ORPXNAME,"
QUIT
+13 ; " TEST QO AS FINDING"
SET ORPXNAME=$PIECE(ORPXNAME,":",2)
+14 ; "TEST QO AS FINDING"
SET ORPXNAME=$EXTRACT(ORPXNAME,2,99)
+15 SET ORPXIEN=$ORDER(^PXRMD(801.41,"B",ORPXNAME,""))
+16 SET ^TMP($JOB,ARRNAME,801.41,ORPXIEN)=ORPXNAME
End DoDot:4
End DoDot:3
End DoDot:2
+17 DO OR100(DLG,ARRNAME)
+18 DO ORD10098(DLG,ARRNAME)
End DoDot:1
+19 SET AREPTRS=$DATA(^TMP($JOB,ARRNAME))
+20 QUIT +AREPTRS
+21 ;
PTRRPT(ARRNAME,ORIFN) ; --show list of pointers to order dialog
+1 NEW FILENUM,ITEMIEN,IEN,TAB,ITEM,LINCNT,CONTINUE
SET (FILENUM,ITEMIEN,IEN,CONTINUE)=""
SET LINCNT=0
+2 FOR FILENUM=100.98,801.41,100
Begin DoDot:1
+3 IF $DATA(^TMP($JOB,ARRNAME,FILENUM))
Begin DoDot:2
+4 WRITE @IOF
SET (CONTINUE,ITEMIEN)=""
+5 WRITE !,$PIECE(^ORD(101.41,ORIFN,0),U)_" is pointed to by:"
+6 WRITE !,"FILE ",?13,"IEN",?23,"NAME"
+7 WRITE !,$$REPEAT^XLFSTR("-",27)
+8 FOR
SET ITEMIEN=$ORDER(^TMP($JOB,ARRNAME,FILENUM,ITEMIEN))
if ITEMIEN=""!(CONTINUE["^")
QUIT
Begin DoDot:3
+9 SET ITEM=^TMP($JOB,ARRNAME,FILENUM,ITEMIEN)
+10 WRITE !,$SELECT(FILENUM=100:"ORDER",FILENUM=100.98:"DISPLAY GRP",FILENUM=801.41:"REMINDER DLG",1:FILENUM),?13,ITEMIEN
+11 WRITE ?23,$SELECT(FILENUM=100:"N/A",1:ITEM)
+12 SET LINCNT=LINCNT+1
+13 IF LINCNT#20=0
SET CONTINUE=$$CONT
IF CONTINUE'["^"
DO HDR
+14 if CONTINUE["^"
QUIT
End DoDot:3
+15 if $GET(CONTINUE)="^"
QUIT
SET CONTINUE=$$CONT
if CONTINUE["^"
QUIT
End DoDot:2
End DoDot:1
+16 KILL ^TMP($JOB,ARRNAME)
+17 QUIT
+18 ;
OR100(DLG,ARR) ;100
+1 NEW ORIFN,TEMP
+2 SET TEMP=DLG_";ORD(101.41,"
SET ORIFN=""
+3 IF $DATA(^OR(100,"C",TEMP))
Begin DoDot:1
+4 FOR
SET ORIFN=$ORDER(^OR(100,"C",TEMP,ORIFN))
if ORIFN=""
QUIT
Begin DoDot:2
+5 if $DATA(^OR(100,ORIFN))=0
QUIT
+6 ;if DIALOG has pointer to order dialog
IF $PIECE(^OR(100,ORIFN,0),U,5)=TEMP
Begin DoDot:3
+7 SET ^TMP($JOB,ARR,100,ORIFN)=$PIECE(^OR(100,ORIFN,0),U,5)
End DoDot:3
End DoDot:2
End DoDot:1
+8 SET ORIFN=""
+9 IF $DATA(^OR(100,"D",TEMP))
Begin DoDot:1
+10 FOR
SET ORIFN=$ORDER(^OR(100,"D",TEMP,ORIFN))
if ORIFN=""
QUIT
Begin DoDot:2
+11 if $DATA(^OR(100,ORIFN))=0
QUIT
+12 ;if ITEM ORDERED has pointer to order dialog
IF $PIECE(^OR(100,ORIFN,3),U,4)=TEMP
Begin DoDot:3
+13 SET ^TMP($JOB,ARR,100,ORIFN)=$PIECE(^OR(100,ORIFN,3),U,4)
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
ORD10098(DLG,ARR) ;100.98
+1 NEW DISGRP,DISIEN
SET DISGRP=""
SET DISIEN=""
+2 FOR
SET DISGRP=$ORDER(^ORD(100.98,"B",DISGRP))
if DISGRP=""
QUIT
Begin DoDot:1
+3 FOR
SET DISIEN=$ORDER(^ORD(100.98,"B",DISGRP,DISIEN))
if DISIEN=""
QUIT
Begin DoDot:2
+4 ;second B x-ref entry for SHORT NAME, Q to avoid duplicates in results
if ^ORD(100.98,"B",DISGRP,DISIEN)=1
QUIT
+5 ;if DEFAULT DIALOG has pointer to order dialog
IF $PIECE(^ORD(100.98,DISIEN,0),U,4)=DLG
Begin DoDot:3
+6 SET ^TMP($JOB,ARR,100.98,DISIEN)=$PIECE(^ORD(100.98,DISIEN,0),U)
End DoDot:3
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
HDR ;header
+1 WRITE @IOF
+2 WRITE !,"FILE ",?13,"IEN",?23,"NAME"
+3 WRITE !,$$REPEAT^XLFSTR("-",27)
+4 QUIT
CONT() ; -- gives user a chance to read output from pointer check
+1 NEW X,Y,DIR
+2 SET DIR(0)="FO"
SET DIR("A")="Press any key to continue reviewing pointer report"
+3 SET DIR("?")="Enter any key to continue; enter ^ to exit."
+4 DO ^DIR
+5 QUIT X
+6 ;
