ORWPS ; SLC/KCM/JLI/REV/CLA - Meds Tab; 02/11/2008
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,141,173,203,190,195,265,275,243**;Dec 17, 1997;Build 242
;;Per VHA Directive 2004-038, this routine should not be modified.
COVER(LST,DFN) ; retrieve meds for cover sheet
K ^TMP("PS",$J)
D OCL^PSOORRL(DFN,"","")
N ILST,ITMP,X S ILST=0
S ITMP="" F S ITMP=$O(^TMP("PS",$J,ITMP)) Q:'ITMP D
. 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)
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) ; retrieve active inpatient & outpatient meds
K ^TMP("PS",$J)
K ^TMP("ORACT",$J)
N BEG,END,ERROR,CTX,STVIEW
S (BEG,END,CTX)=""
S VIEW=+$G(VIEW)
S UPDATE=+$G(UPDATE)
I VIEW=0,UPDATE=0 S VIEW=1
S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS")
I CTX=";" D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS")
S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS")
S BEG=$$DT($P(CTX,";")),END=$$DT($P(CTX,";",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
D OCL^PSOORRL(DFN,BEG,END,VIEW)
N ITMP,FIELDS,INSTRUCT,COMMENTS,REASON,NVSDT,TYPE,ILST,J S ILST=0
S 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)
. I +$P(FIELDS,"^",8),$D(^OR(100,+$P(FIELDS,"^",8),8,"C","XX")) D
. . S $P(^TMP("PS",$J,ITMP,0),"^",2)="*"_$P(^TMP("PS",$J,ITMP,0),"^",2) ;dan testing
. 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 OPINST(.INSTRUCT,ITMP)
. 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
. 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)
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 CLINDISP,IVDIAL
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 CLINDISP=$O(^ORD(100.98,"B","C RX",""))
S IVDIAL=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE",""))
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)=CLINDISP)&(+$P($G(^OR(100,+ORIFN,0)),U,5)=IVDIAL)) 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
ORWPS ; SLC/KCM/JLI/REV/CLA - Meds Tab; 02/11/2008
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,141,173,203,190,195,265,275,243**;Dec 17, 1997;Build 242
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
COVER(LST,DFN) ; retrieve meds for cover sheet
+1 KILL ^TMP("PS",$JOB)
+2 DO OCL^PSOORRL(DFN,"","")
+3 NEW ILST,ITMP,X
SET ILST=0
+4 SET ITMP=""
FOR
SET ITMP=$ORDER(^TMP("PS",$JOB,ITMP))
IF 'ITMP
QUIT
Begin DoDot:1
+5 SET X=^TMP("PS",$JOB,ITMP,0)
+6 ; show something if drug empty
IF '$LENGTH($PIECE(X,U,2))
SET X="??"
+7 IF $DATA(^TMP("PS",$JOB,ITMP,"CLINIC",0))
SET LST($$NXT)=$P(X,U,1,2)_U_$PIECE(X,U,8,9)_U_"C"
+8 IF '$TEST
SET LST($$NXT)=$P(X,U,1,2)_U_$PIECE(X,U,8,9)
End DoDot:1
+9 KILL ^TMP("PS",$JOB)
+10 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) ; retrieve active inpatient & outpatient meds
+1 KILL ^TMP("PS",$JOB)
+2 KILL ^TMP("ORACT",$JOB)
+3 NEW BEG,END,ERROR,CTX,STVIEW
+4 SET (BEG,END,CTX)=""
+5 SET VIEW=+$GET(VIEW)
+6 SET UPDATE=+$GET(UPDATE)
+7 IF VIEW=0
IF UPDATE=0
SET VIEW=1
+8 SET CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS")
+9 IF CTX=";"
DO DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS")
+10 SET CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS")
+11 SET BEG=$$DT($PIECE(CTX,";"))
SET END=$$DT($PIECE(CTX,";",2))
+12 IF +$GET(USER)=0
SET USER=DUZ
+13 IF UPDATE=1
Begin DoDot:1
+14 SET STVIEW=$$GET^XPAR($GET(USER)_";VA(200,","OR MEDS TAB SORT",1,"I")
+15 IF VIEW>0
IF +STVIEW'=VIEW
DO PUT^XPAR(DUZ_";VA(200,","OR MEDS TAB SORT",,VIEW,.ERROR)
SET STVIEW=VIEW
+16 IF VIEW=0
IF +STVIEW=0
DO PUT^XPAR(DUZ_";VA(200,","OR MEDS TAB SORT",,"1",.ERROR)
SET STVIEW=1
SET VIEW=1
+17 IF VIEW=0
IF +STVIEW'=VIEW
SET VIEW=+STVIEW
+18 SET LST(0)=STVIEW
End DoDot:1
+19 DO OCL^PSOORRL(DFN,BEG,END,VIEW)
+20 NEW ITMP,FIELDS,INSTRUCT,COMMENTS,REASON,NVSDT,TYPE,ILST,J
SET ILST=0
+21 SET ITMP=""
FOR
SET ITMP=$ORDER(^TMP("PS",$JOB,ITMP))
IF 'ITMP
QUIT
Begin DoDot:1
+22 KILL INSTRUCT,COMMENTS,REASON
+23 KILL ^TMP("ORACT",$JOB,"COMMENTS")
+24 SET COMMENTS="^TMP(""ORACT"",$J,""COMMENTS"")"
+25 SET (INSTRUCT,@COMMENTS)=""
SET FIELDS=^TMP("PS",$JOB,ITMP,0)
+26 IF +$PIECE(FIELDS,"^",8)
IF $DATA(^OR(100,+$PIECE(FIELDS,"^",8),8,"C","XX"))
Begin DoDot:2
+27 ;dan testing
SET $PIECE(^TMP("PS",$JOB,ITMP,0),"^",2)="*"_$PIECE(^TMP("PS",$JOB,ITMP,0),"^",2)
End DoDot:2
+28 SET TYPE=$SELECT($PIECE($PIECE(FIELDS,U),";",2)="O":"OP",1:"UD")
+29 IF $DATA(^TMP("PS",$JOB,ITMP,"CLINIC",0))
SET TYPE="CP"
+30 NEW LOC,LOCEX
SET (LOC,LOCEX)=""
+31 IF TYPE="CP"
SET LOC=$GET(^TMP("PS",$JOB,ITMP,"CLINIC",0))
+32 ;IMO NEW
IF LOC
SET LOCEX=$PIECE($GET(^SC(+LOC,0)),U)_":"_+LOC
+33 ;non-VA med
IF TYPE="OP"
IF $PIECE(FIELDS,";")["N"
SET TYPE="NV"
+34 IF $ORDER(^TMP("PS",$JOB,ITMP,"A",0))>0
SET TYPE="IV"
+35 IF $ORDER(^TMP("PS",$JOB,ITMP,"B",0))>0
SET TYPE="IV"
+36 IF (TYPE="UD")!(TYPE="CP")
DO UDINST(.INSTRUCT,ITMP)
+37 IF TYPE="OP"
DO OPINST(.INSTRUCT,ITMP)
+38 IF TYPE="IV"
DO IVINST(.INSTRUCT,ITMP)
+39 IF TYPE="NV"
DO NVINST(.INSTRUCT,ITMP)
DO NVREASON(.REASON,.NVSDT,ITMP)
+40 IF (TYPE="UD")!(TYPE="IV")!(TYPE="NV")!(TYPE="CP")
DO SETMULT(COMMENTS,ITMP,"SIO")
+41 MERGE COMMENTS=@COMMENTS
+42 IF $DATA(COMMENTS(1))
SET COMMENTS(1)="\"_COMMENTS(1)
+43 IF TYPE="NV"
SET $PIECE(FIELDS,U,4)=$GET(NVSDT)
+44 IF LOC
SET LST($$NXT)="~CP:"_LOCEX_U_FIELDS
+45 IF '$TEST
SET LST($$NXT)="~"_TYPE_U_FIELDS
+46 SET J=0
FOR
SET J=$ORDER(INSTRUCT(J))
IF 'J
QUIT
SET LST($$NXT)=INSTRUCT(J)
+47 SET J=0
FOR
SET J=$ORDER(COMMENTS(J))
IF 'J
QUIT
SET LST($$NXT)="t"_COMMENTS(J)
+48 SET J=0
FOR
SET J=$ORDER(REASON(J))
IF 'J
QUIT
SET LST($$NXT)="t"_REASON(J)
End DoDot:1
+49 KILL ^TMP("PS",$JOB)
+50 KILL ^TMP("ORACT",$JOB)
+51 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 CLINDISP,IVDIAL
+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 CLINDISP=$ORDER(^ORD(100.98,"B","C RX",""))
+9 SET IVDIAL=$ORDER(^ORD(101.41,"B","PSJI OR PAT FLUID OE",""))
+10 SET CKPKG=$$PATCH^XPDUTL("PSB*2.0*19")
+11 ;if the order is pending or the order has no pharmacy #
+12 ;or the order is not in the Display Group IV MEDICATION
+13 ; then use the Orderable item number to get the MAH.
+14 IF (ORPHMID["P")!(ORPHMID="")
Begin DoDot:1
+15 IF '$LENGTH($TEXT(HISTORY^PSBMLHS))
Begin DoDot:2
+16 SET @ORROOT@(0)="This report is only available using BCMA version 2.0."
End DoDot:2
QUIT
+17 ; DBIA #3459 for BCMA v2.0
DO HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID)
End DoDot:1
QUIT
+18 ; If the order has a Display Group of IV MEDICATION the use the Pharmacy order number to get the MA
+19 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)=CLINDISP)&(+$PIECE($GET(^OR(100,+ORIFN,0)),U,5)=IVDIAL))
Begin DoDot:1
+20 IF 'CKPKG
SET @ORROOT@(0)="Medication Administration History is not available at this time for IV fluids."
+21 IF CKPKG
Begin DoDot:2
+22 ;DBIA #3955
DO RPC^PSBO(.ORROOT,"PM",DFN,"","","","","","","","","",ORPHMID)
+23 IF '$DATA(@ORROOT)
SET @ORROOT@(0)="No Medication Administration History found for the IV order."
End DoDot:2
End DoDot:1
QUIT
+24 IF '$LENGTH($TEXT(HISTORY^PSBMLHS))
Begin DoDot:1
+25 SET @ORROOT@(0)="This report is only available using BCMA version 2.0."
End DoDot:1
QUIT
+26 ; DBIA #3459 for BCMA v2.0
DO HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID)
+27 QUIT
+28 ;
REASON(ORY) ; -- Return Non-VA Med Statement/Reasons
+1 NEW ORE
+2 DO GETLST^XPAR(.ORY,"ALL","ORWD NONVA REASON","E")
+3 QUIT
