- 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/ORCDLG2.m
r613 r623 1 ORCDLG2 ;SLC/MKB-Order dialogs cont ;10/12/2007 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,60,79,94,243**;Dec 17, 1997;Build 242 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 DIR ; -- ^DIR read of X, returns Y 5 N INPUTXFM,LKUP,REPL K DTOUT,DUOUT,DIRUT,DIROUT,DDER,Y 6 S (X,Y)="",INPUTXFM=$P(DIR(0),U,3,99) 7 S LKUP=$G(ORDIALOG(PROMPT,"LKP")) ; special lookup rtn 8 S REPL=$S(DATATYPE'="F":0,$L($G(DIR("B")))>20:1,1:0) S:REPL DIR(0)=$E(DIR(0))_"AO^"_$P(DIR(0),U,2,99) 9 DIR1 I 'REPL W !,DIR("A")_$S($D(DIR("B")):DIR("B")_"// ",1:"") R X:DTIME I '$T S DTOUT=1 Q 10 I REPL D ^DIR Q:$D(DTOUT)!$D(DUOUT) 11 I X="" S:$D(DIR("B")) X=DIR("B"),Y=ORDIALOG(PROMPT,ORI) S:'$L(X)&(SEQ=1)&('MULT) X="^" Q:'REQD!$L(X) W $C(7),!!,$$REQUIRED^ORCDLG1,! G DIR1 12 I X="@" Q:'REQD W $C(7),!!,$$REQUIRED^ORCDLG1,! G DIR1 13 I X?1"^".E S (DUOUT,DIRUT)=1,Y=X S:X="^^" DIROUT=1 Q 14 I X?1"?".E D G DIR1 15 . N XHELP 16 . S XHELP=$S($D(DIR("??")):$P(DIR("??"),U,2,99),1:("D "_DATATYPE_"^ORCDLGH")) 17 . I (DATATYPE="P")!(DATATYPE="S")!(X?1"??".E) X XHELP 18 . S:'$D(DIR("?")) DIR("?")=$$HELP(DATATYPE) 19 . I $L(DIR("?"))<80 W !,DIR("?"),! 20 . E D W ! 21 . . N X,DIWL,DIWR,I S X=DIR("?"),DIWL=1,DIWR=80 K ^UTILITY($J,"W") 22 . . D ^DIWP F I=1:1:^UTILITY($J,"W",DIWL) W !,$G(^UTILITY($J,"W",DIWL,I,0)) 23 I $L(INPUTXFM) X INPUTXFM I '$D(X) D ERR G DIR1 24 I $L(LKUP),$L($T(@LKUP)) D @LKUP Q:Y>0 D ERR G DIR1 25 I $G(ORDIALOG(PROMPT,"LIST")) D Q:$L(Y) I $P(ORDIALOG(PROMPT,"LIST"),U,2) W $C(7) D LIST^ORCD G DIR1 26 . N OROOT S OROOT="ORDIALOG("_PROMPT_",""LIST"")" 27 . S:(X=" ")&(DATATYPE="P") X=$$SPACE(DOMAIN) 28 . S Y=$$FIND(OROOT,X) ; I X'[",",X'["-" S Y=$$FIND Q 29 . ; S ORX=$$EXPLIST(X) F S Y(Y+1)=$$FIND 30 I DATATYPE="P" D DIC I Y'>0 D ERR G DIR1 31 I (DATATYPE="R")!(DATATYPE="D") D DT I Y<0 D ERR G DIR1 32 I "^F^N^S^Y^"[(U_DATATYPE_U) D I $G(DDER) D ERR G DIR1 ;JEH 'REPL was checked 33 . N I F I=1:1:31 S X=$TR(X,$C(I)) ; strip out control char's 34 . S DIR("V")="" D ^DIR ; silent 35 Q 36 ; 37 ERR ; -- show help msg on error 38 W:$D(DIR("?")) $C(7),!,DIR("?"),! 39 Q 40 ; 41 FIND(LIST,X) ; -- find value X in LIST(#) or LIST("B",name) 42 N Y,XP,CNT,MATCH,I,DIR 43 S:$L(X)>63 X=$E(X,1,63) S X=$$UP^XLFSTR(X) 44 S CNT=0,XP="" F S XP=$O(@LIST@("B",XP)) Q:XP="" I $S(X=+X:+XP=+X,1:$E(XP,1,$L(X))=X) S CNT=CNT+1,MATCH(CNT)=@LIST@("B",XP)_U_XP,DIR("A",CNT)=$J(CNT,3)_" "_XP 45 I X=+X!(X?1"0."1.N) S Y=$G(@LIST@(X)) I $L(Y) W " "_$P(Y,U,2) G:$$OK FQ S X="" W " " ;force entire text to echo if CNT=1 46 I 'CNT S Y="" G FQ 47 I CNT=1 S Y=MATCH(1),XP=$P(Y,U,2) W $E(XP,$L(X)+1,$L(XP)) G FQ 48 S DIR("A")="Select 1-"_CNT_": ",DIR(0)="NAO^1:"_CNT 49 S DIR("?")="Select the desired value, by number" 50 D ^DIR I $D(DTOUT)!($D(DUOUT))!(Y="") S Y="" G FQ 51 S Y=MATCH(Y) W " "_$P(Y,U,2) 52 FQ D:Y&((+DOMAIN=101.43)!(DOMAIN?1"ORD(101.43,:".E)) SETDISV 53 Q Y 54 ; 55 OK() ; -- Return 1 or 0, if selected item is correct 56 N X,Y,DIR I CNT'>0 Q 1 ;no other matches 57 S DIR(0)="YA",DIR("A")=" ...OK? ",DIR("B")="YES" 58 S DIR("?")="Enter YES if this is the item you wish to select, or NO to continue searching the list" 59 D ^DIR S:$D(DUOUT)!$D(DTOUT) Y="" 60 Q +Y 61 ; 62 DIC ; -- ^DIC lookup on X, return Y 63 N ORDMN,ORDITM,DIC,D,ORDIC,TYPE S Y=-1,ORDMN=$P(ORDIALOG(PROMPT,0),U,2) 64 S ORDITM=$S(+ORDMN=101.43:1,ORDMN?1"ORD(101.43,:".E:1,1:0) ; OI file? 65 I X=" ",ORDITM D SPBAR W $S(Y>0:" "_X,1:$C(7)_" ??") Q 66 I ORDITM,X?1"`"1.N W $C(7),!,"Lookup by internal entry number not allowed!",! Q 67 I X=$G(DIR("B")) S Y=ORDIALOG(PROMPT,ORI) Q ; default 68 S DIC=$P(ORDMN,":"),DIC(0)=$P(ORDMN,":",2),ORDIC="^DIC" S:'DIC DIC=U_DIC 69 S:$D(ORDIALOG(PROMPT,"S")) DIC("S")=ORDIALOG(PROMPT,"S") 70 S TYPE=$P($G(^ORD(100.98,+$G(ORDG),0)),U,3) 71 S:ORDITM DIC("W")="W:$S('$D(%):0,'$D(DIY):0,%=DIY:0,1:1) $G(DIY)"_$S(TYPE["RX":" W:$P($G(^(""PS"")),U,6) "" (non-formulary)"" ",1:"") ;W NAME if OI/synm, or NF 72 S D=$G(ORDIALOG(PROMPT,"D")),D=$TR(D,";","^") 73 I $L(D) S ORDIC="IX^DIC" S:$L(D,U)>1 ORDIC="MIX^DIC1",DIC(0)=DIC(0)_"M" 74 D @ORDIC,SETDISV:Y&ORDITM 75 I DIC(0)["S",X'=$P(Y,"^",2) W " ",$P(Y,"^",2) 76 Q 77 ; 78 SPACE(FILE) ; -- Resolve spbar-return for ptrs 79 N X,Y,DIC,ROOT S X=" ",FILE=$P(FILE,":") 80 I (+FILE=101.43)!(FILE="ORD(101.43,") D SPBAR Q X 81 S ROOT=$S(+FILE:$$ROOT^DILFD(+FILE),1:U_FILE),Y=$G(^DISV(DUZ,ROOT)) 82 S:Y X=$P(@(ROOT_Y_",0)"),U) 83 Q X 84 ; 85 SPBAR ; -- Resolve spbar-return for #101.43 86 N SDX,I,X1,D S SDX="",D=$G(ORDIALOG(PROMPT,"D")),D=$TR(D,";","^") 87 F I=1:1:$L(D,"^") I $P(D,U,I)?1"S."1.E S SDX=$P(D,U,I) Q 88 Q:'$L(SDX) S X1=$G(^DISV(DUZ,"ORDITM",SDX,1)) Q:'$L(X1) 89 S Y=$O(^ORD(101.43,SDX,X1,0)) S:Y X=X1,Y=Y_U_X1 90 Q 91 ; 92 SETDISV ; -- Save entry Y=ifn^name in ^DISV for #101.43 93 N SDX,I Q:'$L($P(Y,U,2)) 94 S SDX="",D=$G(ORDIALOG(PROMPT,"D")) Q:D'["S." 95 F I=1:1:$L(D,";") I $P(D,";",I)?1"S."1.E S SDX=$P(D,";",I) Q 96 Q:'$L(SDX) S ^DISV(DUZ,"ORDITM",SDX,1)=$P(Y,U,2) 97 Q 98 ; 99 DT ; -- %DT validation on X, return Y 100 N %DT,BEG,END S %DT=$P(DOMAIN,":",3),X=$$UP^XLFSTR(X) 101 I $L($P(DOMAIN,":")) S BEG=$$FMDT($P(DOMAIN,":")) ;earliest date allowed 102 I $L($P(DOMAIN,":",2)) S END=$$FMDT($P(DOMAIN,":",2)) ;latest allowed 103 D ^%DT Q:Y'>0 104 I $G(BEG) D Q:Y<0 105 . I $L(Y,".")'=$L(BEG,".") S BEG=$P(BEG,".") ; date only 106 . I Y<BEG W $C(7),!,"Date may not be before "_$$FMTE^XLFDT(BEG) S Y=-1 Q 107 I $G(END) D Q:Y<0 108 . I $L(Y,".")'=$L(END,".") S END=$P(END,".") ; date only 109 . I Y>END W $C(7),!,"Date may not be after "_$$FMTE^XLFDT(END) S Y=-1 Q 110 I DATATYPE="R",$$RELDT(X) S:(%DT'["T")&("NOW"[X) X="TODAY" S Y=X ;text 111 Q 112 DT1 S:X="NOON" X="T@NOON" S:$E("MIDNIGHT",1,$L(X))=X X="T@MIDNIGHT" 113 I X'?1"V".E,X'?1"T".E D ^%DT S:Y>0&("NOW"[X) Y="NOW" Q 114 S D=$$UP^XLFSTR($P(X,"@")),T=$P(X,"@",2) 115 S Y=$E(D) I "VT"'[Y S Y=-1 Q 116 I (D["+")!(D["-") D Q:Y<0 117 . N SIGN,OFFSET,X1,X2 118 . S SIGN=$S(D["+":"+",1:"-"),OFFSET=$P(D,SIGN,2) I 'OFFSET S Y=-1 Q 119 . S X1=+OFFSET,X2=$P(OFFSET,X1,2) I "DWM"'[$E(X2) S Y=-1 Q 120 . S Y=Y_SIGN_X1_$E(X2) ; T+3W, e.g. 121 I '$L(T)&(DOMAIN["R") S Y=-1 Q ; time missing, required 122 I $L(T) D I '$D(T) S Y=-1 Q 123 . I '(DOMAIN["T"!(DOMAIN["R")) K T Q ; time prohibited 124 . N X,Y S X="T@"_T,%DT=$TR(DOMAIN,"E") D ^%DT I Y<0 K T Q 125 . S T=$E($P(Y,".",2),1,4) S:$L(T)<4 T=T_$E("0000",1,4-$L(T)) 126 S:$L(T) Y=Y_"@"_T ; Y=date text, or -1 if error 127 Q 128 ; 129 RELDT(X) ; -- Returns 1 or 0, if X is relative date 130 N Y S X=$G(X) 131 I ("NOON"[X)!("MIDNIGHT"[X)!($E(X)="T")!($E(X)="N") S Y=1 132 E S Y=0 133 Q Y 134 ; 135 FMDT(X) ; -- Return FM form of date X 136 N Y,%DT S %DT="T" D ^%DT 137 Q Y 138 ; 139 WP ; -- edit WP field 140 N DIC,DWLW,DWPK,DIWESUB,DONE,ORLINEDT,LCNT,UPCARR 141 S DIC="^TMP(""ORWORD"",$J,"_PROMPT_","_INST_",",DWLW=80,DWPK=1 142 S DIWESUB=$P(DIR("A"),":"),ORLINEDT=$$LINEDTR(DUZ) 143 I '$D(^TMP("ORWORD",$J,PROMPT,INST)) M:$D(^ORD(101.41,+ORDIALOG,10,ITM,8))>9 ^TMP("ORWORD",$J,PROMPT,INST)=^(8) 144 I 'ORLINEDT,'REQD,'$$EDITWP Q ;94 145 WP1 W:ORLINEDT !,DIR("A") S DIWESUB=$P(DIR("A"),":") 146 D EN^DIWE I $D(DTOUT)!($D(DUOUT)) S ORQUIT=1 Q 147 I REQD,'$O(^TMP("ORWORD",$J,PROMPT,INST,0)) W $C(7),!!,"A response is required!" G:'$$DONE WP1 S ORQUIT=1 Q 148 I '$O(^TMP("ORWORD",$J,PROMPT,INST,0)) K ^TMP("ORWORD",$J,PROMPT,INST),ORDIALOG(PROMPT,INST) Q ;empty 149 S LCNT="",UPCARR=0 150 F S LCNT=$O(^TMP("ORWORD",$J,PROMPT,INST,LCNT)) Q:LCNT=""!(UPCARR=1) D 151 .I LCNT>0,$G(^TMP("ORWORD",$J,PROMPT,INST,LCNT,0))[U S UPCARR=1 152 I UPCARR=1 W !!,"An ""^"" is not allowed in a word processing field." G:'$$DONE WP1 S ORQUIT=1 Q 153 S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")",DONE=1 154 I $D(^ORD(101.41,+ORDIALOG,10,ITM,5)) X ^(5) Q:$G(ORQUIT)!($G(DONE)) G WP1 155 Q 156 ; 157 EDITWP() ; -- Want to edit WP field? 158 N X,Y,%,%Y 159 W !,ORDIALOG(PROMPT,"A") S Y=$D(ORDIALOG(PROMPT,INST)) 160 I 'Y,REQD Q 1 ; no data, req'd 161 W:'Y !," No existing text",! I Y D ; show comments 162 . N X,DIWL,DIWR,DIWF,ORI 163 . S DIWL=3,DIWR=79,DIWF="W" K ^UTILITY($J,"W") 164 . S ORI=0 F S ORI=$O(^TMP("ORWORD",$J,PROMPT,INST,ORI)) Q:ORI'>0 S X=$G(^(ORI,0)) D:$L(X) ^DIWP 165 . D ^DIWW 166 ED1 S %=$S($D(OREDIT):1,1:2) W " Edit" D YN^DICN 167 I %=0 W !," Enter 'YES' if you wish to go into the editor.",!," Enter 'NO' if you do not wish to edit at this time.",! G ED1 168 S Y=$S(%<0:"^",%=2:0,1:1) 169 Q Y 170 ; 171 LINEDTR(USER) ; -- Returns 1 or 0, if user's editor will be LineEd 172 N X,Y 173 S X=+$P($G(^VA(200,USER,1)),U,5),Y=0 I 'X S Y=1 174 E S:$$GET1^DIQ(1.2,+X_",",.01)="LINE EDITOR - VA FILEMAN" Y=1 175 Q Y 176 ; 177 RETURN() ; -- press return to cont 178 N X W !,"Press <return> to continue ..." R X:DTIME 179 Q "" 180 ; 181 DONE() ; -- Done editing? 182 N DIR,X,Y 183 S DIR(0)="YA",DIR("A")="Do you want to quit? ",DIR("B")="NO" 184 S DIR("?")="Enter YES to exit this order, or NO to continue editing" 185 D ^DIR 186 Q +Y 187 ; 188 HELP(TYPE) ; -- Returns default help msg for TYPE prompt 189 N Y S Y="" 190 I TYPE="D" S Y="Enter a date[/time]." 191 I TYPE="R" S Y="Enter a date[/time] as T for TODAY or T+1 for TOMORROW." 192 I TYPE="F" S Y="Enter a string of text." 193 I TYPE="N" S Y="Enter a number." 194 I TYPE="S" S Y="Enter an item from the list." 195 I TYPE="Y" S Y="Enter YES or NO." 196 I TYPE="P" S Y="Enter an item from the file." 197 I TYPE="W" S Y="" 198 Q Y 1 ORCDLG2 ;SLC/MKB-Order dialogs cont ;3/13/01 11:16 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,60,79,94**;Dec 17, 1997 3 DIR ; -- ^DIR read of X, returns Y 4 N INPUTXFM,LKUP,REPL K DTOUT,DUOUT,DIRUT,DIROUT,DDER,Y 5 S (X,Y)="",INPUTXFM=$P(DIR(0),U,3,99) 6 S LKUP=$G(ORDIALOG(PROMPT,"LKP")) ; special lookup rtn 7 S REPL=$S(DATATYPE'="F":0,$L($G(DIR("B")))>20:1,1:0) S:REPL DIR(0)=$E(DIR(0))_"AO^"_$P(DIR(0),U,2,99) 8 DIR1 I 'REPL W !,DIR("A")_$S($D(DIR("B")):DIR("B")_"// ",1:"") R X:DTIME I '$T S DTOUT=1 Q 9 I REPL D ^DIR Q:$D(DTOUT)!$D(DUOUT) 10 I X="" S:$D(DIR("B")) X=DIR("B"),Y=ORDIALOG(PROMPT,ORI) S:'$L(X)&(SEQ=1)&('MULT) X="^" Q:'REQD!$L(X) W $C(7),!!,$$REQUIRED^ORCDLG1,! G DIR1 11 I X="@" Q:'REQD W $C(7),!!,$$REQUIRED^ORCDLG1,! G DIR1 12 I X?1"^".E S (DUOUT,DIRUT)=1,Y=X S:X="^^" DIROUT=1 Q 13 I X?1"?".E D G DIR1 14 . N XHELP 15 . S XHELP=$S($D(DIR("??")):$P(DIR("??"),U,2,99),1:("D "_DATATYPE_"^ORCDLGH")) 16 . I (DATATYPE="P")!(DATATYPE="S")!(X?1"??".E) X XHELP 17 . S:'$D(DIR("?")) DIR("?")=$$HELP(DATATYPE) 18 . I $L(DIR("?"))<80 W !,DIR("?"),! 19 . E D W ! 20 . . N X,DIWL,DIWR,I S X=DIR("?"),DIWL=1,DIWR=80 K ^UTILITY($J,"W") 21 . . D ^DIWP F I=1:1:^UTILITY($J,"W",DIWL) W !,$G(^UTILITY($J,"W",DIWL,I,0)) 22 I $L(INPUTXFM) X INPUTXFM I '$D(X) D ERR G DIR1 23 I $L(LKUP),$L($T(@LKUP)) D @LKUP Q:Y>0 D ERR G DIR1 24 I $G(ORDIALOG(PROMPT,"LIST")) D Q:$L(Y) I $P(ORDIALOG(PROMPT,"LIST"),U,2) W $C(7) D LIST^ORCD G DIR1 25 . N OROOT S OROOT="ORDIALOG("_PROMPT_",""LIST"")" 26 . S:(X=" ")&(DATATYPE="P") X=$$SPACE(DOMAIN) 27 . S Y=$$FIND(OROOT,X) ; I X'[",",X'["-" S Y=$$FIND Q 28 . ; S ORX=$$EXPLIST(X) F S Y(Y+1)=$$FIND 29 I DATATYPE="P" D DIC I Y'>0 D ERR G DIR1 30 I (DATATYPE="R")!(DATATYPE="D") D DT I Y<0 D ERR G DIR1 31 I "^F^N^S^Y^"[(U_DATATYPE_U),'REPL D I $G(DDER) D ERR G DIR1 32 . N I F I=1:1:31 S X=$TR(X,$C(I)) ; strip out control char's 33 . S DIR("V")="" D ^DIR ; silent 34 Q 35 ; 36 ERR ; -- show help msg on error 37 W:$D(DIR("?")) $C(7),!,DIR("?"),! 38 Q 39 ; 40 FIND(LIST,X) ; -- find value X in LIST(#) or LIST("B",name) 41 N Y,XP,CNT,MATCH,I,DIR 42 S:$L(X)>63 X=$E(X,1,63) S X=$$UP^XLFSTR(X) 43 S CNT=0,XP="" F S XP=$O(@LIST@("B",XP)) Q:XP="" I $S(X=+X:+XP=+X,1:$E(XP,1,$L(X))=X) S CNT=CNT+1,MATCH(CNT)=@LIST@("B",XP)_U_XP,DIR("A",CNT)=$J(CNT,3)_" "_XP 44 I X=+X S Y=$G(@LIST@(X)) I $L(Y) W " "_$P(Y,U,2) G:$$OK FQ S X="" W " " ;force entire text to echo if CNT=1 45 I 'CNT S Y="" G FQ 46 I CNT=1 S Y=MATCH(1),XP=$P(Y,U,2) W $E(XP,$L(X)+1,$L(XP)) G FQ 47 S DIR("A")="Select 1-"_CNT_": ",DIR(0)="NAO^1:"_CNT 48 S DIR("?")="Select the desired value, by number" 49 D ^DIR I $D(DTOUT)!($D(DUOUT))!(Y="") S Y="" G FQ 50 S Y=MATCH(Y) W " "_$P(Y,U,2) 51 FQ D:Y&((+DOMAIN=101.43)!(DOMAIN?1"ORD(101.43,:".E)) SETDISV 52 Q Y 53 ; 54 OK() ; -- Return 1 or 0, if selected item is correct 55 N X,Y,DIR I CNT'>0 Q 1 ;no other matches 56 S DIR(0)="YA",DIR("A")=" ...OK? ",DIR("B")="YES" 57 S DIR("?")="Enter YES if this is the item you wish to select, or NO to continue searching the list" 58 D ^DIR S:$D(DUOUT)!$D(DTOUT) Y="" 59 Q +Y 60 ; 61 DIC ; -- ^DIC lookup on X, return Y 62 N ORDMN,ORDITM,DIC,D,ORDIC,TYPE S Y=-1,ORDMN=$P(ORDIALOG(PROMPT,0),U,2) 63 S ORDITM=$S(+ORDMN=101.43:1,ORDMN?1"ORD(101.43,:".E:1,1:0) ; OI file? 64 I X=" ",ORDITM D SPBAR W $S(Y>0:" "_X,1:$C(7)_" ??") Q 65 I ORDITM,X?1"`"1.N W $C(7),!,"Lookup by internal entry number not allowed!",! Q 66 I X=$G(DIR("B")) S Y=ORDIALOG(PROMPT,ORI) Q ; default 67 S DIC=$P(ORDMN,":"),DIC(0)=$P(ORDMN,":",2),ORDIC="^DIC" S:'DIC DIC=U_DIC 68 S:$D(ORDIALOG(PROMPT,"S")) DIC("S")=ORDIALOG(PROMPT,"S") 69 S TYPE=$P($G(^ORD(100.98,+$G(ORDG),0)),U,3) 70 S:ORDITM DIC("W")="W:$S('$D(%):0,'$D(DIY):0,%=DIY:0,1:1) $G(DIY)"_$S(TYPE["RX":" W:$P($G(^(""PS"")),U,6) "" (non-formulary)"" ",1:"") ;W NAME if OI/synm, or NF 71 S D=$G(ORDIALOG(PROMPT,"D")),D=$TR(D,";","^") 72 I $L(D) S ORDIC="IX^DIC" S:$L(D,U)>1 ORDIC="MIX^DIC1",DIC(0)=DIC(0)_"M" 73 D @ORDIC,SETDISV:Y&ORDITM 74 I DIC(0)["S",X'=$P(Y,"^",2) W " ",$P(Y,"^",2) 75 Q 76 ; 77 SPACE(FILE) ; -- Resolve spbar-return for ptrs 78 N X,Y,DIC,ROOT S X=" ",FILE=$P(FILE,":") 79 I (+FILE=101.43)!(FILE="ORD(101.43,") D SPBAR Q X 80 S ROOT=$S(+FILE:$$ROOT^DILFD(+FILE),1:U_FILE),Y=$G(^DISV(DUZ,ROOT)) 81 S:Y X=$P(@(ROOT_Y_",0)"),U) 82 Q X 83 ; 84 SPBAR ; -- Resolve spbar-return for #101.43 85 N SDX,I,X1,D S SDX="",D=$G(ORDIALOG(PROMPT,"D")),D=$TR(D,";","^") 86 F I=1:1:$L(D,"^") I $P(D,U,I)?1"S."1.E S SDX=$P(D,U,I) Q 87 Q:'$L(SDX) S X1=$G(^DISV(DUZ,"ORDITM",SDX,1)) Q:'$L(X1) 88 S Y=$O(^ORD(101.43,SDX,X1,0)) S:Y X=X1,Y=Y_U_X1 89 Q 90 ; 91 SETDISV ; -- Save entry Y=ifn^name in ^DISV for #101.43 92 N SDX,I Q:'$L($P(Y,U,2)) 93 S SDX="",D=$G(ORDIALOG(PROMPT,"D")) Q:D'["S." 94 F I=1:1:$L(D,";") I $P(D,";",I)?1"S."1.E S SDX=$P(D,";",I) Q 95 Q:'$L(SDX) S ^DISV(DUZ,"ORDITM",SDX,1)=$P(Y,U,2) 96 Q 97 ; 98 DT ; -- %DT validation on X, return Y 99 N %DT,BEG,END S %DT=$P(DOMAIN,":",3),X=$$UP^XLFSTR(X) 100 I $L($P(DOMAIN,":")) S BEG=$$FMDT($P(DOMAIN,":")) ;earliest date allowed 101 I $L($P(DOMAIN,":",2)) S END=$$FMDT($P(DOMAIN,":",2)) ;latest allowed 102 D ^%DT Q:Y'>0 103 I $G(BEG) D Q:Y<0 104 . I $L(Y,".")'=$L(BEG,".") S BEG=$P(BEG,".") ; date only 105 . I Y<BEG W $C(7),!,"Date may not be before "_$$FMTE^XLFDT(BEG) S Y=-1 Q 106 I $G(END) D Q:Y<0 107 . I $L(Y,".")'=$L(END,".") S END=$P(END,".") ; date only 108 . I Y>END W $C(7),!,"Date may not be after "_$$FMTE^XLFDT(END) S Y=-1 Q 109 I DATATYPE="R",$$RELDT(X) S:(%DT'["T")&("NOW"[X) X="TODAY" S Y=X ;text 110 Q 111 DT1 S:X="NOON" X="T@NOON" S:$E("MIDNIGHT",1,$L(X))=X X="T@MIDNIGHT" 112 I X'?1"V".E,X'?1"T".E D ^%DT S:Y>0&("NOW"[X) Y="NOW" Q 113 S D=$$UP^XLFSTR($P(X,"@")),T=$P(X,"@",2) 114 S Y=$E(D) I "VT"'[Y S Y=-1 Q 115 I (D["+")!(D["-") D Q:Y<0 116 . N SIGN,OFFSET,X1,X2 117 . S SIGN=$S(D["+":"+",1:"-"),OFFSET=$P(D,SIGN,2) I 'OFFSET S Y=-1 Q 118 . S X1=+OFFSET,X2=$P(OFFSET,X1,2) I "DWM"'[$E(X2) S Y=-1 Q 119 . S Y=Y_SIGN_X1_$E(X2) ; T+3W, e.g. 120 I '$L(T)&(DOMAIN["R") S Y=-1 Q ; time missing, required 121 I $L(T) D I '$D(T) S Y=-1 Q 122 . I '(DOMAIN["T"!(DOMAIN["R")) K T Q ; time prohibited 123 . N X,Y S X="T@"_T,%DT=$TR(DOMAIN,"E") D ^%DT I Y<0 K T Q 124 . S T=$E($P(Y,".",2),1,4) S:$L(T)<4 T=T_$E("0000",1,4-$L(T)) 125 S:$L(T) Y=Y_"@"_T ; Y=date text, or -1 if error 126 Q 127 ; 128 RELDT(X) ; -- Returns 1 or 0, if X is relative date 129 N Y S X=$G(X) 130 I ("NOON"[X)!("MIDNIGHT"[X)!($E(X)="T")!($E(X)="N") S Y=1 131 E S Y=0 132 Q Y 133 ; 134 FMDT(X) ; -- Return FM form of date X 135 N Y,%DT S %DT="T" D ^%DT 136 Q Y 137 ; 138 WP ; -- edit WP field 139 N DIC,DWLW,DWPK,DIWESUB,DONE,ORLINEDT 140 S DIC="^TMP(""ORWORD"",$J,"_PROMPT_","_INST_",",DWLW=80,DWPK=1 141 S DIWESUB=$P(DIR("A"),":"),ORLINEDT=$$LINEDTR(DUZ) 142 I '$D(^TMP("ORWORD",$J,PROMPT,INST)) M:$D(^ORD(101.41,+ORDIALOG,10,ITM,8))>9 ^TMP("ORWORD",$J,PROMPT,INST)=^(8) 143 I 'ORLINEDT,'REQD,'$$EDITWP Q ;94 144 WP1 W:ORLINEDT !,DIR("A") S DIWESUB=$P(DIR("A"),":") 145 D EN^DIWE I $D(DTOUT)!($D(DUOUT)) S ORQUIT=1 Q 146 I REQD,'$O(^TMP("ORWORD",$J,PROMPT,INST,0)) W $C(7),!!,"A response is required!" G:'$$DONE WP1 S ORQUIT=1 Q 147 I '$O(^TMP("ORWORD",$J,PROMPT,INST,0)) K ^TMP("ORWORD",$J,PROMPT,INST),ORDIALOG(PROMPT,INST) Q ;empty 148 S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")",DONE=1 149 I $D(^ORD(101.41,+ORDIALOG,10,ITM,5)) X ^(5) Q:$G(ORQUIT)!($G(DONE)) G WP1 150 Q 151 ; 152 EDITWP() ; -- Want to edit WP field? 153 N X,Y,%,%Y 154 W !,ORDIALOG(PROMPT,"A") S Y=$D(ORDIALOG(PROMPT,INST)) 155 I 'Y,REQD Q 1 ; no data, req'd 156 W:'Y !," No existing text",! I Y D ; show comments 157 . N X,DIWL,DIWR,DIWF,ORI 158 . S DIWL=3,DIWR=79,DIWF="W" K ^UTILITY($J,"W") 159 . S ORI=0 F S ORI=$O(^TMP("ORWORD",$J,PROMPT,INST,ORI)) Q:ORI'>0 S X=$G(^(ORI,0)) D:$L(X) ^DIWP 160 . D ^DIWW 161 ED1 S %=$S($D(OREDIT):1,1:2) W " Edit" D YN^DICN 162 I %=0 W !," Enter 'YES' if you wish to go into the editor.",!," Enter 'NO' if you do not wish to edit at this time.",! G ED1 163 S Y=$S(%<0:"^",%=2:0,1:1) 164 Q Y 165 ; 166 LINEDTR(USER) ; -- Returns 1 or 0, if user's editor will be LineEd 167 N X,Y 168 S X=+$P($G(^VA(200,USER,1)),U,5),Y=0 I 'X S Y=1 169 E S:$$GET1^DIQ(1.2,+X_",",.01)="LINE EDITOR - VA FILEMAN" Y=1 170 Q Y 171 ; 172 RETURN() ; -- press return to cont 173 N X W !,"Press <return> to continue ..." R X:DTIME 174 Q "" 175 ; 176 DONE() ; -- Done editing? 177 N DIR,X,Y 178 S DIR(0)="YA",DIR("A")="Do you want to quit? ",DIR("B")="NO" 179 S DIR("?")="Enter YES to exit this order, or NO to continue editing" 180 D ^DIR 181 Q +Y 182 ; 183 HELP(TYPE) ; -- Returns default help msg for TYPE prompt 184 N Y S Y="" 185 I TYPE="D" S Y="Enter a date[/time]." 186 I TYPE="R" S Y="Enter a date[/time] as T for TODAY or T+1 for TOMORROW." 187 I TYPE="F" S Y="Enter a string of text." 188 I TYPE="N" S Y="Enter a number." 189 I TYPE="S" S Y="Enter an item from the list." 190 I TYPE="Y" S Y="Enter YES or NO." 191 I TYPE="P" S Y="Enter an item from the file." 192 I TYPE="W" S Y="" 193 Q Y
Note:
See TracChangeset
for help on using the changeset viewer.
