ORCDLG1 ;SLC/MKB - ORDER DIALOGS CONT ;11/14/17 09:49
;;3.0;ORDER ENTRY/RESULTS REPORTING;**60,71,95,110,243,350,467**;Dec 17, 1997;Build 4
;Per VA Directive 6402, this routine should not be modified.
;
EN(ITM,INST) ; -- ask each ITM prompt where
; ORDIALOG(PROMPT,#) = internal form of each response
;
N ITEM,COND,MULT,REQD,EDITONLY,DATATYPE,DOMAIN,DIR,Y,ACTION,PROMPT,ORX,VALIDEF
S ITEM=$G(^ORD(101.41,+ORDIALOG,10,ITM,0)),COND=$G(^(3))
S PROMPT=$P(ITEM,U,2) Q:'PROMPT S:'$G(INST) INST=1
S MULT=$P(ITEM,U,7),ACTION=$P(ITEM,U,9)
S REQD=$P(ITEM,U,6),EDITONLY=$P(ITEM,U,8) S:$G(ORTYPE)="Z" (REQD,EDITONLY)=0
I $D(^ORD(101.41,+ORDIALOG,10,ITM,9)) X ^(9) G:$G(ORQUIT) ENQ ;Entry
I $G(ORTYPE)="Q",$D(ORDIALOG(PROMPT,INST)),$E(ORDIALOG(PROMPT,0))'="W" S EDITONLY=1
I '$D(ORDIALOG(PROMPT,INST)) D ; get default value
. I $E(ORDIALOG(PROMPT,0))="W",$D(^ORD(101.41,+ORDIALOG,10,ITM,8))>9 M ^TMP("ORWORD",$J,PROMPT,INST)=^(8) S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")" Q
. K Y X:$D(^ORD(101.41,+ORDIALOG,10,ITM,7)) ^(7)
. I $D(Y) S VALIDEF=$$VALID S:VALIDEF ORDIALOG(PROMPT,INST)=Y ;**95
. I $G(VALIDEF)=0 W !,"The DEFAULT value for the ",$G(ORDIALOG(PROMPT,"A"))," prompt is invalid." S EDITONLY=0 ;**95
. K VALIDEF ;**95
I $G(AUTO),'REQD!($E(ORDIALOG(PROMPT,0))="W"&$D(ORDIALOG(PROMPT,INST))) S EDITONLY=1 ;Auto-accept
EN0 I FIRST&EDITONLY D:$D(ORDIALOG(PROMPT,INST)) G ENQ ;ck child prompts
. Q:'$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) N SEQ,DA,ITEM,PRMT,X,Y,VALIDEF ;**95
. S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,SEQ)) Q:SEQ'>0 S DA=$O(^(SEQ,0)) D Q:$G(ORQUIT)
. . K VALIDEF ;110
. . S ITEM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)),PRMT=$P(ITEM,U,2)
. . Q:$D(ORDIALOG(PRMT,INST)) ; already has a value
. . K Y X:$D(^ORD(101.41,+ORDIALOG,10,DA,7)) ^(7)
. . I $D(Y) S VALIDEF=$$VALID ;**95
. . I $G(VALIDEF)!('$P(ITEM,U,6)) S:$G(VALIDEF) ORDIALOG(PRMT,INST)=Y Q ;**95
. . D EN(DA,INST) ; ask
I ($G(OREDIT)&(ACTION'["C"))!($G(ORENEW)&(ACTION'["R")) G ENQ ;ask?
I $G(OREWRITE),ACTION'["W",FIRST,'REQD!$D(ORDIALOG(PROMPT,INST)) G ENQ
I $L(COND) X COND G:'$T ENQ ; failed condition
M DIR=ORDIALOG(PROMPT) S DATATYPE=$E(DIR(0)),DOMAIN=$P(DIR(0),U,2)
I 'MULT D WP^ORCDLG2:DATATYPE="W",ONE(INST,REQD):DATATYPE'="W" G ENQ
EN1 ; -- loop for multiples
I '$O(ORDIALOG(PROMPT,0)) D G:$G(ORQUIT)!('$O(ORDIALOG(PROMPT,0)))!FIRST ENQ
M1 . D ADDMULT Q:$G(ORQUIT)
. Q:'REQD!$O(ORDIALOG(PROMPT,0)) I FIRST,$G(SEQ)=1 S ORQUIT=1 Q
. W $C(7),!!,$$REQUIRED,! G M1
F S ORX=$$SELECT Q:ORX="" S:ORX="^" ORQUIT=1 Q:$G(ORQUIT) D Q:$G(DIROUT)
. S DIR("A")=ORDIALOG(PROMPT,"A"),X=$S('REQD:0,$$ONLY(ORX):1,1:0)
. D ADDMULT:ORX="A",ONE(ORX,X):ORX Q:$G(DIROUT) K ORQUIT,DIR("B")
. I REQD,'$O(ORDIALOG(PROMPT,0)) W $C(7),!!,$$REQUIRED,!
ENQ X:$D(^ORD(101.41,+ORDIALOG,10,ITM,10)) ^(10) ; exit action
Q
;
REQUIRED() ; -- Required response message
Q "A response is required! Enter '^' to quit."
;
SELECT() ; -- select instance of multiple to edit
N DIR,X,Y,CNT,I,MAX,TOTAL,DONE,LAST
S MAX=+$G(ORDIALOG(PROMPT,"MAX")),TOTAL=+$G(ORDIALOG(PROMPT,"TOT"))
S DIR("A",1)=$S($L($G(ORDIALOG(PROMPT,"TTL"))):ORDIALOG(PROMPT,"TTL"),1:ORDIALOG(PROMPT,"A"))
S (I,CNT,LAST)=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 S LAST=I,CNT=CNT+1,CNT(CNT)=I,DIR("A",CNT+1)=$J(CNT,3)_": "_$$ITEM^ORCDLG(PROMPT,I) ; parent+children
I 'MAX!(MAX&(MAX>TOTAL)) S CNT=CNT+1,CNT(CNT)="A",DIR("A",CNT+1)=$J(CNT,3)_": <enter more>"
S DIR("A")="Select "_$S(CNT>1:"(1-"_CNT_")",1:1)_" or <return> to continue: "
S DIR(0)="NAO^1:"_CNT,DIR("?")="Select the instance you wish to change"
S1 D ^DIR I $D(DTOUT)!(Y="^") Q "^"
I Y?1"^".E D UJUMP Q:$G(ORQUIT)!($G(DONE)) "" G S1
I Y="" Q Y
I CNT(Y)="A" S ORDIALOG("CURINST")=LAST
Q CNT(Y)
;
ONLY(I) ; -- I the only instance?
N J,Z S J=0,Z=1
F S J=$O(ORDIALOG(PROMPT,J)) Q:J'>0 I J'=I S Z=0 Q
Q Z
;
ADDMULT ; -- add new instances of multiple
N DONE,LAST,MAX,ANOTHER,ORADDMUL
S ORADDMUL=1
S MAX=+$G(ORDIALOG(PROMPT,"MAX")) I MAX,MAX'>$G(ORDIALOG(PROMPT,"TOT")) W $C(7),!,"Only "_MAX_" items may be selected!",! Q
S ANOTHER=$G(ORDIALOG(PROMPT,"MORE")) S:'$L(ANOTHER) ANOTHER="Another "
S DIR("A")=$S($O(ORDIALOG(PROMPT,0)):ANOTHER,1:"")_ORDIALOG(PROMPT,"A")
F D Q:$G(ORQUIT)!($G(DONE)) I MAX Q:MAX'>$G(ORDIALOG(PROMPT,"TOT"))
. S ORDIALOG("CURINST")=1+$G(ORDIALOG("CURINST"))
. D ONE(ORDIALOG("CURINST"),0) I '$D(ORDIALOG(PROMPT,ORDIALOG("CURINST"))) S DONE=1 Q
. S ORDIALOG(PROMPT,"TOT")=+$G(ORDIALOG(PROMPT,"TOT"))+1,DIR("A")=ANOTHER_ORDIALOG(PROMPT,"A")
Q
;
ONE(ORI,REQD) ; -- ask single-valued prompt
N DONE,ORESET,QUERY
S:$D(ORDIALOG(PROMPT,ORI)) DIR("B")=$$EXT^ORCD(PROMPT,ORI),ORESET=ORDIALOG(PROMPT,ORI)
S QUERY=0 I $G(ORTYPE)="Z",PROMPT=$$PTR^ORCD("OR GTX INSTRUCTIONS") D ;DJE/VM *350 Quick Order creation should query for schedule after dose.
. N SCHEDITEM S SCHEDITEM=$O(^ORD(101.41,+ORDIALOG,10,"D",$$PTR^ORCD("OR GTX SCHEDULE"),"")) Q:'SCHEDITEM
. I $P(^ORD(101.41,+ORDIALOG,10,SCHEDITEM,0),U,11)=PROMPT S QUERY=1 ;see if schedule is a child of dose
F D Q:$G(DONE) I $G(ORQUIT) Q:FIRST Q:'REQD!$D(ORDIALOG(PROMPT,ORI)) S FIRST=$$DONE^ORCDLG2 Q:FIRST K ORQUIT
. D DIR^ORCDLG2 I $D(DTOUT)!$D(DIROUT)!(X=U) S ORQUIT=1 Q
. I 'QUERY,X="" S DONE=1 Q
. I X?1"^".E D UJUMP Q
. I X="@" D DELETE Q:'QUERY
. I $E(DIR(0))="N",Y<1,$E(Y,1,2)'="0." S Y=0_Y
. S ORDIALOG(PROMPT,ORI)=$P(Y,U),DONE=1
. X:$L($G(^ORD(101.41,+ORDIALOG,10,ITM,5))) ^(5) I '$G(DONE) D RESET Q ; validate - if failed, K DONE to reask
. D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) CHILDREN(PROMPT,ORI) I '$G(DONE),'FIRST D DELCHILD(PROMPT,ORI),RESET Q
. I QUERY,ORDIALOG(PROMPT,ORI)="" D ;DJE/VM *350 disable empty parent node if children have no data
. . N SEQ,DA,PTR,VALUE
. . S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,SEQ)) Q:SEQ'>0 S DA=$O(^(SEQ,0)),PTR=+$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2) S:PTR&$D(ORDIALOG(PTR,ORI)) VALUE=1
. . I '$G(VALUE) K ORDIALOG(PROMPT,ORI)
Q
;
CHILDREN(PARENT,INST) ; -- ask child prompts
N SEQ,DA,ORQUIT S SEQ=0
F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0 S DA=$O(^(SEQ,0)) D EN(DA,INST) K:$G(ORJUMP) ORJUMP Q:$G(ORQUIT)
K:$G(ORQUIT) DONE ; reask parent
Q
;
RESET ; -- Reset original prompt value
K ORDIALOG(PROMPT,ORI)
S:$D(ORESET) ORDIALOG(PROMPT,ORI)=ORESET
Q
;
UJUMP ; -- ^-jump
N XP,P,CNT,MATCH,I,DIR,NEWSEQ ; XP=$$UP(X),P=PROMPT
I $G(NOJUMP) W $C(7)," ^-jumping not allowed!" Q
S XP=$$UP^XLFSTR($P(X,U,2)) I "^"[XP S ORQUIT=1 Q
I $G(ORDIALOG("B",XP)) S NEWSEQ=+ORDIALOG("B",XP) G UJQ
S CNT=0,P=XP F S P=$O(ORDIALOG("B",P)) Q:P="" Q:$E(P,1,$L(XP))'=XP Q:FIRST&(+ORDIALOG("B",P)'<SEQ) S CNT=CNT+1,MATCH(CNT)=+ORDIALOG("B",P)_U_P ; =SEQ^TEXT
I 'CNT W $C(7)," ??" Q
I CNT=1 S P=$P(MATCH(1),U,2) W $E(P,$L(XP)+1,$L(P)) S NEWSEQ=+MATCH(1) G UJQ
F I=1:1:CNT S DIR("A",I)=I_" "_$P(MATCH(I),U,2)
S DIR("A")="Select 1-"_CNT_": ",DIR(0)="NAO^1:"_CNT
S DIR("?")="Select the field you wish to jump to, by number"
D ^DIR I $D(DTOUT)!($D(DUOUT))!(Y="") Q
S NEWSEQ=+MATCH(Y)
UJQ I FIRST,NEWSEQ'<SEQ W $C(7)," ^-jumping ahead not allowed now!" Q
S SEQ=NEWSEQ-.01,DONE=1
I $G(ORADDMUL) S ORJUMP=1
Q
;
DELETE ; -- delete response
I '$D(DIR("B")) W $C(7)," ??" Q
Q:'$$SURE S DONE=1
K ORDIALOG(PROMPT,ORI),DIR("B")
S:$G(ORDIALOG(PROMPT,"TOT")) ORDIALOG(PROMPT,"TOT")=ORDIALOG(PROMPT,"TOT")-1
I 'QUERY,$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) D DELCHILD(PROMPT,ORI)
Q
;
DELCHILD(PARENT,INST) ; -- delete child prompts
N SEQ,DA,PTR S:'$G(INST) INST=1
S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0 S DA=$O(^(SEQ,0)),PTR=+$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2) K:PTR ORDIALOG(PTR,INST)
Q
;
SURE() ; -- sure you want to delete?
N X,Y,DIR
S DIR(0)="YA",DIR("A")=" Are you sure you want to delete this value? "
S DIR("B")="NO" W $C(7) D ^DIR
S:$D(DTOUT) Y="^"
Q Y
;
VALID() ;Check to see if default value is valid. Returns 0 or 1
;Entire section added in patch 95
N TYPE,RANGE,MIN,MAX,DIR,X,ORDIC,DDS,RTYPE,ORIG
I Y="" Q 1 ;If default is null allow to pass ;110
S DIR(0)=$G(ORDIALOG(PROMPT,0)),(ORIG,X)=Y,DIR("V")="" ;Set reader type, default input, silent call
S TYPE=$E($P(DIR(0),"^")) ;Get type of look-up being done
I TYPE="W" Q 1 ;If word processing assume value is valid, may be referencing a global location
I TYPE="R" S $P(DIR(0),"^")="D"_$E($P(DIR(0),"^"),2,999),TYPE="D",RTYPE=1 ;If type is R then change to date look up
I TYPE="D" I X="AM"!(X="NEXT")!(X="NEXTA")!(X="CLOSEST") Q 1 ;If date/time prompt default is AM, NEXT, NEXTA, or CLOSEST then accept without checking
S:TYPE="P"&(X=+X) X="`"_X ;If pointer type add ` to IEN for DIR call
I TYPE="P" S ORDIC=$P(DIR(0),"^",2) S $P(ORDIC,":",2)=$TR($P(ORDIC,":",2),"QE","") S $P(DIR(0),"^",2)=ORDIC ;If pointer type remove Q&E from DIC(0) so no echo and no ?? on erroneous input
I TYPE="D" S ORDIC=$P(DIR(0),"^",2) S $P(ORDIC,":",3)=$TR($P(ORDIC,":",3),"E",""),$P(ORDIC,":")=$TR($P(ORDIC,":"),"DTNOW",""),$P(DIR(0),"^",2)=ORDIC ;Remove "E" so no echo, remove DT and NOW so DIR call works correctly
I TYPE="Y" S:"^Y^YE^YES^"[("^"_$TR(X,"yes","YES")_"^")!(X=1) X="YES" S:"^N^NO^"[("^"_$TR(X,"no","NO")_"^")!(X=0) X="NO" ;If yes/no type convert input to uppercase full entry to avoid echo
I TYPE="S" S DDS=1 ;Stops DIR call from echoing rest of entry for set of codes
D ^DIR
I TYPE="D"&('$D(Y(0))) Q 0 ;Date not valid
I TYPE="L"&($G(Y)="") Q 0 ;List/Range not valid
I TYPE="N"&('$D(Y)) Q 0 ;Numeric not valid
I TYPE="P"&($G(Y)=-1) Q 0 ;Pointer not valid
I TYPE="S"&($G(Y(0))="") Q 0 ;Set of codes not valid
I TYPE="Y"&($G(Y(0))="") Q 0 ;Yes/No not valid
I TYPE="F" S RANGE=$P(DIR(0),"^",2),MIN=$S($P(RANGE,":"):$P(RANGE,":"),1:1),MAX=$S($P(RANGE,":",2):$P(RANGE,":",2),1:240) I $L(Y)<MIN!($L(Y)>MAX) Q 0 ;Free text and not within valid limit
I $G(RTYPE) S Y=ORIG ;Set y back to relative date
I TYPE="P" S Y=$P(Y,"^") ;only store IEN ;110
Q 1 ;Must be valid
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCDLG1 10158 printed Dec 13, 2024@02:28:02 Page 2
ORCDLG1 ;SLC/MKB - ORDER DIALOGS CONT ;11/14/17 09:49
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**60,71,95,110,243,350,467**;Dec 17, 1997;Build 4
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN(ITM,INST) ; -- ask each ITM prompt where
+1 ; ORDIALOG(PROMPT,#) = internal form of each response
+2 ;
+3 NEW ITEM,COND,MULT,REQD,EDITONLY,DATATYPE,DOMAIN,DIR,Y,ACTION,PROMPT,ORX,VALIDEF
+4 SET ITEM=$GET(^ORD(101.41,+ORDIALOG,10,ITM,0))
SET COND=$GET(^(3))
+5 SET PROMPT=$PIECE(ITEM,U,2)
if 'PROMPT
QUIT
if '$GET(INST)
SET INST=1
+6 SET MULT=$PIECE(ITEM,U,7)
SET ACTION=$PIECE(ITEM,U,9)
+7 SET REQD=$PIECE(ITEM,U,6)
SET EDITONLY=$PIECE(ITEM,U,8)
if $GET(ORTYPE)="Z"
SET (REQD,EDITONLY)=0
+8 ;Entry
IF $DATA(^ORD(101.41,+ORDIALOG,10,ITM,9))
XECUTE ^(9)
if $GET(ORQUIT)
GOTO ENQ
+9 IF $GET(ORTYPE)="Q"
IF $DATA(ORDIALOG(PROMPT,INST))
IF $EXTRACT(ORDIALOG(PROMPT,0))'="W"
SET EDITONLY=1
+10 ; get default value
IF '$DATA(ORDIALOG(PROMPT,INST))
Begin DoDot:1
+11 IF $EXTRACT(ORDIALOG(PROMPT,0))="W"
IF $DATA(^ORD(101.41,+ORDIALOG,10,ITM,8))>9
MERGE ^TMP("ORWORD",$JOB,PROMPT,INST)=^(8)
SET ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$JOB_","_PROMPT_","_INST_")"
QUIT
+12 KILL Y
if $DATA(^ORD(101.41,+ORDIALOG,10,ITM,7))
XECUTE ^(7)
+13 ;**95
IF $DATA(Y)
SET VALIDEF=$$VALID
if VALIDEF
SET ORDIALOG(PROMPT,INST)=Y
+14 ;**95
IF $GET(VALIDEF)=0
WRITE !,"The DEFAULT value for the ",$GET(ORDIALOG(PROMPT,"A"))," prompt is invalid."
SET EDITONLY=0
+15 ;**95
KILL VALIDEF
End DoDot:1
+16 ;Auto-accept
IF $GET(AUTO)
IF 'REQD!($EXTRACT(ORDIALOG(PROMPT,0))="W"&$DATA(ORDIALOG(PROMPT,INST)))
SET EDITONLY=1
EN0 ;ck child prompts
IF FIRST&EDITONLY
if $DATA(ORDIALOG(PROMPT,INST))
Begin DoDot:1
+1 ;**95
if '$DATA(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT))
QUIT
NEW SEQ,DA,ITEM,PRMT,X,Y,VALIDEF
+2 SET SEQ=0
FOR
SET SEQ=$ORDER(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,SEQ))
if SEQ'>0
QUIT
SET DA=$ORDER(^(SEQ,0))
Begin DoDot:2
+3 ;110
KILL VALIDEF
+4 SET ITEM=$GET(^ORD(101.41,+ORDIALOG,10,DA,0))
SET PRMT=$PIECE(ITEM,U,2)
+5 ; already has a value
if $DATA(ORDIALOG(PRMT,INST))
QUIT
+6 KILL Y
if $DATA(^ORD(101.41,+ORDIALOG,10,DA,7))
XECUTE ^(7)
+7 ;**95
IF $DATA(Y)
SET VALIDEF=$$VALID
+8 ;**95
IF $GET(VALIDEF)!('$PIECE(ITEM,U,6))
if $GET(VALIDEF)
SET ORDIALOG(PRMT,INST)=Y
QUIT
+9 ; ask
DO EN(DA,INST)
End DoDot:2
if $GET(ORQUIT)
QUIT
End DoDot:1
GOTO ENQ
+10 ;ask?
IF ($GET(OREDIT)&(ACTION'["C"))!($GET(ORENEW)&(ACTION'["R"))
GOTO ENQ
+11 IF $GET(OREWRITE)
IF ACTION'["W"
IF FIRST
IF 'REQD!$DATA(ORDIALOG(PROMPT,INST))
GOTO ENQ
+12 ; failed condition
IF $LENGTH(COND)
XECUTE COND
if '$TEST
GOTO ENQ
+13 MERGE DIR=ORDIALOG(PROMPT)
SET DATATYPE=$EXTRACT(DIR(0))
SET DOMAIN=$PIECE(DIR(0),U,2)
+14 IF 'MULT
if DATATYPE="W"
DO WP^ORCDLG2
if DATATYPE'="W"
DO ONE(INST,REQD)
GOTO ENQ
EN1 ; -- loop for multiples
+1 IF '$ORDER(ORDIALOG(PROMPT,0))
Begin DoDot:1
M1 DO ADDMULT
if $GET(ORQUIT)
QUIT
+1 if 'REQD!$ORDER(ORDIALOG(PROMPT,0))
QUIT
IF FIRST
IF $GET(SEQ)=1
SET ORQUIT=1
QUIT
+2 WRITE $CHAR(7),!!,$$REQUIRED,!
GOTO M1
End DoDot:1
if $GET(ORQUIT)!('$ORDER(ORDIALOG(PROMPT,0)))!FIRST
GOTO ENQ
+3 FOR
SET ORX=$$SELECT
if ORX=""
QUIT
if ORX="^"
SET ORQUIT=1
if $GET(ORQUIT)
QUIT
Begin DoDot:1
+4 SET DIR("A")=ORDIALOG(PROMPT,"A")
SET X=$SELECT('REQD:0,$$ONLY(ORX):1,1:0)
+5 if ORX="A"
DO ADDMULT
if ORX
DO ONE(ORX,X)
if $GET(DIROUT)
QUIT
KILL ORQUIT,DIR("B")
+6 IF REQD
IF '$ORDER(ORDIALOG(PROMPT,0))
WRITE $CHAR(7),!!,$$REQUIRED,!
End DoDot:1
if $GET(DIROUT)
QUIT
ENQ ; exit action
if $DATA(^ORD(101.41,+ORDIALOG,10,ITM,10))
XECUTE ^(10)
+1 QUIT
+2 ;
REQUIRED() ; -- Required response message
+1 QUIT "A response is required! Enter '^' to quit."
+2 ;
SELECT() ; -- select instance of multiple to edit
+1 NEW DIR,X,Y,CNT,I,MAX,TOTAL,DONE,LAST
+2 SET MAX=+$GET(ORDIALOG(PROMPT,"MAX"))
SET TOTAL=+$GET(ORDIALOG(PROMPT,"TOT"))
+3 SET DIR("A",1)=$SELECT($LENGTH($GET(ORDIALOG(PROMPT,"TTL"))):ORDIALOG(PROMPT,"TTL"),1:ORDIALOG(PROMPT,"A"))
+4 ; parent+children
SET (I,CNT,LAST)=0
FOR
SET I=$ORDER(ORDIALOG(PROMPT,I))
if I'>0
QUIT
SET LAST=I
SET CNT=CNT+1
SET CNT(CNT)=I
SET DIR("A",CNT+1)=$JUSTIFY(CNT,3)_": "_$$ITEM^ORCDLG(PROMPT,I)
+5 IF 'MAX!(MAX&(MAX>TOTAL))
SET CNT=CNT+1
SET CNT(CNT)="A"
SET DIR("A",CNT+1)=$JUSTIFY(CNT,3)_": <enter more>"
+6 SET DIR("A")="Select "_$SELECT(CNT>1:"(1-"_CNT_")",1:1)_" or <return> to continue: "
+7 SET DIR(0)="NAO^1:"_CNT
SET DIR("?")="Select the instance you wish to change"
S1 DO ^DIR
IF $DATA(DTOUT)!(Y="^")
QUIT "^"
+1 IF Y?1"^".E
DO UJUMP
if $GET(ORQUIT)!($GET(DONE))
QUIT ""
GOTO S1
+2 IF Y=""
QUIT Y
+3 IF CNT(Y)="A"
SET ORDIALOG("CURINST")=LAST
+4 QUIT CNT(Y)
+5 ;
ONLY(I) ; -- I the only instance?
+1 NEW J,Z
SET J=0
SET Z=1
+2 FOR
SET J=$ORDER(ORDIALOG(PROMPT,J))
if J'>0
QUIT
IF J'=I
SET Z=0
QUIT
+3 QUIT Z
+4 ;
ADDMULT ; -- add new instances of multiple
+1 NEW DONE,LAST,MAX,ANOTHER,ORADDMUL
+2 SET ORADDMUL=1
+3 SET MAX=+$GET(ORDIALOG(PROMPT,"MAX"))
IF MAX
IF MAX'>$GET(ORDIALOG(PROMPT,"TOT"))
WRITE $CHAR(7),!,"Only "_MAX_" items may be selected!",!
QUIT
+4 SET ANOTHER=$GET(ORDIALOG(PROMPT,"MORE"))
if '$LENGTH(ANOTHER)
SET ANOTHER="Another "
+5 SET DIR("A")=$SELECT($ORDER(ORDIALOG(PROMPT,0)):ANOTHER,1:"")_ORDIALOG(PROMPT,"A")
+6 FOR
Begin DoDot:1
+7 SET ORDIALOG("CURINST")=1+$GET(ORDIALOG("CURINST"))
+8 DO ONE(ORDIALOG("CURINST"),0)
IF '$DATA(ORDIALOG(PROMPT,ORDIALOG("CURINST")))
SET DONE=1
QUIT
+9 SET ORDIALOG(PROMPT,"TOT")=+$GET(ORDIALOG(PROMPT,"TOT"))+1
SET DIR("A")=ANOTHER_ORDIALOG(PROMPT,"A")
End DoDot:1
if $GET(ORQUIT)!($GET(DONE))
QUIT
IF MAX
if MAX'>$GET(ORDIALOG(PROMPT,"TOT"))
QUIT
+10 QUIT
+11 ;
ONE(ORI,REQD) ; -- ask single-valued prompt
+1 NEW DONE,ORESET,QUERY
+2 if $DATA(ORDIALOG(PROMPT,ORI))
SET DIR("B")=$$EXT^ORCD(PROMPT,ORI)
SET ORESET=ORDIALOG(PROMPT,ORI)
+3 ;DJE/VM *350 Quick Order creation should query for schedule after dose.
SET QUERY=0
IF $GET(ORTYPE)="Z"
IF PROMPT=$$PTR^ORCD("OR GTX INSTRUCTIONS")
Begin DoDot:1
+4 NEW SCHEDITEM
SET SCHEDITEM=$ORDER(^ORD(101.41,+ORDIALOG,10,"D",$$PTR^ORCD("OR GTX SCHEDULE"),""))
if 'SCHEDITEM
QUIT
+5 ;see if schedule is a child of dose
IF $PIECE(^ORD(101.41,+ORDIALOG,10,SCHEDITEM,0),U,11)=PROMPT
SET QUERY=1
End DoDot:1
+6 FOR
Begin DoDot:1
+7 DO DIR^ORCDLG2
IF $DATA(DTOUT)!$DATA(DIROUT)!(X=U)
SET ORQUIT=1
QUIT
+8 IF 'QUERY
IF X=""
SET DONE=1
QUIT
+9 IF X?1"^".E
DO UJUMP
QUIT
+10 IF X="@"
DO DELETE
if 'QUERY
QUIT
+11 IF $EXTRACT(DIR(0))="N"
IF Y<1
IF $EXTRACT(Y,1,2)'="0."
SET Y=0_Y
+12 SET ORDIALOG(PROMPT,ORI)=$PIECE(Y,U)
SET DONE=1
+13 ; validate - if failed, K DONE to reask
if $LENGTH($GET(^ORD(101.41,+ORDIALOG,10,ITM,5)))
XECUTE ^(5)
IF '$GET(DONE)
DO RESET
QUIT
+14 if $DATA(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT))
DO CHILDREN(PROMPT,ORI)
IF '$GET(DONE)
IF 'FIRST
DO DELCHILD(PROMPT,ORI)
DO RESET
QUIT
+15 ;DJE/VM *350 disable empty parent node if children have no data
IF QUERY
IF ORDIALOG(PROMPT,ORI)=""
Begin DoDot:2
+16 NEW SEQ,DA,PTR,VALUE
+17 SET SEQ=0
FOR
SET SEQ=$ORDER(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,SEQ))
if SEQ'>0
QUIT
SET DA=$ORDER(^(SEQ,0))
SET PTR=+$PIECE($GET(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2)
if PTR&$DATA(ORDIALOG(PTR,ORI))
SET VALUE=1
+18 IF '$GET(VALUE)
KILL ORDIALOG(PROMPT,ORI)
End DoDot:2
End DoDot:1
if $GET(DONE)
QUIT
IF $GET(ORQUIT)
if FIRST
QUIT
if 'REQD!$DATA(ORDIALOG(PROMPT,ORI))
QUIT
SET FIRST=$$DONE^ORCDLG2
if FIRST
QUIT
KILL ORQUIT
+19 QUIT
+20 ;
CHILDREN(PARENT,INST) ; -- ask child prompts
+1 NEW SEQ,DA,ORQUIT
SET SEQ=0
+2 FOR
SET SEQ=$ORDER(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ))
if SEQ'>0
QUIT
SET DA=$ORDER(^(SEQ,0))
DO EN(DA,INST)
if $GET(ORJUMP)
KILL ORJUMP
if $GET(ORQUIT)
QUIT
+3 ; reask parent
if $GET(ORQUIT)
KILL DONE
+4 QUIT
+5 ;
RESET ; -- Reset original prompt value
+1 KILL ORDIALOG(PROMPT,ORI)
+2 if $DATA(ORESET)
SET ORDIALOG(PROMPT,ORI)=ORESET
+3 QUIT
+4 ;
UJUMP ; -- ^-jump
+1 ; XP=$$UP(X),P=PROMPT
NEW XP,P,CNT,MATCH,I,DIR,NEWSEQ
+2 IF $GET(NOJUMP)
WRITE $CHAR(7)," ^-jumping not allowed!"
QUIT
+3 SET XP=$$UP^XLFSTR($PIECE(X,U,2))
IF "^"[XP
SET ORQUIT=1
QUIT
+4 IF $GET(ORDIALOG("B",XP))
SET NEWSEQ=+ORDIALOG("B",XP)
GOTO UJQ
+5 ; =SEQ^TEXT
SET CNT=0
SET P=XP
FOR
SET P=$ORDER(ORDIALOG("B",P))
if P=""
QUIT
if $EXTRACT(P,1,$LENGTH(XP))'=XP
QUIT
if FIRST&(+ORDIALOG("B",P)'<SEQ)
QUIT
SET CNT=CNT+1
SET MATCH(CNT)=+ORDIALOG("B",P)_U_P
+6 IF 'CNT
WRITE $CHAR(7)," ??"
QUIT
+7 IF CNT=1
SET P=$PIECE(MATCH(1),U,2)
WRITE $EXTRACT(P,$LENGTH(XP)+1,$LENGTH(P))
SET NEWSEQ=+MATCH(1)
GOTO UJQ
+8 FOR I=1:1:CNT
SET DIR("A",I)=I_" "_$PIECE(MATCH(I),U,2)
+9 SET DIR("A")="Select 1-"_CNT_": "
SET DIR(0)="NAO^1:"_CNT
+10 SET DIR("?")="Select the field you wish to jump to, by number"
+11 DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!(Y="")
QUIT
+12 SET NEWSEQ=+MATCH(Y)
UJQ IF FIRST
IF NEWSEQ'<SEQ
WRITE $CHAR(7)," ^-jumping ahead not allowed now!"
QUIT
+1 SET SEQ=NEWSEQ-.01
SET DONE=1
+2 IF $GET(ORADDMUL)
SET ORJUMP=1
+3 QUIT
+4 ;
DELETE ; -- delete response
+1 IF '$DATA(DIR("B"))
WRITE $CHAR(7)," ??"
QUIT
+2 if '$$SURE
QUIT
SET DONE=1
+3 KILL ORDIALOG(PROMPT,ORI),DIR("B")
+4 if $GET(ORDIALOG(PROMPT,"TOT"))
SET ORDIALOG(PROMPT,"TOT")=ORDIALOG(PROMPT,"TOT")-1
+5 IF 'QUERY
IF $DATA(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT))
DO DELCHILD(PROMPT,ORI)
+6 QUIT
+7 ;
DELCHILD(PARENT,INST) ; -- delete child prompts
+1 NEW SEQ,DA,PTR
if '$GET(INST)
SET INST=1
+2 SET SEQ=0
FOR
SET SEQ=$ORDER(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ))
if SEQ'>0
QUIT
SET DA=$ORDER(^(SEQ,0))
SET PTR=+$PIECE($GET(^ORD(101.41,+ORDIALOG,10,DA,0)),U,2)
if PTR
KILL ORDIALOG(PTR,INST)
+3 QUIT
+4 ;
SURE() ; -- sure you want to delete?
+1 NEW X,Y,DIR
+2 SET DIR(0)="YA"
SET DIR("A")=" Are you sure you want to delete this value? "
+3 SET DIR("B")="NO"
WRITE $CHAR(7)
DO ^DIR
+4 if $DATA(DTOUT)
SET Y="^"
+5 QUIT Y
+6 ;
VALID() ;Check to see if default value is valid. Returns 0 or 1
+1 ;Entire section added in patch 95
+2 NEW TYPE,RANGE,MIN,MAX,DIR,X,ORDIC,DDS,RTYPE,ORIG
+3 ;If default is null allow to pass ;110
IF Y=""
QUIT 1
+4 ;Set reader type, default input, silent call
SET DIR(0)=$GET(ORDIALOG(PROMPT,0))
SET (ORIG,X)=Y
SET DIR("V")=""
+5 ;Get type of look-up being done
SET TYPE=$EXTRACT($PIECE(DIR(0),"^"))
+6 ;If word processing assume value is valid, may be referencing a global location
IF TYPE="W"
QUIT 1
+7 ;If type is R then change to date look up
IF TYPE="R"
SET $PIECE(DIR(0),"^")="D"_$EXTRACT($PIECE(DIR(0),"^"),2,999)
SET TYPE="D"
SET RTYPE=1
+8 ;If date/time prompt default is AM, NEXT, NEXTA, or CLOSEST then accept without checking
IF TYPE="D"
IF X="AM"!(X="NEXT")!(X="NEXTA")!(X="CLOSEST")
QUIT 1
+9 ;If pointer type add ` to IEN for DIR call
if TYPE="P"&(X=+X)
SET X="`"_X
+10 ;If pointer type remove Q&E from DIC(0) so no echo and no ?? on erroneous input
IF TYPE="P"
SET ORDIC=$PIECE(DIR(0),"^",2)
SET $PIECE(ORDIC,":",2)=$TRANSLATE($PIECE(ORDIC,":",2),"QE","")
SET $PIECE(DIR(0),"^",2)=ORDIC
+11 ;Remove "E" so no echo, remove DT and NOW so DIR call works correctly
IF TYPE="D"
SET ORDIC=$PIECE(DIR(0),"^",2)
SET $PIECE(ORDIC,":",3)=$TRANSLATE($PIECE(ORDIC,":",3),"E","")
SET $PIECE(ORDIC,":")=$TRANSLATE($PIECE(ORDIC,":"),"DTNOW","")
SET $PIECE(DIR(0),"^",2)=ORDIC
+12 ;If yes/no type convert input to uppercase full entry to avoid echo
IF TYPE="Y"
if "^Y^YE^YES^"[("^"_$TRANSLATE(X,"yes","YES")_"^")!(X=1)
SET X="YES"
if "^N^NO^"[("^"_$TRANSLATE(X,"no","NO")_"^")!(X=0)
SET X="NO"
+13 ;Stops DIR call from echoing rest of entry for set of codes
IF TYPE="S"
SET DDS=1
+14 DO ^DIR
+15 ;Date not valid
IF TYPE="D"&('$DATA(Y(0)))
QUIT 0
+16 ;List/Range not valid
IF TYPE="L"&($GET(Y)="")
QUIT 0
+17 ;Numeric not valid
IF TYPE="N"&('$DATA(Y))
QUIT 0
+18 ;Pointer not valid
IF TYPE="P"&($GET(Y)=-1)
QUIT 0
+19 ;Set of codes not valid
IF TYPE="S"&($GET(Y(0))="")
QUIT 0
+20 ;Yes/No not valid
IF TYPE="Y"&($GET(Y(0))="")
QUIT 0
+21 ;Free text and not within valid limit
IF TYPE="F"
SET RANGE=$PIECE(DIR(0),"^",2)
SET MIN=$SELECT($PIECE(RANGE,":"):$PIECE(RANGE,":"),1:1)
SET MAX=$SELECT($PIECE(RANGE,":",2):$PIECE(RANGE,":",2),1:240)
IF $LENGTH(Y)<MIN!($LENGTH(Y)>MAX)
QUIT 0
+22 ;Set y back to relative date
IF $GET(RTYPE)
SET Y=ORIG
+23 ;only store IEN ;110
IF TYPE="P"
SET Y=$PIECE(Y,"^")
+24 ;Must be valid
QUIT 1
