- 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 Jan 18, 2025@03:38:17 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