ORWPS ;SLC/KCM,JLI,REV,CLA - MEDS TAB ; May 15, 2023@16:02
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,141,173,203,190,195,265,275,243,280,350,498,405,588**;Dec 17, 1997;Build 29
;;Per VHA Directive 6402, this routine should not be modified.
COVER(LST,DFN,FILTER) ; retrieve meds for cover sheet
S FILTER=$G(FILTER,0)
K ^TMP("PS",$J)
N DRG,ND2P5,RNWDT,SG D OCL^PSOORRL(DFN,"","") ; *498 new'd variables left over after call
N ILST,ITMP,X,VAIN,VAERR S ILST=0
D:FILTER INP^VADPT
S ITMP="" F S ITMP=$O(^TMP("PS",$J,ITMP)) Q:'ITMP D
. I FILTER,$G(VAIN(1))>0,$P(^TMP("PS",$J,ITMP,0),U)["N;O" Q
. S X=^TMP("PS",$J,ITMP,0)
. I '$L($P(X,U,2)) S X="??" ; show something if drug empty
. I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S LST($$NXT)=$P(X,U,1,2)_U_$P(X,U,8,9)_U_"C"
. E S LST($$NXT)=$P(X,U,1,2)_U_$P(X,U,8,9)
K ^TMP("PS",$J)
; assumes 101.24/ORCV ACTIVE MEDICATIONS/INVERT="" via *498 post-install (OR498P)
; *498 sort order: clinic (A), in/out (B), non-va (C) - KLUNK
N TMP S X=0 F S X=$O(LST(X)) Q:'+X S TMP($S($P(LST(X),U,5)="C":"A"_X,$P(LST(X),U)["N;O":"C"_X,1:"B"_X))=LST(X) K LST(X)
S ILST=0,X="" F S X=$O(TMP(X)) Q:X="" S LST($$NXT)=TMP(X) ; put TMP entries back in LST
; *498
Q
DT(X) ; -- Returns FM date for X
N Y,%DT S %DT="T",Y="" D:X'="" ^%DT
Q Y
;
ACTIVE(LST,DFN,USER,VIEW,UPDATE,ADDINFO) ; retrieve active inpatient & outpatient meds
; ADDINFO adds additional pieces of data to the first line of each medication.
; ADDINFO Value Piece Data
; 1 or higher 20 Display Group IEN
K ^TMP("PS",$J)
K ^TMP("ORACT",$J)
N BEG,DATE,END,ERROR,CTX,STVIEW,CTXOUT,CTXIN,BEGIN,ENDIN,BEGOUT,ENDOUT,DATEIN,DATEOUT,ORX
S (BEG,END,CTX,CTXOUT,CTXIN,BEGIN,ENDIN,BEGOUT,ENDOUT)=""
S VIEW=+$G(VIEW)
S UPDATE=+$G(UPDATE)
I VIEW=0,UPDATE=0 S VIEW=1
S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS") ;CTX=Overall date range
I CTX=";" D
. D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS")
. S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS")
S CTXIN=$$GET^XPAR("ALL","ORCH CONTEXT MEDS INPAT") ;CTXIN=Inpatient date range
I CTXIN=";" D
. D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS INPAT")
. S CTXIN=$$GET^XPAR("ALL","ORCH CONTEXT MEDS INPAT")
S CTXOUT=$$GET^XPAR("ALL","ORCH CONTEXT MEDS OUTPAT NONVA") ;CTXOUT=Outpatient non-VA date range
I CTXOUT=";" D
. D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS OUTPAT NONVA")
. S CTXOUT=$$GET^XPAR("ALL","ORCH CONTEXT MEDS OUTPAT NONVA")
I '$L(CTXIN) S CTXIN=CTX
I '$L(CTXOUT) S CTXOUT=CTX
S BEG=$$DT($P(CTX,";"))
S END=$$DT($P(CTX,";",2))
S BEGIN=$$DT($P(CTXIN,";"))
S ENDIN=$$DT($P(CTXIN,";",2))
S BEGOUT=$$DT($P(CTXOUT,";"))
S ENDOUT=$$DT($P(CTXOUT,";",2))
I +$G(USER)=0 S USER=DUZ
I UPDATE=1 D
. S STVIEW=$$GET^XPAR($G(USER)_";VA(200,","OR MEDS TAB SORT",1,"I")
. I VIEW>0,+STVIEW'=VIEW D PUT^XPAR(DUZ_";VA(200,","OR MEDS TAB SORT",,VIEW,.ERROR) S STVIEW=VIEW
. I VIEW=0,+STVIEW=0 D PUT^XPAR(DUZ_";VA(200,","OR MEDS TAB SORT",,"1",.ERROR) S STVIEW=1,VIEW=1
. I VIEW=0,+STVIEW'=VIEW S VIEW=+STVIEW
. S LST(0)=STVIEW_U
. S (DATE,DATEIN,DATEOUT)=""
. I BEG>0,END>0 S DATE=$$FMTE^XLFDT(BEG,1)_" - "_$$FMTE^XLFDT(END,1)_" "
. ;I BEGIN>0,ENDIN>0 S DATEIN=$$FMTE^XLFDT(BEGIN,1)_" - "_$$FMTE^XLFDT(ENDIN,1)_" "
. ; If BEGIN is not defined, default to T; If ENDOUT is not defined, default to no end date.
. S ORX=$S(BEGIN>0:BEGIN,1:$$DT("T"))
. I ENDIN>0 S DATEIN=$$FMTE^XLFDT(ORX,1)_" - "_$$FMTE^XLFDT(ENDIN,1)_" "
. I ENDIN'>0 S DATEIN=$$FMTE^XLFDT(ORX,1)_" and Later "
. ;I BEGOUT>0,ENDOUT>0 S DATEOUT=$$FMTE^XLFDT(BEGOUT,1)_" - "_$$FMTE^XLFDT(ENDOUT,1)_" "
. ; If BEGOUT is not defined, default to T-120; If ENDOUT is not defined, default to no end date.
. S ORX=$S(BEGOUT>0:BEGOUT,1:$$DT("T-120"))
. I ENDOUT>0 S DATEOUT=$$FMTE^XLFDT(ORX,1)_" - "_$$FMTE^XLFDT(ENDOUT,1)_" "
. I ENDOUT'>0 S DATEOUT=$$FMTE^XLFDT(ORX,1)_" and Later "
. S LST(0)=LST(0)_DATE_U_DATEIN_U_DATEOUT
D OCL^PSOORRL(DFN,BEGOUT,ENDOUT,VIEW,BEGIN,ENDIN)
N ITMP,FIELDS,INSTRUCT,COMMENTS,REASON,NVSDT,TYPE,ILST,J,ORIFN
S ILST=0,ITMP=""
F S ITMP=$O(^TMP("PS",$J,ITMP)) Q:'ITMP D
. K INSTRUCT,COMMENTS,REASON
. K ^TMP("ORACT",$J,"COMMENTS")
. S COMMENTS="^TMP(""ORACT"",$J,""COMMENTS"")"
. S (INSTRUCT,@COMMENTS)="",FIELDS=^TMP("PS",$J,ITMP,0),ORIFN=+$P(FIELDS,U,8)
. I ORIFN,$D(^OR(100,ORIFN,8,"C","XX")) D
.. S $P(^TMP("PS",$J,ITMP,0),"^",2)="*"_$P(^TMP("PS",$J,ITMP,0),"^",2)
. S TYPE=$S($P($P(FIELDS,U),";",2)="O":"OP",1:"UD")
. I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S TYPE="CP"
. N LOC,LOCEX S (LOC,LOCEX)=""
. I TYPE="CP" S LOC=$G(^TMP("PS",$J,ITMP,"CLINIC",0))
. S:LOC LOCEX=$P($G(^SC(+LOC,0)),U)_":"_+LOC ;IMO NEW
. I TYPE="OP",$P(FIELDS,";")["N" S TYPE="NV" ;non-VA med
. I $O(^TMP("PS",$J,ITMP,"A",0))>0 S TYPE="IV"
. I $O(^TMP("PS",$J,ITMP,"B",0))>0 S TYPE="IV"
. I (TYPE="UD")!(TYPE="CP") D UDINST(.INSTRUCT,ITMP)
. I TYPE="OP" D
. . D OPINST(.INSTRUCT,ITMP)
. . D TITR(.INSTRUCT,ORIFN)
. I TYPE="IV" D IVINST(.INSTRUCT,ITMP)
. I TYPE="NV" D NVINST(.INSTRUCT,ITMP),NVREASON(.REASON,.NVSDT,ITMP)
. I (TYPE="UD")!(TYPE="IV")!(TYPE="NV")!(TYPE="CP") D SETMULT(COMMENTS,ITMP,"SIO")
. M COMMENTS=@COMMENTS
. I $D(COMMENTS(1)) S COMMENTS(1)="\"_COMMENTS(1)
. S:TYPE="NV" $P(FIELDS,U,4)=$G(NVSDT)
. I LOC S LST($$NXT)="~CP:"_LOCEX_U_FIELDS
. E S LST($$NXT)="~"_TYPE_U_FIELDS
. I +$G(ADDINFO)>0 D
. . I ADDINFO'<1 S $P(LST(ILST),U,20)=$P($G(^OR(100,ORIFN,0)),U,11)
. . ; I ADDINFO'<2 S $P(LST(ILST),U,21)=??? For future use...
. S J=0 F S J=$O(INSTRUCT(J)) Q:'J S LST($$NXT)=INSTRUCT(J)
. S J=0 F S J=$O(COMMENTS(J)) Q:'J S LST($$NXT)="t"_COMMENTS(J)
. S J=0 F S J=$O(REASON(J)) Q:'J S LST($$NXT)="t"_REASON(J)
. S:$D(^TMP("PS",$J,ITMP,"IND")) LST($$NXT)="\Indication: "_^TMP("PS",$J,ITMP,"IND",0) ;*405-IND
K ^TMP("PS",$J)
K ^TMP("ORACT",$J)
Q
NXT() ; increment ILST
S ILST=ILST+1
Q ILST
;
UDINST(Y,INDEX) ; assembles instructions for a unit dose order
N I,X,RST
S X=^TMP("PS",$J,INDEX,0)
S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
S @RST@(1)=" "_$P(X,U,2),@RST=1
S X=$S($L($P(X,U,6)):$P(X,U,6),1:$P(X,U,7))
I $L(X) S @RST=2,@RST@(2)=X
E S @RST=1 D SETMULT(.RST,INDEX,"SIG")
S @RST@(2)="\Give: "_$G(@RST@(2)),@RST=$G(@RST,2)
D SETMULT(RST,INDEX,"MDR"),SETMULT(RST,INDEX,"SCH")
F I=3:1:@RST S @RST@(I)=" "_@RST@(I)
M Y=@RST K @RST
Q
OPINST(Y,INDEX) ; assembles instructions for an outpatient prescription
N I,X,RST
S X=^TMP("PS",$J,INDEX,0)
S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
S @RST@(1)=" "_$P(X,U,2),@RST=1
I $L($P(X,U,12)) S @RST@(1)=@RST@(1)_" Qty: "_$P(X,U,12)
I $L($P(X,U,11)) S @RST@(1)=@RST@(1)_" for "_$P(X,U,11)_" days"
D SETMULT(RST,INDEX,"SIG")
I @RST=1 D
. D SETMULT(RST,INDEX,"SIO")
. D SETMULT(RST,INDEX,"MDR")
. D SETMULT(RST,INDEX,"SCH")
S @RST@(2)="\ Sig: "_$G(@RST@(2))
F I=3:1:@RST S @RST@(I)=" "_@RST@(I)
M Y=@RST K @RST
Q
IVINST(Y,INDEX) ; assembles instructions for an IV order
N SOLN1,I,RST,IVDUR,CNT
S IVDUR=""
S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
S @RST=0 D SETMULT(RST,INDEX,"A") S SOLN1=@RST+1
D SETMULT(RST,INDEX,"B")
I $D(@RST@(SOLN1)),$L($P(FIELDS,U,2)) S @RST@(SOLN1)="in "_@RST@(SOLN1)
S SOLN1=@RST+1
S CNT=@RST
D SETMULT(RST,INDEX,"MDR")
I $D(^TMP("PS",$J,INDEX,"SCH",1,0)) S @RST@(@RST)=@RST@(@RST)_" "_^TMP("PS",$J,INDEX,"SCH",1,0)
F I=1:1:@RST S @RST@(I)="\"_$TR(@RST@(I),U," ")
I $D(@RST@(1)) S @RST@(1)=" "_$E(@RST@(1),2,999)
S @RST@(@RST)=@RST@(@RST)_" "_$P(^TMP("PS",$J,INDEX,0),U,3)
S:$D(^TMP("PS",$J,INDEX,"IVLIM",0)) IVDUR=$G(^TMP("PS",$J,INDEX,"IVLIM",0))
I $L(IVDUR) D
. N DURU,DURV S DURU="",DURV=0
. I IVDUR["dose" D Q
..S DURV=$P(IVDUR,"doses",2)
..S IVDUR="for a total of "_+DURV_$S(+DURV=1:"dose",+DURV>1:" doses",1:" dose")
..S @RST@(@RST)=@RST@(@RST)_" "_IVDUR
. S DURU=$E(IVDUR,1),DURV=$E(IVDUR,2,$L(IVDUR))
. I (DURU="D")!(DURU="d") S IVDUR="for "_+DURV_$S(+DURV=1:" day",+DURV>1:" days",1:" day")
. I (DURU="H")!(DURU="h") S IVDUR="for "_+DURV_$S(+DURV=1:" hours",+DURV>1:" hours",1:" hour")
. I (DURU="M")!(DURU="m") S IVDUR="with total volume "_+DURV_" ml"
. I (DURU="L")!(DURU="l") S IVDUR="with total volume "_+DURV_" L"
. S @RST@(@RST)=@RST@(@RST)_" "_IVDUR
M Y=@RST K @RST
Q
NVINST(Y,INDEX) ; assembles instructions for a non-VA med
N I,X,RST
S X=^TMP("PS",$J,INDEX,0)
S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
S @RST@(1)=" "_$P(X,U,2),@RST=1
D SETMULT(RST,INDEX,"SIG")
I @RST=1 D
. D SETMULT(RST,INDEX,"SIO")
. D SETMULT(RST,INDEX,"MDR")
. D SETMULT(RST,INDEX,"SCH")
S @RST@(2)="\ "_$G(@RST@(2))
F I=3:1:@RST S @RST@(I)=" "_@RST@(I)
M Y=@RST K @RST
Q
NVREASON(ORR,NVSDT,INDEX) ; assembles start date and reasons for a non-VA med
N ORI,J,X,ORN,ORA
S ORI=0 K ORR
S X=^TMP("PS",$J,INDEX,0)
S ORN=+$P(X,U,8)
I $D(^OR(100,ORN,0)) D
.S NVSDT=$P(^OR(100,ORN,0),U,8)
.D WPVAL^ORWDXR(.ORA,ORN,"STATEMENTS") I $D(ORA) D
..S J=0 F S J=$O(ORA(J)) Q:J<1 S ORI=ORI+1,ORR(ORI)=ORA(J)
Q
SETMULT(Y,INDEX,SUB) ; appends the multiple at the subscript to Y
N I,X,J
S J=$G(@Y)
S I=0 F S I=$O(^TMP("PS",$J,INDEX,SUB,I)) Q:'I S X=$G(^(I,0)) D
. I SUB="B",$L($P(X,U,3)) S X=$P(X,U)_" "_$P(X,U,3)_"^"_$P(X,U,2)
. S J=J+1,@Y@(J)=X
S @Y=J
Q
COMPRESS(Y) ; concatenate Y subscripts into smallest possible number
N I,J,X S J=1,X(J)=""
S I=0 F S I=$O(Y(I)) Q:'I D
. I ($L(Y(I))+$L(X(J)))>245 S J=J+1,X(J)=""
. S X(J)=X(J)_$S($L(X(J)):" ",1:"")_Y(I)
K Y M Y=X
Q
DETAIL(ROOT,DFN,ID) ; -- show details for a med order
K ^TMP("ORXPND",$J)
N LCNT,ORVP
S LCNT=0,ORVP=DFN_";DPT("
D MEDS^ORCXPND1
S ROOT=$NA(^TMP("ORXPND",$J))
Q
MEDHIST(ORROOT,DFN,ORIFN) ; -- show admin history for a med (RV)
N ORPSID,HPIV,ISIV,CKPKG,ORPHMID
N CLIVDISP
S ORPSID=+$P($$OI^ORX8(ORIFN),U,3),ISIV=0,HPIV=0
S ORROOT=$NA(^TMP("ORHIST",$J)) K @ORROOT
S ORPHMID=$G(^OR(100,+ORIFN,4)) ;Pharmacy order number
S ISIV=$O(^ORD(100.98,"B","IV RX",ISIV))
S HPIV=$O(^ORD(100.98,"B","TPN",HPIV))
S CLIVDISP=$O(^ORD(100.98,"B","CI RX",""))
S CKPKG=$$PATCH^XPDUTL("PSB*2.0*19")
;if the order is pending or the order has no pharmacy #
;or the order is not in the Display Group IV MEDICATION
; then use the Orderable item number to get the MAH.
I (ORPHMID["P")!(ORPHMID="") D Q
. I '$L($T(HISTORY^PSBMLHS)) D Q
.. S @ORROOT@(0)="This report is only available using BCMA version 2.0."
. D HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID) ; DBIA #3459 for BCMA v2.0
; If the order has a Display Group of IV MEDICATION the use the Pharmacy order number to get the MA
I ($P($G(^OR(100,+ORIFN,0)),U,11)=ISIV)!($P($G(^OR(100,+ORIFN,0)),U,11)=HPIV)!($P($G(^OR(100,+ORIFN,0)),U,11)=CLIVDISP) D Q
. I 'CKPKG S @ORROOT@(0)="Medication Administration History is not available at this time for IV fluids."
. I CKPKG D
.. D RPC^PSBO(.ORROOT,"PM",DFN,"","","","","","","","","",ORPHMID) ;DBIA #3955
.. I '$D(@ORROOT) S @ORROOT@(0)="No Medication Administration History found for the IV order."
I '$L($T(HISTORY^PSBMLHS)) D Q
. S @ORROOT@(0)="This report is only available using BCMA version 2.0."
D HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID) ; DBIA #3459 for BCMA v2.0
Q
;
REASON(ORY) ; -- Return Non-VA Med Statement/Reasons
N ORE
D GETLST^XPAR(.ORY,"ALL","ORWD NONVA REASON","E")
Q
;
TITR(INSTRUCT,ORIFN) ; p405 - Add titration info
N ORI
I $$ISTITR^ORUTL3(+ORIFN) D
. S ORI=$O(INSTRUCT(""),-1)
. S ORI=ORI+1
. S INSTRUCT(ORI)="\ ** This Rx contains a separate titration and maintenance component to its schedule and instructions **"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWPS 11661 printed Dec 13, 2024@02:37:08 Page 2
ORWPS ;SLC/KCM,JLI,REV,CLA - MEDS TAB ; May 15, 2023@16:02
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,141,173,203,190,195,265,275,243,280,350,498,405,588**;Dec 17, 1997;Build 29
+2 ;;Per VHA Directive 6402, this routine should not be modified.
COVER(LST,DFN,FILTER) ; retrieve meds for cover sheet
+1 SET FILTER=$GET(FILTER,0)
+2 KILL ^TMP("PS",$JOB)
+3 ; *498 new'd variables left over after call
NEW DRG,ND2P5,RNWDT,SG
DO OCL^PSOORRL(DFN,"","")
+4 NEW ILST,ITMP,X,VAIN,VAERR
SET ILST=0
+5 if FILTER
DO INP^VADPT
+6 SET ITMP=""
FOR
SET ITMP=$ORDER(^TMP("PS",$JOB,ITMP))
if 'ITMP
QUIT
Begin DoDot:1
+7 IF FILTER
IF $GET(VAIN(1))>0
IF $PIECE(^TMP("PS",$JOB,ITMP,0),U)["N;O"
QUIT
+8 SET X=^TMP("PS",$JOB,ITMP,0)
+9 ; show something if drug empty
IF '$LENGTH($PIECE(X,U,2))
SET X="??"
+10 IF $DATA(^TMP("PS",$JOB,ITMP,"CLINIC",0))
SET LST($$NXT)=$P(X,U,1,2)_U_$PIECE(X,U,8,9)_U_"C"
+11 IF '$TEST
SET LST($$NXT)=$P(X,U,1,2)_U_$PIECE(X,U,8,9)
End DoDot:1
+12 KILL ^TMP("PS",$JOB)
+13 ; assumes 101.24/ORCV ACTIVE MEDICATIONS/INVERT="" via *498 post-install (OR498P)
+14 ; *498 sort order: clinic (A), in/out (B), non-va (C) - KLUNK
+15 NEW TMP
SET X=0
FOR
SET X=$ORDER(LST(X))
if '+X
QUIT
SET TMP($SELECT($PIECE(LST(X),U,5)="C":"A"_X,$PIECE(LST(X),U)["N;O":"C"_X,1:"B"_X))=LST(X)
KILL LST(X)
+16 ; put TMP entries back in LST
SET ILST=0
SET X=""
FOR
SET X=$ORDER(TMP(X))
if X=""
QUIT
SET LST($$NXT)=TMP(X)
+17 ; *498
+18 QUIT
DT(X) ; -- Returns FM date for X
+1 NEW Y,%DT
SET %DT="T"
SET Y=""
if X'=""
DO ^%DT
+2 QUIT Y
+3 ;
ACTIVE(LST,DFN,USER,VIEW,UPDATE,ADDINFO) ; retrieve active inpatient & outpatient meds
+1 ; ADDINFO adds additional pieces of data to the first line of each medication.
+2 ; ADDINFO Value Piece Data
+3 ; 1 or higher 20 Display Group IEN
+4 KILL ^TMP("PS",$JOB)
+5 KILL ^TMP("ORACT",$JOB)
+6 NEW BEG,DATE,END,ERROR,CTX,STVIEW,CTXOUT,CTXIN,BEGIN,ENDIN,BEGOUT,ENDOUT,DATEIN,DATEOUT,ORX
+7 SET (BEG,END,CTX,CTXOUT,CTXIN,BEGIN,ENDIN,BEGOUT,ENDOUT)=""
+8 SET VIEW=+$GET(VIEW)
+9 SET UPDATE=+$GET(UPDATE)
+10 IF VIEW=0
IF UPDATE=0
SET VIEW=1
+11 ;CTX=Overall date range
SET CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS")
+12 IF CTX=";"
Begin DoDot:1
+13 DO DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS")
+14 SET CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS")
End DoDot:1
+15 ;CTXIN=Inpatient date range
SET CTXIN=$$GET^XPAR("ALL","ORCH CONTEXT MEDS INPAT")
+16 IF CTXIN=";"
Begin DoDot:1
+17 DO DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS INPAT")
+18 SET CTXIN=$$GET^XPAR("ALL","ORCH CONTEXT MEDS INPAT")
End DoDot:1
+19 ;CTXOUT=Outpatient non-VA date range
SET CTXOUT=$$GET^XPAR("ALL","ORCH CONTEXT MEDS OUTPAT NONVA")
+20 IF CTXOUT=";"
Begin DoDot:1
+21 DO DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS OUTPAT NONVA")
+22 SET CTXOUT=$$GET^XPAR("ALL","ORCH CONTEXT MEDS OUTPAT NONVA")
End DoDot:1
+23 IF '$LENGTH(CTXIN)
SET CTXIN=CTX
+24 IF '$LENGTH(CTXOUT)
SET CTXOUT=CTX
+25 SET BEG=$$DT($PIECE(CTX,";"))
+26 SET END=$$DT($PIECE(CTX,";",2))
+27 SET BEGIN=$$DT($PIECE(CTXIN,";"))
+28 SET ENDIN=$$DT($PIECE(CTXIN,";",2))
+29 SET BEGOUT=$$DT($PIECE(CTXOUT,";"))
+30 SET ENDOUT=$$DT($PIECE(CTXOUT,";",2))
+31 IF +$GET(USER)=0
SET USER=DUZ
+32 IF UPDATE=1
Begin DoDot:1
+33 SET STVIEW=$$GET^XPAR($GET(USER)_";VA(200,","OR MEDS TAB SORT",1,"I")
+34 IF VIEW>0
IF +STVIEW'=VIEW
DO PUT^XPAR(DUZ_";VA(200,","OR MEDS TAB SORT",,VIEW,.ERROR)
SET STVIEW=VIEW
+35 IF VIEW=0
IF +STVIEW=0
DO PUT^XPAR(DUZ_";VA(200,","OR MEDS TAB SORT",,"1",.ERROR)
SET STVIEW=1
SET VIEW=1
+36 IF VIEW=0
IF +STVIEW'=VIEW
SET VIEW=+STVIEW
+37 SET LST(0)=STVIEW_U
+38 SET (DATE,DATEIN,DATEOUT)=""
+39 IF BEG>0
IF END>0
SET DATE=$$FMTE^XLFDT(BEG,1)_" - "_$$FMTE^XLFDT(END,1)_" "
+40 ;I BEGIN>0,ENDIN>0 S DATEIN=$$FMTE^XLFDT(BEGIN,1)_" - "_$$FMTE^XLFDT(ENDIN,1)_" "
+41 ; If BEGIN is not defined, default to T; If ENDOUT is not defined, default to no end date.
+42 SET ORX=$SELECT(BEGIN>0:BEGIN,1:$$DT("T"))
+43 IF ENDIN>0
SET DATEIN=$$FMTE^XLFDT(ORX,1)_" - "_$$FMTE^XLFDT(ENDIN,1)_" "
+44 IF ENDIN'>0
SET DATEIN=$$FMTE^XLFDT(ORX,1)_" and Later "
+45 ;I BEGOUT>0,ENDOUT>0 S DATEOUT=$$FMTE^XLFDT(BEGOUT,1)_" - "_$$FMTE^XLFDT(ENDOUT,1)_" "
+46 ; If BEGOUT is not defined, default to T-120; If ENDOUT is not defined, default to no end date.
+47 SET ORX=$SELECT(BEGOUT>0:BEGOUT,1:$$DT("T-120"))
+48 IF ENDOUT>0
SET DATEOUT=$$FMTE^XLFDT(ORX,1)_" - "_$$FMTE^XLFDT(ENDOUT,1)_" "
+49 IF ENDOUT'>0
SET DATEOUT=$$FMTE^XLFDT(ORX,1)_" and Later "
+50 SET LST(0)=LST(0)_DATE_U_DATEIN_U_DATEOUT
End DoDot:1
+51 DO OCL^PSOORRL(DFN,BEGOUT,ENDOUT,VIEW,BEGIN,ENDIN)
+52 NEW ITMP,FIELDS,INSTRUCT,COMMENTS,REASON,NVSDT,TYPE,ILST,J,ORIFN
+53 SET ILST=0
SET ITMP=""
+54 FOR
SET ITMP=$ORDER(^TMP("PS",$JOB,ITMP))
if 'ITMP
QUIT
Begin DoDot:1
+55 KILL INSTRUCT,COMMENTS,REASON
+56 KILL ^TMP("ORACT",$JOB,"COMMENTS")
+57 SET COMMENTS="^TMP(""ORACT"",$J,""COMMENTS"")"
+58 SET (INSTRUCT,@COMMENTS)=""
SET FIELDS=^TMP("PS",$JOB,ITMP,0)
SET ORIFN=+$PIECE(FIELDS,U,8)
+59 IF ORIFN
IF $DATA(^OR(100,ORIFN,8,"C","XX"))
Begin DoDot:2
+60 SET $PIECE(^TMP("PS",$JOB,ITMP,0),"^",2)="*"_$PIECE(^TMP("PS",$JOB,ITMP,0),"^",2)
End DoDot:2
+61 SET TYPE=$SELECT($PIECE($PIECE(FIELDS,U),";",2)="O":"OP",1:"UD")
+62 IF $DATA(^TMP("PS",$JOB,ITMP,"CLINIC",0))
SET TYPE="CP"
+63 NEW LOC,LOCEX
SET (LOC,LOCEX)=""
+64 IF TYPE="CP"
SET LOC=$GET(^TMP("PS",$JOB,ITMP,"CLINIC",0))
+65 ;IMO NEW
if LOC
SET LOCEX=$PIECE($GET(^SC(+LOC,0)),U)_":"_+LOC
+66 ;non-VA med
IF TYPE="OP"
IF $PIECE(FIELDS,";")["N"
SET TYPE="NV"
+67 IF $ORDER(^TMP("PS",$JOB,ITMP,"A",0))>0
SET TYPE="IV"
+68 IF $ORDER(^TMP("PS",$JOB,ITMP,"B",0))>0
SET TYPE="IV"
+69 IF (TYPE="UD")!(TYPE="CP")
DO UDINST(.INSTRUCT,ITMP)
+70 IF TYPE="OP"
Begin DoDot:2
+71 DO OPINST(.INSTRUCT,ITMP)
+72 DO TITR(.INSTRUCT,ORIFN)
End DoDot:2
+73 IF TYPE="IV"
DO IVINST(.INSTRUCT,ITMP)
+74 IF TYPE="NV"
DO NVINST(.INSTRUCT,ITMP)
DO NVREASON(.REASON,.NVSDT,ITMP)
+75 IF (TYPE="UD")!(TYPE="IV")!(TYPE="NV")!(TYPE="CP")
DO SETMULT(COMMENTS,ITMP,"SIO")
+76 MERGE COMMENTS=@COMMENTS
+77 IF $DATA(COMMENTS(1))
SET COMMENTS(1)="\"_COMMENTS(1)
+78 if TYPE="NV"
SET $PIECE(FIELDS,U,4)=$GET(NVSDT)
+79 IF LOC
SET LST($$NXT)="~CP:"_LOCEX_U_FIELDS
+80 IF '$TEST
SET LST($$NXT)="~"_TYPE_U_FIELDS
+81 IF +$GET(ADDINFO)>0
Begin DoDot:2
+82 IF ADDINFO'<1
SET $PIECE(LST(ILST),U,20)=$PIECE($GET(^OR(100,ORIFN,0)),U,11)
+83 ; I ADDINFO'<2 S $P(LST(ILST),U,21)=??? For future use...
End DoDot:2
+84 SET J=0
FOR
SET J=$ORDER(INSTRUCT(J))
if 'J
QUIT
SET LST($$NXT)=INSTRUCT(J)
+85 SET J=0
FOR
SET J=$ORDER(COMMENTS(J))
if 'J
QUIT
SET LST($$NXT)="t"_COMMENTS(J)
+86 SET J=0
FOR
SET J=$ORDER(REASON(J))
if 'J
QUIT
SET LST($$NXT)="t"_REASON(J)
+87 ;*405-IND
if $DATA(^TMP("PS",$JOB,ITMP,"IND"))
SET LST($$NXT)="\Indication: "_^TMP("PS",$JOB,ITMP,"IND",0)
End DoDot:1
+88 KILL ^TMP("PS",$JOB)
+89 KILL ^TMP("ORACT",$JOB)
+90 QUIT
NXT() ; increment ILST
+1 SET ILST=ILST+1
+2 QUIT ILST
+3 ;
UDINST(Y,INDEX) ; assembles instructions for a unit dose order
+1 NEW I,X,RST
+2 SET X=^TMP("PS",$JOB,INDEX,0)
+3 SET RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
+4 SET @RST@(1)=" "_$PIECE(X,U,2)
SET @RST=1
+5 SET X=$SELECT($LENGTH($PIECE(X,U,6)):$PIECE(X,U,6),1:$PIECE(X,U,7))
+6 IF $LENGTH(X)
SET @RST=2
SET @RST@(2)=X
+7 IF '$TEST
SET @RST=1
DO SETMULT(.RST,INDEX,"SIG")
+8 SET @RST@(2)="\Give: "_$GET(@RST@(2))
SET @RST=$GET(@RST,2)
+9 DO SETMULT(RST,INDEX,"MDR")
DO SETMULT(RST,INDEX,"SCH")
+10 FOR I=3:1:@RST
SET @RST@(I)=" "_@RST@(I)
+11 MERGE Y=@RST
KILL @RST
+12 QUIT
OPINST(Y,INDEX) ; assembles instructions for an outpatient prescription
+1 NEW I,X,RST
+2 SET X=^TMP("PS",$JOB,INDEX,0)
+3 SET RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
+4 SET @RST@(1)=" "_$PIECE(X,U,2)
SET @RST=1
+5 IF $LENGTH($PIECE(X,U,12))
SET @RST@(1)=@RST@(1)_" Qty: "_$PIECE(X,U,12)
+6 IF $LENGTH($PIECE(X,U,11))
SET @RST@(1)=@RST@(1)_" for "_$PIECE(X,U,11)_" days"
+7 DO SETMULT(RST,INDEX,"SIG")
+8 IF @RST=1
Begin DoDot:1
+9 DO SETMULT(RST,INDEX,"SIO")
+10 DO SETMULT(RST,INDEX,"MDR")
+11 DO SETMULT(RST,INDEX,"SCH")
End DoDot:1
+12 SET @RST@(2)="\ Sig: "_$GET(@RST@(2))
+13 FOR I=3:1:@RST
SET @RST@(I)=" "_@RST@(I)
+14 MERGE Y=@RST
KILL @RST
+15 QUIT
IVINST(Y,INDEX) ; assembles instructions for an IV order
+1 NEW SOLN1,I,RST,IVDUR,CNT
+2 SET IVDUR=""
+3 SET RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
+4 SET @RST=0
DO SETMULT(RST,INDEX,"A")
SET SOLN1=@RST+1
+5 DO SETMULT(RST,INDEX,"B")
+6 IF $DATA(@RST@(SOLN1))
IF $LENGTH($PIECE(FIELDS,U,2))
SET @RST@(SOLN1)="in "_@RST@(SOLN1)
+7 SET SOLN1=@RST+1
+8 SET CNT=@RST
+9 DO SETMULT(RST,INDEX,"MDR")
+10 IF $DATA(^TMP("PS",$JOB,INDEX,"SCH",1,0))
SET @RST@(@RST)=@RST@(@RST)_" "_^TMP("PS",$JOB,INDEX,"SCH",1,0)
+11 FOR I=1:1:@RST
SET @RST@(I)="\"_$TRANSLATE(@RST@(I),U," ")
+12 IF $DATA(@RST@(1))
SET @RST@(1)=" "_$EXTRACT(@RST@(1),2,999)
+13 SET @RST@(@RST)=@RST@(@RST)_" "_$PIECE(^TMP("PS",$JOB,INDEX,0),U,3)
+14 if $DATA(^TMP("PS",$JOB,INDEX,"IVLIM",0))
SET IVDUR=$GET(^TMP("PS",$JOB,INDEX,"IVLIM",0))
+15 IF $LENGTH(IVDUR)
Begin DoDot:1
+16 NEW DURU,DURV
SET DURU=""
SET DURV=0
+17 IF IVDUR["dose"
Begin DoDot:2
+18 SET DURV=$PIECE(IVDUR,"doses",2)
+19 SET IVDUR="for a total of "_+DURV_$SELECT(+DURV=1:"dose",+DURV>1:" doses",1:" dose")
+20 SET @RST@(@RST)=@RST@(@RST)_" "_IVDUR
End DoDot:2
QUIT
+21 SET DURU=$EXTRACT(IVDUR,1)
SET DURV=$EXTRACT(IVDUR,2,$LENGTH(IVDUR))
+22 IF (DURU="D")!(DURU="d")
SET IVDUR="for "_+DURV_$SELECT(+DURV=1:" day",+DURV>1:" days",1:" day")
+23 IF (DURU="H")!(DURU="h")
SET IVDUR="for "_+DURV_$SELECT(+DURV=1:" hours",+DURV>1:" hours",1:" hour")
+24 IF (DURU="M")!(DURU="m")
SET IVDUR="with total volume "_+DURV_" ml"
+25 IF (DURU="L")!(DURU="l")
SET IVDUR="with total volume "_+DURV_" L"
+26 SET @RST@(@RST)=@RST@(@RST)_" "_IVDUR
End DoDot:1
+27 MERGE Y=@RST
KILL @RST
+28 QUIT
NVINST(Y,INDEX) ; assembles instructions for a non-VA med
+1 NEW I,X,RST
+2 SET X=^TMP("PS",$JOB,INDEX,0)
+3 SET RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
+4 SET @RST@(1)=" "_$PIECE(X,U,2)
SET @RST=1
+5 DO SETMULT(RST,INDEX,"SIG")
+6 IF @RST=1
Begin DoDot:1
+7 DO SETMULT(RST,INDEX,"SIO")
+8 DO SETMULT(RST,INDEX,"MDR")
+9 DO SETMULT(RST,INDEX,"SCH")
End DoDot:1
+10 SET @RST@(2)="\ "_$GET(@RST@(2))
+11 FOR I=3:1:@RST
SET @RST@(I)=" "_@RST@(I)
+12 MERGE Y=@RST
KILL @RST
+13 QUIT
NVREASON(ORR,NVSDT,INDEX) ; assembles start date and reasons for a non-VA med
+1 NEW ORI,J,X,ORN,ORA
+2 SET ORI=0
KILL ORR
+3 SET X=^TMP("PS",$JOB,INDEX,0)
+4 SET ORN=+$PIECE(X,U,8)
+5 IF $DATA(^OR(100,ORN,0))
Begin DoDot:1
+6 SET NVSDT=$PIECE(^OR(100,ORN,0),U,8)
+7 DO WPVAL^ORWDXR(.ORA,ORN,"STATEMENTS")
IF $DATA(ORA)
Begin DoDot:2
+8 SET J=0
FOR
SET J=$ORDER(ORA(J))
if J<1
QUIT
SET ORI=ORI+1
SET ORR(ORI)=ORA(J)
End DoDot:2
End DoDot:1
+9 QUIT
SETMULT(Y,INDEX,SUB) ; appends the multiple at the subscript to Y
+1 NEW I,X,J
+2 SET J=$GET(@Y)
+3 SET I=0
FOR
SET I=$ORDER(^TMP("PS",$JOB,INDEX,SUB,I))
if 'I
QUIT
SET X=$GET(^(I,0))
Begin DoDot:1
+4 IF SUB="B"
IF $LENGTH($PIECE(X,U,3))
SET X=$PIECE(X,U)_" "_$PIECE(X,U,3)_"^"_$PIECE(X,U,2)
+5 SET J=J+1
SET @Y@(J)=X
End DoDot:1
+6 SET @Y=J
+7 QUIT
COMPRESS(Y) ; concatenate Y subscripts into smallest possible number
+1 NEW I,J,X
SET J=1
SET X(J)=""
+2 SET I=0
FOR
SET I=$ORDER(Y(I))
if 'I
QUIT
Begin DoDot:1
+3 IF ($LENGTH(Y(I))+$LENGTH(X(J)))>245
SET J=J+1
SET X(J)=""
+4 SET X(J)=X(J)_$SELECT($LENGTH(X(J)):" ",1:"")_Y(I)
End DoDot:1
+5 KILL Y
MERGE Y=X
+6 QUIT
DETAIL(ROOT,DFN,ID) ; -- show details for a med order
+1 KILL ^TMP("ORXPND",$JOB)
+2 NEW LCNT,ORVP
+3 SET LCNT=0
SET ORVP=DFN_";DPT("
+4 DO MEDS^ORCXPND1
+5 SET ROOT=$NAME(^TMP("ORXPND",$JOB))
+6 QUIT
MEDHIST(ORROOT,DFN,ORIFN) ; -- show admin history for a med (RV)
+1 NEW ORPSID,HPIV,ISIV,CKPKG,ORPHMID
+2 NEW CLIVDISP
+3 SET ORPSID=+$PIECE($$OI^ORX8(ORIFN),U,3)
SET ISIV=0
SET HPIV=0
+4 SET ORROOT=$NAME(^TMP("ORHIST",$JOB))
KILL @ORROOT
+5 ;Pharmacy order number
SET ORPHMID=$GET(^OR(100,+ORIFN,4))
+6 SET ISIV=$ORDER(^ORD(100.98,"B","IV RX",ISIV))
+7 SET HPIV=$ORDER(^ORD(100.98,"B","TPN",HPIV))
+8 SET CLIVDISP=$ORDER(^ORD(100.98,"B","CI RX",""))
+9 SET CKPKG=$$PATCH^XPDUTL("PSB*2.0*19")
+10 ;if the order is pending or the order has no pharmacy #
+11 ;or the order is not in the Display Group IV MEDICATION
+12 ; then use the Orderable item number to get the MAH.
+13 IF (ORPHMID["P")!(ORPHMID="")
Begin DoDot:1
+14 IF '$LENGTH($TEXT(HISTORY^PSBMLHS))
Begin DoDot:2
+15 SET @ORROOT@(0)="This report is only available using BCMA version 2.0."
End DoDot:2
QUIT
+16 ; DBIA #3459 for BCMA v2.0
DO HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID)
End DoDot:1
QUIT
+17 ; If the order has a Display Group of IV MEDICATION the use the Pharmacy order number to get the MA
+18 IF ($PIECE($GET(^OR(100,+ORIFN,0)),U,11)=ISIV)!($PIECE($GET(^OR(100,+ORIFN,0)),U,11)=HPIV)!($PIECE($GET(^OR(100,+ORIFN,0)),U,11)=CLIVDISP)
Begin DoDot:1
+19 IF 'CKPKG
SET @ORROOT@(0)="Medication Administration History is not available at this time for IV fluids."
+20 IF CKPKG
Begin DoDot:2
+21 ;DBIA #3955
DO RPC^PSBO(.ORROOT,"PM",DFN,"","","","","","","","","",ORPHMID)
+22 IF '$DATA(@ORROOT)
SET @ORROOT@(0)="No Medication Administration History found for the IV order."
End DoDot:2
End DoDot:1
QUIT
+23 IF '$LENGTH($TEXT(HISTORY^PSBMLHS))
Begin DoDot:1
+24 SET @ORROOT@(0)="This report is only available using BCMA version 2.0."
End DoDot:1
QUIT
+25 ; DBIA #3459 for BCMA v2.0
DO HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID)
+26 QUIT
+27 ;
REASON(ORY) ; -- Return Non-VA Med Statement/Reasons
+1 NEW ORE
+2 DO GETLST^XPAR(.ORY,"ALL","ORWD NONVA REASON","E")
+3 QUIT
+4 ;
TITR(INSTRUCT,ORIFN) ; p405 - Add titration info
+1 NEW ORI
+2 IF $$ISTITR^ORUTL3(+ORIFN)
Begin DoDot:1
+3 SET ORI=$ORDER(INSTRUCT(""),-1)
+4 SET ORI=ORI+1
+5 SET INSTRUCT(ORI)="\ ** This Rx contains a separate titration and maintenance component to its schedule and instructions **"
End DoDot:1
+6 QUIT
