ORCMED ;SLC/MKB - MEDICATION ACTIONS ;11/07/13 11:07
;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,7,38,48,94,141,178,190,195,243,306,371,380,383,311,381**;Dec 17, 1997;Build 8
XFER ; -- transfer to in/outpt medsx
N ORPTLK,ORTYPE,ORXFER,ORSRC,ORCAT,OREVENT,X,ORINPT,ORIDLG,ORODLG,ORIVDLG,ORNMSP,ORCNT,ORI,NMBR,ORIFN,OLDIFN,ORDIALOG,ORDG,ORCHECK,ORQUIT,ORDUZ,ORLOG,FIRST,ORDITM,ORD,ORERR
S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK D G XFQ ; lock pt chart
. W !!,$C(7),$P(ORPTLK,U,2) H 2
. S:'$D(VALMBCK) VALMBCK=""
I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("transfer") G:'ORNMBR XFQ
D FULL^VALM1 S VALMBCK="R",ORTYPE="Q",ORXFER=1,ORDUZ=DUZ,ORSRC="X"
S X=$P($P($G(^TMP("OR",$J,"CURRENT",0)),U,3),";",3) S:X="" X=$G(ORWARD)
S ORCAT=$S(X:"O",1:"I") I ORCAT="I"!$G(ORWARD) D Q:$G(OREVENT)="^"
. W !!,$$CURRENT^OREVNT
. S X=$$DELAY^ORCACT I X="^" S OREVENT="^" Q
. S:X OREVENT=+$$PTEVENT^OREVNT(+ORVP,1)
I '$G(ORL) S ORL=$S($G(OREVENT):$$LOC^OREVNTX(OREVENT),1:$$LOCATION^ORCMENU1) G:ORL="^" XFQ
S ORINPT=$$INPT^ORCD,ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" XFQ
I 'ORINPT,ORCAT="I" D IMOLOC^ORIMO(.ORINPT,+ORL,+ORVP) S:ORINPT<0 ORINPT=0 ;allow inpt meds at this location?
S ORIDLG=+$O(^ORD(101.41,"AB","PSJ OR PAT OE",0))
S ORODLG=+$O(^ORD(101.41,"AB","PSO OERR",0))
S ORIVDLG=+$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0))
D PROVIDER^ORCDPSIV G:$G(ORQUIT) XFQ ;X:$D(^ORD(101.41,ORDIALOG,3)) ^(3)
S ORNMSP="PS" D DISPLAY^ORCHECK
S ORCNT=$L(ORNMBR,",") S:$P(ORNMBR,",",ORCNT)'>0 ORCNT=ORCNT-1
XF1 F ORI=1:1:ORCNT S NMBR=$P(ORNMBR,",",ORI) D:NMBR I $D(ORQUIT),ORI<ORCNT Q:'$$CONT ;if not last one, ask
. K ORIFN,ORDIALOG,ORDG,ORDOSE,ORCHECK,ORQUIT,ORERR
. K ^TMP("PSJMR",$J),^TMP("ORWORD",$J),^TMP("ORSIG",$J)
. S OLDIFN=+$P($G(^TMP("OR",$J,ORTAB,"IDX",NMBR)),U,4)
. S ORDITM=$$ORDITEM^ORCACT(OLDIFN) D SUBHDR^ORCACT(ORDITM)
. I '$$VALID^ORCACT0(OLDIFN,"XFR",.ORERR) W !,ORERR H 2 Q
. S ORD=$P($G(^OR(100,OLDIFN,0)),U,5) Q:ORD'["101.41" ;error msg?
. S ORDIALOG=$S(+ORD=ORIVDLG:ORIVDLG,ORCAT="I":ORIDLG,1:ORODLG)
. S ORDG=+$P($G(^ORD(101.41,ORDIALOG,0)),U,5)
. D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD(OLDIFN)
. I ORDIALOG'=ORIVDLG D OUT:ORCAT="I",IN:ORCAT="O" ;convert data
. K ORDIALOG($$PTR^ORCD("OR GTX START DATE/TIME"),1)
. K ORDIALOG($$PTR^ORCD("OR GTX NOW"),1)
. S ORLOG=+$E($$NOW^XLFDT,1,12),FIRST=1
XF2 . D DIALOG^ORCDLG Q:$G(ORQUIT)&FIRST K ORQUIT
. D ACCEPT^ORCHECK(),DISPLAY^ORCDLG S X=$$OK^ORCDLG I X="^" S ORQUIT=1 Q
. I X="E" K ORCHECK S FIRST=0 G XF2
. I X="C" W !?10,"... order cancelled.",! Q
. I X="P" D
. . D EN^ORCSAVE W !?10,$S(ORIFN:"... order placed.",1:"ERROR"),!
. . S:$G(ORIFN) ^TMP("ORNEW",$J,ORIFN,1)=""
. . I '$D(^TMP("ORECALL",$J,ORDIALOG)) M ^(ORDIALOG)=ORDIALOG M:$D(^TMP("ORWORD",$J)) ^TMP("ORECALL",$J,ORDIALOG)=^TMP("ORWORD",$J) ;save 1st values
XFQ D EXIT^ORCDPS1 ;X:$D(^ORD(101.41,ORDIALOG,4)) ^(4)
K ^TMP("ORWORD",$J),^TMP("ORSIG",$J)
D:'$D(^TMP("ORNEW",$J)) UNLOCK^ORX2(+ORVP) ;unlock if no new orders
Q
;
IN ; -- Kill extra values, Reset ID's/DD from Inpt dialog
N ORD1,ORDLI,ORDFIN,ORDCNT,ORDORIG,ORDORIGF,P,ORDD,INSTR,ORDE
F P="START DATE/TIME","NOW" K ORDIALOG($$PTR(P),1)
S ORD1=$P($G(ORDIALOG($$PTR("DOSE"),1)),"&",5)
S ORDORIG=ORDIALOG($$PTR("INSTRUCTIONS"),1)
S ORDD=$G(ORDIALOG($$PTR("DISPENSE DRUG"),1))
S INSTR=$$PTR("INSTRUCTIONS"),ORDE=$D(ORDIALOG($$PTR("DOSE"),1))
D DOSES("O")
I ORDE=1,($D(ORDIALOG($$PTR("DOSE"),0))'=1) D Q
.;corresponding dosage deleted, wipe the instructions
.S ORDIALOG(INSTR,1)=""
S ORDFIN="",ORDCNT=0,ORDORIGF=0
;look in the new instructions list for the original inpatient instructions and the dose
I $L(ORD1) D
.S ORDLI=0 F S ORDLI=$O(ORDIALOG(INSTR,"LIST",ORDLI)) Q:'ORDLI D
..I $P(ORDIALOG(INSTR,"LIST",ORDLI),U)=ORDORIG S ORDORIGF=1
.;look in the returned doses for the local possible dose
I '$L(ORD1) D
.S ORDOSE=0 F S ORDOSE=$O(ORDOSE(ORDOSE)) Q:'ORDOSE D
..I $P(ORDOSE(ORDOSE),U,5)=ORDORIG,($P(ORDOSE(ORDOSE),U,6)=ORDD) S ORDFIN=$P(ORDIALOG(INSTR,"LIST",ORDOSE),U),ORDCNT=ORDCNT+1
;If there was a dose string and original instructions are not in the new instructions list then replace the instructions
I ORDE=1,(ORDORIGF=0) D
.I ORDCNT=1 S ORDIALOG(INSTR,1)=ORDFIN ;only one item in the list found containing the dose string - set the instructions to the item found
.I ORDCNT'=1 S ORDIALOG(INSTR,1)="" ;no items or more than one item in the list found containing the dose string - blank the instructions
Q
;
OUT ; -- Kill extra values, Reset ID's/DD from Outpt dialog
N ORD1,ORDLI,ORDFIN,ORDCNT,ORDORIG,ORDORIGF,INSTR,I,ORDD,ORDE
S ORDD=$G(ORDIALOG($$PTR("DISPENSE DRUG"),1))
S INSTR=$$PTR("INSTRUCTIONS"),I=0 F S I=$O(ORDIALOG(INSTR,I)) Q:'I S ORDE(I)=$D(ORDIALOG($$PTR("DOSE"),I))
D DOSES("I")
;quit if a complex order
I $D(ORDIALOG($$PTR^ORCMED("AND/THEN"),1)) Q
S I=0 F S I=$O(ORDIALOG(INSTR,I)) Q:'I D
.I ORDE(I)=1,($D(ORDIALOG($$PTR("DOSE"),I))'=1) D Q
..;corresponding dosage deleted, wipe the instructions
..S ORDIALOG(INSTR,I)=""
.S ORD1=$P($G(ORDIALOG($$PTR("DOSE"),I)),"&",5)
.S ORDORIG=ORDIALOG(INSTR,I)
.N P I '$O(ORDIALOG(INSTR,0)) D ;old sig in comments
.. N WP S WP=$$PTR("WORD PROCESSING 1") K ^TMP("ORSIG",$J)
.. M ^TMP("ORSIG",$J)=^TMP("ORWORD",$J,WP,1)
.. K ORDIALOG(WP,1),^TMP("ORWORD",$J,WP,1)
.F P="PATIENT INSTRUCTIONS","START DATE/TIME","DAYS SUPPLY","QUANTITY","REFILLS","ROUTING","SERVICE CONNECTED" K ORDIALOG($$PTR(P),I)
.I $G(ORDIALOG($$PTR("URGENCY"),I))=99 K ORDIALOG($$PTR("URGENCY"),I)
.S ORDFIN="",ORDCNT=0,ORDORIGF=0
.;look in the new instructions list for the original instructions and the possible dose
.I $L(ORD1) D
..S ORDLI=0 F S ORDLI=$O(ORDIALOG(INSTR,"LIST",ORDLI)) Q:'ORDLI D
...I $P(ORDIALOG(INSTR,"LIST",ORDLI),U)=ORDORIG S ORDORIGF=1
.;look in the returned doses for the local possible dose
.I '$L(ORD1) D
..S ORDOSE=0 F S ORDOSE=$O(ORDOSE(ORDOSE)) Q:'ORDOSE D
...I $P(ORDOSE(ORDOSE),U,5)=ORDORIG,($P(ORDOSE(ORDOSE),U,6)=ORDD) S ORDFIN=$P(ORDIALOG(INSTR,"LIST",ORDOSE),U),ORDCNT=ORDCNT+1
.;If there was a dose string and original instructions are not in the new instructions list then replace the instructions
.I ORDE(I)=1,(ORDORIGF=0) D
..I ORDCNT=1 S ORDIALOG(INSTR,I)=ORDFIN ;only one item in the list found containing the dose string - set the instructions to the item found
..I ORDCNT'=1 S ORDIALOG(INSTR,I)="" ;no items or more than one item in the list found containing the dose string - blank the instructions
Q
;
DOSES(TYPE) ; -- Convert doses to new TYPE, reset ID strings
N PSOI,ORMED,PROMPT,DOSE,DRUG,I,X,DD,DRUG0,STR
F I="DISPENSE DRUG","STRENGTH","DRUG NAME","SIG" K ORDIALOG($$PTR(I),1)
S PSOI=+$P($G(^ORD(101.43,+$G(ORDIALOG($$PTR("ORDERABLE ITEM"),1)),0)),U,2),ORMED=$P($G(^(0)),U)
D DOSE^PSSORUTL(.ORDOSE,PSOI,TYPE,+ORVP) I $G(ORDOSE(1))=-1 K ORDOSE
S PROMPT=$$PTR("INSTRUCTIONS"),DOSE=$$PTR("DOSE")
S DRUG=$$PTR("DISPENSE DRUG") D D1^ORCDPS2
S I=0 F S I=$O(ORDIALOG(PROMPT,I)) Q:I'>0 D
. K ORDIALOG(DOSE,I) S X=$G(ORDIALOG(PROMPT,I)) Q:'$L(X)
. S X=$$UP^XLFSTR(X),DD=+$G(ORDIALOG(PROMPT,"LIST","D",X)) Q:'DD
. S ORDIALOG(DOSE,I)=$TR($G(ORDOSE("DD",DD,X)),"^","&")
. S ORDIALOG(DRUG,I)=DD,DRUG0=$G(ORDOSE("DD",DD))
. S STR=$P(DRUG0,U,5)_$P(DRUG0,U,6)
. I STR'>0 S:'$G(ORDOSE(1)) ORDIALOG($$PTR("DRUG NAME"),1)=$P(DRUG0,U) Q
. I ORMED'[STR,TYPE="O"!'$G(ORDOSE(1)) S ORDIALOG($$PTR("STRENGTH"),1)=STR
Q
;
CONT() ; -- Want to continue processing orders?
N X,Y,DIR
S DIR(0)="YA",DIR("A")="Do you want to continue transferring orders? ",DIR("B")="YES"
S DIR("?")="Enter YES to continue transferring the remaining orders selected, or NO to quit this option."
D ^DIR
Q +Y
;
SHOWSIG ; -- Show old sig for transfer in ^TMP("ORSIG",$J)
N ORTX,I,X,ORMAX S ORMAX=72
S I=0 F S I=$O(^TMP("ORSIG",$J,I)) Q:I'>0 S X=$G(^(I,0)) D:$L(X) TXT^ORCHTAB
S I=0 F S I=$O(ORTX(I)) Q:I'>0 W !,$S(I=1:"(Sig: ",1:" ")_ORTX(I)
W ")"
Q
;
PTR(NAME) ; -- Returns pointer to OR GTX NAME
Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
;
REFILLS ; -- Request a refill for med orders
; ORNMBR = #,#,...,# of selected orders
;
N ORLK,ORI,NMBR,IDX,ORIFN,ORDITM,ORERR,ORQUIT,OROUT
I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("") G:'ORNMBR RFQ
D FREEZE^ORCMENU S VALMBCK="R"
S ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" RFQ
S:'$G(ORL) ORL=$$LOCATION^ORCMENU1 G:ORL="^" RFQ
S OROUT=$$ROUTING G:OROUT="^" RFQ
F ORI=1:1:$L(ORNMBR,",") S NMBR=$P(ORNMBR,",",ORI) D:NMBR Q:$D(ORQUIT)
. S IDX=$G(^TMP("OR",$J,"CURRENT","IDX",NMBR)),ORIFN=+$P(IDX,U,4)
. Q:'ORIFN I '$D(^OR(100,ORIFN,0)) W !,"Invalid order number!" H 2 Q
. S ORDITM=$$ORDITEM^ORCACT(ORIFN) D SUBHDR^ORCACT(ORDITM)
. I '$$VALID^ORCACT0(ORIFN,"RF",.ORERR) W !,ORERR H 2 Q
. S ORLK=$$LOCK1^ORX2(+ORIFN) I 'ORLK W !,$P(ORLK,U,2) H 2 Q
. D REF^ORMBLDPS(ORIFN,OROUT),UNLK1^ORX2(+ORIFN)
. W !?10,"... refill requested.",$$RETURN
RFQ Q
;
RETURN() ; -- press return to cont
N X W !,"Press <return> to continue ..." R X:DTIME
Q ""
;
ROUTING() ; -- Routing for refill
N X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT S DIR(0)="SAM^W:WINDOW;M:MAIL;C:ADMINISTERED IN CLINIC;"
S DIR("A")="Routing: ",DIR("B")=$S($D(^PSX(550,"C")):"MAIL",1:"WINDOW")
S DIR("?")="Select how the patient is to receive this refill, by mail or at the window or in the clinic"
D ^DIR S:$D(DTOUT)!(X["^") Y="^"
Q Y
;
NW ; -- Order New Medication from Meds tab
; Requires ORDIALOG = name of pkg dialog
; OREVENT = event, if delaying orders
; OREVENT("TS") = treating spec, if admission or transfer
N ORPTLK G:'$L($G(ORDIALOG)) NWQ
S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK W !!,$C(7),$P(ORPTLK,U,2) H 2 Q
D FREEZE^ORCMENU S VALMBCK="R"
S ORNP=$$PROVIDER^ORCMENU1 G:ORNP="^" NWQ
I '$G(ORL) S ORL=$S($G(OREVENT):$$LOC^OREVNTX(OREVENT),1:$$LOCATION^ORCMENU1) G:ORL["^" NWQ
S ORDIALOG=$O(^ORD(101.41,"AB",$E(ORDIALOG,1,63),0)) G:'ORDIALOG NWQ
D ADD^ORCDLG,REBLD^ORCMENU:$D(^TMP("ORNEW",$J))
K ORDIALOG,^TMP("ORWORD",$J),^TMP("ORECALL",$J) S VALMBCK="R"
NWQ D:'$D(^TMP("ORNEW",$J)) UNLOCK^ORX2(+ORVP) ;unlock if no new orders
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCMED 10240 printed Sep 23, 2025@20:04:50 Page 2
ORCMED ;SLC/MKB - MEDICATION ACTIONS ;11/07/13 11:07
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,7,38,48,94,141,178,190,195,243,306,371,380,383,311,381**;Dec 17, 1997;Build 8
XFER ; -- transfer to in/outpt medsx
+1 NEW ORPTLK,ORTYPE,ORXFER,ORSRC,ORCAT,OREVENT,X,ORINPT,ORIDLG,ORODLG,ORIVDLG,ORNMSP,ORCNT,ORI,NMBR,ORIFN,OLDIFN,ORDIALOG,ORDG,ORCHECK,ORQUIT,ORDUZ,ORLOG,FIRST,ORDITM,ORD,ORERR
+2 ; lock pt chart
SET ORPTLK=$$LOCK^ORX2(+ORVP)
IF 'ORPTLK
Begin DoDot:1
+3 WRITE !!,$CHAR(7),$PIECE(ORPTLK,U,2)
HANG 2
+4 if '$DATA(VALMBCK)
SET VALMBCK=""
End DoDot:1
GOTO XFQ
+5 IF '$GET(ORNMBR)
SET ORNMBR=$$ORDERS^ORCHART("transfer")
if 'ORNMBR
GOTO XFQ
+6 DO FULL^VALM1
SET VALMBCK="R"
SET ORTYPE="Q"
SET ORXFER=1
SET ORDUZ=DUZ
SET ORSRC="X"
+7 SET X=$PIECE($PIECE($GET(^TMP("OR",$JOB,"CURRENT",0)),U,3),";",3)
if X=""
SET X=$GET(ORWARD)
+8 SET ORCAT=$SELECT(X:"O",1:"I")
IF ORCAT="I"!$GET(ORWARD)
Begin DoDot:1
+9 WRITE !!,$$CURRENT^OREVNT
+10 SET X=$$DELAY^ORCACT
IF X="^"
SET OREVENT="^"
QUIT
+11 if X
SET OREVENT=+$$PTEVENT^OREVNT(+ORVP,1)
End DoDot:1
if $GET(OREVENT)="^"
QUIT
+12 IF '$GET(ORL)
SET ORL=$SELECT($GET(OREVENT):$$LOC^OREVNTX(OREVENT),1:$$LOCATION^ORCMENU1)
if ORL="^"
GOTO XFQ
+13 SET ORINPT=$$INPT^ORCD
SET ORNP=$$PROVIDER^ORCMENU1
if ORNP="^"
GOTO XFQ
+14 ;allow inpt meds at this location?
IF 'ORINPT
IF ORCAT="I"
DO IMOLOC^ORIMO(.ORINPT,+ORL,+ORVP)
if ORINPT<0
SET ORINPT=0
+15 SET ORIDLG=+$ORDER(^ORD(101.41,"AB","PSJ OR PAT OE",0))
+16 SET ORODLG=+$ORDER(^ORD(101.41,"AB","PSO OERR",0))
+17 SET ORIVDLG=+$ORDER(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0))
+18 ;X:$D(^ORD(101.41,ORDIALOG,3)) ^(3)
DO PROVIDER^ORCDPSIV
if $GET(ORQUIT)
GOTO XFQ
+19 SET ORNMSP="PS"
DO DISPLAY^ORCHECK
+20 SET ORCNT=$LENGTH(ORNMBR,",")
if $PIECE(ORNMBR,",",ORCNT)'>0
SET ORCNT=ORCNT-1
XF1 ;if not last one, ask
FOR ORI=1:1:ORCNT
SET NMBR=$PIECE(ORNMBR,",",ORI)
if NMBR
Begin DoDot:1
+1 KILL ORIFN,ORDIALOG,ORDG,ORDOSE,ORCHECK,ORQUIT,ORERR
+2 KILL ^TMP("PSJMR",$JOB),^TMP("ORWORD",$JOB),^TMP("ORSIG",$JOB)
+3 SET OLDIFN=+$PIECE($GET(^TMP("OR",$JOB,ORTAB,"IDX",NMBR)),U,4)
+4 SET ORDITM=$$ORDITEM^ORCACT(OLDIFN)
DO SUBHDR^ORCACT(ORDITM)
+5 IF '$$VALID^ORCACT0(OLDIFN,"XFR",.ORERR)
WRITE !,ORERR
HANG 2
QUIT
+6 ;error msg?
SET ORD=$PIECE($GET(^OR(100,OLDIFN,0)),U,5)
if ORD'["101.41"
QUIT
+7 SET ORDIALOG=$SELECT(+ORD=ORIVDLG:ORIVDLG,ORCAT="I":ORIDLG,1:ORODLG)
+8 SET ORDG=+$PIECE($GET(^ORD(101.41,ORDIALOG,0)),U,5)
+9 DO GETDLG^ORCD(ORDIALOG)
DO GETORDER^ORCD(OLDIFN)
+10 ;convert data
IF ORDIALOG'=ORIVDLG
if ORCAT="I"
DO OUT
if ORCAT="O"
DO IN
+11 KILL ORDIALOG($$PTR^ORCD("OR GTX START DATE/TIME"),1)
+12 KILL ORDIALOG($$PTR^ORCD("OR GTX NOW"),1)
+13 SET ORLOG=+$EXTRACT($$NOW^XLFDT,1,12)
SET FIRST=1
XF2 DO DIALOG^ORCDLG
if $GET(ORQUIT)&FIRST
QUIT
KILL ORQUIT
+1 DO ACCEPT^ORCHECK()
DO DISPLAY^ORCDLG
SET X=$$OK^ORCDLG
IF X="^"
SET ORQUIT=1
QUIT
+2 IF X="E"
KILL ORCHECK
SET FIRST=0
GOTO XF2
+3 IF X="C"
WRITE !?10,"... order cancelled.",!
QUIT
+4 IF X="P"
Begin DoDot:2
+5 DO EN^ORCSAVE
WRITE !?10,$SELECT(ORIFN:"... order placed.",1:"ERROR"),!
+6 if $GET(ORIFN)
SET ^TMP("ORNEW",$JOB,ORIFN,1)=""
+7 ;save 1st values
IF '$DATA(^TMP("ORECALL",$JOB,ORDIALOG))
MERGE ^(ORDIALOG)=ORDIALOG
if $DATA(^TMP("ORWORD",$JOB))
MERGE ^TMP("ORECALL",$JOB,ORDIALOG)=^TMP("ORWORD",$JOB)
End DoDot:2
End DoDot:1
IF $DATA(ORQUIT)
IF ORI<ORCNT
if '$$CONT
QUIT
XFQ ;X:$D(^ORD(101.41,ORDIALOG,4)) ^(4)
DO EXIT^ORCDPS1
+1 KILL ^TMP("ORWORD",$JOB),^TMP("ORSIG",$JOB)
+2 ;unlock if no new orders
if '$DATA(^TMP("ORNEW",$JOB))
DO UNLOCK^ORX2(+ORVP)
+3 QUIT
+4 ;
IN ; -- Kill extra values, Reset ID's/DD from Inpt dialog
+1 NEW ORD1,ORDLI,ORDFIN,ORDCNT,ORDORIG,ORDORIGF,P,ORDD,INSTR,ORDE
+2 FOR P="START DATE/TIME","NOW"
KILL ORDIALOG($$PTR(P),1)
+3 SET ORD1=$PIECE($GET(ORDIALOG($$PTR("DOSE"),1)),"&",5)
+4 SET ORDORIG=ORDIALOG($$PTR("INSTRUCTIONS"),1)
+5 SET ORDD=$GET(ORDIALOG($$PTR("DISPENSE DRUG"),1))
+6 SET INSTR=$$PTR("INSTRUCTIONS")
SET ORDE=$DATA(ORDIALOG($$PTR("DOSE"),1))
+7 DO DOSES("O")
+8 IF ORDE=1
IF ($DATA(ORDIALOG($$PTR("DOSE"),0))'=1)
Begin DoDot:1
+9 ;corresponding dosage deleted, wipe the instructions
+10 SET ORDIALOG(INSTR,1)=""
End DoDot:1
QUIT
+11 SET ORDFIN=""
SET ORDCNT=0
SET ORDORIGF=0
+12 ;look in the new instructions list for the original inpatient instructions and the dose
+13 IF $LENGTH(ORD1)
Begin DoDot:1
+14 SET ORDLI=0
FOR
SET ORDLI=$ORDER(ORDIALOG(INSTR,"LIST",ORDLI))
if 'ORDLI
QUIT
Begin DoDot:2
+15 IF $PIECE(ORDIALOG(INSTR,"LIST",ORDLI),U)=ORDORIG
SET ORDORIGF=1
End DoDot:2
+16 ;look in the returned doses for the local possible dose
End DoDot:1
+17 IF '$LENGTH(ORD1)
Begin DoDot:1
+18 SET ORDOSE=0
FOR
SET ORDOSE=$ORDER(ORDOSE(ORDOSE))
if 'ORDOSE
QUIT
Begin DoDot:2
+19 IF $PIECE(ORDOSE(ORDOSE),U,5)=ORDORIG
IF ($PIECE(ORDOSE(ORDOSE),U,6)=ORDD)
SET ORDFIN=$PIECE(ORDIALOG(INSTR,"LIST",ORDOSE),U)
SET ORDCNT=ORDCNT+1
End DoDot:2
End DoDot:1
+20 ;If there was a dose string and original instructions are not in the new instructions list then replace the instructions
+21 IF ORDE=1
IF (ORDORIGF=0)
Begin DoDot:1
+22 ;only one item in the list found containing the dose string - set the instructions to the item found
IF ORDCNT=1
SET ORDIALOG(INSTR,1)=ORDFIN
+23 ;no items or more than one item in the list found containing the dose string - blank the instructions
IF ORDCNT'=1
SET ORDIALOG(INSTR,1)=""
End DoDot:1
+24 QUIT
+25 ;
OUT ; -- Kill extra values, Reset ID's/DD from Outpt dialog
+1 NEW ORD1,ORDLI,ORDFIN,ORDCNT,ORDORIG,ORDORIGF,INSTR,I,ORDD,ORDE
+2 SET ORDD=$GET(ORDIALOG($$PTR("DISPENSE DRUG"),1))
+3 SET INSTR=$$PTR("INSTRUCTIONS")
SET I=0
FOR
SET I=$ORDER(ORDIALOG(INSTR,I))
if 'I
QUIT
SET ORDE(I)=$DATA(ORDIALOG($$PTR("DOSE"),I))
+4 DO DOSES("I")
+5 ;quit if a complex order
+6 IF $DATA(ORDIALOG($$PTR^ORCMED("AND/THEN"),1))
QUIT
+7 SET I=0
FOR
SET I=$ORDER(ORDIALOG(INSTR,I))
if 'I
QUIT
Begin DoDot:1
+8 IF ORDE(I)=1
IF ($DATA(ORDIALOG($$PTR("DOSE"),I))'=1)
Begin DoDot:2
+9 ;corresponding dosage deleted, wipe the instructions
+10 SET ORDIALOG(INSTR,I)=""
End DoDot:2
QUIT
+11 SET ORD1=$PIECE($GET(ORDIALOG($$PTR("DOSE"),I)),"&",5)
+12 SET ORDORIG=ORDIALOG(INSTR,I)
+13 ;old sig in comments
NEW P
IF '$ORDER(ORDIALOG(INSTR,0))
Begin DoDot:2
+14 NEW WP
SET WP=$$PTR("WORD PROCESSING 1")
KILL ^TMP("ORSIG",$JOB)
+15 MERGE ^TMP("ORSIG",$JOB)=^TMP("ORWORD",$JOB,WP,1)
+16 KILL ORDIALOG(WP,1),^TMP("ORWORD",$JOB,WP,1)
End DoDot:2
+17 FOR P="PATIENT INSTRUCTIONS","START DATE/TIME","DAYS SUPPLY","QUANTITY","REFILLS","ROUTING","SERVICE CONNECTED"
KILL ORDIALOG($$PTR(P),I)
+18 IF $GET(ORDIALOG($$PTR("URGENCY"),I))=99
KILL ORDIALOG($$PTR("URGENCY"),I)
+19 SET ORDFIN=""
SET ORDCNT=0
SET ORDORIGF=0
+20 ;look in the new instructions list for the original instructions and the possible dose
+21 IF $LENGTH(ORD1)
Begin DoDot:2
+22 SET ORDLI=0
FOR
SET ORDLI=$ORDER(ORDIALOG(INSTR,"LIST",ORDLI))
if 'ORDLI
QUIT
Begin DoDot:3
+23 IF $PIECE(ORDIALOG(INSTR,"LIST",ORDLI),U)=ORDORIG
SET ORDORIGF=1
End DoDot:3
End DoDot:2
+24 ;look in the returned doses for the local possible dose
+25 IF '$LENGTH(ORD1)
Begin DoDot:2
+26 SET ORDOSE=0
FOR
SET ORDOSE=$ORDER(ORDOSE(ORDOSE))
if 'ORDOSE
QUIT
Begin DoDot:3
+27 IF $PIECE(ORDOSE(ORDOSE),U,5)=ORDORIG
IF ($PIECE(ORDOSE(ORDOSE),U,6)=ORDD)
SET ORDFIN=$PIECE(ORDIALOG(INSTR,"LIST",ORDOSE),U)
SET ORDCNT=ORDCNT+1
End DoDot:3
End DoDot:2
+28 ;If there was a dose string and original instructions are not in the new instructions list then replace the instructions
+29 IF ORDE(I)=1
IF (ORDORIGF=0)
Begin DoDot:2
+30 ;only one item in the list found containing the dose string - set the instructions to the item found
IF ORDCNT=1
SET ORDIALOG(INSTR,I)=ORDFIN
+31 ;no items or more than one item in the list found containing the dose string - blank the instructions
IF ORDCNT'=1
SET ORDIALOG(INSTR,I)=""
End DoDot:2
End DoDot:1
+32 QUIT
+33 ;
DOSES(TYPE) ; -- Convert doses to new TYPE, reset ID strings
+1 NEW PSOI,ORMED,PROMPT,DOSE,DRUG,I,X,DD,DRUG0,STR
+2 FOR I="DISPENSE DRUG","STRENGTH","DRUG NAME","SIG"
KILL ORDIALOG($$PTR(I),1)
+3 SET PSOI=+$PIECE($GET(^ORD(101.43,+$GET(ORDIALOG($$PTR("ORDERABLE ITEM"),1)),0)),U,2)
SET ORMED=$PIECE($GET(^(0)),U)
+4 DO DOSE^PSSORUTL(.ORDOSE,PSOI,TYPE,+ORVP)
IF $GET(ORDOSE(1))=-1
KILL ORDOSE
+5 SET PROMPT=$$PTR("INSTRUCTIONS")
SET DOSE=$$PTR("DOSE")
+6 SET DRUG=$$PTR("DISPENSE DRUG")
DO D1^ORCDPS2
+7 SET I=0
FOR
SET I=$ORDER(ORDIALOG(PROMPT,I))
if I'>0
QUIT
Begin DoDot:1
+8 KILL ORDIALOG(DOSE,I)
SET X=$GET(ORDIALOG(PROMPT,I))
if '$LENGTH(X)
QUIT
+9 SET X=$$UP^XLFSTR(X)
SET DD=+$GET(ORDIALOG(PROMPT,"LIST","D",X))
if 'DD
QUIT
+10 SET ORDIALOG(DOSE,I)=$TRANSLATE($GET(ORDOSE("DD",DD,X)),"^","&")
+11 SET ORDIALOG(DRUG,I)=DD
SET DRUG0=$GET(ORDOSE("DD",DD))
+12 SET STR=$PIECE(DRUG0,U,5)_$PIECE(DRUG0,U,6)
+13 IF STR'>0
if '$GET(ORDOSE(1))
SET ORDIALOG($$PTR("DRUG NAME"),1)=$PIECE(DRUG0,U)
QUIT
+14 IF ORMED'[STR
IF TYPE="O"!'$GET(ORDOSE(1))
SET ORDIALOG($$PTR("STRENGTH"),1)=STR
End DoDot:1
+15 QUIT
+16 ;
CONT() ; -- Want to continue processing orders?
+1 NEW X,Y,DIR
+2 SET DIR(0)="YA"
SET DIR("A")="Do you want to continue transferring orders? "
SET DIR("B")="YES"
+3 SET DIR("?")="Enter YES to continue transferring the remaining orders selected, or NO to quit this option."
+4 DO ^DIR
+5 QUIT +Y
+6 ;
SHOWSIG ; -- Show old sig for transfer in ^TMP("ORSIG",$J)
+1 NEW ORTX,I,X,ORMAX
SET ORMAX=72
+2 SET I=0
FOR
SET I=$ORDER(^TMP("ORSIG",$JOB,I))
if I'>0
QUIT
SET X=$GET(^(I,0))
if $LENGTH(X)
DO TXT^ORCHTAB
+3 SET I=0
FOR
SET I=$ORDER(ORTX(I))
if I'>0
QUIT
WRITE !,$SELECT(I=1:"(Sig: ",1:" ")_ORTX(I)
+4 WRITE ")"
+5 QUIT
+6 ;
PTR(NAME) ; -- Returns pointer to OR GTX NAME
+1 QUIT +$ORDER(^ORD(101.41,"AB",$EXTRACT("OR GTX "_NAME,1,63),0))
+2 ;
REFILLS ; -- Request a refill for med orders
+1 ; ORNMBR = #,#,...,# of selected orders
+2 ;
+3 NEW ORLK,ORI,NMBR,IDX,ORIFN,ORDITM,ORERR,ORQUIT,OROUT
+4 IF '$GET(ORNMBR)
SET ORNMBR=$$ORDERS^ORCHART("")
if 'ORNMBR
GOTO RFQ
+5 DO FREEZE^ORCMENU
SET VALMBCK="R"
+6 SET ORNP=$$PROVIDER^ORCMENU1
if ORNP="^"
GOTO RFQ
+7 if '$GET(ORL)
SET ORL=$$LOCATION^ORCMENU1
if ORL="^"
GOTO RFQ
+8 SET OROUT=$$ROUTING
if OROUT="^"
GOTO RFQ
+9 FOR ORI=1:1:$LENGTH(ORNMBR,",")
SET NMBR=$PIECE(ORNMBR,",",ORI)
if NMBR
Begin DoDot:1
+10 SET IDX=$GET(^TMP("OR",$JOB,"CURRENT","IDX",NMBR))
SET ORIFN=+$PIECE(IDX,U,4)
+11 if 'ORIFN
QUIT
IF '$DATA(^OR(100,ORIFN,0))
WRITE !,"Invalid order number!"
HANG 2
QUIT
+12 SET ORDITM=$$ORDITEM^ORCACT(ORIFN)
DO SUBHDR^ORCACT(ORDITM)
+13 IF '$$VALID^ORCACT0(ORIFN,"RF",.ORERR)
WRITE !,ORERR
HANG 2
QUIT
+14 SET ORLK=$$LOCK1^ORX2(+ORIFN)
IF 'ORLK
WRITE !,$PIECE(ORLK,U,2)
HANG 2
QUIT
+15 DO REF^ORMBLDPS(ORIFN,OROUT)
DO UNLK1^ORX2(+ORIFN)
+16 WRITE !?10,"... refill requested.",$$RETURN
End DoDot:1
if $DATA(ORQUIT)
QUIT
RFQ QUIT
+1 ;
RETURN() ; -- press return to cont
+1 NEW X
WRITE !,"Press <return> to continue ..."
READ X:DTIME
+2 QUIT ""
+3 ;
ROUTING() ; -- Routing for refill
+1 NEW X,Y,DIR,DTOUT,DUOUT,DIRUT,DIROUT
SET DIR(0)="SAM^W:WINDOW;M:MAIL;C:ADMINISTERED IN CLINIC;"
+2 SET DIR("A")="Routing: "
SET DIR("B")=$SELECT($DATA(^PSX(550,"C")):"MAIL",1:"WINDOW")
+3 SET DIR("?")="Select how the patient is to receive this refill, by mail or at the window or in the clinic"
+4 DO ^DIR
if $DATA(DTOUT)!(X["^")
SET Y="^"
+5 QUIT Y
+6 ;
NW ; -- Order New Medication from Meds tab
+1 ; Requires ORDIALOG = name of pkg dialog
+2 ; OREVENT = event, if delaying orders
+3 ; OREVENT("TS") = treating spec, if admission or transfer
+4 NEW ORPTLK
if '$LENGTH($GET(ORDIALOG))
GOTO NWQ
+5 SET ORPTLK=$$LOCK^ORX2(+ORVP)
IF 'ORPTLK
WRITE !!,$CHAR(7),$PIECE(ORPTLK,U,2)
HANG 2
QUIT
+6 DO FREEZE^ORCMENU
SET VALMBCK="R"
+7 SET ORNP=$$PROVIDER^ORCMENU1
if ORNP="^"
GOTO NWQ
+8 IF '$GET(ORL)
SET ORL=$SELECT($GET(OREVENT):$$LOC^OREVNTX(OREVENT),1:$$LOCATION^ORCMENU1)
if ORL["^"
GOTO NWQ
+9 SET ORDIALOG=$ORDER(^ORD(101.41,"AB",$EXTRACT(ORDIALOG,1,63),0))
if 'ORDIALOG
GOTO NWQ
+10 DO ADD^ORCDLG
if $DATA(^TMP("ORNEW",$JOB))
DO REBLD^ORCMENU
+11 KILL ORDIALOG,^TMP("ORWORD",$JOB),^TMP("ORECALL",$JOB)
SET VALMBCK="R"
NWQ ;unlock if no new orders
if '$DATA(^TMP("ORNEW",$JOB))
DO UNLOCK^ORX2(+ORVP)
+1 QUIT
