ORCMEDT3 ;SLC/MKB-Dialog editor ;Apr 21, 2021@13:21
;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,60,95,556,567**;Dec 17, 1997;Build 1
;
EN ; -- Enter/edit generic ordering dialog
N ORDLG,ORDG
F S ORDLG=$$DIALOG^ORCMEDT0("D") Q:ORDLG="^" D EN1(ORDLG) W !
Q
EN1(ORDLG) ; -- edit dialog ORDLG
N ORPROG,X,Y,D,DA,DR,DIE,DIC,OR0,ORP,ORTYPE,ORDOM,ORQUIT,ORNAME,ORPKG
Q:'$G(ORDLG) S ORPROG=(DUZ(0)="@"),DA=ORDLG,DIE="^ORD(101.41,",DR=""
S ORPKG=+$P($G(^ORD(101.41,ORDLG,0)),U,7),ORPKG=$S($O(^DIC(9.4,"C","OR",0))=ORPKG:1,1:0) ;1 or 0, if PKG=OR
I ORPKG S ORNAME=$$NAME^ORCMEDT4(ORDLG) Q:(ORNAME="@")!(ORNAME="^") S DR=".01///^S X=ORNAME;" ; Name not editable for pkg dialogs
S DR=DR_"2;6;8;9"_$S('ORPKG:"",ORPROG:";20;30;40;17;19",1:";20")
D ^DIE Q:$D(DTOUT)!$D(Y) Q:'$G(DA) ; deleted
D DGRP Q:ORDG="^" ;edit display group
EN11 S ORQUIT=0 F D Q:ORQUIT W ! ; ** Only few fields editable if pkg dlg
. S DIC="^ORD(101.41,"_ORDLG_",10,",DIC(0)="AEQM"_$S(ORPKG:"L",1:"")
. S DIC("A")="Select PROMPT: ",DIC("P")=$P(^DD(101.41,10,0),U,2),D="B^D"
. S DIC("DR")="21///"_(+$O(^ORD(101.41,ORDLG,10,"ATXT","A"),-1)+1)
. K DA S DA(1)=ORDLG D MIX^DIC1 I Y'>0 S ORQUIT=1 Q
. S DA=+Y,DIE=DIC,DR=.01 I ORPKG D ^DIE Q:'$G(DA)!$D(DTOUT)!$D(Y)
. S OR0=$G(^ORD(101.41,DA(1),10,DA,0)),ORP=$S(ORPKG:$$PROMPT($P(OR0,U,2)),1:$P(OR0,U,2))
. I ORP="^" S DIK=DIC D:'$P(OR0,U,2) ^DIK Q ;delete item if no prompt
. S ORTYPE=$P(^ORD(101.41,ORP,1),U),ORDOM=$P(^(1),U,2)
. I ORP'=$P(OR0,U,2),ORTYPE'=$P($G(^ORD(101.41,+$P(OR0,U,2),1)),U) D
. . N I F I=.1,4,7,8 K ^ORD(101.41,ORDLG,10,DA,I) ;kill xform,screen,def
. . S $P(^ORD(101.41,ORDLG,10,DA,0),U,10)="",$P(^(1),U,2)="" ;index,lkup
. S DR=$S(ORPKG:"2////"_ORP_$S(ORTYPE="P"&ORPROG:";10;14;12",1:"")_";4;6;7;I 'X S Y=""@1"";7.1;7.2;7.3;S Y=8;@1;7.1///@;7.2///@;7.3///@;8;9;11",1:"8;9") D ^DIE Q:$D(DTOUT)!$D(Y)
. I 'ORPROG K DIRUT D DEFAULT Q:$G(DIRUT)
. I ORPROG S DR=$S(ORPKG:"16;13;.1;",1:"")_$S(ORTYPE="W":18,1:17)_$S(ORPKG:";15;19;20",1:"") D ^DIE Q:$D(DTOUT)!$D(Y)
. S DR="21;I X'>0 S Y=0;22:"_$S(ORTYPE="W":"27",1:"26") D ^DIE
D WINID,AUTO^ORCMEDT1(ORDLG),TRY(ORDLG) ;Auto-Accept flag, test changes
Q
;
PROMPT(X) ; -- Enter/edit prompt
;OR*3.0*556 - check for same ID on multiple prompts
N ORXPR,ORXSUB,ORXID,ORXIDAR
S ORXPR=0
F S ORXPR=$O(^ORD(101.41,ORDLG,10,ORXPR)) Q:'ORXPR D
. S ORXSUB=$P($G(^ORD(101.41,ORDLG,10,ORXPR,0)),"^",2)
. Q:ORXSUB=""
. S ORXID=$P($G(^ORD(101.41,ORXSUB,1)),"^",3)
. I ORXID]"" S ORXIDAR(ORXID)=$P(^ORD(101.41,ORDLG,10,ORXPR,0),"^")_" ("_$P(^ORD(101.41,ORXSUB,0),"^")_")"
;end OR*3.0*556
N Y,DIC,OLD S OLD=+$G(X)
S DIC="^ORD(101.41,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,4)=""P"""
S DIC("A")="PROMPT: " S:OLD DIC("B")=$P(^ORD(101.41,X,0),U)
S DIC("W")="W "" ""_$$TYPE^ORCMEDT3($P($G(^(1)),U))" ; show type
P1 D ^DIC I $D(DTOUT)!$D(DUOUT) S Y="^" G PQ
I Y'>0 W $C(7),!?5,"This is a required field!" G P1
I +Y'=OLD,$D(^ORD(101.41,ORDLG,10,"D",+Y)) W $C(7),!?5,"Duplicates are not allowed!" G P1
;OR*3.0*556 begin
S ORXID=$P($G(^ORD(101.41,+Y,1)),"^",3)
;OR*3.0*567: added the check for variable "OLD" so that
; existing prompts may be edited.
I 'OLD,ORXID]"",$D(ORXIDAR(ORXID)) D G P1
. W $C(7),!!,?5,"Sequence ",ORXIDAR(ORXID)," is also"
. W !,?5,"defined with an ID of ",ORXID,"."
. W !!,?5,"Select another prompt or define a new prompt"
. W !,?5,"with a different ID."
. W !!,?5,"WARNING: Do not change the ID field on an existing"
. W !,?5," prompt so as to not affect order dialogs"
. W !,?5," already using the existing prompt."
. W !,?5," (The ID field can only be edited in the option"
. W !,?5," ""Enter/edit prompts"" - not this option.)"
I ORXID]"" S ORXIDAR(ORXID)=OR0_" ("_$P(^ORD(101.41,+Y,0),"^")_")"
;end OR*3.0*556
S Y=+Y
PQ Q Y
;
TYPE(X) ; -- Displays datatype and domain as identifiers
I '$L($G(X)) Q ""
N Y S Y=$S(X="D":"date/time",X="R":"relative date/time",X="F":"free text",X="N":"numeric",X="S":"set of codes",X="P":"pointer to a file",X="Y":"yes/no",X="W":"word processing",1:"")
Q Y
;
DEFAULT ; -- Enter/edit default value
G:ORTYPE="W" WP N OLD,X,Y,D,DIC,DIR,%DT,ORDIC,ORSCR
S:$D(^ORD(101.41,ORDLG,10,DA,4)) ORSCR=^(4)
S OLD=$G(^ORD(101.41,ORDLG,10,DA,7)) I $L(OLD) D Q:OLD="^"
. S OLD=$$VALUE(OLD) S:"^P^D^R^"[(U_ORTYPE_U)&(OLD=-1) OLD=""
. I OLD="^" W !,"DEFAULT: <executable code - uneditable>//" Q
S DIR("A")="DEFAULT: ",DIR(0)=$S(ORTYPE="P":"FAO^1:63",ORTYPE="D"!(ORTYPE="R"):"DAO^"_ORDOM,1:ORTYPE_"AO^"_ORDOM)
S:$L(OLD) DIR("B")=$S(ORTYPE="P":$$GET1^DIQ(+ORDOM,+OLD_",",.01),ORTYPE="D":$$FMTE^XLFDT(OLD),1:OLD)
S:ORTYPE="P" DIR("?")="Select an entry from the file; enter ?? to see a list of choices",DIR("??")="^D LIST^ORCMEDT3"
DF1 D ^DIR K DIRUT I $D(DTOUT)!(X["^") S DIRUT=1 Q
Q:X="" Q:X=$G(DIR("B")) ; no value or no change
I X="@" K ^ORD(101.41,ORDLG,10,DA,7) Q
I ORTYPE="R" S Y=X
I ORTYPE="P" D G:Y'>0 DF1
. S DIC=$S(+ORDOM:+ORDOM,1:U_$P(ORDOM,":"))
. S DIC(0)="EQ",D=$P(OR0,U,10),ORDIC="^DIC"
. S:$D(ORSCR) DIC("S")=ORSCR
. I $L(D) S D=$TR(D,";","^"),ORDIC=$S($L(D,"^")>1:"MIX^DIC1",1:"IX^DIC")
. D @ORDIC S Y=$P(Y,U)
DFQ S ^ORD(101.41,ORDLG,10,DA,7)=$S(Y'="":"S Y="""_Y_"""",1:"Q")
Q
;
VALUE(CODE) ; -- Returns value following "S Y="
N I,X,Y,Z S Z=$F(CODE,"S Y=") I 'Z Q "^"
S X=$E(CODE,Z,999),Y="" I '+X,$E(X)'="""" Q "^" ;not numeric or literal
S:$E(X)="""" X=$E(X,2,999)
F I=1:1:$L(X) S Z=$E(X,I) Q:(Z="""") S Y=Y_Z
Q Y
;
LIST ; -- ??help for ptrs
N D,DIC,DZ
S DIC=$S(+ORDOM:$$ROOT^DILFD(+ORDOM),1:U_$P(ORDOM,":"))
S DIC(0)="EQS",DZ="??",D=$P(OR0,U,10) S:'$L(D) D="B"
S:$D(ORSCR) DIC("S")=ORSCR
D DQ^DICQ
Q
;
WP ; -- Enter/edit WP data
N DIC,DIWESUB W !,"DEFAULT: "
S DIC="^ORD(101.41,"_ORDLG_",10,"_DA_",8,",DIWESUB="DEFAULT"
D EN^DIWE
Q
;
DGRP ; -- Edit display group [and orderable item]
N X,Y,DA,DR,DIE,OI,IDX
S DA=ORDLG,DR="5R",DIE="^ORD(101.41," D ^DIE I $D(Y) S ORDG="^" Q
Q:$P($G(^ORD(101.41,ORDLG,0)),U,5)=ORDG S ORDG=$P(^(0),U,5)
S OI=$O(^ORD(101.41,ORDLG,10,"D",+$$PTR^ORCD("OR GTX ORDERABLE ITEM"),0)) Q:'OI
S IDX="S."_$P($G(^ORD(100.98,ORDG,0)),U,3)
S $P(^ORD(101.41,ORDLG,10,OI,0),U,10)=IDX K ^(7)
W !," >> You must select a new orderable item from this group."
Q
;
OI(ORDG) ; -- Returns OI for generic dialog
Q:'$G(ORDG) "" N X,Y,D,DIC,DLAYGO,DA,DR,DIE,ID,ORDIC,ORY
S D=$P($G(^ORD(100.98,+ORDG,0)),U,3)
I "^ANI^AP^AU^BB^CARD^CH^CSLT^CT^CY^D AO^D CON^DIET^DO^E/L T^EM^HEMA^I RX^IV RX^LAB^MAM^MI^MRI^NM^O RX^PREC^PROC^RAD^RX^SP^SPLY^TF^TPN^UD RX^US^VAS^XRAY^"'[(U_D_U) S ORADD=1 ;95 Only add OI if generic DG
S DIC=101.43,DIC(0)="AEQ"_$S($G(ORADD):"L",1:""),ORDIC="^DIC",DIE=DIC S:$G(ORADD) DLAYGO=101.43 ;95
S DIC("A")=" ORDERABLE ITEM: " S:$L(D) D="S."_D,ORDIC="IX^DIC"
D @ORDIC S ORY=Y S:Y'>0 Y=$S(X["^":"^",$D(DTOUT):"^",1:""),ORY=Y
I Y,$P(Y,U,3) S DA=+Y,ID=DA_";99ORD",DR="2///^S X=ID;5////"_+ORDG D ^DIE
Q ORY
;
TRY(ORDIALOG) ; -- Test [new] dialog
N X,Y,DIR,FIRST,ORTYPE,ORNMSP,ORVP,ORL,ORNP,AUTO W !
S DIR(0)="YA",DIR("A")="Do you want to test this dialog now? "
D ^DIR Q:Y'>0 W ! D GETDLG^ORCD(ORDIALOG)
S ORTYPE="D",ORNMSP="OR",FIRST=1,(ORVP,ORL,ORNP)=0
S AUTO=$P($G(^ORD(101.41,ORDIALOG,5)),U,8)
X:$D(^ORD(101.41,ORDIALOG,3.1)) ^(3.1) ;editor entry action
D DIALOG^ORCDLG,DISPLAY^ORCDLG
X:$D(^ORD(101.41,ORDIALOG,4)) ^(4) ;dlg exit action
Q
;
WINID ; -- Need to clear Window ID for GUI? [from EN]
Q:'ORPKG Q:'$P($G(^ORD(101.41,ORDLG,5)),U,5) ;already cleared
; ck prompts to see if they match OR GXMISC GENERAL
N ORGXMISC,ORX,ORP,ORQUIT
F ORX="ORDERABLE ITEM","FREE TEXT 1","START DATE/TIME","STOP DATE/TIME" S ORP=+$O(^ORD(101.41,"AB","OR GTX "_ORX,0)) I ORP S ORGXMISC(ORP)="" I '$O(^ORD(101.41,ORDLG,10,"D",ORP,0)) S ORQUIT=1 Q
I '$G(ORQUIT) S ORP=0 F S ORP=$O(^ORD(101.41,ORDLG,10,"D",ORP)) Q:ORP'>0 I '$D(ORGXMISC(ORP)) S ORQUIT=1 Q
S:$G(ORQUIT) $P(^ORD(101.41,ORDLG,5),U,5)="" ;clear ID
Q
;
ACTION ; -- Enter/edit actions
N DA,DR,DIE,ORNAME S DIE="^ORD(101.41,"
F S DA=$$DIALOG^ORCMEDT0("A") Q:DA="^" D W !
. S ORNAME=$$NAME^ORCMEDT4(DA) Q:(ORNAME="@")!(ORNAME="^")
. S DR=".01///^S X=ORNAME;2;"_$S(DUZ(0)="@":"30;40;",1:"")_"20" D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCMEDT3 8345 printed Apr 09, 2024@21:33:46 Page 2
ORCMEDT3 ;SLC/MKB-Dialog editor ;Apr 21, 2021@13:21
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,60,95,556,567**;Dec 17, 1997;Build 1
+2 ;
EN ; -- Enter/edit generic ordering dialog
+1 NEW ORDLG,ORDG
+2 FOR
SET ORDLG=$$DIALOG^ORCMEDT0("D")
if ORDLG="^"
QUIT
DO EN1(ORDLG)
WRITE !
+3 QUIT
EN1(ORDLG) ; -- edit dialog ORDLG
+1 NEW ORPROG,X,Y,D,DA,DR,DIE,DIC,OR0,ORP,ORTYPE,ORDOM,ORQUIT,ORNAME,ORPKG
+2 if '$GET(ORDLG)
QUIT
SET ORPROG=(DUZ(0)="@")
SET DA=ORDLG
SET DIE="^ORD(101.41,"
SET DR=""
+3 ;1 or 0, if PKG=OR
SET ORPKG=+$PIECE($GET(^ORD(101.41,ORDLG,0)),U,7)
SET ORPKG=$SELECT($ORDER(^DIC(9.4,"C","OR",0))=ORPKG:1,1:0)
+4 ; Name not editable for pkg dialogs
IF ORPKG
SET ORNAME=$$NAME^ORCMEDT4(ORDLG)
if (ORNAME="@")!(ORNAME="^")
QUIT
SET DR=".01///^S X=ORNAME;"
+5 SET DR=DR_"2;6;8;9"_$SELECT('ORPKG:"",ORPROG:";20;30;40;17;19",1:";20")
+6 ; deleted
DO ^DIE
if $DATA(DTOUT)!$DATA(Y)
QUIT
if '$GET(DA)
QUIT
+7 ;edit display group
DO DGRP
if ORDG="^"
QUIT
EN11 ; ** Only few fields editable if pkg dlg
SET ORQUIT=0
FOR
Begin DoDot:1
+1 SET DIC="^ORD(101.41,"_ORDLG_",10,"
SET DIC(0)="AEQM"_$SELECT(ORPKG:"L",1:"")
+2 SET DIC("A")="Select PROMPT: "
SET DIC("P")=$PIECE(^DD(101.41,10,0),U,2)
SET D="B^D"
+3 SET DIC("DR")="21///"_(+$ORDER(^ORD(101.41,ORDLG,10,"ATXT","A"),-1)+1)
+4 KILL DA
SET DA(1)=ORDLG
DO MIX^DIC1
IF Y'>0
SET ORQUIT=1
QUIT
+5 SET DA=+Y
SET DIE=DIC
SET DR=.01
IF ORPKG
DO ^DIE
if '$GET(DA)!$DATA(DTOUT)!$DATA(Y)
QUIT
+6 SET OR0=$GET(^ORD(101.41,DA(1),10,DA,0))
SET ORP=$SELECT(ORPKG:$$PROMPT($PIECE(OR0,U,2)),1:$PIECE(OR0,U,2))
+7 ;delete item if no prompt
IF ORP="^"
SET DIK=DIC
if '$PIECE(OR0,U,2)
DO ^DIK
QUIT
+8 SET ORTYPE=$PIECE(^ORD(101.41,ORP,1),U)
SET ORDOM=$PIECE(^(1),U,2)
+9 IF ORP'=$PIECE(OR0,U,2)
IF ORTYPE'=$PIECE($GET(^ORD(101.41,+$PIECE(OR0,U,2),1)),U)
Begin DoDot:2
+10 ;kill xform,screen,def
NEW I
FOR I=.1,4,7,8
KILL ^ORD(101.41,ORDLG,10,DA,I)
+11 ;index,lkup
SET $PIECE(^ORD(101.41,ORDLG,10,DA,0),U,10)=""
SET $PIECE(^(1),U,2)=""
End DoDot:2
+12 SET DR=$SELECT(ORPKG:"2////"_ORP_$SELECT(ORTYPE="P"&ORPROG:";10;14;12",1:"")_";4;6;7;I 'X S Y=""@1"";7.1;7.2;7.3;S Y=8;@1;7.1///@;7.2///@;7.3///@;8;9;11",1:"8;9")
DO ^DIE
if $DATA(DTOUT)!$DATA(Y)
QUIT
+13 IF 'ORPROG
KILL DIRUT
DO DEFAULT
if $GET(DIRUT)
QUIT
+14 IF ORPROG
SET DR=$SELECT(ORPKG:"16;13;.1;",1:"")_$SELECT(ORTYPE="W":18,1:17)_$SELECT(ORPKG:";15;19;20",1:"")
DO ^DIE
if $DATA(DTOUT)!$DATA(Y)
QUIT
+15 SET DR="21;I X'>0 S Y=0;22:"_$SELECT(ORTYPE="W":"27",1:"26")
DO ^DIE
End DoDot:1
if ORQUIT
QUIT
WRITE !
+16 ;Auto-Accept flag, test changes
DO WINID
DO AUTO^ORCMEDT1(ORDLG)
DO TRY(ORDLG)
+17 QUIT
+18 ;
PROMPT(X) ; -- Enter/edit prompt
+1 ;OR*3.0*556 - check for same ID on multiple prompts
+2 NEW ORXPR,ORXSUB,ORXID,ORXIDAR
+3 SET ORXPR=0
+4 FOR
SET ORXPR=$ORDER(^ORD(101.41,ORDLG,10,ORXPR))
if 'ORXPR
QUIT
Begin DoDot:1
+5 SET ORXSUB=$PIECE($GET(^ORD(101.41,ORDLG,10,ORXPR,0)),"^",2)
+6 if ORXSUB=""
QUIT
+7 SET ORXID=$PIECE($GET(^ORD(101.41,ORXSUB,1)),"^",3)
+8 IF ORXID]""
SET ORXIDAR(ORXID)=$PIECE(^ORD(101.41,ORDLG,10,ORXPR,0),"^")_" ("_$PIECE(^ORD(101.41,ORXSUB,0),"^")_")"
End DoDot:1
+9 ;end OR*3.0*556
+10 NEW Y,DIC,OLD
SET OLD=+$GET(X)
+11 SET DIC="^ORD(101.41,"
SET DIC(0)="AEQM"
SET DIC("S")="I $P(^(0),U,4)=""P"""
+12 SET DIC("A")="PROMPT: "
if OLD
SET DIC("B")=$PIECE(^ORD(101.41,X,0),U)
+13 ; show type
SET DIC("W")="W "" ""_$$TYPE^ORCMEDT3($P($G(^(1)),U))"
P1 DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)
SET Y="^"
GOTO PQ
+1 IF Y'>0
WRITE $CHAR(7),!?5,"This is a required field!"
GOTO P1
+2 IF +Y'=OLD
IF $DATA(^ORD(101.41,ORDLG,10,"D",+Y))
WRITE $CHAR(7),!?5,"Duplicates are not allowed!"
GOTO P1
+3 ;OR*3.0*556 begin
+4 SET ORXID=$PIECE($GET(^ORD(101.41,+Y,1)),"^",3)
+5 ;OR*3.0*567: added the check for variable "OLD" so that
+6 ; existing prompts may be edited.
+7 IF 'OLD
IF ORXID]""
IF $DATA(ORXIDAR(ORXID))
Begin DoDot:1
+8 WRITE $CHAR(7),!!,?5,"Sequence ",ORXIDAR(ORXID)," is also"
+9 WRITE !,?5,"defined with an ID of ",ORXID,"."
+10 WRITE !!,?5,"Select another prompt or define a new prompt"
+11 WRITE !,?5,"with a different ID."
+12 WRITE !!,?5,"WARNING: Do not change the ID field on an existing"
+13 WRITE !,?5," prompt so as to not affect order dialogs"
+14 WRITE !,?5," already using the existing prompt."
+15 WRITE !,?5," (The ID field can only be edited in the option"
+16 WRITE !,?5," ""Enter/edit prompts"" - not this option.)"
End DoDot:1
GOTO P1
+17 IF ORXID]""
SET ORXIDAR(ORXID)=OR0_" ("_$PIECE(^ORD(101.41,+Y,0),"^")_")"
+18 ;end OR*3.0*556
+19 SET Y=+Y
PQ QUIT Y
+1 ;
TYPE(X) ; -- Displays datatype and domain as identifiers
+1 IF '$LENGTH($GET(X))
QUIT ""
+2 NEW Y
SET Y=$SELECT(X="D":"date/time",X="R":"relative date/time",X="F":"free text",X="N":"numeric",X="S":"set of codes",X="P":"pointer to a file",X="Y":"yes/no",X="W":"word processing",1:"")
+3 QUIT Y
+4 ;
DEFAULT ; -- Enter/edit default value
+1 if ORTYPE="W"
GOTO WP
NEW OLD,X,Y,D,DIC,DIR,%DT,ORDIC,ORSCR
+2 if $DATA(^ORD(101.41,ORDLG,10,DA,4))
SET ORSCR=^(4)
+3 SET OLD=$GET(^ORD(101.41,ORDLG,10,DA,7))
IF $LENGTH(OLD)
Begin DoDot:1
+4 SET OLD=$$VALUE(OLD)
if "^P^D^R^"[(U_ORTYPE_U)&(OLD=-1)
SET OLD=""
+5 IF OLD="^"
WRITE !,"DEFAULT: <executable code - uneditable>//"
QUIT
End DoDot:1
if OLD="^"
QUIT
+6 SET DIR("A")="DEFAULT: "
SET DIR(0)=$SELECT(ORTYPE="P":"FAO^1:63",ORTYPE="D"!(ORTYPE="R"):"DAO^"_ORDOM,1:ORTYPE_"AO^"_ORDOM)
+7 if $LENGTH(OLD)
SET DIR("B")=$SELECT(ORTYPE="P":$$GET1^DIQ(+ORDOM,+OLD_",",.01),ORTYPE="D":$$FMTE^XLFDT(OLD),1:OLD)
+8 if ORTYPE="P"
SET DIR("?")="Select an entry from the file; enter ?? to see a list of choices"
SET DIR("??")="^D LIST^ORCMEDT3"
DF1 DO ^DIR
KILL DIRUT
IF $DATA(DTOUT)!(X["^")
SET DIRUT=1
QUIT
+1 ; no value or no change
if X=""
QUIT
if X=$GET(DIR("B"))
QUIT
+2 IF X="@"
KILL ^ORD(101.41,ORDLG,10,DA,7)
QUIT
+3 IF ORTYPE="R"
SET Y=X
+4 IF ORTYPE="P"
Begin DoDot:1
+5 SET DIC=$SELECT(+ORDOM:+ORDOM,1:U_$PIECE(ORDOM,":"))
+6 SET DIC(0)="EQ"
SET D=$PIECE(OR0,U,10)
SET ORDIC="^DIC"
+7 if $DATA(ORSCR)
SET DIC("S")=ORSCR
+8 IF $LENGTH(D)
SET D=$TRANSLATE(D,";","^")
SET ORDIC=$SELECT($LENGTH(D,"^")>1:"MIX^DIC1",1:"IX^DIC")
+9 DO @ORDIC
SET Y=$PIECE(Y,U)
End DoDot:1
if Y'>0
GOTO DF1
DFQ SET ^ORD(101.41,ORDLG,10,DA,7)=$SELECT(Y'="":"S Y="""_Y_"""",1:"Q")
+1 QUIT
+2 ;
VALUE(CODE) ; -- Returns value following "S Y="
+1 NEW I,X,Y,Z
SET Z=$FIND(CODE,"S Y=")
IF 'Z
QUIT "^"
+2 ;not numeric or literal
SET X=$EXTRACT(CODE,Z,999)
SET Y=""
IF '+X
IF $EXTRACT(X)'=""""
QUIT "^"
+3 if $EXTRACT(X)=""""
SET X=$EXTRACT(X,2,999)
+4 FOR I=1:1:$LENGTH(X)
SET Z=$EXTRACT(X,I)
if (Z="""")
QUIT
SET Y=Y_Z
+5 QUIT Y
+6 ;
LIST ; -- ??help for ptrs
+1 NEW D,DIC,DZ
+2 SET DIC=$SELECT(+ORDOM:$$ROOT^DILFD(+ORDOM),1:U_$PIECE(ORDOM,":"))
+3 SET DIC(0)="EQS"
SET DZ="??"
SET D=$PIECE(OR0,U,10)
if '$LENGTH(D)
SET D="B"
+4 if $DATA(ORSCR)
SET DIC("S")=ORSCR
+5 DO DQ^DICQ
+6 QUIT
+7 ;
WP ; -- Enter/edit WP data
+1 NEW DIC,DIWESUB
WRITE !,"DEFAULT: "
+2 SET DIC="^ORD(101.41,"_ORDLG_",10,"_DA_",8,"
SET DIWESUB="DEFAULT"
+3 DO EN^DIWE
+4 QUIT
+5 ;
DGRP ; -- Edit display group [and orderable item]
+1 NEW X,Y,DA,DR,DIE,OI,IDX
+2 SET DA=ORDLG
SET DR="5R"
SET DIE="^ORD(101.41,"
DO ^DIE
IF $DATA(Y)
SET ORDG="^"
QUIT
+3 if $PIECE($GET(^ORD(101.41,ORDLG,0)),U,5)=ORDG
QUIT
SET ORDG=$PIECE(^(0),U,5)
+4 SET OI=$ORDER(^ORD(101.41,ORDLG,10,"D",+$$PTR^ORCD("OR GTX ORDERABLE ITEM"),0))
if 'OI
QUIT
+5 SET IDX="S."_$PIECE($GET(^ORD(100.98,ORDG,0)),U,3)
+6 SET $PIECE(^ORD(101.41,ORDLG,10,OI,0),U,10)=IDX
KILL ^(7)
+7 WRITE !," >> You must select a new orderable item from this group."
+8 QUIT
+9 ;
OI(ORDG) ; -- Returns OI for generic dialog
+1 if '$GET(ORDG)
QUIT ""
NEW X,Y,D,DIC,DLAYGO,DA,DR,DIE,ID,ORDIC,ORY
+2 SET D=$PIECE($GET(^ORD(100.98,+ORDG,0)),U,3)
+3 ;95 Only add OI if generic DG
IF "^ANI^AP^AU^BB^CARD^CH^CSLT^CT^CY^D AO^D CON^DIET^DO^E/L T^EM^HEMA^I RX^IV RX^LAB^MAM^MI^MRI^NM^O RX^PREC^PROC^RAD^RX^SP^SPLY^TF^TPN^UD RX^US^VAS^XRAY^"'[(U_D_U)
SET ORADD=1
+4 ;95
SET DIC=101.43
SET DIC(0)="AEQ"_$SELECT($GET(ORADD):"L",1:"")
SET ORDIC="^DIC"
SET DIE=DIC
if $GET(ORADD)
SET DLAYGO=101.43
+5 SET DIC("A")=" ORDERABLE ITEM: "
if $LENGTH(D)
SET D="S."_D
SET ORDIC="IX^DIC"
+6 DO @ORDIC
SET ORY=Y
if Y'>0
SET Y=$SELECT(X["^":"^",$DATA(DTOUT):"^",1:"")
SET ORY=Y
+7 IF Y
IF $PIECE(Y,U,3)
SET DA=+Y
SET ID=DA_";99ORD"
SET DR="2///^S X=ID;5////"_+ORDG
DO ^DIE
+8 QUIT ORY
+9 ;
TRY(ORDIALOG) ; -- Test [new] dialog
+1 NEW X,Y,DIR,FIRST,ORTYPE,ORNMSP,ORVP,ORL,ORNP,AUTO
WRITE !
+2 SET DIR(0)="YA"
SET DIR("A")="Do you want to test this dialog now? "
+3 DO ^DIR
if Y'>0
QUIT
WRITE !
DO GETDLG^ORCD(ORDIALOG)
+4 SET ORTYPE="D"
SET ORNMSP="OR"
SET FIRST=1
SET (ORVP,ORL,ORNP)=0
+5 SET AUTO=$PIECE($GET(^ORD(101.41,ORDIALOG,5)),U,8)
+6 ;editor entry action
if $DATA(^ORD(101.41,ORDIALOG,3.1))
XECUTE ^(3.1)
+7 DO DIALOG^ORCDLG
DO DISPLAY^ORCDLG
+8 ;dlg exit action
if $DATA(^ORD(101.41,ORDIALOG,4))
XECUTE ^(4)
+9 QUIT
+10 ;
WINID ; -- Need to clear Window ID for GUI? [from EN]
+1 ;already cleared
if 'ORPKG
QUIT
if '$PIECE($GET(^ORD(101.41,ORDLG,5)),U,5)
QUIT
+2 ; ck prompts to see if they match OR GXMISC GENERAL
+3 NEW ORGXMISC,ORX,ORP,ORQUIT
+4 FOR ORX="ORDERABLE ITEM","FREE TEXT 1","START DATE/TIME","STOP DATE/TIME"
SET ORP=+$ORDER(^ORD(101.41,"AB","OR GTX "_ORX,0))
IF ORP
SET ORGXMISC(ORP)=""
IF '$ORDER(^ORD(101.41,ORDLG,10,"D",ORP,0))
SET ORQUIT=1
QUIT
+5 IF '$GET(ORQUIT)
SET ORP=0
FOR
SET ORP=$ORDER(^ORD(101.41,ORDLG,10,"D",ORP))
if ORP'>0
QUIT
IF '$DATA(ORGXMISC(ORP))
SET ORQUIT=1
QUIT
+6 ;clear ID
if $GET(ORQUIT)
SET $PIECE(^ORD(101.41,ORDLG,5),U,5)=""
+7 QUIT
+8 ;
ACTION ; -- Enter/edit actions
+1 NEW DA,DR,DIE,ORNAME
SET DIE="^ORD(101.41,"
+2 FOR
SET DA=$$DIALOG^ORCMEDT0("A")
if DA="^"
QUIT
Begin DoDot:1
+3 SET ORNAME=$$NAME^ORCMEDT4(DA)
if (ORNAME="@")!(ORNAME="^")
QUIT
+4 SET DR=".01///^S X=ORNAME;2;"_$SELECT(DUZ(0)="@":"30;40;",1:"")_"20"
DO ^DIE
End DoDot:1
WRITE !
+5 QUIT
