- 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 Feb 18, 2025@23:55:11 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