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