ORCMEDT6 ;SLC/MKB-QO editor utilities ;12/18/02 13:33
;;3.0;ORDER ENTRY/RESULTS REPORTING;**164,297,548**;Dec 17, 1997;Build 3
;
QO ; -- Enter/edit QO restriction on orderable items
N X,Y,DA,DR,DIE,ORIT,OLDVAL,OREBLD
F S ORIT=$$OI("S.RX^S.LAB","Select an ORDERABLE ITEM (meds or labs only): ") Q:ORIT'>0 D W !!
. W !!,"Select the type of usage for which you wish to restrict ordering of this item."
. F S ORDG=$$SET(+ORIT) Q:"^"[ORDG D
.. S DA(1)=+ORIT,DA=+$O(^ORD(101.43,+ORIT,9,"B",ORDG,0))
.. S OLDVAL=$G(^ORD(101.43,+ORIT,9,DA,0))
.. S DR=2,DIE="^ORD(101.43,"_DA(1)_",9," D ^DIE W !
.. I ORDG="O RX"!(ORDG="UD RX"),OLDVAL'=$G(^ORD(101.43,+ORIT,9,DA,0)) S OREBLD(ORDG)=1
F ORDG="O RX","UD RX" I $G(OREBLD(ORDG)) D FVBLDQ^ORWUL(ORDG)
Q
;
SET(OI) ; -- Returns Set Membership for OI
N X,Y,I,DOMAIN,NAME,HELP,DONE
S X="",I=0 F S X=$O(^ORD(101.43,+OI,9,"B",X)) Q:X="" S NAME=$$NAME(X) I NAME'="PHARMACY" S I=I+1,DOMAIN(I)=X_U_NAME,DOMAIN("B",NAME)=I
S DOMAIN(0)=I,HELP="Select the type of usage for which you wish to restrict ordering of this item."
S DONE=0,Y="" F D Q:DONE
. W !,"Usage: "
. R X:DTIME S:'$T X="^" I X["^" S Y="^",DONE=1 Q
. I X="" S Y="^",DONE=1 Q
. I X["?" W !!,HELP D LIST Q
. D I 'Y W $C(7),!,HELP Q
. . N XP,XY,CNT,MATCH,DIR,I
. . S X=$$UP^XLFSTR(X),Y=+$G(DOMAIN("B",X)) Q:Y ; done
. . S CNT=0,XP=X F S XP=$O(DOMAIN("B",XP)) Q:XP="" Q:$E(XP,1,$L(X))'=X S CNT=CNT+1,XY=+DOMAIN("B",XP),MATCH(CNT)=XY_U_$P(DOMAIN(XY),U,2)
. . Q:'CNT
. . I CNT=1 S Y=+MATCH(1),XP=$P(MATCH(1),U,2) W $E(XP,$L(X)+1,$L(XP)) Q
. . S DIR(0)="NAO^1:"_CNT,DIR("A")="Select 1-"_CNT_": "
. . F I=1:1:CNT S DIR("A",I)=$J(I,3)_" "_$P(MATCH(I),U,2)
. . S DIR("?")="Select the desired value, by number"
. . D ^DIR I $D(DIRUT) S Y="" Q
. . S Y=+MATCH(Y) W " "_$P(DOMAIN(Y),U,2)
. S Y=$P(DOMAIN(Y),U),DONE=1
Q Y
;
LIST ; -- List order statuses in DOMAIN
N I,Z,CNT,DONE
S CNT=0 W !,"Choose from:"
F I=1:1:DOMAIN(0) D Q:$G(DONE)
. S CNT=CNT+1 W ! I CNT>(IOSL-3) D Q:$G(DONE)
.. W ?3,"'^' TO STOP: " R Z:DTIME S:'$T!(Z["^") DONE=1 S CNT=1
. W $C(13)," "_$P(DOMAIN(I),U,2)
Q
;
NAME(X) ; -- Returns full name of set X
N Y,I S Y=$S(X="IVA RX":"IV ADDITIVES",X="IVB RX":"IV SOLUTIONS",X="IVM RX":"IV MEDICATIONS",1:"")
I Y="" S I=+$O(^ORD(100.98,"B",X,0)),Y=$S(I:$P($G(^ORD(100.98,I,0)),U),1:X)
Q Y
;
OI(IDX,CAPTION) ; -- Returns selected OI from file #101.43 using IDX xrefs
N X,Y,D,DIC,DTOUT,DUOUT,DIRUT,DIROUT,ORDIC
S DIC="^ORD(101.43,",DIC(0)="AEQS" S:$L($G(CAPTION)) DIC("A")=CAPTION
S DIC("W")="W:$S('$D(%):0,'$D(DIY):0,%=DIY:0,1:1) $G(DIY)"
;OR*3*548 Indicate inactive OIs
S DIC("W")=DIC("W")_" D INACT^ORCMEDT6"
S D=IDX,ORDIC="IX^DIC" S:$L(D,U)>1 ORDIC="MIX^DIC1",DIC(0)=DIC(0)_"M"
D @ORDIC
Q Y
;
INACT ;is OI inactive
;TO DO: is OI called by other routines, protocols, etc.
; other than the Enter/edit QO restriction option?
N ORINACT
S ORINACT=""
I $G(Y) S ORINACT=$P($G(^ORD(101.43,Y,.1)),"^") ;OR*3*548 Add $G
;OR 548 Do not display future inactive dates
I ORINACT]"",ORINACT'>DT W "*** INACTIVE AS OF ",$$FMTE^XLFDT(ORINACT)," ***"
Q
;
OIB(CAPTION) ; -- Returns selected OI from file #101.43 using B xref
N X,Y,DIC,DTOUT,DUOUT,DIRUT,DIROUT
S DIC="^ORD(101.43,",DIC(0)="AEQ"
S:$L($G(CAPTION)) DIC("A")=CAPTION
;OR*3*548 Indicate inactive OIs
S DIC("W")="W:$S('$D(%):0,'$D(DIY):0,%=DIY:0,1:1) $G(DIY)"
S DIC("W")=DIC("W")_" D INACT^ORCMEDT6"
D ^DIC
Q Y
;
SEARCH ; -- Search/replace orderables in QO responses
N I,ORP,ORIT
S I=0 F S I=$O(^ORD(101.41,I)) Q:I<1 I $P($G(^(I,0)),U,4)="P",$P($G(^(1)),U)="P",+$P($G(^(1)),U,2)=101.43 S ORP(I)="" ;OI prompts
F S ORIT=$$OIB("Search for: ") Q:ORIT<1 D SR1 W !!
Q
;
SR1 ; -- list QO's & Dlgs where ORIT is used, get replacement
N I,X,ORDAD,ORDG,ORY,ORNMBR,NUM,DA,ORNM,TYPE,SET
D FIND(ORIT,.ORDAD) I ORDAD<1 W !,$P(ORIT,U,2)_" is not used by any quick orders or dialogs." Q
W @IOF,"Quick Orders and Dialogs containing "_$P(ORIT,U,2),!,$$REPEAT^XLFSTR("-",79)
S I=0 F S I=$O(ORDAD(I)) Q:I'>0 D
. S X=+ORDAD(I) W !,I,?4,$P(^ORD(101.41,X,0),U)
W !,$$REPEAT^XLFSTR("-",79)
S ORDG=+$P($G(^ORD(101.43,+ORIT,0)),U,5),ORDG=$P($G(^ORD(100.98,ORDG,0)),U,3)
S ORY=$$OI("S."_ORDG,"Replace with: ") Q:ORY<1
D SELECT(ORDAD,.ORNMBR) Q:ORNMBR="^"
Q:'$$OK W !!,"Replacing "_$P(ORIT,U,2)_" with "_$P(ORY,U,2)_" in:"
F I=1:1:$L(ORNMBR,",") S NUM=$P(ORNMBR,",",I) I NUM D
. S DA(1)=+ORDAD(NUM),DA=$P(ORDAD(NUM),U,2),SET=$P(ORDAD(NUM),U,3)
. S ORNM=$P(^ORD(101.41,DA(1),0),U),TYPE=$P($G(^(0)),U,4)
. I '$O(^ORD(101.43,+ORY,9,"B",SET,0)) W !?3,ORNM_" canceled: item invalid for this dialog." Q
. I TYPE="Q" S ^ORD(101.41,DA(1),6,DA,1)=+ORY
. I TYPE="D" S ^ORD(101.41,DA(1),10,DA,7)="S Y="_+ORY
. W !?3,ORNM_" ...done."
Q
;
FIND(X,QO) ; -- Find QO's, Dlg's that use ord item X
N IFN,P,TYPE,NODE,DEF,DA,DLG,PRMT,SET S IFN=0,QO=0
F S IFN=+$O(^ORD(101.41,IFN)) Q:IFN<1 S TYPE=$P($G(^(IFN,0)),U,4) D
. S NODE=$S(TYPE="Q":6,TYPE="D":10,1:0) Q:'NODE
. S P=0 F S P=$O(ORP(P)) Q:P<1 S DA=$O(^ORD(101.41,IFN,NODE,"D",P,0)) I DA D
.. I TYPE="Q" Q:+$G(^ORD(101.41,IFN,6,DA,1))'=+X S DLG=$$DEFDLG^ORCD(IFN),PRMT=+$O(^ORD(101.41,DLG,10,"D",P,0))
.. I TYPE="D" S DEF=$G(^ORD(101.41,IFN,10,DA,7)) Q:DEF'?1"S Y=".E S DEF=$P(DEF,"=",2) S:$E(DEF)="""" DEF=$P(DEF,"""",2) Q:+DEF'=+X S DLG=IFN,PRMT=DA
.. S SET=$P($G(^ORD(101.41,DLG,10,PRMT,0)),U,10),SET=$P($P(SET,";"),".",2)
.. S QO=QO+1,QO(QO)=IFN_U_DA_U_SET
Q
;
SELECT(MAX,Y) ; -- Select which QOs to replace Ord Item
N X,DIR
S DIR(0)="LA^1:"_MAX,DIR("A")="Replace in: ",DIR("B")=$S(MAX>1:"1-"_MAX,1:"1")
; S DIR("?")
D ^DIR S:$D(DTOUT)!(X["^") Y="^"
Q
;
OK() ; -- Are you ready?
N X,Y,DIR
S DIR(0)="YA",DIR("A")="Are you ready? ",DIR("B")="NO"
W ! D ^DIR
Q +Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCMEDT6 5888 printed Dec 13, 2024@02:28:40 Page 2
ORCMEDT6 ;SLC/MKB-QO editor utilities ;12/18/02 13:33
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**164,297,548**;Dec 17, 1997;Build 3
+2 ;
QO ; -- Enter/edit QO restriction on orderable items
+1 NEW X,Y,DA,DR,DIE,ORIT,OLDVAL,OREBLD
+2 FOR
SET ORIT=$$OI("S.RX^S.LAB","Select an ORDERABLE ITEM (meds or labs only): ")
if ORIT'>0
QUIT
Begin DoDot:1
+3 WRITE !!,"Select the type of usage for which you wish to restrict ordering of this item."
+4 FOR
SET ORDG=$$SET(+ORIT)
if "^"[ORDG
QUIT
Begin DoDot:2
+5 SET DA(1)=+ORIT
SET DA=+$ORDER(^ORD(101.43,+ORIT,9,"B",ORDG,0))
+6 SET OLDVAL=$GET(^ORD(101.43,+ORIT,9,DA,0))
+7 SET DR=2
SET DIE="^ORD(101.43,"_DA(1)_",9,"
DO ^DIE
WRITE !
+8 IF ORDG="O RX"!(ORDG="UD RX")
IF OLDVAL'=$GET(^ORD(101.43,+ORIT,9,DA,0))
SET OREBLD(ORDG)=1
End DoDot:2
End DoDot:1
WRITE !!
+9 FOR ORDG="O RX","UD RX"
IF $GET(OREBLD(ORDG))
DO FVBLDQ^ORWUL(ORDG)
+10 QUIT
+11 ;
SET(OI) ; -- Returns Set Membership for OI
+1 NEW X,Y,I,DOMAIN,NAME,HELP,DONE
+2 SET X=""
SET I=0
FOR
SET X=$ORDER(^ORD(101.43,+OI,9,"B",X))
if X=""
QUIT
SET NAME=$$NAME(X)
IF NAME'="PHARMACY"
SET I=I+1
SET DOMAIN(I)=X_U_NAME
SET DOMAIN("B",NAME)=I
+3 SET DOMAIN(0)=I
SET HELP="Select the type of usage for which you wish to restrict ordering of this item."
+4 SET DONE=0
SET Y=""
FOR
Begin DoDot:1
+5 WRITE !,"Usage: "
+6 READ X:DTIME
if '$TEST
SET X="^"
IF X["^"
SET Y="^"
SET DONE=1
QUIT
+7 IF X=""
SET Y="^"
SET DONE=1
QUIT
+8 IF X["?"
WRITE !!,HELP
DO LIST
QUIT
+9 Begin DoDot:2
+10 NEW XP,XY,CNT,MATCH,DIR,I
+11 ; done
SET X=$$UP^XLFSTR(X)
SET Y=+$GET(DOMAIN("B",X))
if Y
QUIT
+12 SET CNT=0
SET XP=X
FOR
SET XP=$ORDER(DOMAIN("B",XP))
if XP=""
QUIT
if $EXTRACT(XP,1,$LENGTH(X))'=X
QUIT
SET CNT=CNT+1
SET XY=+DOMAIN("B",XP)
SET MATCH(CNT)=XY_U_$PIECE(DOMAIN(XY),U,2)
+13 if 'CNT
QUIT
+14 IF CNT=1
SET Y=+MATCH(1)
SET XP=$PIECE(MATCH(1),U,2)
WRITE $EXTRACT(XP,$LENGTH(X)+1,$LENGTH(XP))
QUIT
+15 SET DIR(0)="NAO^1:"_CNT
SET DIR("A")="Select 1-"_CNT_": "
+16 FOR I=1:1:CNT
SET DIR("A",I)=$JUSTIFY(I,3)_" "_$PIECE(MATCH(I),U,2)
+17 SET DIR("?")="Select the desired value, by number"
+18 DO ^DIR
IF $DATA(DIRUT)
SET Y=""
QUIT
+19 SET Y=+MATCH(Y)
WRITE " "_$PIECE(DOMAIN(Y),U,2)
End DoDot:2
IF 'Y
WRITE $CHAR(7),!,HELP
QUIT
+20 SET Y=$PIECE(DOMAIN(Y),U)
SET DONE=1
End DoDot:1
if DONE
QUIT
+21 QUIT Y
+22 ;
LIST ; -- List order statuses in DOMAIN
+1 NEW I,Z,CNT,DONE
+2 SET CNT=0
WRITE !,"Choose from:"
+3 FOR I=1:1:DOMAIN(0)
Begin DoDot:1
+4 SET CNT=CNT+1
WRITE !
IF CNT>(IOSL-3)
Begin DoDot:2
+5 WRITE ?3,"'^' TO STOP: "
READ Z:DTIME
if '$TEST!(Z["^")
SET DONE=1
SET CNT=1
End DoDot:2
if $GET(DONE)
QUIT
+6 WRITE $CHAR(13)," "_$PIECE(DOMAIN(I),U,2)
End DoDot:1
if $GET(DONE)
QUIT
+7 QUIT
+8 ;
NAME(X) ; -- Returns full name of set X
+1 NEW Y,I
SET Y=$SELECT(X="IVA RX":"IV ADDITIVES",X="IVB RX":"IV SOLUTIONS",X="IVM RX":"IV MEDICATIONS",1:"")
+2 IF Y=""
SET I=+$ORDER(^ORD(100.98,"B",X,0))
SET Y=$SELECT(I:$PIECE($GET(^ORD(100.98,I,0)),U),1:X)
+3 QUIT Y
+4 ;
OI(IDX,CAPTION) ; -- Returns selected OI from file #101.43 using IDX xrefs
+1 NEW X,Y,D,DIC,DTOUT,DUOUT,DIRUT,DIROUT,ORDIC
+2 SET DIC="^ORD(101.43,"
SET DIC(0)="AEQS"
if $LENGTH($GET(CAPTION))
SET DIC("A")=CAPTION
+3 SET DIC("W")="W:$S('$D(%):0,'$D(DIY):0,%=DIY:0,1:1) $G(DIY)"
+4 ;OR*3*548 Indicate inactive OIs
+5 SET DIC("W")=DIC("W")_" D INACT^ORCMEDT6"
+6 SET D=IDX
SET ORDIC="IX^DIC"
if $LENGTH(D,U)>1
SET ORDIC="MIX^DIC1"
SET DIC(0)=DIC(0)_"M"
+7 DO @ORDIC
+8 QUIT Y
+9 ;
INACT ;is OI inactive
+1 ;TO DO: is OI called by other routines, protocols, etc.
+2 ; other than the Enter/edit QO restriction option?
+3 NEW ORINACT
+4 SET ORINACT=""
+5 ;OR*3*548 Add $G
IF $GET(Y)
SET ORINACT=$PIECE($GET(^ORD(101.43,Y,.1)),"^")
+6 ;OR 548 Do not display future inactive dates
+7 IF ORINACT]""
IF ORINACT'>DT
WRITE "*** INACTIVE AS OF ",$$FMTE^XLFDT(ORINACT)," ***"
+8 QUIT
+9 ;
OIB(CAPTION) ; -- Returns selected OI from file #101.43 using B xref
+1 NEW X,Y,DIC,DTOUT,DUOUT,DIRUT,DIROUT
+2 SET DIC="^ORD(101.43,"
SET DIC(0)="AEQ"
+3 if $LENGTH($GET(CAPTION))
SET DIC("A")=CAPTION
+4 ;OR*3*548 Indicate inactive OIs
+5 SET DIC("W")="W:$S('$D(%):0,'$D(DIY):0,%=DIY:0,1:1) $G(DIY)"
+6 SET DIC("W")=DIC("W")_" D INACT^ORCMEDT6"
+7 DO ^DIC
+8 QUIT Y
+9 ;
SEARCH ; -- Search/replace orderables in QO responses
+1 NEW I,ORP,ORIT
+2 ;OI prompts
SET I=0
FOR
SET I=$ORDER(^ORD(101.41,I))
if I<1
QUIT
IF $PIECE($GET(^(I,0)),U,4)="P"
IF $PIECE($GET(^(1)),U)="P"
IF +$PIECE($GET(^(1)),U,2)=101.43
SET ORP(I)=""
+3 FOR
SET ORIT=$$OIB("Search for: ")
if ORIT<1
QUIT
DO SR1
WRITE !!
+4 QUIT
+5 ;
SR1 ; -- list QO's & Dlgs where ORIT is used, get replacement
+1 NEW I,X,ORDAD,ORDG,ORY,ORNMBR,NUM,DA,ORNM,TYPE,SET
+2 DO FIND(ORIT,.ORDAD)
IF ORDAD<1
WRITE !,$PIECE(ORIT,U,2)_" is not used by any quick orders or dialogs."
QUIT
+3 WRITE @IOF,"Quick Orders and Dialogs containing "_$PIECE(ORIT,U,2),!,$$REPEAT^XLFSTR("-",79)
+4 SET I=0
FOR
SET I=$ORDER(ORDAD(I))
if I'>0
QUIT
Begin DoDot:1
+5 SET X=+ORDAD(I)
WRITE !,I,?4,$PIECE(^ORD(101.41,X,0),U)
End DoDot:1
+6 WRITE !,$$REPEAT^XLFSTR("-",79)
+7 SET ORDG=+$PIECE($GET(^ORD(101.43,+ORIT,0)),U,5)
SET ORDG=$PIECE($GET(^ORD(100.98,ORDG,0)),U,3)
+8 SET ORY=$$OI("S."_ORDG,"Replace with: ")
if ORY<1
QUIT
+9 DO SELECT(ORDAD,.ORNMBR)
if ORNMBR="^"
QUIT
+10 if '$$OK
QUIT
WRITE !!,"Replacing "_$PIECE(ORIT,U,2)_" with "_$PIECE(ORY,U,2)_" in:"
+11 FOR I=1:1:$LENGTH(ORNMBR,",")
SET NUM=$PIECE(ORNMBR,",",I)
IF NUM
Begin DoDot:1
+12 SET DA(1)=+ORDAD(NUM)
SET DA=$PIECE(ORDAD(NUM),U,2)
SET SET=$PIECE(ORDAD(NUM),U,3)
+13 SET ORNM=$PIECE(^ORD(101.41,DA(1),0),U)
SET TYPE=$PIECE($GET(^(0)),U,4)
+14 IF '$ORDER(^ORD(101.43,+ORY,9,"B",SET,0))
WRITE !?3,ORNM_" canceled: item invalid for this dialog."
QUIT
+15 IF TYPE="Q"
SET ^ORD(101.41,DA(1),6,DA,1)=+ORY
+16 IF TYPE="D"
SET ^ORD(101.41,DA(1),10,DA,7)="S Y="_+ORY
+17 WRITE !?3,ORNM_" ...done."
End DoDot:1
+18 QUIT
+19 ;
FIND(X,QO) ; -- Find QO's, Dlg's that use ord item X
+1 NEW IFN,P,TYPE,NODE,DEF,DA,DLG,PRMT,SET
SET IFN=0
SET QO=0
+2 FOR
SET IFN=+$ORDER(^ORD(101.41,IFN))
if IFN<1
QUIT
SET TYPE=$PIECE($GET(^(IFN,0)),U,4)
Begin DoDot:1
+3 SET NODE=$SELECT(TYPE="Q":6,TYPE="D":10,1:0)
if 'NODE
QUIT
+4 SET P=0
FOR
SET P=$ORDER(ORP(P))
if P<1
QUIT
SET DA=$ORDER(^ORD(101.41,IFN,NODE,"D",P,0))
IF DA
Begin DoDot:2
+5 IF TYPE="Q"
if +$GET(^ORD(101.41,IFN,6,DA,1))'=+X
QUIT
SET DLG=$$DEFDLG^ORCD(IFN)
SET PRMT=+$ORDER(^ORD(101.41,DLG,10,"D",P,0))
+6 IF TYPE="D"
SET DEF=$GET(^ORD(101.41,IFN,10,DA,7))
if DEF'?1"S Y=".E
QUIT
SET DEF=$PIECE(DEF,"=",2)
if $EXTRACT(DEF)=""""
SET DEF=$PIECE(DEF,"""",2)
if +DEF'=+X
QUIT
SET DLG=IFN
SET PRMT=DA
+7 SET SET=$PIECE($GET(^ORD(101.41,DLG,10,PRMT,0)),U,10)
SET SET=$PIECE($PIECE(SET,";"),".",2)
+8 SET QO=QO+1
SET QO(QO)=IFN_U_DA_U_SET
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
SELECT(MAX,Y) ; -- Select which QOs to replace Ord Item
+1 NEW X,DIR
+2 SET DIR(0)="LA^1:"_MAX
SET DIR("A")="Replace in: "
SET DIR("B")=$SELECT(MAX>1:"1-"_MAX,1:"1")
+3 ; S DIR("?")
+4 DO ^DIR
if $DATA(DTOUT)!(X["^")
SET Y="^"
+5 QUIT
+6 ;
OK() ; -- Are you ready?
+1 NEW X,Y,DIR
+2 SET DIR(0)="YA"
SET DIR("A")="Are you ready? "
SET DIR("B")="NO"
+3 WRITE !
DO ^DIR
+4 QUIT +Y
