- ORMPS1 ;SLC/MKB - Process Pharmacy ORM msgs cont ;Nov 17, 2020@13:57:35
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**86,92,94,116,134,152,158,149,190,195,215,265,275,243,280,350,382,397,413,405**;Dec 17, 1997;Build 211
- ;;Per VA Directive 6402, 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,INDICATN
- I $G(ORAPPT)>0 S ORDIALOG=+$O(^ORD(101.41,"AB","PSJ OR CLINIC OE",0)),ORDG=+$O(^ORD(100.98,"B","CLINIC MEDICATIONS",0))
- E S ORDIALOG=+$O(^ORD(101.41,"AB","PSJ OR PAT OE",0)),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 INDICATN=$$PTR("INDICATION") ;*405-IND
- 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),ORDIALOG(INDICATN,1)=$$UNESC^ORMPS2($P(RXO,"|",21)) ;*405-IND
- 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 ORDIALOG(DOSE,1)=$$UNESC^ORMPS2($S($L(ID):$P(ID,"&",1,4),1:"&&&")_"&"_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 PSDD=$P($$FIND^ORM(+RXE,3),U,4,5)
- I $$ISSUPPLY^ORUTL3(+PSDD) D
- . S ORDIALOG=+$O(^ORD(101.41,"AB","PSO SUPPLY",0))
- . S ORDG=+$O(^ORD(100.98,"B","SUPPLIES/DEVICES",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")
- S INDICATN=$$PTR("INDICATION") ;*405-IND
- S:RXO X=$P(RXO,"|",2),ORDIALOG(OI,1)=$$ORDITEM^ORM(X),PSOI=$P(X,U,4,5),ORDIALOG(INDICATN,1)=$$UNESC^ORMPS2($P(RXO,"|",21)) ;*405-IND
- I '$G(ORDIALOG(OI,1)) S ORERR="Missing or invalid orderable item" Q
- S 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)
- . ; Populate DOSE response
- . S X=$P(ORQT(I),U)
- . ; If Dose component (X) of Quantity/Timing (RXE-1-1) is null, still populate DOSE response if Drug IEN (PSDD) is defined.
- . ; (For example, when local possible dosages were used, Pharmacy is not sending the Dose component).
- . I X="",PSDD S X="&&&"
- . 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)
- I $$ASKTITR^ORCDPS3 D
- . S X=+$P($G(ZRX),"|",9) S ORDIALOG($$PTR("TITRATION"),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,X3,I,J,TYPE,OI,WP,NTE,SCH
- N DAYS,ROUTE,ADMIN,RXR,ADDFREQ
- I $G(ORAPPT)>0 S ORDIALOG=+$O(^ORD(101.41,"AB","CLINIC OR PAT FLUID OE",0)),ORDG=+$O(^ORD(100.98,"B","CLINIC INFUSIONS",0))
- E S ORDIALOG=+$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0)),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 ADDFREQ=$$PTR("ADDITIVE FREQUENCY")
- S STR=$$PTR("STRENGTH PSIV"),UNITS=$$PTR("UNITS")
- S DAYS=$$PTR("DURATION"),IVTYPE=$$PTR("IV TYPE"),ADMIN=$$PTR("ADMIN TIMES")
- S INDICATN=$$PTR("INDICATION") ;*405-IND
- 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),ORDIALOG(INDICATN,1)=$$UNESC^ORMPS2($P(RXO,"|",21)) ;*405-IND
- 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),X3=$P(X,"|",6)
- . 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,ORDIALOG(ADDFREQ,I)=$$ADDFRQCV^ORMBLDP1(X3,"I")
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORMPS1 11086 printed Feb 18, 2025@23:58:38 Page 2
- ORMPS1 ;SLC/MKB - Process Pharmacy ORM msgs cont ;Nov 17, 2020@13:57:35
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**86,92,94,116,134,152,158,149,190,195,215,265,275,243,280,350,382,397,413,405**;Dec 17, 1997;Build 211
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;
- 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,INDICATN
- +2 IF $GET(ORAPPT)>0
- SET ORDIALOG=+$ORDER(^ORD(101.41,"AB","PSJ OR CLINIC OE",0))
- SET ORDG=+$ORDER(^ORD(100.98,"B","CLINIC MEDICATIONS",0))
- +3 IF '$TEST
- SET ORDIALOG=+$ORDER(^ORD(101.41,"AB","PSJ OR PAT OE",0))
- SET ORDG=+$ORDER(^ORD(100.98,"B","UNIT DOSE MEDICATIONS",0))
- +4 SET ORPKG=+$$PKG("PSJ")
- +5 DO GETDLG1^ORCD(ORDIALOG)
- SET QT=$GET(ORQT(1))
- +6 SET DRUG=$$PTR("DISPENSE DRUG")
- SET INSTR=$$PTR("INSTRUCTIONS")
- +7 SET DOSE=$$PTR("DOSE")
- SET RTE=$$PTR("ROUTE")
- +8 SET SCH=$$PTR("SCHEDULE")
- SET ADMIN=$$PTR("ADMIN TIMES")
- +9 SET OI=$$PTR("ORDERABLE ITEM")
- SET URG=$$PTR("URGENCY")
- +10 SET WP=$$PTR("WORD PROCESSING 1")
- SET DUR=$$PTR("DURATION")
- +11 ;*405-IND
- SET INDICATN=$$PTR("INDICATION")
- +12 SET STR=$$PTR("STRENGTH")
- SET DRGNM=$$PTR("DRUG NAME")
- UD1 ;*405-IND
- if RXO
- SET X=$PIECE(RXO,"|",2)
- SET ORDIALOG(OI,1)=$$ORDITEM^ORM(X)
- SET PSOI=$PIECE(X,U,4,5)
- SET ORDIALOG(INDICATN,1)=$$UNESC^ORMPS2($PIECE(RXO,"|",21))
- +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 SET ORDIALOG(DOSE,1)=$$UNESC^ORMPS2($SELECT($LENGTH(ID):$PIECE(ID,"&",1,4),1:"&&&")_"&"_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 PSDD=$PIECE($$FIND^ORM(+RXE,3),U,4,5)
- +5 IF $$ISSUPPLY^ORUTL3(+PSDD)
- Begin DoDot:1
- +6 SET ORDIALOG=+$ORDER(^ORD(101.41,"AB","PSO SUPPLY",0))
- +7 SET ORDG=+$ORDER(^ORD(100.98,"B","SUPPLIES/DEVICES",0))
- End DoDot:1
- +8 SET ORPKG=+$$PKG("PSO")
- +9 DO GETDLG1^ORCD(ORDIALOG)
- +10 SET OI=$$PTR("ORDERABLE ITEM")
- SET SIG=$$PTR("SIG")
- +11 SET INSTR=$$PTR("INSTRUCTIONS")
- SET DOSE=$$PTR("DOSE")
- +12 SET SCH=$$PTR("SCHEDULE")
- SET DUR=$$PTR("DURATION")
- +13 SET RTE=$$PTR("ROUTE")
- SET SC=$$PTR("SERVICE CONNECTED")
- +14 SET STR=$$PTR("STRENGTH")
- SET DRUG=$$PTR("DISPENSE DRUG")
- +15 SET PI=$$PTR("PATIENT INSTRUCTIONS")
- SET CONJ=$$PTR("AND/THEN")
- +16 SET PC=$$PTR("WORD PROCESSING 1")
- +17 ;*405-IND
- SET INDICATN=$$PTR("INDICATION")
- +18 ;*405-IND
- if RXO
- SET X=$PIECE(RXO,"|",2)
- SET ORDIALOG(OI,1)=$$ORDITEM^ORM(X)
- SET PSOI=$PIECE(X,U,4,5)
- SET ORDIALOG(INDICATN,1)=$$UNESC^ORMPS2($PIECE(RXO,"|",21))
- +19 IF '$GET(ORDIALOG(OI,1))
- SET ORERR="Missing or invalid orderable item"
- QUIT
- +20 SET ORDIALOG(DRUG,1)=+PSDD
- +21 SET S0=$$FIND^ORM(+RXE,26)_"&"_$PIECE($$FIND^ORM(+RXE,27),U,5)
- +22 IF S0
- IF $PIECE(PSOI,U,2)'[S0
- SET ORDIALOG(STR,1)=$TRANSLATE(S0,"&")
- +23 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 ; Populate DOSE response
- +8 SET X=$PIECE(ORQT(I),U)
- +9 ; If Dose component (X) of Quantity/Timing (RXE-1-1) is null, still populate DOSE response if Drug IEN (PSDD) is defined.
- +10 ; (For example, when local possible dosages were used, Pharmacy is not sending the Dose component).
- +11 IF X=""
- IF PSDD
- SET X="&&&"
- +12 if $LENGTH(X)
- SET ORDIALOG(DOSE,I)=$$UNESC^ORMPS2($PIECE(X,"&",1,4)_"&"_$PIECE(ORQT(I),U,8)_"&"_+PSDD_"&"_S0)
- +13 SET X=$PIECE(ORQT(I),U,2)
- if $LENGTH(X)
- SET ORDIALOG(SCH,I)=$$UNESC^ORMPS2(X)
- +14 SET X=$PIECE(ORQT(I),U,3)
- if $LENGTH(X)
- SET ORDIALOG(DUR,I)=$$DURATION^ORMPS3(X)
- +15 SET X=$PIECE(ORQT(I),U,9)
- if $LENGTH(X)
- SET ORDIALOG(CONJ,I)=$SELECT(X="S":"T",1:X)
- End DoDot:1
- +16 IF $$ASKTITR^ORCDPS3
- Begin DoDot:1
- +17 SET X=+$PIECE($GET(ZRX),"|",9)
- SET ORDIALOG($$PTR("TITRATION"),1)=X
- End DoDot:1
- +18 SET RXR=$$RXR^ORMPS
- IF RXR
- SET ORDIALOG(RTE,1)=$PIECE($PIECE(RXR,"|",2),U,4)
- Begin DoDot:1
- +19 ;look for multiple RXR's
- SET I=1
- SET J=+RXR
- +20 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,X3,I,J,TYPE,OI,WP,NTE,SCH
- +3 NEW DAYS,ROUTE,ADMIN,RXR,ADDFREQ
- +4 IF $GET(ORAPPT)>0
- SET ORDIALOG=+$ORDER(^ORD(101.41,"AB","CLINIC OR PAT FLUID OE",0))
- SET ORDG=+$ORDER(^ORD(100.98,"B","CLINIC INFUSIONS",0))
- +5 IF '$TEST
- SET ORDIALOG=+$ORDER(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0))
- SET ORDG=+$ORDER(^ORD(100.98,"B",$SELECT($PIECE(ZRX,"|",7)="TPN":"TPN",1:"IV RX"),0))
- +6 SET ORPKG=+$$PKG("PSJ")
- DO GETDLG1^ORCD(ORDIALOG)
- +7 SET SOLN=$$PTR("ORDERABLE ITEM")
- SET VOL=$$PTR("VOLUME")
- SET SCH=$$PTR("SCHEDULE")
- +8 SET RATE=$$PTR("INFUSION RATE")
- if ORURG
- SET ORDIALOG($$PTR("URGENCY"),1)=ORURG
- +9 SET WP=$$PTR("WORD PROCESSING 1")
- SET ADDS=$$PTR("ADDITIVE")
- +10 SET ADDFREQ=$$PTR("ADDITIVE FREQUENCY")
- +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")
- +13 ;*405-IND
- SET INDICATN=$$PTR("INDICATION")
- 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 ;*405-IND
- if $DATA(RXO)
- SET ORDAYS=$PIECE($PIECE(RXO,"|",2),"^",3)
- SET ORDIALOG(INDICATN,1)=$$UNESC^ORMPS2($PIECE(RXO,"|",21))
- +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)
- SET X3=$PIECE(X,"|",6)
- +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
- SET ORDIALOG(ADDFREQ,I)=$$ADDFRQCV^ORMBLDP1(X3,"I")
- 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