ORCMEDT0 ;SLC/MKB-Dialog Utilities ;Jun 17, 2022@14:32:43
;;3.0;ORDER ENTRY/RESULTS REPORTING;**46,60,190,215,243,296,389,539,569**;Dec 17, 1997;Build 23
DIALOG(TYPE) ; -- Get Dialog file entry
N X,Y,Z,D,DIC,DIE,DIK,DA,DR,DLAYGO,ORPKG,ORDLG,ORIT,OROI,I,IDX
;389/WAT - Sites have deleted entries in 101.41 w/o also removing pointers ergo reusing IENs can result in other file entries pointing back to
;incorrect order dialog entries. Adding a check if 3rd piece is not highest available IEN, then reset accordingly
N ORD03,ORD03TMP S ORD03=$P(^ORD(101.41,0),U,3) S ORD03TMP=$$CHKDA(ORD03)
I ORD03TMP'=ORD03 S $P(^ORD(101.41,0),U,3)=ORD03TMP
S ORPKG="ORDER ENTRY/RESULTS REPORTING",DIC="^ORD(101.41,",DIC(0)="AEQLZ"
S DIC("S")="I $P(^(0),U,4)="""_TYPE_"""",DLAYGO=101.41
S DIC("A")="Select "_$S(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",TYPE="A":"ACTION",1:"ORDER DIALOG")_" NAME: "
S DIC("DR")="4///"_TYPE_$S(TYPE="D":";7///^S X=ORPKG",1:"")
D0 S D="AB" D IX^DIC I Y'>0 S ORDLG="^" G DQ
S ORDLG=+Y,ORDG=$P(Y(0),U,5) G:'$P(Y,U,3) DQ ; not a new entry
I $O(^ORD(101.41,"AB",$P(Y,U,2),0))'=+Y W $C(7),!,"Another entry already exists by this name!",! D DEL(+Y) G D0
I TYPE="D" D G:ORDLG="^" DQ ;new dialog
. S DA=ORDLG,DR="5R",DIE=DIC,ORIT=$P(Y,U,2) D ^DIE
. S ORDG=+$P($G(^ORD(101.41,ORDLG,0)),U,5)
. I 'ORDG W $C(7),!,"Deleting <"_ORIT_"> ..." S DA=ORDLG,DIK=DIC D ^DIK S ORDLG="^" Q
. S ORIT=$$OI^ORCMEDT3(+ORDG) S:ORIT="^" ORDLG="^"
I TYPE="Q" D G DQ ;new quick order
. S DIC="^ORD(100.98,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,4)"
. S DIC("A")="TYPE OF QUICK ORDER: " D ^DIC
. ;I Y>0,$P($G(^ORD(100.98,+Y,0)),U)="ANATOMIC PATHOLOGY" S Y=0 W !,!,"ANATOMIC PATHOLOGY does not support quick orders at this time.",!
. I Y>0 S ORDG=+Y,$P(^ORD(101.41,ORDLG,0),U,5)=+Y Q
. W !,$P(^ORD(101.41,ORDLG,0),U)_" quick order dialog DELETED!",!
. S DA=ORDLG,DIK="^ORD(101.41,",ORDLG="^" D ^DIK
D1 I $$COPY^ORCMEDIT(TYPE) D ;copy an existing dialog?
. K DLAYGO,DIC("B") S DIC(0)="AEQZ",DIC("A")="Select "_$S(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",1:"ORDER DIALOG")_" TO COPY: "
. D ^DIC Q:Y'>0 W !,"Copying ..."
. F I=2,6,8,9 S $P(^ORD(101.41,ORDLG,0),U,I)=$P(Y(0),U,I)
. S:TYPE'="D" $P(^ORD(101.41,ORDLG,0),U,5)=$P(Y(0),U,5) ;skip DG if Dlg
. S:$L($P(Y(0),U,2)) ^ORD(101.41,"C",$$UP^XLFSTR($P(Y(0),U,2)),ORDLG)="" ;disp text
. F I=2,3,3.1,4,5,6,7,9,10 I $D(^ORD(101.41,+Y,I)) M ^ORD(101.41,ORDLG,I)=^ORD(101.41,+Y,I)
. I $P(Y(0),U,7) S DA=ORDLG,DIE=DIC,DR="7///"_$P(Y(0),U,7) D ^DIE
. K DA S DA(1)=ORDLG,DIK="^ORD(101.41,"_ORDLG_",10,",DIK(1)="2^AD" D ENALL^DIK
D2 I TYPE="D",$G(ORIT) D ;stuff in default OI
. S DA=ORDLG,DR="2///"_$P(ORIT,U,2),DIE="^ORD(101.41," D ^DIE
. S OROI=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),DA=$O(^ORD(101.41,ORDLG,10,"D",OROI,0)) I 'DA D Q:'DA ;create OI prompt
.. S X=+$O(^ORD(101.41,ORDLG,10,"B",0)),X=$S(X=0:1,1:X-.1) ;get Seq#
.. K DA,DIC S DIC="^ORD(101.41,"_ORDLG_",10,",DIC(0)="L",DA(1)=ORDLG
.. D ^DIC Q:Y'>0 S DA=+Y ;S DIC("P")=$P(^DD(101.41,10,0),U,2)
.. S Z=+$O(^ORD(101.41,ORDLG,10,"ATXT",0)),Z=$S(Z=0:1,1:Z-.1) ;TxtSeq#
.. S ^ORD(101.41,ORDLG,10,DA,0)=X_U_OROI_"^^Order: ^^1",^(2)=Z
.. S ^ORD(101.41,"AD",OROI,ORDLG,DA)="",^ORD(101.41,ORDLG,10,"B",X,DA)="",^ORD(101.41,ORDLG,10,"D",OROI,DA)="",^ORD(101.41,ORDLG,10,"ATXT",X,DA)=""
. S IDX="S."_$P($G(^ORD(100.98,+ORDG,0)),U,3)
. S $P(^ORD(101.41,ORDLG,10,DA,0),U,8)=1,$P(^(0),U,10)=IDX,^(3)="I 0 ;uneditable",^(7)="S Y="_+ORIT
DQ Q ORDLG
;
DEL(DA) ; -- delete bad entry in Order Dialog file
N DIK S DIK="^ORD(101.41," D:$G(DA) ^DIK
Q
;
SAVE ; -- Save ORDG, responses in ORDIALOG to dialog ORQDLG
N PROMPT,CNT,ITM,TYPE,INST,VALUE,INP,UD K ^ORD(101.41,ORQDLG,6)
S (PROMPT,CNT)=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0 D
. S ITM=ORDIALOG(PROMPT),TYPE=$E(ORDIALOG(PROMPT,0))
. S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 D
. . S VALUE=$G(ORDIALOG(PROMPT,INST)),CNT=CNT+1
. . S ^ORD(101.41,ORQDLG,6,CNT,0)=+ITM_U_PROMPT_U_INST
. . S:TYPE'="W" ^ORD(101.41,ORQDLG,6,CNT,1)=VALUE
. . M:TYPE="W" ^ORD(101.41,ORQDLG,6,CNT,2)=@VALUE
. . S ^ORD(101.41,ORQDLG,6,"D",PROMPT,CNT)=""
S ^ORD(101.41,ORQDLG,6,0)="^101.416^"_CNT_U_CNT
S INP=+$O(^ORD(100.98,"B","INPATIENT MEDICATIONS",""))
S UD=+$O(^ORD(100.98,"B","UNIT DOSE MEDICATIONS",""))
I +$G(ORDG)>0,ORDG=INP,UD>0 S ORDG=UD
S:$G(ORDG) $P(^ORD(101.41,ORQDLG,0),U,5)=+ORDG
Q
;
ITEM(Z) ; -- Select new item to add
N X,Y,DIC,ORDDF,ORERR,I
S DIC=101.41,DIC(0)="AEQM",DIC("A")="ITEM: "
I $G(Z) S Z=$P($G(^ORD(101.41,+Z,0)),U) S:$L(Z) DIC("B")=Z
S DIC("S")="I $P(^(0),U,4)'=""P"""
IT1 D ^DIC I Y'>0 S Y=$S($D(DUOUT)!$D(DTOUT):"^",1:"") Q Y
D RECURSV^ORCMEDT5(+Y,+ORMENU,.ORERR) I $D(ORERR) D G IT1
. W $C(7),!!,"If an item is already included on this menu, it may not be added!"
. W !,ORERR S I=0 F S I=$O(ORERR(I)) Q:I'>0 W !?18," =>"_ORERR(I)
Q +Y
;
CHKDA(ORIFN) ; return numerically largest IEN in use
N ORFLG,ORNEW
S ORFLG=0
;ORIFN - 3rd piece 0 node
;ORFLG - Set to 1 when the largest IEN is found
;ORNEW - next higher IEN
Q:$G(ORIFN)=""
S ORNEW=ORIFN
F S ORNEW=$O(^ORD(101.41,ORNEW)) D Q:ORFLG=1
. I +$O(^ORD(101.41,ORNEW))'>0 S ORFLG=1 Q
I +$G(ORNEW)>ORIFN Q ORNEW
Q ORIFN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCMEDT0 5299 printed Apr 09, 2024@21:27:13 Page 2
ORCMEDT0 ;SLC/MKB-Dialog Utilities ;Jun 17, 2022@14:32:43
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**46,60,190,215,243,296,389,539,569**;Dec 17, 1997;Build 23
DIALOG(TYPE) ; -- Get Dialog file entry
+1 NEW X,Y,Z,D,DIC,DIE,DIK,DA,DR,DLAYGO,ORPKG,ORDLG,ORIT,OROI,I,IDX
+2 ;389/WAT - Sites have deleted entries in 101.41 w/o also removing pointers ergo reusing IENs can result in other file entries pointing back to
+3 ;incorrect order dialog entries. Adding a check if 3rd piece is not highest available IEN, then reset accordingly
+4 NEW ORD03,ORD03TMP
SET ORD03=$PIECE(^ORD(101.41,0),U,3)
SET ORD03TMP=$$CHKDA(ORD03)
+5 IF ORD03TMP'=ORD03
SET $PIECE(^ORD(101.41,0),U,3)=ORD03TMP
+6 SET ORPKG="ORDER ENTRY/RESULTS REPORTING"
SET DIC="^ORD(101.41,"
SET DIC(0)="AEQLZ"
+7 SET DIC("S")="I $P(^(0),U,4)="""_TYPE_""""
SET DLAYGO=101.41
+8 SET DIC("A")="Select "_$SELECT(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",TYPE="A":"ACTION",1:"ORDER DIALOG")_" NAME: "
+9 SET DIC("DR")="4///"_TYPE_$SELECT(TYPE="D":";7///^S X=ORPKG",1:"")
D0 SET D="AB"
DO IX^DIC
IF Y'>0
SET ORDLG="^"
GOTO DQ
+1 ; not a new entry
SET ORDLG=+Y
SET ORDG=$PIECE(Y(0),U,5)
if '$PIECE(Y,U,3)
GOTO DQ
+2 IF $ORDER(^ORD(101.41,"AB",$PIECE(Y,U,2),0))'=+Y
WRITE $CHAR(7),!,"Another entry already exists by this name!",!
DO DEL(+Y)
GOTO D0
+3 ;new dialog
IF TYPE="D"
Begin DoDot:1
+4 SET DA=ORDLG
SET DR="5R"
SET DIE=DIC
SET ORIT=$PIECE(Y,U,2)
DO ^DIE
+5 SET ORDG=+$PIECE($GET(^ORD(101.41,ORDLG,0)),U,5)
+6 IF 'ORDG
WRITE $CHAR(7),!,"Deleting <"_ORIT_"> ..."
SET DA=ORDLG
SET DIK=DIC
DO ^DIK
SET ORDLG="^"
QUIT
+7 SET ORIT=$$OI^ORCMEDT3(+ORDG)
if ORIT="^"
SET ORDLG="^"
End DoDot:1
if ORDLG="^"
GOTO DQ
+8 ;new quick order
IF TYPE="Q"
Begin DoDot:1
+9 SET DIC="^ORD(100.98,"
SET DIC(0)="AEQM"
SET DIC("S")="I $P(^(0),U,4)"
+10 SET DIC("A")="TYPE OF QUICK ORDER: "
DO ^DIC
+11 ;I Y>0,$P($G(^ORD(100.98,+Y,0)),U)="ANATOMIC PATHOLOGY" S Y=0 W !,!,"ANATOMIC PATHOLOGY does not support quick orders at this time.",!
+12 IF Y>0
SET ORDG=+Y
SET $PIECE(^ORD(101.41,ORDLG,0),U,5)=+Y
QUIT
+13 WRITE !,$PIECE(^ORD(101.41,ORDLG,0),U)_" quick order dialog DELETED!",!
+14 SET DA=ORDLG
SET DIK="^ORD(101.41,"
SET ORDLG="^"
DO ^DIK
End DoDot:1
GOTO DQ
D1 ;copy an existing dialog?
IF $$COPY^ORCMEDIT(TYPE)
Begin DoDot:1
+1 KILL DLAYGO,DIC("B")
SET DIC(0)="AEQZ"
SET DIC("A")="Select "_$SELECT(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",1:"ORDER DIALOG")_" TO COPY: "
+2 DO ^DIC
if Y'>0
QUIT
WRITE !,"Copying ..."
+3 FOR I=2,6,8,9
SET $PIECE(^ORD(101.41,ORDLG,0),U,I)=$PIECE(Y(0),U,I)
+4 ;skip DG if Dlg
if TYPE'="D"
SET $PIECE(^ORD(101.41,ORDLG,0),U,5)=$PIECE(Y(0),U,5)
+5 ;disp text
if $LENGTH($PIECE(Y(0),U,2))
SET ^ORD(101.41,"C",$$UP^XLFSTR($PIECE(Y(0),U,2)),ORDLG)=""
+6 FOR I=2,3,3.1,4,5,6,7,9,10
IF $DATA(^ORD(101.41,+Y,I))
MERGE ^ORD(101.41,ORDLG,I)=^ORD(101.41,+Y,I)
+7 IF $PIECE(Y(0),U,7)
SET DA=ORDLG
SET DIE=DIC
SET DR="7///"_$PIECE(Y(0),U,7)
DO ^DIE
+8 KILL DA
SET DA(1)=ORDLG
SET DIK="^ORD(101.41,"_ORDLG_",10,"
SET DIK(1)="2^AD"
DO ENALL^DIK
End DoDot:1
D2 ;stuff in default OI
IF TYPE="D"
IF $GET(ORIT)
Begin DoDot:1
+1 SET DA=ORDLG
SET DR="2///"_$PIECE(ORIT,U,2)
SET DIE="^ORD(101.41,"
DO ^DIE
+2 ;create OI prompt
SET OROI=$$PTR^ORCD("OR GTX ORDERABLE ITEM")
SET DA=$ORDER(^ORD(101.41,ORDLG,10,"D",OROI,0))
IF 'DA
Begin DoDot:2
+3 ;get Seq#
SET X=+$ORDER(^ORD(101.41,ORDLG,10,"B",0))
SET X=$SELECT(X=0:1,1:X-.1)
+4 KILL DA,DIC
SET DIC="^ORD(101.41,"_ORDLG_",10,"
SET DIC(0)="L"
SET DA(1)=ORDLG
+5 ;S DIC("P")=$P(^DD(101.41,10,0),U,2)
DO ^DIC
if Y'>0
QUIT
SET DA=+Y
+6 ;TxtSeq#
SET Z=+$ORDER(^ORD(101.41,ORDLG,10,"ATXT",0))
SET Z=$SELECT(Z=0:1,1:Z-.1)
+7 SET ^ORD(101.41,ORDLG,10,DA,0)=X_U_OROI_"^^Order: ^^1"
SET ^(2)=Z
+8 SET ^ORD(101.41,"AD",OROI,ORDLG,DA)=""
SET ^ORD(101.41,ORDLG,10,"B",X,DA)=""
SET ^ORD(101.41,ORDLG,10,"D",OROI,DA)=""
SET ^ORD(101.41,ORDLG,10,"ATXT",X,DA)=""
End DoDot:2
if 'DA
QUIT
+9 SET IDX="S."_$PIECE($GET(^ORD(100.98,+ORDG,0)),U,3)
+10 SET $PIECE(^ORD(101.41,ORDLG,10,DA,0),U,8)=1
SET $PIECE(^(0),U,10)=IDX
SET ^(3)="I 0 ;uneditable"
SET ^(7)="S Y="_+ORIT
End DoDot:1
DQ QUIT ORDLG
+1 ;
DEL(DA) ; -- delete bad entry in Order Dialog file
+1 NEW DIK
SET DIK="^ORD(101.41,"
if $GET(DA)
DO ^DIK
+2 QUIT
+3 ;
SAVE ; -- Save ORDG, responses in ORDIALOG to dialog ORQDLG
+1 NEW PROMPT,CNT,ITM,TYPE,INST,VALUE,INP,UD
KILL ^ORD(101.41,ORQDLG,6)
+2 SET (PROMPT,CNT)=0
FOR
SET PROMPT=$ORDER(ORDIALOG(PROMPT))
if PROMPT'>0
QUIT
Begin DoDot:1
+3 SET ITM=ORDIALOG(PROMPT)
SET TYPE=$EXTRACT(ORDIALOG(PROMPT,0))
+4 SET INST=0
FOR
SET INST=$ORDER(ORDIALOG(PROMPT,INST))
if INST'>0
QUIT
Begin DoDot:2
+5 SET VALUE=$GET(ORDIALOG(PROMPT,INST))
SET CNT=CNT+1
+6 SET ^ORD(101.41,ORQDLG,6,CNT,0)=+ITM_U_PROMPT_U_INST
+7 if TYPE'="W"
SET ^ORD(101.41,ORQDLG,6,CNT,1)=VALUE
+8 if TYPE="W"
MERGE ^ORD(101.41,ORQDLG,6,CNT,2)=@VALUE
+9 SET ^ORD(101.41,ORQDLG,6,"D",PROMPT,CNT)=""
End DoDot:2
End DoDot:1
+10 SET ^ORD(101.41,ORQDLG,6,0)="^101.416^"_CNT_U_CNT
+11 SET INP=+$ORDER(^ORD(100.98,"B","INPATIENT MEDICATIONS",""))
+12 SET UD=+$ORDER(^ORD(100.98,"B","UNIT DOSE MEDICATIONS",""))
+13 IF +$GET(ORDG)>0
IF ORDG=INP
IF UD>0
SET ORDG=UD
+14 if $GET(ORDG)
SET $PIECE(^ORD(101.41,ORQDLG,0),U,5)=+ORDG
+15 QUIT
+16 ;
ITEM(Z) ; -- Select new item to add
+1 NEW X,Y,DIC,ORDDF,ORERR,I
+2 SET DIC=101.41
SET DIC(0)="AEQM"
SET DIC("A")="ITEM: "
+3 IF $GET(Z)
SET Z=$PIECE($GET(^ORD(101.41,+Z,0)),U)
if $LENGTH(Z)
SET DIC("B")=Z
+4 SET DIC("S")="I $P(^(0),U,4)'=""P"""
IT1 DO ^DIC
IF Y'>0
SET Y=$SELECT($DATA(DUOUT)!$DATA(DTOUT):"^",1:"")
QUIT Y
+1 DO RECURSV^ORCMEDT5(+Y,+ORMENU,.ORERR)
IF $DATA(ORERR)
Begin DoDot:1
+2 WRITE $CHAR(7),!!,"If an item is already included on this menu, it may not be added!"
+3 WRITE !,ORERR
SET I=0
FOR
SET I=$ORDER(ORERR(I))
if I'>0
QUIT
WRITE !?18," =>"_ORERR(I)
End DoDot:1
GOTO IT1
+4 QUIT +Y
+5 ;
CHKDA(ORIFN) ; return numerically largest IEN in use
+1 NEW ORFLG,ORNEW
+2 SET ORFLG=0
+3 ;ORIFN - 3rd piece 0 node
+4 ;ORFLG - Set to 1 when the largest IEN is found
+5 ;ORNEW - next higher IEN
+6 if $GET(ORIFN)=""
QUIT
+7 SET ORNEW=ORIFN
+8 FOR
SET ORNEW=$ORDER(^ORD(101.41,ORNEW))
Begin DoDot:1
+9 IF +$ORDER(^ORD(101.41,ORNEW))'>0
SET ORFLG=1
QUIT
End DoDot:1
if ORFLG=1
QUIT
+10 IF +$GET(ORNEW)>ORIFN
QUIT ORNEW
+11 QUIT ORIFN
