ORCMEDT1 ;SLC/MKB-QO,Set editor ;Aug 18, 2022@08:07
;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,57,95,110,245,243,296,341,377,569**;Dec 17, 1997;Build 23
OI ; -- Enter/edit generic orderable items
N X,Y,DA,DR,DIE,DIC,ID,DLAYGO,ORDG
F S ORDG=$$DGRP Q:ORDG'>0 D W !!
. F S D="S."_$P(ORDG,U,4) D Q:Y'>0 S DA=+Y,ID=DA_";99ORD",DR=".01"_$S($P(Y,U,3):";2///^S X=ID;5////"_+ORDG,1:"") D ^DIE W ! ;110
.. ;*341 Screen OI from editing if it isn't in the DG.
.. S DIC("S")="I $P(^(0),U,5)="_+ORDG,DIC="^ORD(101.43,",DIC(0)="AEQL",DLAYGO=101.43,DIE=DIC D IX^DIC ;110
Q
;
DGRP() ; -- Returns sub-display group of Nursing or Other for generic OI
N X,Y,DIC,ORGRP,ORDG,ORI
F ORI="NURS","OTHER" S ORDG=+$O(^ORD(100.98,"B",ORI,0)) D DG^ORCHANG1(ORDG,"BILD",.ORGRP)
S DIC="^ORD(100.98,",DIC(0)="AEQ",DIC("S")="I $D(ORGRP(+Y))"
S DIC("A")="Type of Orderable: " D ^DIC
S:Y>0 Y=+Y_U_$G(^ORD(100.98,+Y,0))
Q Y
;
QUICK ; -- Enter/edit quick order dialogs
N ORQDLG,ORDG
F S ORQDLG=$$DIALOG^ORCMEDT0("Q") Q:ORQDLG="^" D QCK0(ORQDLG) W !
Q
QCK0(ORQDLG) ; -- edit quick order ORQDLG
N ORDIALOG,DA,DR,DIE,DIDEL,ORQUIT,ORVP,ORL,ACTION,FIRST,ORTYPE,ORNAME,X,Y,BEFORCRC,AFTERCRC,ISAPDLG,OK2PLACE
Q:'$G(ORQDLG) S DA=ORQDLG,(ORVP,ORL)=0,FIRST=1,ORTYPE="Z",ISAPDLG=$$ISAPDLG(ORQDLG)
S ORNAME=$$NAME^ORCMEDT4(ORQDLG) Q:(ORNAME="@")!(ORNAME="^") ;deleted,^
S BEFORCRC=$$RAWCRC^ORCMEDT8(ORQDLG)
I ISAPDLG!($$ISTUBEQO^ORWDXM3(ORQDLG)=1) S DR=".01///^S X=ORNAME;2;20"_$S(DUZ(0)="@":";30",1:"")
E S DR=".01///^S X=ORNAME;2;8;20"_$S(DUZ(0)="@":";30",1:"")
S DIE="^ORD(101.41,"
D ^DIE G:$D(Y)!$D(DTOUT) QR D GETQDLG^ORCD(ORQDLG) G:'$G(ORDIALOG) QR
I '$P($G(^ORD(101.41,ORQDLG,0)),U,7) S X=+$P($G(^ORD(101.41,+ORDIALOG,0)),U,7) S:X $P(^ORD(101.41,ORQDLG,0),U,7)=X,^ORD(101.41,"APKG",X,ORQDLG)=""
W ! I $D(^ORD(101.41,+ORDIALOG,3.1)) X ^(3.1) G:$G(ORQUIT) QQ
Q1 D DIALOG^ORCDLG G:$G(ORQUIT) QQ
D DISPLAY^ORCDLG
S OK2PLACE=1 I ISAPDLG,$$ISINVALID^ORWLRAP2 S OK2PLACE=0
S ACTION=$$OK(OK2PLACE) G:ACTION="^" QQ
I ACTION="P" D SAVE^ORCMEDT0 I 'ISAPDLG D AUTO(ORQDLG)
I ACTION="E" S FIRST=0 G Q1 ;fall thru if "C"
QQ X:$D(^ORD(101.41,+ORDIALOG,4)) ^(4)
QR S AFTERCRC=$$RAWCRC^ORCMEDT8(ORQDLG)
I BEFORCRC'=AFTERCRC D UPDQNAME^ORCMEDT8(ORQDLG) ; Rename personal quick order if modified
Q
;
OK(OK2PLACE) ; -- Ready to save?
N X,Y,DIR S DIR(0)="SAM^"_$S(OK2PLACE:"P:PLACE;",1:"")_"E:EDIT;C:CANCEL;",DIR("B")=$S(OK2PLACE:"PLACE",1:"EDIT")
S DIR("A")=$S(OK2PLACE:"(P)lace, ",1:"")_"(E)dit, or (C)ancel this quick order? "
S DIR("?")="Enter "_$S(OK2PLACE:"P to save this quick order, or ",1:"")
S DIR("?")=DIR("?")_"E to change any of the displayed values; enter C to quit without saving these responses"
D ^DIR S:$D(DTOUT) Y="^"
Q Y
;
SAVE G SAVE^ORCMEDT0
;
AUTO(DLG) ; -- set AutoAccept flag for GUI
N X,Y,DIR
I $$VBQO^ORWDXM4(+DLG)=0 S $P(^ORD(101.41,+DLG,5),U,8)="" Q
I $$VALQO^ORWDXM3(+DLG)=0 S $P(^ORD(101.41,+DLG,5),U,8)="" Q
I $$ISTUBEQO^ORWDXM3(+DLG)=1 S $P(^ORD(101.41,+DLG,5),U,8)="" Q
S DIR(0)="YA",DIR("A")="Auto-accept this order? "
S DIR("B")=$S($P($G(^ORD(101.41,+DLG,5)),U,8):"YES",1:"NO")
S DIR("?")="Enter YES if this order can be placed simply by selecting it, or NO if the dialog should be presented to complete the order."
D ^DIR S:Y=1!(Y=0) $P(^ORD(101.41,+DLG,5),U,8)=$S(Y:1,1:"")
I $P($G(^ORD(101.41,+DLG,0)),"^",8)'=1&($P($G(^(0)),"^",9)=2)&(Y) D EXPLAIN S $P(^ORD(101.41,+DLG,5),"^",8)="" ;Reset auto-accept to no if explanation required.
Q
;
SET ; -- Order Sets
N ORSET,ORDG
F S ORSET=$$DIALOG^ORCMEDT0("O") Q:ORSET="^" D SET0(ORSET) W !
Q
SET0(ORSET) ; -- edit order set ORSET
N DA,DR,DIE,DIC,DIK,X,Y,SEQ,ITM,LCNT,QUIT,ORNAME Q:'$G(ORSET)
S ORNAME=$$NAME^ORCMEDT4(ORSET) Q:(ORNAME="@")!(ORNAME="^") ;deleted,^
S DR=".01///^S X=ORNAME;2;20"_$S(DUZ(0)="@":";30;40",1:""),DA=ORSET
S DIE="^ORD(101.41," D ^DIE Q:$D(Y) Q:'$G(DA)
S1 I $O(^ORD(101.41,+ORSET,10,0)) D Q:QUIT ;Show existing components
. W !,"ORDER SET COMPONENTS:" S (SEQ,LCNT,QUIT)=0
. S DIK="^ORD(101.41,"_+ORSET_",10,",DA(1)=+ORSET ;just in case
. F S SEQ=$O(^ORD(101.41,+ORSET,10,"B",SEQ)) Q:SEQ'>0 D
. . S DA=0 F S DA=$O(^ORD(101.41,+ORSET,10,"B",SEQ,DA)) Q:DA'>0 D
. . . S ITM=$P($G(^ORD(101.41,+ORSET,10,DA,0)),U,2) I ITM'>0 D ^DIK Q
. . . S LCNT=LCNT+1 I LCNT>(IOSL-3) R !,"Press <return> to continue ...",X:DTIME S LCNT=0 I X["^" S QUIT=1 Q
. . . W !?3,SEQ,?10,$P(^ORD(101.41,ITM,0),U)
S2 S QUIT=0 F D Q:QUIT W ! ;Enter/edit components
. S DIC="^ORD(101.41,"_+ORSET_",10,",DIC(0)="AEQLM",D="B^D"
. S DIC("A")="Select COMPONENT SEQUENCE#: ",DIC("P")=$P(^DD(101.41,10,0),U,2)
. K DA S DA(1)=+ORSET D MIX^DIC1 I Y'>0 S QUIT=1 Q
. S DA=+Y,DIE=DIC,DR=".01;2R" D ^DIE Q:'$G(DA)
. I $D(^ORD(101.41,+ORSET,10,DA,0)),'$P(^(0),U,2) S DIK=DIE D ^DIK
Q
;
PROTOCOL ; -- Convert additional protocols to dialogs
N X,Y,DIC,ORERR
F S DIC="^ORD(101,",DIC(0)="AEQM" D ^DIC Q:Y'>0 D W !
. S ORP=+Y,ORM=$$MENU Q:ORM="^" ; What about "^^"-jumping? (ORWARD)
. W !,"Converting ..." D ONE(ORP,ORM,.ORERR) I '$G(ORERR) W " done." Q
. W " unable to convert.",!,">> "_$P(ORERR,U,2) K ORERR
Q
ONE(PITEM,ORADD,ERROR) ; -- Convert single item protocol, add to menu(s)
N PMENU,DMENU,NAME,ORPOS,POS,XUTL,DA,DIK
I $D(^ORD(100.99,1,101.41,PITEM,0)) S DA=PITEM,DA(1)=1,DIK="^ORD(100.99,1,101.41," D ^DIK ; delete error entry
S NAME=$P($G(^ORD(101,PITEM,0)),U),DITEM=$$ITEM^ORCONVRT(PITEM)
I 'DITEM!$D(^ORD(100.99,1,101.41,PITEM,0)) S ERROR=$G(^(0)) Q
Q:'$G(ORADD) ;to add, may enter here with PITEM & DITEM defined
ADD S PMENU=0 F S PMENU=$O(^ORD(101,"AD",PITEM,PMENU)) Q:PMENU'>0 D W "."
. S DMENU=$O(^ORD(101.41,"AB",$P(^ORD(101,PMENU,0),U),0)) Q:'DMENU
. S ORPOS=$$FINDXUTL(PMENU,PITEM) Q:'ORPOS
. S XUTL=$G(^XUTL("XQORM",PMENU_";ORD(101,",ORPOS,0))
. S DA=$O(^ORD(101.41,DMENU,10,"B",ORPOS,0)) I DA Q:$P(^ORD(101.41,DMENU,10,DA,0),U,2)=DITEM S POS=$O(^ORD(101.41,DMENU,10,"B",""),-1),ORPOS=($P(POS,".")+1)_".1",DA="" ; move to end, if collision
. S DA=$$NEXT^ORCONVRT(DMENU)
. S ^ORD(101.41,DMENU,10,DA,0)=ORPOS_U_DITEM_U_$P(XUTL,U,4)_U_$S($P(XUTL,U,3)'=$P(^ORD(101.41,DITEM,0),U,2):$P(XUTL,U,3),1:"")
. S ^ORD(101.41,DMENU,10,"B",ORPOS,DA)="",^ORD(101.41,DMENU,10,"D",DITEM,DA)=""
. S ^ORD(101.41,"AD",DITEM,DMENU,DA)="",^ORD(101.41,DMENU,99)=$H
Q
;
FINDXUTL(MENU,ITEM) ; -- Returns position of ITEM in MENU
N XQORM,POS
S XQORM=MENU_";ORD(101," D XREF^XQORM
S POS=0 F S POS=$O(^XUTL("XQORM",XQORM,POS)) Q:POS'>0 I $P(^(POS,0),U,2)=ITEM Q
Q POS
;
N X,Y,DIR S DIR(0)="YA"
S DIR("A")="Add this item to the same menus again? ",DIR("B")="YES"
S DIR("?")="Enter YES to have this item placed on the same menus in the Order Dialog file as it was in the Protocol file"
D ^DIR S:$D(DTOUT) Y="^"
Q Y
EXPLAIN ;Give reason why user can't set auto-accept to yes
W !!,"The combination of VERIFY set to NO and ASK FOR ANOTHER ORDER set to",!,"YES, DON'T ASK and AUTO-ACCEPT set to YES is not allowed."
W !!,"This combination of settings could cause CPRS to enter into an infinite loop",!,"creating the same order over and over. If you wish to have"
W !,"AUTO-ACCEPT set to YES you must change one of the other two fields",!,"to a different value.",!!,"AUTO-ACCEPT is being set to NO for you."
Q
ISAPDLG(DA) ; Is order dialog ANATOMIC PATHOLOGY
N GRP,AP,CH
I '$G(DA) Q 0
S GRP=$P($G(^ORD(101.41,DA,0)),U,5) I 'GRP Q 0
S AP=$O(^ORD(100.98,"B","ANATOMIC PATHOLOGY",0)) I 'AP Q 0
I GRP=AP Q 1
I +$O(^ORD(100.98,AP,1,"B",GRP,0)) Q 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCMEDT1 7661 printed Apr 09, 2024@21:37:22 Page 2
ORCMEDT1 ;SLC/MKB-QO,Set editor ;Aug 18, 2022@08:07
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,57,95,110,245,243,296,341,377,569**;Dec 17, 1997;Build 23
OI ; -- Enter/edit generic orderable items
+1 NEW X,Y,DA,DR,DIE,DIC,ID,DLAYGO,ORDG
+2 FOR
SET ORDG=$$DGRP
if ORDG'>0
QUIT
Begin DoDot:1
+3 ;110
FOR
SET D="S."_$PIECE(ORDG,U,4)
Begin DoDot:2
+4 ;*341 Screen OI from editing if it isn't in the DG.
+5 ;110
SET DIC("S")="I $P(^(0),U,5)="_+ORDG
SET DIC="^ORD(101.43,"
SET DIC(0)="AEQL"
SET DLAYGO=101.43
SET DIE=DIC
DO IX^DIC
End DoDot:2
if Y'>0
QUIT
SET DA=+Y
SET ID=DA_";99ORD"
SET DR=".01"_$SELECT($PIECE(Y,U,3):";2///^S X=ID;5////"_+ORDG,1:"")
DO ^DIE
WRITE !
End DoDot:1
WRITE !!
+6 QUIT
+7 ;
DGRP() ; -- Returns sub-display group of Nursing or Other for generic OI
+1 NEW X,Y,DIC,ORGRP,ORDG,ORI
+2 FOR ORI="NURS","OTHER"
SET ORDG=+$ORDER(^ORD(100.98,"B",ORI,0))
DO DG^ORCHANG1(ORDG,"BILD",.ORGRP)
+3 SET DIC="^ORD(100.98,"
SET DIC(0)="AEQ"
SET DIC("S")="I $D(ORGRP(+Y))"
+4 SET DIC("A")="Type of Orderable: "
DO ^DIC
+5 if Y>0
SET Y=+Y_U_$GET(^ORD(100.98,+Y,0))
+6 QUIT Y
+7 ;
QUICK ; -- Enter/edit quick order dialogs
+1 NEW ORQDLG,ORDG
+2 FOR
SET ORQDLG=$$DIALOG^ORCMEDT0("Q")
if ORQDLG="^"
QUIT
DO QCK0(ORQDLG)
WRITE !
+3 QUIT
QCK0(ORQDLG) ; -- edit quick order ORQDLG
+1 NEW ORDIALOG,DA,DR,DIE,DIDEL,ORQUIT,ORVP,ORL,ACTION,FIRST,ORTYPE,ORNAME,X,Y,BEFORCRC,AFTERCRC,ISAPDLG,OK2PLACE
+2 if '$GET(ORQDLG)
QUIT
SET DA=ORQDLG
SET (ORVP,ORL)=0
SET FIRST=1
SET ORTYPE="Z"
SET ISAPDLG=$$ISAPDLG(ORQDLG)
+3 ;deleted,^
SET ORNAME=$$NAME^ORCMEDT4(ORQDLG)
if (ORNAME="@")!(ORNAME="^")
QUIT
+4 SET BEFORCRC=$$RAWCRC^ORCMEDT8(ORQDLG)
+5 IF ISAPDLG!($$ISTUBEQO^ORWDXM3(ORQDLG)=1)
SET DR=".01///^S X=ORNAME;2;20"_$SELECT(DUZ(0)="@":";30",1:"")
+6 IF '$TEST
SET DR=".01///^S X=ORNAME;2;8;20"_$SELECT(DUZ(0)="@":";30",1:"")
+7 SET DIE="^ORD(101.41,"
+8 DO ^DIE
if $DATA(Y)!$DATA(DTOUT)
GOTO QR
DO GETQDLG^ORCD(ORQDLG)
if '$GET(ORDIALOG)
GOTO QR
+9 IF '$PIECE($GET(^ORD(101.41,ORQDLG,0)),U,7)
SET X=+$PIECE($GET(^ORD(101.41,+ORDIALOG,0)),U,7)
if X
SET $PIECE(^ORD(101.41,ORQDLG,0),U,7)=X
SET ^ORD(101.41,"APKG",X,ORQDLG)=""
+10 WRITE !
IF $DATA(^ORD(101.41,+ORDIALOG,3.1))
XECUTE ^(3.1)
if $GET(ORQUIT)
GOTO QQ
Q1 DO DIALOG^ORCDLG
if $GET(ORQUIT)
GOTO QQ
+1 DO DISPLAY^ORCDLG
+2 SET OK2PLACE=1
IF ISAPDLG
IF $$ISINVALID^ORWLRAP2
SET OK2PLACE=0
+3 SET ACTION=$$OK(OK2PLACE)
if ACTION="^"
GOTO QQ
+4 IF ACTION="P"
DO SAVE^ORCMEDT0
IF 'ISAPDLG
DO AUTO(ORQDLG)
+5 ;fall thru if "C"
IF ACTION="E"
SET FIRST=0
GOTO Q1
QQ if $DATA(^ORD(101.41,+ORDIALOG,4))
XECUTE ^(4)
QR SET AFTERCRC=$$RAWCRC^ORCMEDT8(ORQDLG)
+1 ; Rename personal quick order if modified
IF BEFORCRC'=AFTERCRC
DO UPDQNAME^ORCMEDT8(ORQDLG)
+2 QUIT
+3 ;
OK(OK2PLACE) ; -- Ready to save?
+1 NEW X,Y,DIR
SET DIR(0)="SAM^"_$SELECT(OK2PLACE:"P:PLACE;",1:"")_"E:EDIT;C:CANCEL;"
SET DIR("B")=$SELECT(OK2PLACE:"PLACE",1:"EDIT")
+2 SET DIR("A")=$SELECT(OK2PLACE:"(P)lace, ",1:"")_"(E)dit, or (C)ancel this quick order? "
+3 SET DIR("?")="Enter "_$SELECT(OK2PLACE:"P to save this quick order, or ",1:"")
+4 SET DIR("?")=DIR("?")_"E to change any of the displayed values; enter C to quit without saving these responses"
+5 DO ^DIR
if $DATA(DTOUT)
SET Y="^"
+6 QUIT Y
+7 ;
SAVE GOTO SAVE^ORCMEDT0
+1 ;
AUTO(DLG) ; -- set AutoAccept flag for GUI
+1 NEW X,Y,DIR
+2 IF $$VBQO^ORWDXM4(+DLG)=0
SET $PIECE(^ORD(101.41,+DLG,5),U,8)=""
QUIT
+3 IF $$VALQO^ORWDXM3(+DLG)=0
SET $PIECE(^ORD(101.41,+DLG,5),U,8)=""
QUIT
+4 IF $$ISTUBEQO^ORWDXM3(+DLG)=1
SET $PIECE(^ORD(101.41,+DLG,5),U,8)=""
QUIT
+5 SET DIR(0)="YA"
SET DIR("A")="Auto-accept this order? "
+6 SET DIR("B")=$SELECT($PIECE($GET(^ORD(101.41,+DLG,5)),U,8):"YES",1:"NO")
+7 SET DIR("?")="Enter YES if this order can be placed simply by selecting it, or NO if the dialog should be presented to complete the order."
+8 DO ^DIR
if Y=1!(Y=0)
SET $PIECE(^ORD(101.41,+DLG,5),U,8)=$SELECT(Y:1,1:"")
+9 ;Reset auto-accept to no if explanation required.
IF $PIECE($GET(^ORD(101.41,+DLG,0)),"^",8)'=1&($PIECE($GET(^(0)),"^",9)=2)&(Y)
DO EXPLAIN
SET $PIECE(^ORD(101.41,+DLG,5),"^",8)=""
+10 QUIT
+11 ;
SET ; -- Order Sets
+1 NEW ORSET,ORDG
+2 FOR
SET ORSET=$$DIALOG^ORCMEDT0("O")
if ORSET="^"
QUIT
DO SET0(ORSET)
WRITE !
+3 QUIT
SET0(ORSET) ; -- edit order set ORSET
+1 NEW DA,DR,DIE,DIC,DIK,X,Y,SEQ,ITM,LCNT,QUIT,ORNAME
if '$GET(ORSET)
QUIT
+2 ;deleted,^
SET ORNAME=$$NAME^ORCMEDT4(ORSET)
if (ORNAME="@")!(ORNAME="^")
QUIT
+3 SET DR=".01///^S X=ORNAME;2;20"_$SELECT(DUZ(0)="@":";30;40",1:"")
SET DA=ORSET
+4 SET DIE="^ORD(101.41,"
DO ^DIE
if $DATA(Y)
QUIT
if '$GET(DA)
QUIT
S1 ;Show existing components
IF $ORDER(^ORD(101.41,+ORSET,10,0))
Begin DoDot:1
+1 WRITE !,"ORDER SET COMPONENTS:"
SET (SEQ,LCNT,QUIT)=0
+2 ;just in case
SET DIK="^ORD(101.41,"_+ORSET_",10,"
SET DA(1)=+ORSET
+3 FOR
SET SEQ=$ORDER(^ORD(101.41,+ORSET,10,"B",SEQ))
if SEQ'>0
QUIT
Begin DoDot:2
+4 SET DA=0
FOR
SET DA=$ORDER(^ORD(101.41,+ORSET,10,"B",SEQ,DA))
if DA'>0
QUIT
Begin DoDot:3
+5 SET ITM=$PIECE($GET(^ORD(101.41,+ORSET,10,DA,0)),U,2)
IF ITM'>0
DO ^DIK
QUIT
+6 SET LCNT=LCNT+1
IF LCNT>(IOSL-3)
READ !,"Press <return> to continue ...",X:DTIME
SET LCNT=0
IF X["^"
SET QUIT=1
QUIT
+7 WRITE !?3,SEQ,?10,$PIECE(^ORD(101.41,ITM,0),U)
End DoDot:3
End DoDot:2
End DoDot:1
if QUIT
QUIT
S2 ;Enter/edit components
SET QUIT=0
FOR
Begin DoDot:1
+1 SET DIC="^ORD(101.41,"_+ORSET_",10,"
SET DIC(0)="AEQLM"
SET D="B^D"
+2 SET DIC("A")="Select COMPONENT SEQUENCE#: "
SET DIC("P")=$PIECE(^DD(101.41,10,0),U,2)
+3 KILL DA
SET DA(1)=+ORSET
DO MIX^DIC1
IF Y'>0
SET QUIT=1
QUIT
+4 SET DA=+Y
SET DIE=DIC
SET DR=".01;2R"
DO ^DIE
if '$GET(DA)
QUIT
+5 IF $DATA(^ORD(101.41,+ORSET,10,DA,0))
IF '$PIECE(^(0),U,2)
SET DIK=DIE
DO ^DIK
End DoDot:1
if QUIT
QUIT
WRITE !
+6 QUIT
+7 ;
PROTOCOL ; -- Convert additional protocols to dialogs
+1 NEW X,Y,DIC,ORERR
+2 FOR
SET DIC="^ORD(101,"
SET DIC(0)="AEQM"
DO ^DIC
if Y'>0
QUIT
Begin DoDot:1
+3 ; What about "^^"-jumping? (ORWARD)
SET ORP=+Y
SET ORM=$$MENU
if ORM="^"
QUIT
+4 WRITE !,"Converting ..."
DO ONE(ORP,ORM,.ORERR)
IF '$GET(ORERR)
WRITE " done."
QUIT
+5 WRITE " unable to convert.",!,">> "_$PIECE(ORERR,U,2)
KILL ORERR
End DoDot:1
WRITE !
+6 QUIT
ONE(PITEM,ORADD,ERROR) ; -- Convert single item protocol, add to menu(s)
+1 NEW PMENU,DMENU,NAME,ORPOS,POS,XUTL,DA,DIK
+2 ; delete error entry
IF $DATA(^ORD(100.99,1,101.41,PITEM,0))
SET DA=PITEM
SET DA(1)=1
SET DIK="^ORD(100.99,1,101.41,"
DO ^DIK
+3 SET NAME=$PIECE($GET(^ORD(101,PITEM,0)),U)
SET DITEM=$$ITEM^ORCONVRT(PITEM)
+4 IF 'DITEM!$DATA(^ORD(100.99,1,101.41,PITEM,0))
SET ERROR=$GET(^(0))
QUIT
+5 ;to add, may enter here with PITEM & DITEM defined
if '$GET(ORADD)
QUIT
ADD SET PMENU=0
FOR
SET PMENU=$ORDER(^ORD(101,"AD",PITEM,PMENU))
if PMENU'>0
QUIT
Begin DoDot:1
+1 SET DMENU=$ORDER(^ORD(101.41,"AB",$PIECE(^ORD(101,PMENU,0),U),0))
if 'DMENU
QUIT
+2 SET ORPOS=$$FINDXUTL(PMENU,PITEM)
if 'ORPOS
QUIT
+3 SET XUTL=$GET(^XUTL("XQORM",PMENU_";ORD(101,",ORPOS,0))
+4 ; move to end, if collision
SET DA=$ORDER(^ORD(101.41,DMENU,10,"B",ORPOS,0))
IF DA
if $PIECE(^ORD(101.41,DMENU,10,DA,0),U,2)=DITEM
QUIT
SET POS=$ORDER(^ORD(101.41,DMENU,10,"B",""),-1)
SET ORPOS=($PIECE(POS,".")+1)_".1"
SET DA=""
+5 SET DA=$$NEXT^ORCONVRT(DMENU)
+6 SET ^ORD(101.41,DMENU,10,DA,0)=ORPOS_U_DITEM_U_$PIECE(XUTL,U,4)_U_$SELECT($PIECE(XUTL,U,3)'=$PIECE(^ORD(101.41,DITEM,0),U,2):$PIECE(XUTL,U,3),1:"")
+7 SET ^ORD(101.41,DMENU,10,"B",ORPOS,DA)=""
SET ^ORD(101.41,DMENU,10,"D",DITEM,DA)=""
+8 SET ^ORD(101.41,"AD",DITEM,DMENU,DA)=""
SET ^ORD(101.41,DMENU,99)=$HOROLOG
End DoDot:1
WRITE "."
+9 QUIT
+10 ;
FINDXUTL(MENU,ITEM) ; -- Returns position of ITEM in MENU
+1 NEW XQORM,POS
+2 SET XQORM=MENU_";ORD(101,"
DO XREF^XQORM
+3 SET POS=0
FOR
SET POS=$ORDER(^XUTL("XQORM",XQORM,POS))
if POS'>0
QUIT
IF $PIECE(^(POS,0),U,2)=ITEM
QUIT
+4 QUIT POS
+5 ;
+1 NEW X,Y,DIR
SET DIR(0)="YA"
+2 SET DIR("A")="Add this item to the same menus again? "
SET DIR("B")="YES"
+3 SET DIR("?")="Enter YES to have this item placed on the same menus in the Order Dialog file as it was in the Protocol file"
+4 DO ^DIR
if $DATA(DTOUT)
SET Y="^"
+5 QUIT Y
EXPLAIN ;Give reason why user can't set auto-accept to yes
+1 WRITE !!,"The combination of VERIFY set to NO and ASK FOR ANOTHER ORDER set to",!,"YES, DON'T ASK and AUTO-ACCEPT set to YES is not allowed."
+2 WRITE !!,"This combination of settings could cause CPRS to enter into an infinite loop",!,"creating the same order over and over. If you wish to have"
+3 WRITE !,"AUTO-ACCEPT set to YES you must change one of the other two fields",!,"to a different value.",!!,"AUTO-ACCEPT is being set to NO for you."
+4 QUIT
ISAPDLG(DA) ; Is order dialog ANATOMIC PATHOLOGY
+1 NEW GRP,AP,CH
+2 IF '$GET(DA)
QUIT 0
+3 SET GRP=$PIECE($GET(^ORD(101.41,DA,0)),U,5)
IF 'GRP
QUIT 0
+4 SET AP=$ORDER(^ORD(100.98,"B","ANATOMIC PATHOLOGY",0))
IF 'AP
QUIT 0
+5 IF GRP=AP
QUIT 1
+6 IF +$ORDER(^ORD(100.98,AP,1,"B",GRP,0))
QUIT 1
+7 QUIT 0
