Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORWPS

ORWPS.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 6402, this routine should not be modified.
  1. COVER(LST,DFN,FILTER) ; retrieve meds for cover sheet
  1. S FILTER=$G(FILTER,0)
  1. K ^TMP("PS",$J)
  1. N DRG,ND2P5,RNWDT,SG D OCL^PSOORRL(DFN,"","") ; *498 new'd variables left over after call
  1. N ILST,ITMP,X,VAIN,VAERR S ILST=0
  1. D:FILTER INP^VADPT
  1. S ITMP="" F S ITMP=$O(^TMP("PS",$J,ITMP)) Q:'ITMP D
  1. . I FILTER,$G(VAIN(1))>0,$P(^TMP("PS",$J,ITMP,0),U)["N;O" Q
  1. . S X=^TMP("PS",$J,ITMP,0)
  1. . I '$L($P(X,U,2)) S X="??" ; show something if drug empty
  1. . I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S LST($$NXT)=$P(X,U,1,2)_U_$P(X,U,8,9)_U_"C"
  1. . E S LST($$NXT)=$P(X,U,1,2)_U_$P(X,U,8,9)
  1. K ^TMP("PS",$J)
  1. ; assumes 101.24/ORCV ACTIVE MEDICATIONS/INVERT="" via *498 post-install (OR498P)
  1. ; *498 sort order: clinic (A), in/out (B), non-va (C) - KLUNK
  1. 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)
  1. S ILST=0,X="" F S X=$O(TMP(X)) Q:X="" S LST($$NXT)=TMP(X) ; put TMP entries back in LST
  1. ; *498
  1. Q
  1. DT(X) ; -- Returns FM date for X
  1. N Y,%DT S %DT="T",Y="" D:X'="" ^%DT
  1. Q Y
  1. ;
  1. 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.
  1. ; ADDINFO Value Piece Data
  1. ; 1 or higher 20 Display Group IEN
  1. K ^TMP("PS",$J)
  1. K ^TMP("ORACT",$J)
  1. N BEG,DATE,END,ERROR,CTX,STVIEW,CTXOUT,CTXIN,BEGIN,ENDIN,BEGOUT,ENDOUT,DATEIN,DATEOUT,ORX
  1. S (BEG,END,CTX,CTXOUT,CTXIN,BEGIN,ENDIN,BEGOUT,ENDOUT)=""
  1. S VIEW=+$G(VIEW)
  1. S UPDATE=+$G(UPDATE)
  1. I VIEW=0,UPDATE=0 S VIEW=1
  1. S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS") ;CTX=Overall date range
  1. I CTX=";" D
  1. . D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS")
  1. . S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS")
  1. S CTXIN=$$GET^XPAR("ALL","ORCH CONTEXT MEDS INPAT") ;CTXIN=Inpatient date range
  1. I CTXIN=";" D
  1. . D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS INPAT")
  1. . S CTXIN=$$GET^XPAR("ALL","ORCH CONTEXT MEDS INPAT")
  1. S CTXOUT=$$GET^XPAR("ALL","ORCH CONTEXT MEDS OUTPAT NONVA") ;CTXOUT=Outpatient non-VA date range
  1. I CTXOUT=";" D
  1. . D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS OUTPAT NONVA")
  1. . S CTXOUT=$$GET^XPAR("ALL","ORCH CONTEXT MEDS OUTPAT NONVA")
  1. I '$L(CTXIN) S CTXIN=CTX
  1. I '$L(CTXOUT) S CTXOUT=CTX
  1. S BEG=$$DT($P(CTX,";"))
  1. S END=$$DT($P(CTX,";",2))
  1. S BEGIN=$$DT($P(CTXIN,";"))
  1. S ENDIN=$$DT($P(CTXIN,";",2))
  1. S BEGOUT=$$DT($P(CTXOUT,";"))
  1. S ENDOUT=$$DT($P(CTXOUT,";",2))
  1. I +$G(USER)=0 S USER=DUZ
  1. I UPDATE=1 D
  1. . S STVIEW=$$GET^XPAR($G(USER)_";VA(200,","OR MEDS TAB SORT",1,"I")
  1. . I VIEW>0,+STVIEW'=VIEW D PUT^XPAR(DUZ_";VA(200,","OR MEDS TAB SORT",,VIEW,.ERROR) S STVIEW=VIEW
  1. . I VIEW=0,+STVIEW=0 D PUT^XPAR(DUZ_";VA(200,","OR MEDS TAB SORT",,"1",.ERROR) S STVIEW=1,VIEW=1
  1. . I VIEW=0,+STVIEW'=VIEW S VIEW=+STVIEW
  1. . S LST(0)=STVIEW_U
  1. . S (DATE,DATEIN,DATEOUT)=""
  1. . I BEG>0,END>0 S DATE=$$FMTE^XLFDT(BEG,1)_" - "_$$FMTE^XLFDT(END,1)_" "
  1. . ;I BEGIN>0,ENDIN>0 S DATEIN=$$FMTE^XLFDT(BEGIN,1)_" - "_$$FMTE^XLFDT(ENDIN,1)_" "
  1. . ; If BEGIN is not defined, default to T; If ENDOUT is not defined, default to no end date.
  1. . S ORX=$S(BEGIN>0:BEGIN,1:$$DT("T"))
  1. . I ENDIN>0 S DATEIN=$$FMTE^XLFDT(ORX,1)_" - "_$$FMTE^XLFDT(ENDIN,1)_" "
  1. . I ENDIN'>0 S DATEIN=$$FMTE^XLFDT(ORX,1)_" and Later "
  1. . ;I BEGOUT>0,ENDOUT>0 S DATEOUT=$$FMTE^XLFDT(BEGOUT,1)_" - "_$$FMTE^XLFDT(ENDOUT,1)_" "
  1. . ; If BEGOUT is not defined, default to T-120; If ENDOUT is not defined, default to no end date.
  1. . S ORX=$S(BEGOUT>0:BEGOUT,1:$$DT("T-120"))
  1. . I ENDOUT>0 S DATEOUT=$$FMTE^XLFDT(ORX,1)_" - "_$$FMTE^XLFDT(ENDOUT,1)_" "
  1. . I ENDOUT'>0 S DATEOUT=$$FMTE^XLFDT(ORX,1)_" and Later "
  1. . S LST(0)=LST(0)_DATE_U_DATEIN_U_DATEOUT
  1. D OCL^PSOORRL(DFN,BEGOUT,ENDOUT,VIEW,BEGIN,ENDIN)
  1. N ITMP,FIELDS,INSTRUCT,COMMENTS,REASON,NVSDT,TYPE,ILST,J,ORIFN
  1. S ILST=0,ITMP=""
  1. F S ITMP=$O(^TMP("PS",$J,ITMP)) Q:'ITMP D
  1. . K INSTRUCT,COMMENTS,REASON
  1. . K ^TMP("ORACT",$J,"COMMENTS")
  1. . S COMMENTS="^TMP(""ORACT"",$J,""COMMENTS"")"
  1. . S (INSTRUCT,@COMMENTS)="",FIELDS=^TMP("PS",$J,ITMP,0),ORIFN=+$P(FIELDS,U,8)
  1. . I ORIFN,$D(^OR(100,ORIFN,8,"C","XX")) D
  1. .. S $P(^TMP("PS",$J,ITMP,0),"^",2)="*"_$P(^TMP("PS",$J,ITMP,0),"^",2)
  1. . S TYPE=$S($P($P(FIELDS,U),";",2)="O":"OP",1:"UD")
  1. . I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S TYPE="CP"
  1. . N LOC,LOCEX S (LOC,LOCEX)=""
  1. . I TYPE="CP" S LOC=$G(^TMP("PS",$J,ITMP,"CLINIC",0))
  1. . S:LOC LOCEX=$P($G(^SC(+LOC,0)),U)_":"_+LOC ;IMO NEW
  1. . I TYPE="OP",$P(FIELDS,";")["N" S TYPE="NV" ;non-VA med
  1. . I $O(^TMP("PS",$J,ITMP,"A",0))>0 S TYPE="IV"
  1. . I $O(^TMP("PS",$J,ITMP,"B",0))>0 S TYPE="IV"
  1. . I (TYPE="UD")!(TYPE="CP") D UDINST(.INSTRUCT,ITMP)
  1. . I TYPE="OP" D
  1. . . D OPINST(.INSTRUCT,ITMP)
  1. . . D TITR(.INSTRUCT,ORIFN)
  1. . I TYPE="IV" D IVINST(.INSTRUCT,ITMP)
  1. . I TYPE="NV" D NVINST(.INSTRUCT,ITMP),NVREASON(.REASON,.NVSDT,ITMP)
  1. . I (TYPE="UD")!(TYPE="IV")!(TYPE="NV")!(TYPE="CP") D SETMULT(COMMENTS,ITMP,"SIO")
  1. . M COMMENTS=@COMMENTS
  1. . I $D(COMMENTS(1)) S COMMENTS(1)="\"_COMMENTS(1)
  1. . S:TYPE="NV" $P(FIELDS,U,4)=$G(NVSDT)
  1. . I LOC S LST($$NXT)="~CP:"_LOCEX_U_FIELDS
  1. . E S LST($$NXT)="~"_TYPE_U_FIELDS
  1. . I +$G(ADDINFO)>0 D
  1. . . I ADDINFO'<1 S $P(LST(ILST),U,20)=$P($G(^OR(100,ORIFN,0)),U,11)
  1. . . ; I ADDINFO'<2 S $P(LST(ILST),U,21)=??? For future use...
  1. . S J=0 F S J=$O(INSTRUCT(J)) Q:'J S LST($$NXT)=INSTRUCT(J)
  1. . S J=0 F S J=$O(COMMENTS(J)) Q:'J S LST($$NXT)="t"_COMMENTS(J)
  1. . S J=0 F S J=$O(REASON(J)) Q:'J S LST($$NXT)="t"_REASON(J)
  1. . S:$D(^TMP("PS",$J,ITMP,"IND")) LST($$NXT)="\Indication: "_^TMP("PS",$J,ITMP,"IND",0) ;*405-IND
  1. K ^TMP("PS",$J)
  1. K ^TMP("ORACT",$J)
  1. Q
  1. NXT() ; increment ILST
  1. S ILST=ILST+1
  1. Q ILST
  1. ;
  1. UDINST(Y,INDEX) ; assembles instructions for a unit dose order
  1. N I,X,RST
  1. S X=^TMP("PS",$J,INDEX,0)
  1. S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
  1. S @RST@(1)=" "_$P(X,U,2),@RST=1
  1. S X=$S($L($P(X,U,6)):$P(X,U,6),1:$P(X,U,7))
  1. I $L(X) S @RST=2,@RST@(2)=X
  1. E S @RST=1 D SETMULT(.RST,INDEX,"SIG")
  1. S @RST@(2)="\Give: "_$G(@RST@(2)),@RST=$G(@RST,2)
  1. D SETMULT(RST,INDEX,"MDR"),SETMULT(RST,INDEX,"SCH")
  1. F I=3:1:@RST S @RST@(I)=" "_@RST@(I)
  1. M Y=@RST K @RST
  1. Q
  1. OPINST(Y,INDEX) ; assembles instructions for an outpatient prescription
  1. N I,X,RST
  1. S X=^TMP("PS",$J,INDEX,0)
  1. S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
  1. S @RST@(1)=" "_$P(X,U,2),@RST=1
  1. I $L($P(X,U,12)) S @RST@(1)=@RST@(1)_" Qty: "_$P(X,U,12)
  1. I $L($P(X,U,11)) S @RST@(1)=@RST@(1)_" for "_$P(X,U,11)_" days"
  1. D SETMULT(RST,INDEX,"SIG")
  1. I @RST=1 D
  1. . D SETMULT(RST,INDEX,"SIO")
  1. . D SETMULT(RST,INDEX,"MDR")
  1. . D SETMULT(RST,INDEX,"SCH")
  1. S @RST@(2)="\ Sig: "_$G(@RST@(2))
  1. F I=3:1:@RST S @RST@(I)=" "_@RST@(I)
  1. M Y=@RST K @RST
  1. Q
  1. IVINST(Y,INDEX) ; assembles instructions for an IV order
  1. N SOLN1,I,RST,IVDUR,CNT
  1. S IVDUR=""
  1. S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
  1. S @RST=0 D SETMULT(RST,INDEX,"A") S SOLN1=@RST+1
  1. D SETMULT(RST,INDEX,"B")
  1. I $D(@RST@(SOLN1)),$L($P(FIELDS,U,2)) S @RST@(SOLN1)="in "_@RST@(SOLN1)
  1. S SOLN1=@RST+1
  1. S CNT=@RST
  1. D SETMULT(RST,INDEX,"MDR")
  1. I $D(^TMP("PS",$J,INDEX,"SCH",1,0)) S @RST@(@RST)=@RST@(@RST)_" "_^TMP("PS",$J,INDEX,"SCH",1,0)
  1. F I=1:1:@RST S @RST@(I)="\"_$TR(@RST@(I),U," ")
  1. I $D(@RST@(1)) S @RST@(1)=" "_$E(@RST@(1),2,999)
  1. S @RST@(@RST)=@RST@(@RST)_" "_$P(^TMP("PS",$J,INDEX,0),U,3)
  1. S:$D(^TMP("PS",$J,INDEX,"IVLIM",0)) IVDUR=$G(^TMP("PS",$J,INDEX,"IVLIM",0))
  1. I $L(IVDUR) D
  1. . N DURU,DURV S DURU="",DURV=0
  1. . I IVDUR["dose" D Q
  1. ..S DURV=$P(IVDUR,"doses",2)
  1. ..S IVDUR="for a total of "_+DURV_$S(+DURV=1:"dose",+DURV>1:" doses",1:" dose")
  1. ..S @RST@(@RST)=@RST@(@RST)_" "_IVDUR
  1. . S DURU=$E(IVDUR,1),DURV=$E(IVDUR,2,$L(IVDUR))
  1. . I (DURU="D")!(DURU="d") S IVDUR="for "_+DURV_$S(+DURV=1:" day",+DURV>1:" days",1:" day")
  1. . I (DURU="H")!(DURU="h") S IVDUR="for "_+DURV_$S(+DURV=1:" hours",+DURV>1:" hours",1:" hour")
  1. . I (DURU="M")!(DURU="m") S IVDUR="with total volume "_+DURV_" ml"
  1. . I (DURU="L")!(DURU="l") S IVDUR="with total volume "_+DURV_" L"
  1. . S @RST@(@RST)=@RST@(@RST)_" "_IVDUR
  1. M Y=@RST K @RST
  1. Q
  1. NVINST(Y,INDEX) ; assembles instructions for a non-VA med
  1. N I,X,RST
  1. S X=^TMP("PS",$J,INDEX,0)
  1. S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
  1. S @RST@(1)=" "_$P(X,U,2),@RST=1
  1. D SETMULT(RST,INDEX,"SIG")
  1. I @RST=1 D
  1. . D SETMULT(RST,INDEX,"SIO")
  1. . D SETMULT(RST,INDEX,"MDR")
  1. . D SETMULT(RST,INDEX,"SCH")
  1. S @RST@(2)="\ "_$G(@RST@(2))
  1. F I=3:1:@RST S @RST@(I)=" "_@RST@(I)
  1. M Y=@RST K @RST
  1. Q
  1. NVREASON(ORR,NVSDT,INDEX) ; assembles start date and reasons for a non-VA med
  1. N ORI,J,X,ORN,ORA
  1. S ORI=0 K ORR
  1. S X=^TMP("PS",$J,INDEX,0)
  1. S ORN=+$P(X,U,8)
  1. I $D(^OR(100,ORN,0)) D
  1. .S NVSDT=$P(^OR(100,ORN,0),U,8)
  1. .D WPVAL^ORWDXR(.ORA,ORN,"STATEMENTS") I $D(ORA) D
  1. ..S J=0 F S J=$O(ORA(J)) Q:J<1 S ORI=ORI+1,ORR(ORI)=ORA(J)
  1. Q
  1. SETMULT(Y,INDEX,SUB) ; appends the multiple at the subscript to Y
  1. N I,X,J
  1. S J=$G(@Y)
  1. S I=0 F S I=$O(^TMP("PS",$J,INDEX,SUB,I)) Q:'I S X=$G(^(I,0)) D
  1. . I SUB="B",$L($P(X,U,3)) S X=$P(X,U)_" "_$P(X,U,3)_"^"_$P(X,U,2)
  1. . S J=J+1,@Y@(J)=X
  1. S @Y=J
  1. Q
  1. COMPRESS(Y) ; concatenate Y subscripts into smallest possible number
  1. N I,J,X S J=1,X(J)=""
  1. S I=0 F S I=$O(Y(I)) Q:'I D
  1. . I ($L(Y(I))+$L(X(J)))>245 S J=J+1,X(J)=""
  1. . S X(J)=X(J)_$S($L(X(J)):" ",1:"")_Y(I)
  1. K Y M Y=X
  1. Q
  1. DETAIL(ROOT,DFN,ID) ; -- show details for a med order
  1. K ^TMP("ORXPND",$J)
  1. N LCNT,ORVP
  1. S LCNT=0,ORVP=DFN_";DPT("
  1. D MEDS^ORCXPND1
  1. S ROOT=$NA(^TMP("ORXPND",$J))
  1. Q
  1. MEDHIST(ORROOT,DFN,ORIFN) ; -- show admin history for a med (RV)
  1. N ORPSID,HPIV,ISIV,CKPKG,ORPHMID
  1. N CLIVDISP
  1. S ORPSID=+$P($$OI^ORX8(ORIFN),U,3),ISIV=0,HPIV=0
  1. S ORROOT=$NA(^TMP("ORHIST",$J)) K @ORROOT
  1. S ORPHMID=$G(^OR(100,+ORIFN,4)) ;Pharmacy order number
  1. S ISIV=$O(^ORD(100.98,"B","IV RX",ISIV))
  1. S HPIV=$O(^ORD(100.98,"B","TPN",HPIV))
  1. S CLIVDISP=$O(^ORD(100.98,"B","CI RX",""))
  1. S CKPKG=$$PATCH^XPDUTL("PSB*2.0*19")
  1. ;if the order is pending or the order has no pharmacy #
  1. ;or the order is not in the Display Group IV MEDICATION
  1. ; then use the Orderable item number to get the MAH.
  1. I (ORPHMID["P")!(ORPHMID="") D Q
  1. . I '$L($T(HISTORY^PSBMLHS)) D Q
  1. .. S @ORROOT@(0)="This report is only available using BCMA version 2.0."
  1. . D HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID) ; DBIA #3459 for BCMA v2.0
  1. ; If the order has a Display Group of IV MEDICATION the use the Pharmacy order number to get the MA
  1. 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
  1. . I 'CKPKG S @ORROOT@(0)="Medication Administration History is not available at this time for IV fluids."
  1. . I CKPKG D
  1. .. D RPC^PSBO(.ORROOT,"PM",DFN,"","","","","","","","","",ORPHMID) ;DBIA #3955
  1. .. I '$D(@ORROOT) S @ORROOT@(0)="No Medication Administration History found for the IV order."
  1. I '$L($T(HISTORY^PSBMLHS)) D Q
  1. . S @ORROOT@(0)="This report is only available using BCMA version 2.0."
  1. D HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID) ; DBIA #3459 for BCMA v2.0
  1. Q
  1. ;
  1. REASON(ORY) ; -- Return Non-VA Med Statement/Reasons
  1. N ORE
  1. D GETLST^XPAR(.ORY,"ALL","ORWD NONVA REASON","E")
  1. Q
  1. ;
  1. TITR(INSTRUCT,ORIFN) ; p405 - Add titration info
  1. N ORI
  1. I $$ISTITR^ORUTL3(+ORIFN) D
  1. . S ORI=$O(INSTRUCT(""),-1)
  1. . S ORI=ORI+1
  1. . S INSTRUCT(ORI)="\ ** This Rx contains a separate titration and maintenance component to its schedule and instructions **"
  1. Q