ORMPS1 ;SLC/MKB - Process Pharmacy ORM msgs cont ;03-Jun-2014 11:20;PLS
;;3.0;ORDER ENTRY/RESULTS REPORTING;**86,92,94,116,134,152,158,149,190,1005,195,215,265,275,243,1010,1012,1013**;Dec 17, 1997;Build 43
; Modified - IHS/MSC/PLS - 10/07/08 - OUT+12
; 07/30/13 - OUT+13
; 04/14/14 - Changed SNOMED reference and added DSCMED to OUT+13
; 05/27/2014 - OUT+12
; 06/02/2014 - Line OUT+21
;;Per VHA Directive 2004-038, this routine should not be modified.
UDOSE ; -- new Unit Dose order
N ADMIN,QT,DRUG,INSTR,DOSE,RTE,SCH,OI,URG,WP,DUR,STR,DRGNM,X,PSOI,PSDD,S0,ID,LDOSE,XC,NTE,S0,RXR
S ORDIALOG=+$O(^ORD(101.41,"AB","PSJ OR PAT OE",0))
I $G(ORAPPT)>0 S ORDG=+$O(^ORD(100.98,"B","CLINIC ORDERS",0))
E S ORDG=+$O(^ORD(100.98,"B","UNIT DOSE MEDICATIONS",0))
S ORPKG=+$$PKG("PSJ")
D GETDLG1^ORCD(ORDIALOG) S QT=$G(ORQT(1))
S DRUG=$$PTR("DISPENSE DRUG"),INSTR=$$PTR("INSTRUCTIONS")
S DOSE=$$PTR("DOSE"),RTE=$$PTR("ROUTE")
S SCH=$$PTR("SCHEDULE"),ADMIN=$$PTR("ADMIN TIMES")
S OI=$$PTR("ORDERABLE ITEM"),URG=$$PTR("URGENCY")
S WP=$$PTR("WORD PROCESSING 1"),DUR=$$PTR("DURATION")
S STR=$$PTR("STRENGTH"),DRGNM=$$PTR("DRUG NAME")
UD1 S:RXO X=$P(RXO,"|",2),ORDIALOG(OI,1)=$$ORDITEM^ORM(X),PSOI=$P(X,U,4,5)
I '$G(ORDIALOG(OI,1)) S ORERR="Missing or invalid orderable item" Q
S PSDD=$P($$FIND^ORM(+RXE,3),U,4,5),ORDIALOG(DRUG,1)=+PSDD
S S0=$$FIND^ORM(+RXE,26)_"&"_$P($$FIND^ORM(+RXE,27),U,5)
S ID=$P(QT,U),LDOSE=$P(QT,U,8) I 'ID,S0 D
. N UNT,PTRN S UNT=$P(S0,"&",2),PTRN="1.N1"""_UNT_""""
. I LDOSE?@PTRN S $P(ID,"&",1,2)=+LDOSE_"&"_UNT Q ;pre-POE orders
. S:$P(PSOI,U,2)'[S0 ORDIALOG(STR,1)=$TR(S0,"&")
I 'ID,'S0 S ORDIALOG(DRGNM,1)=$$UNESC^ORMPS2($P(PSDD,U,2))
S:$L(ID) ORDIALOG(DOSE,1)=$$UNESC^ORMPS2($P(ID,"&",1,4)_"&"_LDOSE_"&"_+PSDD_"&"_S0)
I LDOSE="" D I LDOSE="" S ORERR="Unable to determine instructions" Q
. I $G(RXC)'>0 D Q ;look for units/dose
.. S LDOSE=$P(ID,"&",3),X=$P(ID,"&",4) I 'LDOSE S LDOSE="" Q
.. S:'$L(X) X=$$UNESC^ORMPS2($P($$FIND^ORM(+RXE,7),U,5)) S:$L(X) LDOSE=LDOSE_" "_X
.. S ORDIALOG(DRGNM,1)=$$UNESC^ORMPS2($P(PSDD,U,2)) ;force use of DD
. F D Q:LDOSE'="" S RXC=$O(@ORMSG@(RXC)) Q:'RXC Q:$E(@ORMSG@(RXC),1,3)'="RXC"
.. S XC=@ORMSG@(RXC) Q:+$P($P(XC,"|",3),U,4)'=+PSOI
.. S LDOSE=$P(XC,"|",4)_$P($P(XC,"|",5),U,5) ;strength_units
S ORDIALOG(INSTR,1)=$$UNESC^ORMPS2(LDOSE)
UD2 S NTE=$$NTE^ORMPS3(21) I NTE D
. N CNT,I S CNT=1,^TMP("ORWORD",$J,WP,1,CNT,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4))
. I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,WP,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I))
. S ^TMP("ORWORD",$J,WP,1,0)="^^"_CNT_U_CNT_U_DT_U
. S ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)"
S RXR=$$RXR^ORMPS I 'RXR S ORERR="Missing or invalid RXR segment" Q
S ORDIALOG(RTE,1)=$P($P(RXR,"|",2),U,4),ORDIALOG(URG,1)=ORURG
S X=$P(QT,U,2)
S ORDIALOG(SCH,1)=$$UNESC^ORMPS2($P(X,"&"))
S:$L($P(X,"&",2)) ORDIALOG(ADMIN,1)=$P(X,"&",2)
S X=$P(QT,U,3) I $L(X) D ;set only if previous order had duration
. N IFN S IFN=$S($G(ORIFN):+ORIFN,$P(ZRX,"|",2):+$P(ZRX,"|",2),1:0)
. S:$O(^OR(100,+IFN,4.5,"ID","DAYS",0)) ORDIALOG(DUR,1)=$$DURATION^ORMPS3(X)
D DOSETEXT^ORCDPS2 ;reset Instructions text, SIG
D UNESCARR^ORMPS2("ORDIALOG")
Q
OUT ; -- new Outpt order
N OI,SIG,INSTR,DOSE,RTE,SCH,DUR,SC,STR,DRUG,PI,CONJ,PSOI,PSDD,S0,X,I,RXR,J,NTE,ZSC,CNT,PC
S ORDIALOG=+$O(^ORD(101.41,"AB","PSO OERR",0))
S ORDG=+$O(^ORD(100.98,"B","OUTPATIENT MEDICATIONS",0))
S ORPKG=+$$PKG("PSO") D GETDLG1^ORCD(ORDIALOG)
S OI=$$PTR("ORDERABLE ITEM"),SIG=$$PTR("SIG")
S INSTR=$$PTR("INSTRUCTIONS"),DOSE=$$PTR("DOSE")
S SCH=$$PTR("SCHEDULE"),DUR=$$PTR("DURATION")
S RTE=$$PTR("ROUTE"),SC=$$PTR("SERVICE CONNECTED")
S STR=$$PTR("STRENGTH"),DRUG=$$PTR("DISPENSE DRUG")
S PI=$$PTR("PATIENT INSTRUCTIONS"),CONJ=$$PTR("AND/THEN")
S PC=$$PTR("WORD PROCESSING 1")
;IHS/MSC/MGH Patch 1013
S X=$$FIND^ORM(+ORC,4)
I $P(X,U,2)="PS"&(+X) D
.S ORDIALOG($$PTR("DAW"),1)=$$GET1^DIQ(52,+X,9999999.25,"I")
.S ORDIALOG($$PTR("CMF"),1)=$$GET1^DIQ(52,+X,9999999.02,"I")
.S ORDIALOG($$PTR("DSCMED"),1)=$$GET1^DIQ(52,+X,9999999.28,"I")
I $G(ORIFN) D
.;IHS/MSC/PLS - 07/30/13
.;F X="CLININD","CLININD2","CMF","DAW","PHARMACY","SSRREQIEN" D SAVEVAL^ORM(+ORIFN,X) ; IHS/MSC/DKM - Save IHS-specific prompts
.;IHS/MSC/MGH - 06/02/14
.F X="CLININD","CLININD2","PHARMACY","SSRREQIEN","SNMDCNPTID" D SAVEVAL^ORM(+ORIFN,X)
.S X=$$FIND^ORM(+ORC,4)
.I $P(X,U,2)="PS"&(+X) D
..S ORDIALOG($$PTR("DAW"),1)=$$GET1^DIQ(52,+X,9999999.25,"I")
..S ORDIALOG($$PTR("CMF"),1)=$$GET1^DIQ(52,+X,9999999.02,"I")
..S ORDIALOG($$PTR("DSCMED"),1)=$$GET1^DIQ(52,+X,9999999.28,"I")
.;End mod
.D SSRREQ
;
S:RXO X=$P(RXO,"|",2),ORDIALOG(OI,1)=$$ORDITEM^ORM(X),PSOI=$P(X,U,4,5)
I '$G(ORDIALOG(OI,1)) S ORERR="Missing or invalid orderable item" Q
S PSDD=$P($$FIND^ORM(+RXE,3),U,4,5),ORDIALOG(DRUG,1)=+PSDD
S S0=$$FIND^ORM(+RXE,26)_"&"_$P($$FIND^ORM(+RXE,27),U,5)
I S0,$P(PSOI,U,2)'[S0 S ORDIALOG(STR,1)=$TR(S0,"&")
I 'S0,'$G(ORQT(1)) S ORDIALOG($$PTR("DRUG NAME"),1)=$$UNESC^ORMPS2($P(PSDD,U,2))
OUT1 S ORDIALOG($$PTR("QUANTITY"),1)=$$FIND^ORM(+RXE,11)
S ORDIALOG($$PTR("REFILLS"),1)=$$FIND^ORM(+RXE,13)
S X=$$FIND^ORM(+RXE,23) S:$E(X)="D" X=+$E(X,2,99)
S:X ORDIALOG($$PTR("DAYS SUPPLY"),1)=X
I ZRX S X=$P(ZRX,"|",5) S:$L(X) ORDIALOG($$PTR("ROUTING"),1)=X
S:ORURG ORDIALOG($$PTR("URGENCY"),1)=ORURG F I=1:1:ORQT D
. S ORDIALOG(INSTR,I)=$$UNESC^ORMPS2($P(ORQT(I),U,8)),X=$P(ORQT(I),U)
. S:$L(X) ORDIALOG(DOSE,I)=$$UNESC^ORMPS2($P(X,"&",1,4)_"&"_$P(ORQT(I),U,8)_"&"_+PSDD_"&"_S0)
. S X=$P(ORQT(I),U,2) S:$L(X) ORDIALOG(SCH,I)=$$UNESC^ORMPS2(X)
. S X=$P(ORQT(I),U,3) S:$L(X) ORDIALOG(DUR,I)=$$DURATION^ORMPS3(X)
. S X=$P(ORQT(I),U,9) S:$L(X) ORDIALOG(CONJ,I)=$S(X="S":"T",1:X)
S RXR=$$RXR^ORMPS I RXR S ORDIALOG(RTE,1)=$P($P(RXR,"|",2),U,4) D
. S I=1,J=+RXR ;look for multiple RXR's
. F S J=$O(@ORMSG@(J)) Q:J'>0 S RXR=@ORMSG@(J) Q:$E(RXR,1,3)'="RXR" S I=I+1,ORDIALOG(RTE,I)=$P($P(RXR,"|",2),U,4)
OUT2 S NTE=$$NTE^ORMPS3(6) I NTE D ;Prov Comm ;D:'NTE PCOMM^ORMPS2
. S CNT=1,^TMP("ORWORD",$J,PC,1,CNT,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4))
. I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,PC,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I))
. S ^TMP("ORWORD",$J,PC,1,0)="^^"_CNT_U_CNT_U_DT_U
. S ORDIALOG(PC,1)="^TMP(""ORWORD"",$J,"_PC_",1)",ORDIALOG(PC,"FORMAT")="@" ;keep, don't show
. N XCNT,XCOMM,XCOMMENT,XORCOMM,XXCNT,XORIFN
. S XORIFN=$G(ORIFN) S:XORIFN="" XORIFN=$P(RXR,"|",2) Q:XORIFN=""
. S XCOMM=$O(^OR(100,+XORIFN,4.5,"ID","COMMENT",0)) Q:XCOMM=""
. S XCNT=0 F S XCNT=$O(^TMP("ORWORD",$J,PC,1,XCNT)) Q:XCNT="" S XCOMMENT=^TMP("ORWORD",$J,PC,1,XCNT,0) D
.. S XORCOMM=$G(^OR(100,+XORIFN,4.5,XCOMM,2,XCNT,0)),XXCNT=0
.. I XORCOMM="" F S XXCNT=$O(^OR(100,+XORIFN,4.5,XCOMM,2,XXCNT)) Q:XXCNT="" S XORCOMM=$G(^(XXCNT,0)) Q:XORCOMM'=""
.. I $G(XCOMMENT)=$G(XORCOMM) S ORDIALOG(PC,"FORMAT")="@"
S NTE=$$NTE^ORMPS3(7) I NTE D ;Pat Instr
. S CNT=1,^TMP("ORWORD",$J,PI,1,CNT,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4))
. I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,PI,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I))
. S ^TMP("ORWORD",$J,PI,1,0)="^^"_CNT_U_CNT_U_DT_U
. S ORDIALOG(PI,1)="^TMP(""ORWORD"",$J,"_PI_",1)"
S NTE=$$NTE^ORMPS3(21) I NTE D ;Sig
. S CNT=1,^TMP("ORWORD",$J,SIG,1,CNT,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4))
. I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,SIG,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I))
. S ^TMP("ORWORD",$J,SIG,1,0)="^^"_CNT_U_CNT_U_DT_U
. S ORDIALOG(SIG,1)="^TMP(""ORWORD"",$J,"_SIG_",1)"
. S ORDIALOG(PI,"FORMAT")="@" ;PI already included in Sig
OUT3 I '$G(ORQT(1))!('NTE) D DOSETEXT^ORCDPS2 ;reset Instructions text, Sig
S ZSC=$$ZSC^ORMPS3,X=$P(ZSC,"|",2) I X?2.3U S ORDIALOG(SC,1)=$S(X="SC":1,1:0)
Q
IV ; -- new IV order
N IVTYP,IVTYPE S IVTYP=$P(ZRX,"|",7) I IVTYP="",$$NUMADDS^ORMPS3'>1 G UDOSE
N SOLN,VOL,ADDS,STR,UNITS,RATE,URG,X,X1,X2,I,J,TYPE,OI,WP,NTE,SCH,DAYS,ROUTE,ADMIN
N RXR
S ORDIALOG=+$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0))
I +$G(ORAPPT)>0 S ORDG=+$O(^ORD(100.98,"B","CLINIC ORDERS",0))
E S ORDG=+$O(^ORD(100.98,"B",$S($P(ZRX,"|",7)="TPN":"TPN",1:"IV RX"),0))
S ORPKG=+$$PKG("PSJ") D GETDLG1^ORCD(ORDIALOG)
S SOLN=$$PTR("ORDERABLE ITEM"),VOL=$$PTR("VOLUME"),SCH=$$PTR("SCHEDULE")
S RATE=$$PTR("INFUSION RATE") S:ORURG ORDIALOG($$PTR("URGENCY"),1)=ORURG
S WP=$$PTR("WORD PROCESSING 1"),ADDS=$$PTR("ADDITIVE")
S STR=$$PTR("STRENGTH PSIV"),UNITS=$$PTR("UNITS")
S DAYS=$$PTR("DURATION"),IVTYPE=$$PTR("IV TYPE"),ADMIN=$$PTR("ADMIN TIMES")
IV1 S NTE=$$NTE^ORMPS3(21) I NTE D
. N CNT,I S CNT=1,^TMP("ORWORD",$J,WP,1,CNT,0)=$$UNESC^ORMPS2($P(@ORMSG@(NTE),"|",4))
. I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S CNT=CNT+1,^TMP("ORWORD",$J,WP,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I))
. S ^TMP("ORWORD",$J,WP,1,0)="^^"_CNT_U_CNT_U_DT_U
. S ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)"
N ORDAYS S ORDAYS=""
S:$D(RXO) ORDAYS=$P($P(RXO,"|",2),"^",3)
S:$L(ORDAYS) ORDAYS=$$IVLIM^ORMPS2(ORDAYS)
S:$L(ORDAYS) ORDIALOG(DAYS,1)=ORDAYS
S ORDIALOG(IVTYPE,1)=IVTYP
S X=$P($$FIND^ORM(+RXE,25),U,5)
S ORDIALOG(RATE,1)=$$FIND^ORM(+RXE,24)_$S($L(X):" "_X,1:""),(I,J)=0
F D S RXC=$O(@ORMSG@(RXC)) Q:'RXC Q:$E(@ORMSG@(RXC),1,3)'="RXC"
. S X=@ORMSG@(RXC),TYPE=$P(X,"|",2),OI=$$ORDITEM^ORM($P(X,"|",3)) Q:'OI
. S X1=$P(X,"|",4),X2=$P($P(X,"|",5),U,5)
. I $E(TYPE)="B" S J=J+1,ORDIALOG(SOLN,J)=OI,ORDIALOG(VOL,J)=X1 Q
. S I=I+1,ORDIALOG(ADDS,I)=OI,ORDIALOG(STR,I)=X1,ORDIALOG(UNITS,I)=X2
IV2 ;
S RXR=$$RXR^ORMPS
S ROUTE=$P(RXR,"|",2)
S ORDIALOG($$PTR("ROUTE"),1)=$P(ROUTE,U,4)
I IVTYP="I" S X=$P($G(ORQT(1)),U,2) D
.S:$L($P(X,"&")) ORDIALOG(SCH,1)=$P(X,"&")
.S:$L($P(X,"&",2)) ORDIALOG(ADMIN,1)=$P(X,"&",2)
D UNESCARR^ORMPS2("ORDIALOG")
Q
PKG(NMSP) ; -- Return Package file ptr for NMSP
N I S I=0
F S I=+$O(^DIC(9.4,"C",NMSP,I)) Q:I<1 Q:'$O(^(I,0)) ;no Addl Prefs
Q I
PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41
Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
QT ; -- Unpiece the Q/T field from RXE
I 'RXE S ORQT(1)=ORQT,ORQT=1 Q ; nothing to reset
N X,Y,I,J,P,SEG,DONE K ORQT
S SEG=$G(@ORMSG@(+RXE)),X=$P(SEG,"|",2),(I,J,P,DONE)=0
F D Q:DONE
. S P=P+1,Y=$P(X,"~",P) I Y="" S DONE=1 Q
. I P<$L(X,"~") S I=I+1,ORQT(I)=Y Q
. I $L(SEG,"|")>2 S I=I+1,ORQT(I)=Y,DONE=1 Q
. S J=+$O(@ORMSG@(+RXE,J)) I J'>0 S I=I+1,ORQT(I)=Y,DONE=1 Q
. S SEG=$G(@ORMSG@(+RXE,J)),X=$P(SEG,"|"),P=1,I=I+1,ORQT(I)=Y_$P(X,"~")
S ORQT=I Q:'ORQT ; else reset ORSTRT, ORSTOP, ORURG
S ORSTRT=$P(ORQT(1),U,4),ORSTOP=$P(ORQT(ORQT),U,5),ORURG=$P(ORQT(1),U,6)
S:ORSTRT ORSTRT=$$FMDATE^ORM(ORSTRT) S:ORSTOP ORSTOP=$$FMDATE^ORM(ORSTOP) S:$L(ORURG) ORURG=$$URGENCY^ORM(ORURG)
Q
; -- Get Refill Request Test from order
SSRREQ N I,PTR
S PTR=$$PTR("SSREFREQ")
Q:'PTR
S I=+$O(^OR(100,ORIFN,4.5,"ID","SSREFREQ",0))
Q:I<1
M ^TMP("ORWORD",$J,PTR,1)=^OR(100,ORIFN,4.5,I,2)
S ORDIALOG(PTR,1)=$NA(^TMP("ORWORD",$J,PTR,1))
Q
ORMPS1 ;SLC/MKB - Process Pharmacy ORM msgs cont ;03-Jun-2014 11:20;PLS
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**86,92,94,116,134,152,158,149,190,1005,195,215,265,275,243,1010,1012,1013**;Dec 17, 1997;Build 43
+2 ; Modified - IHS/MSC/PLS - 10/07/08 - OUT+12
+3 ; 07/30/13 - OUT+13
+4 ; 04/14/14 - Changed SNOMED reference and added DSCMED to OUT+13
+5 ; 05/27/2014 - OUT+12
+6 ; 06/02/2014 - Line OUT+21
+7 ;;Per VHA Directive 2004-038, this routine should not be modified.
UDOSE ; -- new Unit Dose order
+1 NEW ADMIN,QT,DRUG,INSTR,DOSE,RTE,SCH,OI,URG,WP,DUR,STR,DRGNM,X,PSOI,PSDD,S0,ID,LDOSE,XC,NTE,S0,RXR
+2 SET ORDIALOG=+$ORDER(^ORD(101.41,"AB","PSJ OR PAT OE",0))
+3 IF $GET(ORAPPT)>0
SET ORDG=+$ORDER(^ORD(100.98,"B","CLINIC ORDERS",0))
+4 IF '$TEST
SET ORDG=+$ORDER(^ORD(100.98,"B","UNIT DOSE MEDICATIONS",0))
+5 SET ORPKG=+$$PKG("PSJ")
+6 DO GETDLG1^ORCD(ORDIALOG)
SET QT=$GET(ORQT(1))
+7 SET DRUG=$$PTR("DISPENSE DRUG")
SET INSTR=$$PTR("INSTRUCTIONS")
+8 SET DOSE=$$PTR("DOSE")
SET RTE=$$PTR("ROUTE")
+9 SET SCH=$$PTR("SCHEDULE")
SET ADMIN=$$PTR("ADMIN TIMES")
+10 SET OI=$$PTR("ORDERABLE ITEM")
SET URG=$$PTR("URGENCY")
+11 SET WP=$$PTR("WORD PROCESSING 1")
SET DUR=$$PTR("DURATION")
+12 SET STR=$$PTR("STRENGTH")
SET DRGNM=$$PTR("DRUG NAME")
UD1 IF RXO
SET X=$PIECE(RXO,"|",2)
SET ORDIALOG(OI,1)=$$ORDITEM^ORM(X)
SET PSOI=$PIECE(X,U,4,5)
+1 IF '$GET(ORDIALOG(OI,1))
SET ORERR="Missing or invalid orderable item"
QUIT
+2 SET PSDD=$PIECE($$FIND^ORM(+RXE,3),U,4,5)
SET ORDIALOG(DRUG,1)=+PSDD
+3 SET S0=$$FIND^ORM(+RXE,26)_"&"_$PIECE($$FIND^ORM(+RXE,27),U,5)
+4 SET ID=$PIECE(QT,U)
SET LDOSE=$PIECE(QT,U,8)
IF 'ID
IF S0
Begin DoDot:1
+5 NEW UNT,PTRN
SET UNT=$PIECE(S0,"&",2)
SET PTRN="1.N1"""_UNT_""""
+6 ;pre-POE orders
IF LDOSE?@PTRN
SET $PIECE(ID,"&",1,2)=+LDOSE_"&"_UNT
QUIT
+7 IF $PIECE(PSOI,U,2)'[S0
SET ORDIALOG(STR,1)=$TRANSLATE(S0,"&")
End DoDot:1
+8 IF 'ID
IF 'S0
SET ORDIALOG(DRGNM,1)=$$UNESC^ORMPS2($PIECE(PSDD,U,2))
+9 IF $LENGTH(ID)
SET ORDIALOG(DOSE,1)=$$UNESC^ORMPS2($PIECE(ID,"&",1,4)_"&"_LDOSE_"&"_+PSDD_"&"_S0)
+10 IF LDOSE=""
Begin DoDot:1
+11 ;look for units/dose
IF $GET(RXC)'>0
Begin DoDot:2
+12 SET LDOSE=$PIECE(ID,"&",3)
SET X=$PIECE(ID,"&",4)
IF 'LDOSE
SET LDOSE=""
QUIT
+13 IF '$LENGTH(X)
SET X=$$UNESC^ORMPS2($PIECE($$FIND^ORM(+RXE,7),U,5))
IF $LENGTH(X)
SET LDOSE=LDOSE_" "_X
+14 ;force use of DD
SET ORDIALOG(DRGNM,1)=$$UNESC^ORMPS2($PIECE(PSDD,U,2))
End DoDot:2
QUIT
+15 FOR
Begin DoDot:2
+16 SET XC=@ORMSG@(RXC)
IF +$PIECE($PIECE(XC,"|",3),U,4)'=+PSOI
QUIT
+17 ;strength_units
SET LDOSE=$PIECE(XC,"|",4)_$PIECE($PIECE(XC,"|",5),U,5)
End DoDot:2
IF LDOSE'=""
QUIT
SET RXC=$ORDER(@ORMSG@(RXC))
IF 'RXC
QUIT
IF $EXTRACT(@ORMSG@(RXC),1,3)'="RXC"
QUIT
End DoDot:1
IF LDOSE=""
SET ORERR="Unable to determine instructions"
QUIT
+18 SET ORDIALOG(INSTR,1)=$$UNESC^ORMPS2(LDOSE)
UD2 SET NTE=$$NTE^ORMPS3(21)
IF NTE
Begin DoDot:1
+1 NEW CNT,I
SET CNT=1
SET ^TMP("ORWORD",$JOB,WP,1,CNT,0)=$$UNESC^ORMPS2($PIECE(@ORMSG@(NTE),"|",4))
+2 IF $ORDER(@ORMSG@(NTE,0))
SET I=0
FOR
SET I=$ORDER(@ORMSG@(NTE,I))
IF I'>0
QUIT
SET CNT=CNT+1
SET ^TMP("ORWORD",$JOB,WP,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I))
+3 SET ^TMP("ORWORD",$JOB,WP,1,0)="^^"_CNT_U_CNT_U_DT_U
+4 SET ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)"
End DoDot:1
+5 SET RXR=$$RXR^ORMPS
IF 'RXR
SET ORERR="Missing or invalid RXR segment"
QUIT
+6 SET ORDIALOG(RTE,1)=$PIECE($PIECE(RXR,"|",2),U,4)
SET ORDIALOG(URG,1)=ORURG
+7 SET X=$PIECE(QT,U,2)
+8 SET ORDIALOG(SCH,1)=$$UNESC^ORMPS2($PIECE(X,"&"))
+9 IF $LENGTH($PIECE(X,"&",2))
SET ORDIALOG(ADMIN,1)=$PIECE(X,"&",2)
+10 ;set only if previous order had duration
SET X=$PIECE(QT,U,3)
IF $LENGTH(X)
Begin DoDot:1
+11 NEW IFN
SET IFN=$SELECT($GET(ORIFN):+ORIFN,$PIECE(ZRX,"|",2):+$PIECE(ZRX,"|",2),1:0)
+12 IF $ORDER(^OR(100,+IFN,4.5,"ID","DAYS",0))
SET ORDIALOG(DUR,1)=$$DURATION^ORMPS3(X)
End DoDot:1
+13 ;reset Instructions text, SIG
DO DOSETEXT^ORCDPS2
+14 DO UNESCARR^ORMPS2("ORDIALOG")
+15 QUIT
OUT ; -- new Outpt order
+1 NEW OI,SIG,INSTR,DOSE,RTE,SCH,DUR,SC,STR,DRUG,PI,CONJ,PSOI,PSDD,S0,X,I,RXR,J,NTE,ZSC,CNT,PC
+2 SET ORDIALOG=+$ORDER(^ORD(101.41,"AB","PSO OERR",0))
+3 SET ORDG=+$ORDER(^ORD(100.98,"B","OUTPATIENT MEDICATIONS",0))
+4 SET ORPKG=+$$PKG("PSO")
DO GETDLG1^ORCD(ORDIALOG)
+5 SET OI=$$PTR("ORDERABLE ITEM")
SET SIG=$$PTR("SIG")
+6 SET INSTR=$$PTR("INSTRUCTIONS")
SET DOSE=$$PTR("DOSE")
+7 SET SCH=$$PTR("SCHEDULE")
SET DUR=$$PTR("DURATION")
+8 SET RTE=$$PTR("ROUTE")
SET SC=$$PTR("SERVICE CONNECTED")
+9 SET STR=$$PTR("STRENGTH")
SET DRUG=$$PTR("DISPENSE DRUG")
+10 SET PI=$$PTR("PATIENT INSTRUCTIONS")
SET CONJ=$$PTR("AND/THEN")
+11 SET PC=$$PTR("WORD PROCESSING 1")
+12 ;IHS/MSC/MGH Patch 1013
+13 SET X=$$FIND^ORM(+ORC,4)
+14 IF $PIECE(X,U,2)="PS"&(+X)
Begin DoDot:1
+15 SET ORDIALOG($$PTR("DAW"),1)=$$GET1^DIQ(52,+X,9999999.25,"I")
+16 SET ORDIALOG($$PTR("CMF"),1)=$$GET1^DIQ(52,+X,9999999.02,"I")
+17 SET ORDIALOG($$PTR("DSCMED"),1)=$$GET1^DIQ(52,+X,9999999.28,"I")
End DoDot:1
+18 IF $GET(ORIFN)
Begin DoDot:1
+19 ;IHS/MSC/PLS - 07/30/13
+20 ;F X="CLININD","CLININD2","CMF","DAW","PHARMACY","SSRREQIEN" D SAVEVAL^ORM(+ORIFN,X) ; IHS/MSC/DKM - Save IHS-specific prompts
+21 ;IHS/MSC/MGH - 06/02/14
+22 FOR X="CLININD","CLININD2","PHARMACY","SSRREQIEN","SNMDCNPTID"
DO SAVEVAL^ORM(+ORIFN,X)
+23 SET X=$$FIND^ORM(+ORC,4)
+24 IF $PIECE(X,U,2)="PS"&(+X)
Begin DoDot:2
+25 SET ORDIALOG($$PTR("DAW"),1)=$$GET1^DIQ(52,+X,9999999.25,"I")
+26 SET ORDIALOG($$PTR("CMF"),1)=$$GET1^DIQ(52,+X,9999999.02,"I")
+27 SET ORDIALOG($$PTR("DSCMED"),1)=$$GET1^DIQ(52,+X,9999999.28,"I")
End DoDot:2
+28 ;End mod
+29 DO SSRREQ
End DoDot:1
+30 ;
+31 IF RXO
SET X=$PIECE(RXO,"|",2)
SET ORDIALOG(OI,1)=$$ORDITEM^ORM(X)
SET PSOI=$PIECE(X,U,4,5)
+32 IF '$GET(ORDIALOG(OI,1))
SET ORERR="Missing or invalid orderable item"
QUIT
+33 SET PSDD=$PIECE($$FIND^ORM(+RXE,3),U,4,5)
SET ORDIALOG(DRUG,1)=+PSDD
+34 SET S0=$$FIND^ORM(+RXE,26)_"&"_$PIECE($$FIND^ORM(+RXE,27),U,5)
+35 IF S0
IF $PIECE(PSOI,U,2)'[S0
SET ORDIALOG(STR,1)=$TRANSLATE(S0,"&")
+36 IF 'S0
IF '$GET(ORQT(1))
SET ORDIALOG($$PTR("DRUG NAME"),1)=$$UNESC^ORMPS2($PIECE(PSDD,U,2))
OUT1 SET ORDIALOG($$PTR("QUANTITY"),1)=$$FIND^ORM(+RXE,11)
+1 SET ORDIALOG($$PTR("REFILLS"),1)=$$FIND^ORM(+RXE,13)
+2 SET X=$$FIND^ORM(+RXE,23)
IF $EXTRACT(X)="D"
SET X=+$EXTRACT(X,2,99)
+3 IF X
SET ORDIALOG($$PTR("DAYS SUPPLY"),1)=X
+4 IF ZRX
SET X=$PIECE(ZRX,"|",5)
IF $LENGTH(X)
SET ORDIALOG($$PTR("ROUTING"),1)=X
+5 IF ORURG
SET ORDIALOG($$PTR("URGENCY"),1)=ORURG
FOR I=1:1:ORQT
Begin DoDot:1
+6 SET ORDIALOG(INSTR,I)=$$UNESC^ORMPS2($PIECE(ORQT(I),U,8))
SET X=$PIECE(ORQT(I),U)
+7 IF $LENGTH(X)
SET ORDIALOG(DOSE,I)=$$UNESC^ORMPS2($PIECE(X,"&",1,4)_"&"_$PIECE(ORQT(I),U,8)_"&"_+PSDD_"&"_S0)
+8 SET X=$PIECE(ORQT(I),U,2)
IF $LENGTH(X)
SET ORDIALOG(SCH,I)=$$UNESC^ORMPS2(X)
+9 SET X=$PIECE(ORQT(I),U,3)
IF $LENGTH(X)
SET ORDIALOG(DUR,I)=$$DURATION^ORMPS3(X)
+10 SET X=$PIECE(ORQT(I),U,9)
IF $LENGTH(X)
SET ORDIALOG(CONJ,I)=$SELECT(X="S":"T",1:X)
End DoDot:1
+11 SET RXR=$$RXR^ORMPS
IF RXR
SET ORDIALOG(RTE,1)=$PIECE($PIECE(RXR,"|",2),U,4)
Begin DoDot:1
+12 ;look for multiple RXR's
SET I=1
SET J=+RXR
+13 FOR
SET J=$ORDER(@ORMSG@(J))
IF J'>0
QUIT
SET RXR=@ORMSG@(J)
IF $EXTRACT(RXR,1,3)'="RXR"
QUIT
SET I=I+1
SET ORDIALOG(RTE,I)=$PIECE($PIECE(RXR,"|",2),U,4)
End DoDot:1
OUT2 ;Prov Comm ;D:'NTE PCOMM^ORMPS2
SET NTE=$$NTE^ORMPS3(6)
IF NTE
Begin DoDot:1
+1 SET CNT=1
SET ^TMP("ORWORD",$JOB,PC,1,CNT,0)=$$UNESC^ORMPS2($PIECE(@ORMSG@(NTE),"|",4))
+2 IF $ORDER(@ORMSG@(NTE,0))
SET I=0
FOR
SET I=$ORDER(@ORMSG@(NTE,I))
IF I'>0
QUIT
SET CNT=CNT+1
SET ^TMP("ORWORD",$JOB,PC,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I))
+3 SET ^TMP("ORWORD",$JOB,PC,1,0)="^^"_CNT_U_CNT_U_DT_U
+4 ;keep, don't show
SET ORDIALOG(PC,1)="^TMP(""ORWORD"",$J,"_PC_",1)"
SET ORDIALOG(PC,"FORMAT")="@"
+5 NEW XCNT,XCOMM,XCOMMENT,XORCOMM,XXCNT,XORIFN
+6 SET XORIFN=$GET(ORIFN)
IF XORIFN=""
SET XORIFN=$PIECE(RXR,"|",2)
IF XORIFN=""
QUIT
+7 SET XCOMM=$ORDER(^OR(100,+XORIFN,4.5,"ID","COMMENT",0))
IF XCOMM=""
QUIT
+8 SET XCNT=0
FOR
SET XCNT=$ORDER(^TMP("ORWORD",$JOB,PC,1,XCNT))
IF XCNT=""
QUIT
SET XCOMMENT=^TMP("ORWORD",$JOB,PC,1,XCNT,0)
Begin DoDot:2
+9 SET XORCOMM=$GET(^OR(100,+XORIFN,4.5,XCOMM,2,XCNT,0))
SET XXCNT=0
+10 IF XORCOMM=""
FOR
SET XXCNT=$ORDER(^OR(100,+XORIFN,4.5,XCOMM,2,XXCNT))
IF XXCNT=""
QUIT
SET XORCOMM=$GET(^(XXCNT,0))
IF XORCOMM'=""
QUIT
+11 IF $GET(XCOMMENT)=$GET(XORCOMM)
SET ORDIALOG(PC,"FORMAT")="@"
End DoDot:2
End DoDot:1
+12 ;Pat Instr
SET NTE=$$NTE^ORMPS3(7)
IF NTE
Begin DoDot:1
+13 SET CNT=1
SET ^TMP("ORWORD",$JOB,PI,1,CNT,0)=$$UNESC^ORMPS2($PIECE(@ORMSG@(NTE),"|",4))
+14 IF $ORDER(@ORMSG@(NTE,0))
SET I=0
FOR
SET I=$ORDER(@ORMSG@(NTE,I))
IF I'>0
QUIT
SET CNT=CNT+1
SET ^TMP("ORWORD",$JOB,PI,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I))
+15 SET ^TMP("ORWORD",$JOB,PI,1,0)="^^"_CNT_U_CNT_U_DT_U
+16 SET ORDIALOG(PI,1)="^TMP(""ORWORD"",$J,"_PI_",1)"
End DoDot:1
+17 ;Sig
SET NTE=$$NTE^ORMPS3(21)
IF NTE
Begin DoDot:1
+18 SET CNT=1
SET ^TMP("ORWORD",$JOB,SIG,1,CNT,0)=$$UNESC^ORMPS2($PIECE(@ORMSG@(NTE),"|",4))
+19 IF $ORDER(@ORMSG@(NTE,0))
SET I=0
FOR
SET I=$ORDER(@ORMSG@(NTE,I))
IF I'>0
QUIT
SET CNT=CNT+1
SET ^TMP("ORWORD",$JOB,SIG,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I))
+20 SET ^TMP("ORWORD",$JOB,SIG,1,0)="^^"_CNT_U_CNT_U_DT_U
+21 SET ORDIALOG(SIG,1)="^TMP(""ORWORD"",$J,"_SIG_",1)"
+22 ;PI already included in Sig
SET ORDIALOG(PI,"FORMAT")="@"
End DoDot:1
OUT3 ;reset Instructions text, Sig
IF '$GET(ORQT(1))!('NTE)
DO DOSETEXT^ORCDPS2
+1 SET ZSC=$$ZSC^ORMPS3
SET X=$PIECE(ZSC,"|",2)
IF X?2.3U
SET ORDIALOG(SC,1)=$SELECT(X="SC":1,1:0)
+2 QUIT
IV ; -- new IV order
+1 NEW IVTYP,IVTYPE
SET IVTYP=$PIECE(ZRX,"|",7)
IF IVTYP=""
IF $$NUMADDS^ORMPS3'>1
GOTO UDOSE
+2 NEW SOLN,VOL,ADDS,STR,UNITS,RATE,URG,X,X1,X2,I,J,TYPE,OI,WP,NTE,SCH,DAYS,ROUTE,ADMIN
+3 NEW RXR
+4 SET ORDIALOG=+$ORDER(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0))
+5 IF +$GET(ORAPPT)>0
SET ORDG=+$ORDER(^ORD(100.98,"B","CLINIC ORDERS",0))
+6 IF '$TEST
SET ORDG=+$ORDER(^ORD(100.98,"B",$SELECT($PIECE(ZRX,"|",7)="TPN":"TPN",1:"IV RX"),0))
+7 SET ORPKG=+$$PKG("PSJ")
DO GETDLG1^ORCD(ORDIALOG)
+8 SET SOLN=$$PTR("ORDERABLE ITEM")
SET VOL=$$PTR("VOLUME")
SET SCH=$$PTR("SCHEDULE")
+9 SET RATE=$$PTR("INFUSION RATE")
IF ORURG
SET ORDIALOG($$PTR("URGENCY"),1)=ORURG
+10 SET WP=$$PTR("WORD PROCESSING 1")
SET ADDS=$$PTR("ADDITIVE")
+11 SET STR=$$PTR("STRENGTH PSIV")
SET UNITS=$$PTR("UNITS")
+12 SET DAYS=$$PTR("DURATION")
SET IVTYPE=$$PTR("IV TYPE")
SET ADMIN=$$PTR("ADMIN TIMES")
IV1 SET NTE=$$NTE^ORMPS3(21)
IF NTE
Begin DoDot:1
+1 NEW CNT,I
SET CNT=1
SET ^TMP("ORWORD",$JOB,WP,1,CNT,0)=$$UNESC^ORMPS2($PIECE(@ORMSG@(NTE),"|",4))
+2 IF $ORDER(@ORMSG@(NTE,0))
SET I=0
FOR
SET I=$ORDER(@ORMSG@(NTE,I))
IF I'>0
QUIT
SET CNT=CNT+1
SET ^TMP("ORWORD",$JOB,WP,1,CNT,0)=$$UNESC^ORMPS2(@ORMSG@(NTE,I))
+3 SET ^TMP("ORWORD",$JOB,WP,1,0)="^^"_CNT_U_CNT_U_DT_U
+4 SET ORDIALOG(WP,1)="^TMP(""ORWORD"",$J,"_WP_",1)"
End DoDot:1
+5 NEW ORDAYS
SET ORDAYS=""
+6 IF $DATA(RXO)
SET ORDAYS=$PIECE($PIECE(RXO,"|",2),"^",3)
+7 IF $LENGTH(ORDAYS)
SET ORDAYS=$$IVLIM^ORMPS2(ORDAYS)
+8 IF $LENGTH(ORDAYS)
SET ORDIALOG(DAYS,1)=ORDAYS
+9 SET ORDIALOG(IVTYPE,1)=IVTYP
+10 SET X=$PIECE($$FIND^ORM(+RXE,25),U,5)
+11 SET ORDIALOG(RATE,1)=$$FIND^ORM(+RXE,24)_$SELECT($LENGTH(X):" "_X,1:"")
SET (I,J)=0
+12 FOR
Begin DoDot:1
+13 SET X=@ORMSG@(RXC)
SET TYPE=$PIECE(X,"|",2)
SET OI=$$ORDITEM^ORM($PIECE(X,"|",3))
IF 'OI
QUIT
+14 SET X1=$PIECE(X,"|",4)
SET X2=$PIECE($PIECE(X,"|",5),U,5)
+15 IF $EXTRACT(TYPE)="B"
SET J=J+1
SET ORDIALOG(SOLN,J)=OI
SET ORDIALOG(VOL,J)=X1
QUIT
+16 SET I=I+1
SET ORDIALOG(ADDS,I)=OI
SET ORDIALOG(STR,I)=X1
SET ORDIALOG(UNITS,I)=X2
End DoDot:1
SET RXC=$ORDER(@ORMSG@(RXC))
IF 'RXC
QUIT
IF $EXTRACT(@ORMSG@(RXC),1,3)'="RXC"
QUIT
IV2 ;
+1 SET RXR=$$RXR^ORMPS
+2 SET ROUTE=$PIECE(RXR,"|",2)
+3 SET ORDIALOG($$PTR("ROUTE"),1)=$PIECE(ROUTE,U,4)
+4 IF IVTYP="I"
SET X=$PIECE($GET(ORQT(1)),U,2)
Begin DoDot:1
+5 IF $LENGTH($PIECE(X,"&"))
SET ORDIALOG(SCH,1)=$PIECE(X,"&")
+6 IF $LENGTH($PIECE(X,"&",2))
SET ORDIALOG(ADMIN,1)=$PIECE(X,"&",2)
End DoDot:1
+7 DO UNESCARR^ORMPS2("ORDIALOG")
+8 QUIT
PKG(NMSP) ; -- Return Package file ptr for NMSP
+1 NEW I
SET I=0
+2 ;no Addl Prefs
FOR
SET I=+$ORDER(^DIC(9.4,"C",NMSP,I))
IF I<1
QUIT
IF '$ORDER(^(I,0))
QUIT
+3 QUIT I
PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41
+1 QUIT +$ORDER(^ORD(101.41,"AB",$EXTRACT("OR GTX "_NAME,1,63),0))
QT ; -- Unpiece the Q/T field from RXE
+1 ; nothing to reset
IF 'RXE
SET ORQT(1)=ORQT
SET ORQT=1
QUIT
+2 NEW X,Y,I,J,P,SEG,DONE
KILL ORQT
+3 SET SEG=$GET(@ORMSG@(+RXE))
SET X=$PIECE(SEG,"|",2)
SET (I,J,P,DONE)=0
+4 FOR
Begin DoDot:1
+5 SET P=P+1
SET Y=$PIECE(X,"~",P)
IF Y=""
SET DONE=1
QUIT
+6 IF P<$LENGTH(X,"~")
SET I=I+1
SET ORQT(I)=Y
QUIT
+7 IF $LENGTH(SEG,"|")>2
SET I=I+1
SET ORQT(I)=Y
SET DONE=1
QUIT
+8 SET J=+$ORDER(@ORMSG@(+RXE,J))
IF J'>0
SET I=I+1
SET ORQT(I)=Y
SET DONE=1
QUIT
+9 SET SEG=$GET(@ORMSG@(+RXE,J))
SET X=$PIECE(SEG,"|")
SET P=1
SET I=I+1
SET ORQT(I)=Y_$PIECE(X,"~")
End DoDot:1
IF DONE
QUIT
+10 ; else reset ORSTRT, ORSTOP, ORURG
SET ORQT=I
IF 'ORQT
QUIT
+11 SET ORSTRT=$PIECE(ORQT(1),U,4)
SET ORSTOP=$PIECE(ORQT(ORQT),U,5)
SET ORURG=$PIECE(ORQT(1),U,6)
+12 IF ORSTRT
SET ORSTRT=$$FMDATE^ORM(ORSTRT)
IF ORSTOP
SET ORSTOP=$$FMDATE^ORM(ORSTOP)
IF $LENGTH(ORURG)
SET ORURG=$$URGENCY^ORM(ORURG)
+13 QUIT
+14 ; -- Get Refill Request Test from order
SSRREQ NEW I,PTR
+1 SET PTR=$$PTR("SSREFREQ")
+2 IF 'PTR
QUIT
+3 SET I=+$ORDER(^OR(100,ORIFN,4.5,"ID","SSREFREQ",0))
+4 IF I<1
QUIT
+5 MERGE ^TMP("ORWORD",$JOB,PTR,1)=^OR(100,ORIFN,4.5,I,2)
+6 SET ORDIALOG(PTR,1)=$NAME(^TMP("ORWORD",$JOB,PTR,1))
+7 QUIT
