ORCDLG2 ;SLC/MKB-Order dialogs cont ;13-Oct-2014 15:27;DU
;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,60,79,94,243,1013**;Dec 17, 1997;Build 242
;;Per VHA Directive 2004-038, this routine should not be modified.
; Modified - IHS/MSC/MGH - 10/13/2014 - Line DIR1+1
DIR ; -- ^DIR read of X, returns Y
N INPUTXFM,LKUP,REPL K DTOUT,DUOUT,DIRUT,DIROUT,DDER,Y
S (X,Y)="",INPUTXFM=$P(DIR(0),U,3,99)
S LKUP=$G(ORDIALOG(PROMPT,"LKP")) ; special lookup rtn
;IHS/MSC/MGH changed the 20 in this call to 2
S REPL=$S(DATATYPE'="F":0,$L($G(DIR("B")))>2:1,1:0) S:REPL DIR(0)=$E(DIR(0))_"AO^"_$P(DIR(0),U,2,99)
DIR1 I 'REPL W !,DIR("A")_$S($D(DIR("B")):DIR("B")_"// ",1:"") R X:DTIME I '$T S DTOUT=1 Q
I REPL D ^DIR Q:$D(DTOUT)!$D(DUOUT)
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
I X="@" Q:'REQD W $C(7),!!,$$REQUIRED^ORCDLG1,! G DIR1
I X?1"^".E S (DUOUT,DIRUT)=1,Y=X S:X="^^" DIROUT=1 Q
I X?1"?".E D G DIR1
. N XHELP
. S XHELP=$S($D(DIR("??")):$P(DIR("??"),U,2,99),1:("D "_DATATYPE_"^ORCDLGH"))
. I (DATATYPE="P")!(DATATYPE="S")!(X?1"??".E) X XHELP
. S:'$D(DIR("?")) DIR("?")=$$HELP(DATATYPE)
. I $L(DIR("?"))<80 W !,DIR("?"),!
. E D W !
. . N X,DIWL,DIWR,I S X=DIR("?"),DIWL=1,DIWR=80 K ^UTILITY($J,"W")
. . D ^DIWP F I=1:1:^UTILITY($J,"W",DIWL) W !,$G(^UTILITY($J,"W",DIWL,I,0))
I $L(INPUTXFM) X INPUTXFM I '$D(X) D ERR G DIR1
I $L(LKUP),$L($T(@LKUP)) D @LKUP Q:Y>0 D ERR G DIR1
I $G(ORDIALOG(PROMPT,"LIST")) D Q:$L(Y) I $P(ORDIALOG(PROMPT,"LIST"),U,2) W $C(7) D LIST^ORCD G DIR1
. N OROOT S OROOT="ORDIALOG("_PROMPT_",""LIST"")"
. S:(X=" ")&(DATATYPE="P") X=$$SPACE(DOMAIN)
. S Y=$$FIND(OROOT,X) ; I X'[",",X'["-" S Y=$$FIND Q
. ; S ORX=$$EXPLIST(X) F S Y(Y+1)=$$FIND
I DATATYPE="P" D DIC I Y'>0 D ERR G DIR1
I (DATATYPE="R")!(DATATYPE="D") D DT I Y<0 D ERR G DIR1
I "^F^N^S^Y^"[(U_DATATYPE_U) D I $G(DDER) D ERR G DIR1 ;JEH 'REPL was checked
. N I F I=1:1:31 S X=$TR(X,$C(I)) ; strip out control char's
. S DIR("V")="" D ^DIR ; silent
Q
;
ERR ; -- show help msg on error
W:$D(DIR("?")) $C(7),!,DIR("?"),!
Q
;
FIND(LIST,X) ; -- find value X in LIST(#) or LIST("B",name)
N Y,XP,CNT,MATCH,I,DIR
S:$L(X)>63 X=$E(X,1,63) S X=$$UP^XLFSTR(X)
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
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
I 'CNT S Y="" G FQ
I CNT=1 S Y=MATCH(1),XP=$P(Y,U,2) W $E(XP,$L(X)+1,$L(XP)) G FQ
S DIR("A")="Select 1-"_CNT_": ",DIR(0)="NAO^1:"_CNT
S DIR("?")="Select the desired value, by number"
D ^DIR I $D(DTOUT)!($D(DUOUT))!(Y="") S Y="" G FQ
S Y=MATCH(Y) W " "_$P(Y,U,2)
FQ D:Y&((+DOMAIN=101.43)!(DOMAIN?1"ORD(101.43,:".E)) SETDISV
Q Y
;
OK() ; -- Return 1 or 0, if selected item is correct
N X,Y,DIR I CNT'>0 Q 1 ;no other matches
S DIR(0)="YA",DIR("A")=" ...OK? ",DIR("B")="YES"
S DIR("?")="Enter YES if this is the item you wish to select, or NO to continue searching the list"
D ^DIR S:$D(DUOUT)!$D(DTOUT) Y=""
Q +Y
;
DIC ; -- ^DIC lookup on X, return Y
N ORDMN,ORDITM,DIC,D,ORDIC,TYPE S Y=-1,ORDMN=$P(ORDIALOG(PROMPT,0),U,2)
S ORDITM=$S(+ORDMN=101.43:1,ORDMN?1"ORD(101.43,:".E:1,1:0) ; OI file?
I X=" ",ORDITM D SPBAR W $S(Y>0:" "_X,1:$C(7)_" ??") Q
I ORDITM,X?1"`"1.N W $C(7),!,"Lookup by internal entry number not allowed!",! Q
I X=$G(DIR("B")) S Y=ORDIALOG(PROMPT,ORI) Q ; default
S DIC=$P(ORDMN,":"),DIC(0)=$P(ORDMN,":",2),ORDIC="^DIC" S:'DIC DIC=U_DIC
S:$D(ORDIALOG(PROMPT,"S")) DIC("S")=ORDIALOG(PROMPT,"S")
S TYPE=$P($G(^ORD(100.98,+$G(ORDG),0)),U,3)
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
S D=$G(ORDIALOG(PROMPT,"D")),D=$TR(D,";","^")
I $L(D) S ORDIC="IX^DIC" S:$L(D,U)>1 ORDIC="MIX^DIC1",DIC(0)=DIC(0)_"M"
D @ORDIC,SETDISV:Y&ORDITM
I DIC(0)["S",X'=$P(Y,"^",2) W " ",$P(Y,"^",2)
Q
;
SPACE(FILE) ; -- Resolve spbar-return for ptrs
N X,Y,DIC,ROOT S X=" ",FILE=$P(FILE,":")
I (+FILE=101.43)!(FILE="ORD(101.43,") D SPBAR Q X
S ROOT=$S(+FILE:$$ROOT^DILFD(+FILE),1:U_FILE),Y=$G(^DISV(DUZ,ROOT))
S:Y X=$P(@(ROOT_Y_",0)"),U)
Q X
;
SPBAR ; -- Resolve spbar-return for #101.43
N SDX,I,X1,D S SDX="",D=$G(ORDIALOG(PROMPT,"D")),D=$TR(D,";","^")
F I=1:1:$L(D,"^") I $P(D,U,I)?1"S."1.E S SDX=$P(D,U,I) Q
Q:'$L(SDX) S X1=$G(^DISV(DUZ,"ORDITM",SDX,1)) Q:'$L(X1)
S Y=$O(^ORD(101.43,SDX,X1,0)) S:Y X=X1,Y=Y_U_X1
Q
;
SETDISV ; -- Save entry Y=ifn^name in ^DISV for #101.43
N SDX,I Q:'$L($P(Y,U,2))
S SDX="",D=$G(ORDIALOG(PROMPT,"D")) Q:D'["S."
F I=1:1:$L(D,";") I $P(D,";",I)?1"S."1.E S SDX=$P(D,";",I) Q
Q:'$L(SDX) S ^DISV(DUZ,"ORDITM",SDX,1)=$P(Y,U,2)
Q
;
DT ; -- %DT validation on X, return Y
N %DT,BEG,END S %DT=$P(DOMAIN,":",3),X=$$UP^XLFSTR(X)
I $L($P(DOMAIN,":")) S BEG=$$FMDT($P(DOMAIN,":")) ;earliest date allowed
I $L($P(DOMAIN,":",2)) S END=$$FMDT($P(DOMAIN,":",2)) ;latest allowed
D ^%DT Q:Y'>0
I $G(BEG) D Q:Y<0
. I $L(Y,".")'=$L(BEG,".") S BEG=$P(BEG,".") ; date only
. I Y<BEG W $C(7),!,"Date may not be before "_$$FMTE^XLFDT(BEG) S Y=-1 Q
I $G(END) D Q:Y<0
. I $L(Y,".")'=$L(END,".") S END=$P(END,".") ; date only
. I Y>END W $C(7),!,"Date may not be after "_$$FMTE^XLFDT(END) S Y=-1 Q
I DATATYPE="R",$$RELDT(X) S:(%DT'["T")&("NOW"[X) X="TODAY" S Y=X ;text
Q
DT1 S:X="NOON" X="T@NOON" S:$E("MIDNIGHT",1,$L(X))=X X="T@MIDNIGHT"
I X'?1"V".E,X'?1"T".E D ^%DT S:Y>0&("NOW"[X) Y="NOW" Q
S D=$$UP^XLFSTR($P(X,"@")),T=$P(X,"@",2)
S Y=$E(D) I "VT"'[Y S Y=-1 Q
I (D["+")!(D["-") D Q:Y<0
. N SIGN,OFFSET,X1,X2
. S SIGN=$S(D["+":"+",1:"-"),OFFSET=$P(D,SIGN,2) I 'OFFSET S Y=-1 Q
. S X1=+OFFSET,X2=$P(OFFSET,X1,2) I "DWM"'[$E(X2) S Y=-1 Q
. S Y=Y_SIGN_X1_$E(X2) ; T+3W, e.g.
I '$L(T)&(DOMAIN["R") S Y=-1 Q ; time missing, required
I $L(T) D I '$D(T) S Y=-1 Q
. I '(DOMAIN["T"!(DOMAIN["R")) K T Q ; time prohibited
. N X,Y S X="T@"_T,%DT=$TR(DOMAIN,"E") D ^%DT I Y<0 K T Q
. S T=$E($P(Y,".",2),1,4) S:$L(T)<4 T=T_$E("0000",1,4-$L(T))
S:$L(T) Y=Y_"@"_T ; Y=date text, or -1 if error
Q
;
RELDT(X) ; -- Returns 1 or 0, if X is relative date
N Y S X=$G(X)
I ("NOON"[X)!("MIDNIGHT"[X)!($E(X)="T")!($E(X)="N") S Y=1
E S Y=0
Q Y
;
FMDT(X) ; -- Return FM form of date X
N Y,%DT S %DT="T" D ^%DT
Q Y
;
WP ; -- edit WP field
N DIC,DWLW,DWPK,DIWESUB,DONE,ORLINEDT,LCNT,UPCARR
S DIC="^TMP(""ORWORD"",$J,"_PROMPT_","_INST_",",DWLW=80,DWPK=1
S DIWESUB=$P(DIR("A"),":"),ORLINEDT=$$LINEDTR(DUZ)
I '$D(^TMP("ORWORD",$J,PROMPT,INST)) M:$D(^ORD(101.41,+ORDIALOG,10,ITM,8))>9 ^TMP("ORWORD",$J,PROMPT,INST)=^(8)
I 'ORLINEDT,'REQD,'$$EDITWP Q ;94
WP1 W:ORLINEDT !,DIR("A") S DIWESUB=$P(DIR("A"),":")
D EN^DIWE I $D(DTOUT)!($D(DUOUT)) S ORQUIT=1 Q
I REQD,'$O(^TMP("ORWORD",$J,PROMPT,INST,0)) W $C(7),!!,"A response is required!" G:'$$DONE WP1 S ORQUIT=1 Q
I '$O(^TMP("ORWORD",$J,PROMPT,INST,0)) K ^TMP("ORWORD",$J,PROMPT,INST),ORDIALOG(PROMPT,INST) Q ;empty
S LCNT="",UPCARR=0
F S LCNT=$O(^TMP("ORWORD",$J,PROMPT,INST,LCNT)) Q:LCNT=""!(UPCARR=1) D
.I LCNT>0,$G(^TMP("ORWORD",$J,PROMPT,INST,LCNT,0))[U S UPCARR=1
I UPCARR=1 W !!,"An ""^"" is not allowed in a word processing field." G:'$$DONE WP1 S ORQUIT=1 Q
S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")",DONE=1
I $D(^ORD(101.41,+ORDIALOG,10,ITM,5)) X ^(5) Q:$G(ORQUIT)!($G(DONE)) G WP1
Q
;
EDITWP() ; -- Want to edit WP field?
N X,Y,%,%Y
W !,ORDIALOG(PROMPT,"A") S Y=$D(ORDIALOG(PROMPT,INST))
I 'Y,REQD Q 1 ; no data, req'd
W:'Y !," No existing text",! I Y D ; show comments
. N X,DIWL,DIWR,DIWF,ORI
. S DIWL=3,DIWR=79,DIWF="W" K ^UTILITY($J,"W")
. 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
. D ^DIWW
ED1 S %=$S($D(OREDIT):1,1:2) W " Edit" D YN^DICN
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
S Y=$S(%<0:"^",%=2:0,1:1)
Q Y
;
LINEDTR(USER) ; -- Returns 1 or 0, if user's editor will be LineEd
N X,Y
S X=+$P($G(^VA(200,USER,1)),U,5),Y=0 I 'X S Y=1
E S:$$GET1^DIQ(1.2,+X_",",.01)="LINE EDITOR - VA FILEMAN" Y=1
Q Y
;
RETURN() ; -- press return to cont
N X W !,"Press <return> to continue ..." R X:DTIME
Q ""
;
DONE() ; -- Done editing?
N DIR,X,Y
S DIR(0)="YA",DIR("A")="Do you want to quit? ",DIR("B")="NO"
S DIR("?")="Enter YES to exit this order, or NO to continue editing"
D ^DIR
Q +Y
;
HELP(TYPE) ; -- Returns default help msg for TYPE prompt
N Y S Y=""
I TYPE="D" S Y="Enter a date[/time]."
I TYPE="R" S Y="Enter a date[/time] as T for TODAY or T+1 for TOMORROW."
I TYPE="F" S Y="Enter a string of text."
I TYPE="N" S Y="Enter a number."
I TYPE="S" S Y="Enter an item from the list."
I TYPE="Y" S Y="Enter YES or NO."
I TYPE="P" S Y="Enter an item from the file."
I TYPE="W" S Y=""
Q Y
ORCDLG2 ;SLC/MKB-Order dialogs cont ;13-Oct-2014 15:27;DU
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,60,79,94,243,1013**;Dec 17, 1997;Build 242
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; Modified - IHS/MSC/MGH - 10/13/2014 - Line DIR1+1
DIR ; -- ^DIR read of X, returns Y
+1 NEW INPUTXFM,LKUP,REPL
KILL DTOUT,DUOUT,DIRUT,DIROUT,DDER,Y
+2 SET (X,Y)=""
SET INPUTXFM=$PIECE(DIR(0),U,3,99)
+3 ; special lookup rtn
SET LKUP=$GET(ORDIALOG(PROMPT,"LKP"))
+4 ;IHS/MSC/MGH changed the 20 in this call to 2
+5 SET REPL=$SELECT(DATATYPE'="F":0,$LENGTH($GET(DIR("B")))>2:1,1:0)
IF REPL
SET DIR(0)=$EXTRACT(DIR(0))_"AO^"_$PIECE(DIR(0),U,2,99)
DIR1 IF 'REPL
WRITE !,DIR("A")_$SELECT($DATA(DIR("B")):DIR("B")_"// ",1:"")
READ X:DTIME
IF '$TEST
SET DTOUT=1
QUIT
+1 IF REPL
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+2 IF X=""
IF $DATA(DIR("B"))
SET X=DIR("B")
SET Y=ORDIALOG(PROMPT,ORI)
IF '$LENGTH(X)&(SEQ=1)&('MULT)
SET X="^"
IF 'REQD!$LENGTH(X)
QUIT
WRITE $CHAR(7),!!,$$REQUIRED^ORCDLG1,!
GOTO DIR1
+3 IF X="@"
IF 'REQD
QUIT
WRITE $CHAR(7),!!,$$REQUIRED^ORCDLG1,!
GOTO DIR1
+4 IF X?1"^".E
SET (DUOUT,DIRUT)=1
SET Y=X
IF X="^^"
SET DIROUT=1
QUIT
+5 IF X?1"?".E
Begin DoDot:1
+6 NEW XHELP
+7 SET XHELP=$SELECT($DATA(DIR("??")):$PIECE(DIR("??"),U,2,99),1:("D "_DATATYPE_"^ORCDLGH"))
+8 IF (DATATYPE="P")!(DATATYPE="S")!(X?1"??".E)
XECUTE XHELP
+9 IF '$DATA(DIR("?"))
SET DIR("?")=$$HELP(DATATYPE)
+10 IF $LENGTH(DIR("?"))<80
WRITE !,DIR("?"),!
+11 IF '$TEST
Begin DoDot:2
+12 NEW X,DIWL,DIWR,I
SET X=DIR("?")
SET DIWL=1
SET DIWR=80
KILL ^UTILITY($JOB,"W")
+13 DO ^DIWP
FOR I=1:1:^UTILITY($JOB,"W",DIWL)
WRITE !,$GET(^UTILITY($JOB,"W",DIWL,I,0))
End DoDot:2
WRITE !
End DoDot:1
GOTO DIR1
+14 IF $LENGTH(INPUTXFM)
XECUTE INPUTXFM
IF '$DATA(X)
DO ERR
GOTO DIR1
+15 IF $LENGTH(LKUP)
IF $LENGTH($TEXT(@LKUP))
DO @LKUP
IF Y>0
QUIT
DO ERR
GOTO DIR1
+16 IF $GET(ORDIALOG(PROMPT,"LIST"))
Begin DoDot:1
+17 NEW OROOT
SET OROOT="ORDIALOG("_PROMPT_",""LIST"")"
+18 IF (X=" ")&(DATATYPE="P")
SET X=$$SPACE(DOMAIN)
+19 ; I X'[",",X'["-" S Y=$$FIND Q
SET Y=$$FIND(OROOT,X)
+20 ; S ORX=$$EXPLIST(X) F S Y(Y+1)=$$FIND
End DoDot:1
IF $LENGTH(Y)
QUIT
IF $PIECE(ORDIALOG(PROMPT,"LIST"),U,2)
WRITE $CHAR(7)
DO LIST^ORCD
GOTO DIR1
+21 IF DATATYPE="P"
DO DIC
IF Y'>0
DO ERR
GOTO DIR1
+22 IF (DATATYPE="R")!(DATATYPE="D")
DO DT
IF Y<0
DO ERR
GOTO DIR1
+23 ;JEH 'REPL was checked
IF "^F^N^S^Y^"[(U_DATATYPE_U)
Begin DoDot:1
+24 ; strip out control char's
NEW I
FOR I=1:1:31
SET X=$TRANSLATE(X,$CHAR(I))
+25 ; silent
SET DIR("V")=""
DO ^DIR
End DoDot:1
IF $GET(DDER)
DO ERR
GOTO DIR1
+26 QUIT
+27 ;
ERR ; -- show help msg on error
+1 IF $DATA(DIR("?"))
WRITE $CHAR(7),!,DIR("?"),!
+2 QUIT
+3 ;
FIND(LIST,X) ; -- find value X in LIST(#) or LIST("B",name)
+1 NEW Y,XP,CNT,MATCH,I,DIR
+2 IF $LENGTH(X)>63
SET X=$EXTRACT(X,1,63)
SET X=$$UP^XLFSTR(X)
+3 SET CNT=0
SET XP=""
FOR
SET XP=$ORDER(@LIST@("B",XP))
IF XP=""
QUIT
IF $SELECT(X=+X:+XP=+X,1:$EXTRACT(XP,1,$LENGTH(X))=X)
SET CNT=CNT+1
SET MATCH(CNT)=@LIST@("B",XP)_U_XP
SET DIR("A",CNT)=$JUSTIFY(CNT,3)_" "_XP
+4 ;force entire text to echo if CNT=1
IF X=+X!(X?1"0."1.N)
SET Y=$GET(@LIST@(X))
IF $LENGTH(Y)
WRITE " "_$PIECE(Y,U,2)
IF $$OK
GOTO FQ
SET X=""
WRITE " "
+5 IF 'CNT
SET Y=""
GOTO FQ
+6 IF CNT=1
SET Y=MATCH(1)
SET XP=$PIECE(Y,U,2)
WRITE $EXTRACT(XP,$LENGTH(X)+1,$LENGTH(XP))
GOTO FQ
+7 SET DIR("A")="Select 1-"_CNT_": "
SET DIR(0)="NAO^1:"_CNT
+8 SET DIR("?")="Select the desired value, by number"
+9 DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))!(Y="")
SET Y=""
GOTO FQ
+10 SET Y=MATCH(Y)
WRITE " "_$PIECE(Y,U,2)
FQ IF Y&((+DOMAIN=101.43)!(DOMAIN?1"ORD(101.43,
DO SETDISV
+1 QUIT Y
+2 ;
OK() ; -- Return 1 or 0, if selected item is correct
+1 ;no other matches
NEW X,Y,DIR
IF CNT'>0
QUIT 1
+2 SET DIR(0)="YA"
SET DIR("A")=" ...OK? "
SET DIR("B")="YES"
+3 SET DIR("?")="Enter YES if this is the item you wish to select, or NO to continue searching the list"
+4 DO ^DIR
IF $DATA(DUOUT)!$DATA(DTOUT)
SET Y=""
+5 QUIT +Y
+6 ;
DIC ; -- ^DIC lookup on X, return Y
+1 NEW ORDMN,ORDITM,DIC,D,ORDIC,TYPE
SET Y=-1
SET ORDMN=$PIECE(ORDIALOG(PROMPT,0),U,2)
+2 ; OI file?
SET ORDITM=$SELECT(+ORDMN=101.43:1,ORDMN?1"ORD(101.43,:".E:1,1:0)
+3 IF X=" "
IF ORDITM
DO SPBAR
WRITE $SELECT(Y>0:" "_X,1:$CHAR(7)_" ??")
QUIT
+4 IF ORDITM
IF X?1"`"1.N
WRITE $CHAR(7),!,"Lookup by internal entry number not allowed!",!
QUIT
+5 ; default
IF X=$GET(DIR("B"))
SET Y=ORDIALOG(PROMPT,ORI)
QUIT
+6 SET DIC=$PIECE(ORDMN,":")
SET DIC(0)=$PIECE(ORDMN,":",2)
SET ORDIC="^DIC"
IF 'DIC
SET DIC=U_DIC
+7 IF $DATA(ORDIALOG(PROMPT,"S"))
SET DIC("S")=ORDIALOG(PROMPT,"S")
+8 SET TYPE=$PIECE($GET(^ORD(100.98,+$GET(ORDG),0)),U,3)
+9 ;W NAME if OI/synm, or NF
IF ORDITM
SET DIC("W")="W:$S('$D(%):0,'$D(DIY):0,%=DIY:0,1:1) $G(DIY)"_$SELECT(TYPE["RX":" W:$P($G(^(""PS"")),U,6) "" (non-formulary)"" ",1:"")
+10 SET D=$GET(ORDIALOG(PROMPT,"D"))
SET D=$TRANSLATE(D,";","^")
+11 IF $LENGTH(D)
SET ORDIC="IX^DIC"
IF $LENGTH(D,U)>1
SET ORDIC="MIX^DIC1"
SET DIC(0)=DIC(0)_"M"
+12 DO @ORDIC
IF Y&ORDITM
DO SETDISV
+13 IF DIC(0)["S"
IF X'=$PIECE(Y,"^",2)
WRITE " ",$PIECE(Y,"^",2)
+14 QUIT
+15 ;
SPACE(FILE) ; -- Resolve spbar-return for ptrs
+1 NEW X,Y,DIC,ROOT
SET X=" "
SET FILE=$PIECE(FILE,":")
+2 IF (+FILE=101.43)!(FILE="ORD(101.43,")
DO SPBAR
QUIT X
+3 SET ROOT=$SELECT(+FILE:$$ROOT^DILFD(+FILE),1:U_FILE)
SET Y=$GET(^DISV(DUZ,ROOT))
+4 IF Y
SET X=$PIECE(@(ROOT_Y_",0)"),U)
+5 QUIT X
+6 ;
SPBAR ; -- Resolve spbar-return for #101.43
+1 NEW SDX,I,X1,D
SET SDX=""
SET D=$GET(ORDIALOG(PROMPT,"D"))
SET D=$TRANSLATE(D,";","^")
+2 FOR I=1:1:$LENGTH(D,"^")
IF $PIECE(D,U,I)?1"S."1.E
SET SDX=$PIECE(D,U,I)
QUIT
+3 IF '$LENGTH(SDX)
QUIT
SET X1=$GET(^DISV(DUZ,"ORDITM",SDX,1))
IF '$LENGTH(X1)
QUIT
+4 SET Y=$ORDER(^ORD(101.43,SDX,X1,0))
IF Y
SET X=X1
SET Y=Y_U_X1
+5 QUIT
+6 ;
SETDISV ; -- Save entry Y=ifn^name in ^DISV for #101.43
+1 NEW SDX,I
IF '$LENGTH($PIECE(Y,U,2))
QUIT
+2 SET SDX=""
SET D=$GET(ORDIALOG(PROMPT,"D"))
IF D'["S."
QUIT
+3 FOR I=1:1:$LENGTH(D,";")
IF $PIECE(D,";",I)?1"S."1.E
SET SDX=$PIECE(D,";",I)
QUIT
+4 IF '$LENGTH(SDX)
QUIT
SET ^DISV(DUZ,"ORDITM",SDX,1)=$PIECE(Y,U,2)
+5 QUIT
+6 ;
DT ; -- %DT validation on X, return Y
+1 NEW %DT,BEG,END
SET %DT=$PIECE(DOMAIN,":",3)
SET X=$$UP^XLFSTR(X)
+2 ;earliest date allowed
IF $LENGTH($PIECE(DOMAIN,":"))
SET BEG=$$FMDT($PIECE(DOMAIN,":"))
+3 ;latest allowed
IF $LENGTH($PIECE(DOMAIN,":",2))
SET END=$$FMDT($PIECE(DOMAIN,":",2))
+4 DO ^%DT
IF Y'>0
QUIT
+5 IF $GET(BEG)
Begin DoDot:1
+6 ; date only
IF $LENGTH(Y,".")'=$LENGTH(BEG,".")
SET BEG=$PIECE(BEG,".")
+7 IF Y<BEG
WRITE $CHAR(7),!,"Date may not be before "_$$FMTE^XLFDT(BEG)
SET Y=-1
QUIT
End DoDot:1
IF Y<0
QUIT
+8 IF $GET(END)
Begin DoDot:1
+9 ; date only
IF $LENGTH(Y,".")'=$LENGTH(END,".")
SET END=$PIECE(END,".")
+10 IF Y>END
WRITE $CHAR(7),!,"Date may not be after "_$$FMTE^XLFDT(END)
SET Y=-1
QUIT
End DoDot:1
IF Y<0
QUIT
+11 ;text
IF DATATYPE="R"
IF $$RELDT(X)
IF (%DT'["T")&("NOW"[X)
SET X="TODAY"
SET Y=X
+12 QUIT
DT1 IF X="NOON"
SET X="T@NOON"
IF $EXTRACT("MIDNIGHT",1,$LENGTH(X))=X
SET X="T@MIDNIGHT"
+1 IF X'?1"V".E
IF X'?1"T".E
DO ^%DT
IF Y>0&("NOW"[X)
SET Y="NOW"
QUIT
+2 SET D=$$UP^XLFSTR($PIECE(X,"@"))
SET T=$PIECE(X,"@",2)
+3 SET Y=$EXTRACT(D)
IF "VT"'[Y
SET Y=-1
QUIT
+4 IF (D["+")!(D["-")
Begin DoDot:1
+5 NEW SIGN,OFFSET,X1,X2
+6 SET SIGN=$SELECT(D["+":"+",1:"-")
SET OFFSET=$PIECE(D,SIGN,2)
IF 'OFFSET
SET Y=-1
QUIT
+7 SET X1=+OFFSET
SET X2=$PIECE(OFFSET,X1,2)
IF "DWM"'[$EXTRACT(X2)
SET Y=-1
QUIT
+8 ; T+3W, e.g.
SET Y=Y_SIGN_X1_$EXTRACT(X2)
End DoDot:1
IF Y<0
QUIT
+9 ; time missing, required
IF '$LENGTH(T)&(DOMAIN["R")
SET Y=-1
QUIT
+10 IF $LENGTH(T)
Begin DoDot:1
+11 ; time prohibited
IF '(DOMAIN["T"!(DOMAIN["R"))
KILL T
QUIT
+12 NEW X,Y
SET X="T@"_T
SET %DT=$TRANSLATE(DOMAIN,"E")
DO ^%DT
IF Y<0
KILL T
QUIT
+13 SET T=$EXTRACT($PIECE(Y,".",2),1,4)
IF $LENGTH(T)<4
SET T=T_$EXTRACT("0000",1,4-$LENGTH(T))
End DoDot:1
IF '$DATA(T)
SET Y=-1
QUIT
+14 ; Y=date text, or -1 if error
IF $LENGTH(T)
SET Y=Y_"@"_T
+15 QUIT
+16 ;
RELDT(X) ; -- Returns 1 or 0, if X is relative date
+1 NEW Y
SET X=$GET(X)
+2 IF ("NOON"[X)!("MIDNIGHT"[X)!($EXTRACT(X)="T")!($EXTRACT(X)="N")
SET Y=1
+3 IF '$TEST
SET Y=0
+4 QUIT Y
+5 ;
FMDT(X) ; -- Return FM form of date X
+1 NEW Y,%DT
SET %DT="T"
DO ^%DT
+2 QUIT Y
+3 ;
WP ; -- edit WP field
+1 NEW DIC,DWLW,DWPK,DIWESUB,DONE,ORLINEDT,LCNT,UPCARR
+2 SET DIC="^TMP(""ORWORD"",$J,"_PROMPT_","_INST_","
SET DWLW=80
SET DWPK=1
+3 SET DIWESUB=$PIECE(DIR("A"),":")
SET ORLINEDT=$$LINEDTR(DUZ)
+4 IF '$DATA(^TMP("ORWORD",$JOB,PROMPT,INST))
IF $DATA(^ORD(101.41,+ORDIALOG,10,ITM,8))>9
MERGE ^TMP("ORWORD",$JOB,PROMPT,INST)=^(8)
+5 ;94
IF 'ORLINEDT
IF 'REQD
IF '$$EDITWP
QUIT
WP1 IF ORLINEDT
WRITE !,DIR("A")
SET DIWESUB=$PIECE(DIR("A"),":")
+1 DO EN^DIWE
IF $DATA(DTOUT)!($DATA(DUOUT))
SET ORQUIT=1
QUIT
+2 IF REQD
IF '$ORDER(^TMP("ORWORD",$JOB,PROMPT,INST,0))
WRITE $CHAR(7),!!,"A response is required!"
IF '$$DONE
GOTO WP1
SET ORQUIT=1
QUIT
+3 ;empty
IF '$ORDER(^TMP("ORWORD",$JOB,PROMPT,INST,0))
KILL ^TMP("ORWORD",$JOB,PROMPT,INST),ORDIALOG(PROMPT,INST)
QUIT
+4 SET LCNT=""
SET UPCARR=0
+5 FOR
SET LCNT=$ORDER(^TMP("ORWORD",$JOB,PROMPT,INST,LCNT))
IF LCNT=""!(UPCARR=1)
QUIT
Begin DoDot:1
+6 IF LCNT>0
IF $GET(^TMP("ORWORD",$JOB,PROMPT,INST,LCNT,0))[U
SET UPCARR=1
End DoDot:1
+7 IF UPCARR=1
WRITE !!,"An ""^"" is not allowed in a word processing field."
IF '$$DONE
GOTO WP1
SET ORQUIT=1
QUIT
+8 SET ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$JOB_","_PROMPT_","_INST_")"
SET DONE=1
+9 IF $DATA(^ORD(101.41,+ORDIALOG,10,ITM,5))
XECUTE ^(5)
IF $GET(ORQUIT)!($GET(DONE))
QUIT
GOTO WP1
+10 QUIT
+11 ;
EDITWP() ; -- Want to edit WP field?
+1 NEW X,Y,%,%Y
+2 WRITE !,ORDIALOG(PROMPT,"A")
SET Y=$DATA(ORDIALOG(PROMPT,INST))
+3 ; no data, req'd
IF 'Y
IF REQD
QUIT 1
+4 ; show comments
IF 'Y
WRITE !," No existing text",!
IF Y
Begin DoDot:1
+5 NEW X,DIWL,DIWR,DIWF,ORI
+6 SET DIWL=3
SET DIWR=79
SET DIWF="W"
KILL ^UTILITY($JOB,"W")
+7 SET ORI=0
FOR
SET ORI=$ORDER(^TMP("ORWORD",$JOB,PROMPT,INST,ORI))
IF ORI'>0
QUIT
SET X=$GET(^(ORI,0))
IF $LENGTH(X)
DO ^DIWP
+8 DO ^DIWW
End DoDot:1
ED1 SET %=$SELECT($DATA(OREDIT):1,1:2)
WRITE " Edit"
DO YN^DICN
+1 IF %=0
WRITE !," Enter 'YES' if you wish to go into the editor.",!," Enter 'NO' if you do not wish to edit at this time.",!
GOTO ED1
+2 SET Y=$SELECT(%<0:"^",%=2:0,1:1)
+3 QUIT Y
+4 ;
LINEDTR(USER) ; -- Returns 1 or 0, if user's editor will be LineEd
+1 NEW X,Y
+2 SET X=+$PIECE($GET(^VA(200,USER,1)),U,5)
SET Y=0
IF 'X
SET Y=1
+3 IF '$TEST
IF $$GET1^DIQ(1.2,+X_",",.01)="LINE EDITOR - VA FILEMAN"
SET Y=1
+4 QUIT Y
+5 ;
RETURN() ; -- press return to cont
+1 NEW X
WRITE !,"Press <return> to continue ..."
READ X:DTIME
+2 QUIT ""
+3 ;
DONE() ; -- Done editing?
+1 NEW DIR,X,Y
+2 SET DIR(0)="YA"
SET DIR("A")="Do you want to quit? "
SET DIR("B")="NO"
+3 SET DIR("?")="Enter YES to exit this order, or NO to continue editing"
+4 DO ^DIR
+5 QUIT +Y
+6 ;
HELP(TYPE) ; -- Returns default help msg for TYPE prompt
+1 NEW Y
SET Y=""
+2 IF TYPE="D"
SET Y="Enter a date[/time]."
+3 IF TYPE="R"
SET Y="Enter a date[/time] as T for TODAY or T+1 for TOMORROW."
+4 IF TYPE="F"
SET Y="Enter a string of text."
+5 IF TYPE="N"
SET Y="Enter a number."
+6 IF TYPE="S"
SET Y="Enter an item from the list."
+7 IF TYPE="Y"
SET Y="Enter YES or NO."
+8 IF TYPE="P"
SET Y="Enter an item from the file."
+9 IF TYPE="W"
SET Y=""
+10 QUIT Y
