- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCDLG1.m
r613 r623 1 ORCDLG1 ; SLC/MKB - Order dialogs cont ;12/15/2006 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**60,71,95,110,243**;Dec 17, 1997;Build 242 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 EN(ITM,INST) ; -- ask each ITM prompt where 5 ; ORDIALOG(PROMPT,#) = internal form of each response 6 ; 7 N ITEM,COND,MULT,REQD,EDITONLY,DATATYPE,DOMAIN,DIR,Y,ACTION,PROMPT,ORX,VALIDEF 8 S ITEM=$G(^ORD(101.41,+ORDIALOG,10,ITM,0)),COND=$G(^(3)) 9 S PROMPT=$P(ITEM,U,2) Q:'PROMPT S:'$G(INST) INST=1 10 S MULT=$P(ITEM,U,7),ACTION=$P(ITEM,U,9) 11 S REQD=$P(ITEM,U,6),EDITONLY=$P(ITEM,U,8) S:$G(ORTYPE)="Z" (REQD,EDITONLY)=0 12 I $D(^ORD(101.41,+ORDIALOG,10,ITM,9)) X ^(9) G:$G(ORQUIT) ENQ ;Entry 13 I $G(ORTYPE)="Q",$D(ORDIALOG(PROMPT,INST)),$E(ORDIALOG(PROMPT,0))'="W" S EDITONLY=1 14 I '$D(ORDIALOG(PROMPT,INST)) D ; get default value 15 . 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 16 . K Y X:$D(^ORD(101.41,+ORDIALOG,10,ITM,7)) ^(7) 17 . I $D(Y) S VALIDEF=$$VALID S:VALIDEF ORDIALOG(PROMPT,INST)=Y ;**95 18 . I $G(VALIDEF)=0 W !,"The DEFAULT value for the ",$G(ORDIALOG(PROMPT,"A"))," prompt is invalid." S EDITONLY=0 ;**95 19 . K VALIDEF ;**95 20 I $G(AUTO),'REQD!($E(ORDIALOG(PROMPT,0))="W"&$D(ORDIALOG(PROMPT,INST))) S EDITONLY=1 ;Auto-accept 21 EN0 I FIRST&EDITONLY D:$D(ORDIALOG(PROMPT,INST)) G ENQ ;ck child prompts 22 . Q:'$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) N SEQ,DA,ITEM,PRMT,X,Y,VALIDEF ;**95 23 . 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) 24 . . K VALIDEF ;110 25 . . S ITEM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)),PRMT=$P(ITEM,U,2) 26 . . Q:$D(ORDIALOG(PRMT,INST)) ; already has a value 27 . . K Y X:$D(^ORD(101.41,+ORDIALOG,10,DA,7)) ^(7) 28 . . I $D(Y) S VALIDEF=$$VALID ;**95 29 . . I $G(VALIDEF)!('$P(ITEM,U,6)) S:$G(VALIDEF) ORDIALOG(PRMT,INST)=Y Q ;**95 30 . . D EN(DA,INST) ; ask 31 I ($G(OREDIT)&(ACTION'["C"))!($G(ORENEW)&(ACTION'["R")) G ENQ ;ask? 32 I $G(OREWRITE),ACTION'["W",FIRST,'REQD!$D(ORDIALOG(PROMPT,INST)) G ENQ 33 I $L(COND) X COND G:'$T ENQ ; failed condition 34 M DIR=ORDIALOG(PROMPT) S DATATYPE=$E(DIR(0)),DOMAIN=$P(DIR(0),U,2) 35 I 'MULT D WP^ORCDLG2:DATATYPE="W",ONE(INST,REQD):DATATYPE'="W" G ENQ 36 EN1 ; -- loop for multiples 37 I '$O(ORDIALOG(PROMPT,0)) D G:$G(ORQUIT)!('$O(ORDIALOG(PROMPT,0)))!FIRST ENQ 38 M1 . D ADDMULT Q:$G(ORQUIT) 39 . Q:'REQD!$O(ORDIALOG(PROMPT,0)) I FIRST,$G(SEQ)=1 S ORQUIT=1 Q 40 . W $C(7),!!,$$REQUIRED,! G M1 41 F S ORX=$$SELECT Q:ORX="" S:ORX="^" ORQUIT=1 Q:$G(ORQUIT) D Q:$G(DIROUT) 42 . S DIR("A")=ORDIALOG(PROMPT,"A"),X=$S('REQD:0,$$ONLY(ORX):1,1:0) 43 . D ADDMULT:ORX="A",ONE(ORX,X):ORX Q:$G(DIROUT) K ORQUIT,DIR("B") 44 . I REQD,'$O(ORDIALOG(PROMPT,0)) W $C(7),!!,$$REQUIRED,! 45 ENQ X:$D(^ORD(101.41,+ORDIALOG,10,ITM,10)) ^(10) ; exit action 46 Q 47 ; 48 REQUIRED() ; -- Required response message 49 Q "A response is required! Enter '^' to quit." 50 ; 51 SELECT() ; -- select instance of multiple to edit 52 N DIR,X,Y,CNT,I,MAX,TOTAL,DONE 53 S MAX=+$G(ORDIALOG(PROMPT,"MAX")),TOTAL=+$G(ORDIALOG(PROMPT,"TOT")) 54 S DIR("A",1)=$S($L($G(ORDIALOG(PROMPT,"TTL"))):ORDIALOG(PROMPT,"TTL"),1:ORDIALOG(PROMPT,"A")) 55 S (I,CNT)=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 S CNT=CNT+1,CNT(CNT)=I,DIR("A",CNT+1)=$J(CNT,3)_": "_$$ITEM^ORCDLG(PROMPT,I) ; parent+children 56 I 'MAX!(MAX&(MAX>TOTAL)) S CNT=CNT+1,CNT(CNT)="A",DIR("A",CNT+1)=$J(CNT,3)_": <enter more>" 57 S DIR("A")="Select "_$S(CNT>1:"(1-"_CNT_")",1:1)_" or <return> to continue: " 58 S DIR(0)="NAO^1:"_CNT,DIR("?")="Select the instance you wish to change" 59 S1 D ^DIR I $D(DTOUT)!(Y="^") Q "^" 60 I Y?1"^".E D UJUMP Q:$G(ORQUIT)!($G(DONE)) "" G S1 61 I Y="" Q Y 62 Q CNT(Y) 63 ; 64 ONLY(I) ; -- I the only instance? 65 N J,Z S J=0,Z=1 66 F S J=$O(ORDIALOG(PROMPT,J)) Q:J'>0 I J'=I S Z=0 Q 67 Q Z 68 ; 69 ADDMULT ; -- add new instances of multiple 70 N DONE,LAST,INST,MAX,ANOTHER 71 S MAX=+$G(ORDIALOG(PROMPT,"MAX")) I MAX,MAX'>$G(ORDIALOG(PROMPT,"TOT")) W $C(7),!,"Only "_MAX_" items may be selected!",! Q 72 S ANOTHER=$G(ORDIALOG(PROMPT,"MORE")) S:'$L(ANOTHER) ANOTHER="Another " 73 S DIR("A")=$S($O(ORDIALOG(PROMPT,0)):ANOTHER,1:"")_ORDIALOG(PROMPT,"A") 74 F D Q:$G(ORQUIT)!($G(DONE)) I MAX Q:MAX'>$G(ORDIALOG(PROMPT,"TOT")) 75 . S INST=$O(ORDIALOG(PROMPT,"?"),-1)+1 76 . D ONE(INST,0) I '$D(ORDIALOG(PROMPT,INST)) S DONE=1 Q 77 . S ORDIALOG(PROMPT,"TOT")=+$G(ORDIALOG(PROMPT,"TOT"))+1,DIR("A")=ANOTHER_ORDIALOG(PROMPT,"A") 78 Q 79 ; 80 ONE(ORI,REQD) ; -- ask single-valued prompt 81 N DONE,ORESET 82 S:$D(ORDIALOG(PROMPT,ORI)) DIR("B")=$$EXT^ORCD(PROMPT,ORI),ORESET=ORDIALOG(PROMPT,ORI) 83 F D Q:$G(DONE) I $G(ORQUIT) Q:FIRST Q:'REQD!$D(ORDIALOG(PROMPT,ORI)) S FIRST=$$DONE^ORCDLG2 Q:FIRST K ORQUIT 84 . D DIR^ORCDLG2 I $D(DTOUT)!$D(DIROUT)!(X=U) S ORQUIT=1 Q 85 . I X="" S DONE=1 Q 86 . I X?1"^".E D UJUMP Q 87 . I X="@" D DELETE Q 88 . I $E(DIR(0))="N",Y<1,$E(Y,1,2)'="0." S Y=0_Y 89 . S ORDIALOG(PROMPT,ORI)=$P(Y,U),DONE=1 90 . X:$L($G(^ORD(101.41,+ORDIALOG,10,ITM,5))) ^(5) I '$G(DONE) D RESET Q ; validate - if failed, K DONE to reask 91 . D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) CHILDREN(PROMPT,ORI) I '$G(DONE),'FIRST D DELCHILD(PROMPT,ORI),RESET Q 92 Q 93 ; 94 CHILDREN(PARENT,INST) ; -- ask child prompts 95 N SEQ,DA,ORQUIT S SEQ=0 96 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0 S DA=$O(^(SEQ,0)) D EN(DA,INST) Q:$G(ORQUIT) 97 K:$G(ORQUIT) DONE ; reask parent 98 Q 99 ; 100 RESET ; -- Reset original prompt value 101 K ORDIALOG(PROMPT,ORI) 102 S:$D(ORESET) ORDIALOG(PROMPT,ORI)=ORESET 103 Q 104 ; 105 UJUMP ; -- ^-jump 106 N XP,P,CNT,MATCH,I,DIR,NEWSEQ ; XP=$$UP(X),P=PROMPT 107 I $G(NOJUMP) W $C(7)," ^-jumping not allowed!" Q 108 S XP=$$UP^XLFSTR($P(X,U,2)) I "^"[XP S ORQUIT=1 Q 109 I $G(ORDIALOG("B",XP)) S NEWSEQ=+ORDIALOG("B",XP) G UJQ 110 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 111 I 'CNT W $C(7)," ??" Q 112 I CNT=1 S P=$P(MATCH(1),U,2) W $E(P,$L(XP)+1,$L(P)) S NEWSEQ=+MATCH(1) G UJQ 113 F I=1:1:CNT S DIR("A",I)=I_" "_$P(MATCH(I),U,2) 114 S DIR("A")="Select 1-"_CNT_": ",DIR(0)="NAO^1:"_CNT 115 S DIR("?")="Select the field you wish to jump to, by number" 116 D ^DIR I $D(DTOUT)!($D(DUOUT))!(Y="") Q 117 S NEWSEQ=+MATCH(Y) 118 UJQ I FIRST,NEWSEQ'<SEQ W $C(7)," ^-jumping ahead not allowed now!" Q 119 S SEQ=NEWSEQ-.01,DONE=1 120 Q 121 ; 122 DELETE ; -- delete response 123 I '$D(DIR("B")) W $C(7)," ??" Q 124 Q:'$$SURE S DONE=1 125 K ORDIALOG(PROMPT,ORI),DIR("B") 126 S:$G(ORDIALOG(PROMPT,"TOT")) ORDIALOG(PROMPT,"TOT")=ORDIALOG(PROMPT,"TOT")-1 127 I $D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) D DELCHILD(PROMPT,ORI) 128 Q 129 ; 130 DELCHILD(PARENT,INST) ; -- delete child prompts 131 N SEQ,DA,PTR S:'$G(INST) INST=1 132 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) 133 Q 134 ; 135 SURE() ; -- sure you want to delete? 136 N X,Y,DIR 137 S DIR(0)="YA",DIR("A")=" Are you sure you want to delete this value? " 138 S DIR("B")="NO" W $C(7) D ^DIR 139 S:$D(DTOUT) Y="^" 140 Q Y 141 ; 142 VALID() ;Check to see if default value is valid. Returns 0 or 1 143 ;Entire section added in patch 95 144 N TYPE,RANGE,MIN,MAX,DIR,X,ORDIC,DDS,RTYPE,ORIG 145 I Y="" Q 1 ;If default is null allow to pass ;110 146 S DIR(0)=$G(ORDIALOG(PROMPT,0)),(ORIG,X)=Y,DIR("V")="" ;Set reader type, default input, silent call 147 S TYPE=$E($P(DIR(0),"^")) ;Get type of look-up being done 148 I TYPE="W" Q 1 ;If word processing assume value is valid, may be referencing a global location 149 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 150 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 151 S:TYPE="P"&(X=+X) X="`"_X ;If pointer type add ` to IEN for DIR call 152 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 153 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 154 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 155 I TYPE="S" S DDS=1 ;Stops DIR call from echoing rest of entry for set of codes 156 D ^DIR 157 I TYPE="D"&('$D(Y(0))) Q 0 ;Date not valid 158 I TYPE="L"&($G(Y)="") Q 0 ;List/Range not valid 159 I TYPE="N"&('$D(Y)) Q 0 ;Numeric not valid 160 I TYPE="P"&($G(Y)=-1) Q 0 ;Pointer not valid 161 I TYPE="S"&($G(Y(0))="") Q 0 ;Set of codes not valid 162 I TYPE="Y"&($G(Y(0))="") Q 0 ;Yes/No not valid 163 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 164 I $G(RTYPE) S Y=ORIG ;Set y back to relative date 165 I TYPE="P" S Y=$P(Y,"^") ;only store IEN ;110 166 Q 1 ;Must be valid 1 ORCDLG1 ; SLC/MKB - Order dialogs cont ;11/21/01 08:03 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**60,71,95,110**;Dec 17, 1997 3 EN(ITM,INST) ; -- ask each ITM prompt where 4 ; ORDIALOG(PROMPT,#) = internal form of each response 5 ; 6 N ITEM,COND,MULT,REQD,EDITONLY,DATATYPE,DOMAIN,DIR,Y,ACTION,PROMPT,ORX,VALIDEF 7 S ITEM=$G(^ORD(101.41,+ORDIALOG,10,ITM,0)),COND=$G(^(3)) 8 S PROMPT=$P(ITEM,U,2) Q:'PROMPT S:'$G(INST) INST=1 9 S MULT=$P(ITEM,U,7),ACTION=$P(ITEM,U,9) 10 S REQD=$P(ITEM,U,6),EDITONLY=$P(ITEM,U,8) S:$G(ORTYPE)="Z" (REQD,EDITONLY)=0 11 I $D(^ORD(101.41,+ORDIALOG,10,ITM,9)) X ^(9) G:$G(ORQUIT) ENQ ;Entry 12 I $G(ORTYPE)="Q",$D(ORDIALOG(PROMPT,INST)),$E(ORDIALOG(PROMPT,0))'="W" S EDITONLY=1 13 I '$D(ORDIALOG(PROMPT,INST)) D ; get default value 14 . 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 15 . K Y X:$D(^ORD(101.41,+ORDIALOG,10,ITM,7)) ^(7) 16 . I $D(Y) S VALIDEF=$$VALID S:VALIDEF ORDIALOG(PROMPT,INST)=Y ;**95 17 . I $G(VALIDEF)=0 W !,"The DEFAULT value for the ",$G(ORDIALOG(PROMPT,"A"))," prompt is invalid." S EDITONLY=0 ;**95 18 . K VALIDEF ;**95 19 I $G(AUTO),'REQD!($E(ORDIALOG(PROMPT,0))="W"&$D(ORDIALOG(PROMPT,INST))) S EDITONLY=1 ;Auto-accept 20 EN0 I FIRST&EDITONLY D:$D(ORDIALOG(PROMPT,INST)) G ENQ ;ck child prompts 21 . Q:'$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) N SEQ,DA,ITEM,PRMT,X,Y,VALIDEF ;**95 22 . 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) 23 . . K VALIDEF ;110 24 . . S ITEM=$G(^ORD(101.41,+ORDIALOG,10,DA,0)),PRMT=$P(ITEM,U,2) 25 . . Q:$D(ORDIALOG(PRMT,INST)) ; already has a value 26 . . K Y X:$D(^ORD(101.41,+ORDIALOG,10,DA,7)) ^(7) 27 . . I $D(Y) S VALIDEF=$$VALID ;**95 28 . . I $G(VALIDEF)!('$P(ITEM,U,6)) S:$G(VALIDEF) ORDIALOG(PRMT,INST)=Y Q ;**95 29 . . D EN(DA,INST) ; ask 30 I ($G(OREDIT)&(ACTION'["C"))!($G(ORENEW)&(ACTION'["R")) G ENQ ;ask? 31 I $G(OREWRITE),ACTION'["W",FIRST,'REQD!$D(ORDIALOG(PROMPT,INST)) G ENQ 32 I $L(COND) X COND G:'$T ENQ ; failed condition 33 M DIR=ORDIALOG(PROMPT) S DATATYPE=$E(DIR(0)),DOMAIN=$P(DIR(0),U,2) 34 I 'MULT D WP^ORCDLG2:DATATYPE="W",ONE(INST,REQD):DATATYPE'="W" G ENQ 35 EN1 ; -- loop for multiples 36 I '$O(ORDIALOG(PROMPT,0)) D G:$G(ORQUIT)!('$O(ORDIALOG(PROMPT,0)))!FIRST ENQ 37 M1 . D ADDMULT Q:$G(ORQUIT) 38 . Q:'REQD!$O(ORDIALOG(PROMPT,0)) I FIRST,$G(SEQ)=1 S ORQUIT=1 Q 39 . W $C(7),!!,$$REQUIRED,! G M1 40 F S ORX=$$SELECT Q:ORX="" S:ORX="^" ORQUIT=1 Q:$G(ORQUIT) D Q:$G(DIROUT) 41 . S DIR("A")=ORDIALOG(PROMPT,"A"),X=$S('REQD:0,$$ONLY(ORX):1,1:0) 42 . D ADDMULT:ORX="A",ONE(ORX,X):ORX Q:$G(DIROUT) K ORQUIT,DIR("B") 43 . I REQD,'$O(ORDIALOG(PROMPT,0)) W $C(7),!!,$$REQUIRED,! 44 ENQ X:$D(^ORD(101.41,+ORDIALOG,10,ITM,10)) ^(10) ; exit action 45 Q 46 ; 47 REQUIRED() ; -- Required response message 48 Q "A response is required! Enter '^' to quit." 49 ; 50 SELECT() ; -- select instance of multiple to edit 51 N DIR,X,Y,CNT,I,MAX,TOTAL,DONE 52 S MAX=+$G(ORDIALOG(PROMPT,"MAX")),TOTAL=+$G(ORDIALOG(PROMPT,"TOT")) 53 S DIR("A",1)=$S($L($G(ORDIALOG(PROMPT,"TTL"))):ORDIALOG(PROMPT,"TTL"),1:ORDIALOG(PROMPT,"A")) 54 S (I,CNT)=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 S CNT=CNT+1,CNT(CNT)=I,DIR("A",CNT+1)=$J(CNT,3)_": "_$$ITEM^ORCDLG(PROMPT,I) ; parent+children 55 I 'MAX!(MAX&(MAX>TOTAL)) S CNT=CNT+1,CNT(CNT)="A",DIR("A",CNT+1)=$J(CNT,3)_": <enter more>" 56 S DIR("A")="Select "_$S(CNT>1:"(1-"_CNT_")",1:1)_" or <return> to continue: " 57 S DIR(0)="NAO^1:"_CNT,DIR("?")="Select the instance you wish to change" 58 S1 D ^DIR I $D(DTOUT)!(Y="^") Q "^" 59 I Y?1"^".E D UJUMP Q:$G(ORQUIT)!($G(DONE)) "" G S1 60 I Y="" Q Y 61 Q CNT(Y) 62 ; 63 ONLY(I) ; -- I the only instance? 64 N J,Z S J=0,Z=1 65 F S J=$O(ORDIALOG(PROMPT,J)) Q:J'>0 I J'=I S Z=0 Q 66 Q Z 67 ; 68 ADDMULT ; -- add new instances of multiple 69 N DONE,LAST,INST,MAX,ANOTHER 70 S MAX=+$G(ORDIALOG(PROMPT,"MAX")) I MAX,MAX'>$G(ORDIALOG(PROMPT,"TOT")) W $C(7),!,"Only "_MAX_" items may be selected!",! Q 71 S ANOTHER=$G(ORDIALOG(PROMPT,"MORE")) S:'$L(ANOTHER) ANOTHER="Another " 72 S DIR("A")=$S($O(ORDIALOG(PROMPT,0)):ANOTHER,1:"")_ORDIALOG(PROMPT,"A") 73 F D Q:$G(ORQUIT)!($G(DONE)) I MAX Q:MAX'>$G(ORDIALOG(PROMPT,"TOT")) 74 . S INST=$O(ORDIALOG(PROMPT,"?"),-1)+1 75 . D ONE(INST,0) I '$D(ORDIALOG(PROMPT,INST)) S DONE=1 Q 76 . S ORDIALOG(PROMPT,"TOT")=+$G(ORDIALOG(PROMPT,"TOT"))+1,DIR("A")=ANOTHER_ORDIALOG(PROMPT,"A") 77 Q 78 ; 79 ONE(ORI,REQD) ; -- ask single-valued prompt 80 N DONE,ORESET 81 S:$D(ORDIALOG(PROMPT,ORI)) DIR("B")=$$EXT^ORCD(PROMPT,ORI),ORESET=ORDIALOG(PROMPT,ORI) 82 F D Q:$G(DONE) I $G(ORQUIT) Q:FIRST Q:'REQD!$D(ORDIALOG(PROMPT,ORI)) S FIRST=$$DONE^ORCDLG2 Q:FIRST K ORQUIT 83 . D DIR^ORCDLG2 I $D(DTOUT)!$D(DIROUT)!(X=U) S ORQUIT=1 Q 84 . I X="" S DONE=1 Q 85 . I X?1"^".E D UJUMP Q 86 . I X="@" D DELETE Q 87 . S ORDIALOG(PROMPT,ORI)=$P(Y,U),DONE=1 88 . X:$L($G(^ORD(101.41,+ORDIALOG,10,ITM,5))) ^(5) I '$G(DONE) D RESET Q ; validate - if failed, K DONE to reask 89 . D:$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) CHILDREN(PROMPT,ORI) I '$G(DONE),'FIRST D DELCHILD(PROMPT,ORI),RESET Q 90 Q 91 ; 92 CHILDREN(PARENT,INST) ; -- ask child prompts 93 N SEQ,DA,ORQUIT S SEQ=0 94 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PARENT,SEQ)) Q:SEQ'>0 S DA=$O(^(SEQ,0)) D EN(DA,INST) Q:$G(ORQUIT) 95 K:$G(ORQUIT) DONE ; reask parent 96 Q 97 ; 98 RESET ; -- Reset original prompt value 99 K ORDIALOG(PROMPT,ORI) 100 S:$D(ORESET) ORDIALOG(PROMPT,ORI)=ORESET 101 Q 102 ; 103 UJUMP ; -- ^-jump 104 N XP,P,CNT,MATCH,I,DIR,NEWSEQ ; XP=$$UP(X),P=PROMPT 105 I $G(NOJUMP) W $C(7)," ^-jumping not allowed!" Q 106 S XP=$$UP^XLFSTR($P(X,U,2)) I "^"[XP S ORQUIT=1 Q 107 I $G(ORDIALOG("B",XP)) S NEWSEQ=+ORDIALOG("B",XP) G UJQ 108 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 109 I 'CNT W $C(7)," ??" Q 110 I CNT=1 S P=$P(MATCH(1),U,2) W $E(P,$L(XP)+1,$L(P)) S NEWSEQ=+MATCH(1) G UJQ 111 F I=1:1:CNT S DIR("A",I)=I_" "_$P(MATCH(I),U,2) 112 S DIR("A")="Select 1-"_CNT_": ",DIR(0)="NAO^1:"_CNT 113 S DIR("?")="Select the field you wish to jump to, by number" 114 D ^DIR I $D(DTOUT)!($D(DUOUT))!(Y="") Q 115 S NEWSEQ=+MATCH(Y) 116 UJQ I FIRST,NEWSEQ'<SEQ W $C(7)," ^-jumping ahead not allowed now!" Q 117 S SEQ=NEWSEQ-.01,DONE=1 118 Q 119 ; 120 DELETE ; -- delete response 121 I '$D(DIR("B")) W $C(7)," ??" Q 122 Q:'$$SURE S DONE=1 123 K ORDIALOG(PROMPT,ORI),DIR("B") 124 S:$G(ORDIALOG(PROMPT,"TOT")) ORDIALOG(PROMPT,"TOT")=ORDIALOG(PROMPT,"TOT")-1 125 I $D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT)) D DELCHILD(PROMPT,ORI) 126 Q 127 ; 128 DELCHILD(PARENT,INST) ; -- delete child prompts 129 N SEQ,DA,PTR S:'$G(INST) INST=1 130 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) 131 Q 132 ; 133 SURE() ; -- sure you want to delete? 134 N X,Y,DIR 135 S DIR(0)="YA",DIR("A")=" Are you sure you want to delete this value? " 136 S DIR("B")="NO" W $C(7) D ^DIR 137 S:$D(DTOUT) Y="^" 138 Q Y 139 ; 140 VALID() ;Check to see if default value is valid. Returns 0 or 1 141 ;Entire section added in patch 95 142 N TYPE,RANGE,MIN,MAX,DIR,X,ORDIC,DDS,RTYPE,ORIG 143 I Y="" Q 1 ;If default is null allow to pass ;110 144 S DIR(0)=$G(ORDIALOG(PROMPT,0)),(ORIG,X)=Y,DIR("V")="" ;Set reader type, default input, silent call 145 S TYPE=$E($P(DIR(0),"^")) ;Get type of look-up being done 146 I TYPE="W" Q 1 ;If word processing assume value is valid, may be referencing a global location 147 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 148 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 149 S:TYPE="P"&(X=+X) X="`"_X ;If pointer type add ` to IEN for DIR call 150 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 151 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 152 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 153 I TYPE="S" S DDS=1 ;Stops DIR call from echoing rest of entry for set of codes 154 D ^DIR 155 I TYPE="D"&('$D(Y(0))) Q 0 ;Date not valid 156 I TYPE="L"&($G(Y)="") Q 0 ;List/Range not valid 157 I TYPE="N"&('$D(Y)) Q 0 ;Numeric not valid 158 I TYPE="P"&($G(Y)=-1) Q 0 ;Pointer not valid 159 I TYPE="S"&($G(Y(0))="") Q 0 ;Set of codes not valid 160 I TYPE="Y"&($G(Y(0))="") Q 0 ;Yes/No not valid 161 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 162 I $G(RTYPE) S Y=ORIG ;Set y back to relative date 163 I TYPE="P" S Y=$P(Y,"^") ;only store IEN ;110 164 Q 1 ;Must be valid
Note:
See TracChangeset
for help on using the changeset viewer.
