- 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 Feb 18, 2025@23:54:35 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