- ORCDLG2 ;SLC/MKB-Order dialogs cont ;10/12/2007
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,60,79,94,243,297,467**;Dec 17, 1997;Build 4
- ;;Per VHA Directive 6402, this routine should not be modified.
- ;;
- ;Reference to ^DISV supported by IA #510
- ;
- 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
- 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)
- 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,ORY S OROOT="ORDIALOG("_PROMPT_",""LIST"")"
- . S:(X=" ")&(DATATYPE="P") X=$$SPACE(DOMAIN)
- . S ORY=$$FIND(OROOT,X)
- . I $L(ORY)!$P(ORDIALOG(PROMPT,"LIST"),U,2) S Y=ORY ;matched, or require list
- 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
- . I REPL S Y=X Q ; free text - already validated
- . N I F I=1:1:31 S X=$TR(X,$C(I)) ; strip out control char's
- . S DIR("V")="" D ^DIR K DIR("V") ; 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")
- I ORDITM,$L(X)>30 S X=$E(X,1,30) D
- . W !?5,"Entries are matched based on the first 30 characters. Longer entries may"
- . W !?5,"result in more than one match. If this happens, please select the desired"
- . W !?5,"entry.",!!,X
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCDLG2 9441 printed Jan 18, 2025@03:29:13 Page 2
- ORCDLG2 ;SLC/MKB-Order dialogs cont ;10/12/2007
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,60,79,94,243,297,467**;Dec 17, 1997;Build 4
- +2 ;;Per VHA Directive 6402, this routine should not be modified.
- +3 ;;
- +4 ;Reference to ^DISV supported by IA #510
- +5 ;
- 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 SET REPL=$SELECT(DATATYPE'="F":0,$LENGTH($GET(DIR("B")))>20: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,ORY
- SET OROOT="ORDIALOG("_PROMPT_",""LIST"")"
- +18 if (X=" ")&(DATATYPE="P")
- SET X=$$SPACE(DOMAIN)
- +19 SET ORY=$$FIND(OROOT,X)
- +20 ;matched, or require list
- IF $LENGTH(ORY)!$PIECE(ORDIALOG(PROMPT,"LIST"),U,2)
- SET Y=ORY
- 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 IF "^F^N^S^Y^"[(U_DATATYPE_U)
- Begin DoDot:1
- +24 ; free text - already validated
- IF REPL
- SET Y=X
- QUIT
- +25 ; strip out control char's
- NEW I
- FOR I=1:1:31
- SET X=$TRANSLATE(X,$CHAR(I))
- +26 ; silent
- SET DIR("V")=""
- DO ^DIR
- KILL DIR("V")
- End DoDot:1
- IF $GET(DDER)
- DO ERR
- GOTO DIR1
- +27 QUIT
- +28 ;
- 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 IF ORDITM
- IF $LENGTH(X)>30
- SET X=$EXTRACT(X,1,30)
- Begin DoDot:1
- +9 WRITE !?5,"Entries are matched based on the first 30 characters. Longer entries may"
- +10 WRITE !?5,"result in more than one match. If this happens, please select the desired"
- +11 WRITE !?5,"entry.",!!,X
- End DoDot:1
- +12 SET TYPE=$PIECE($GET(^ORD(100.98,+$GET(ORDG),0)),U,3)
- +13 ;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:"")
- +14 SET D=$GET(ORDIALOG(PROMPT,"D"))
- SET D=$TRANSLATE(D,";","^")
- +15 IF $LENGTH(D)
- SET ORDIC="IX^DIC"
- if $LENGTH(D,U)>1
- SET ORDIC="MIX^DIC1"
- SET DIC(0)=DIC(0)_"M"
- +16 DO @ORDIC
- if Y&ORDITM
- DO SETDISV
- +17 IF DIC(0)["S"
- IF X'=$PIECE(Y,"^",2)
- WRITE " ",$PIECE(Y,"^",2)
- +18 QUIT
- +19 ;
- 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