BTIUMED3 ; SLC/JM - Active/Recent Med Objects Routine ;30-Jul-2010 09:07;MGH
;;1.0;TEXT INTEGRATION UTILITIES;**1006**;Jun 20, 1997
;Object for last class medications
Q
LIST(DFN,BTIUMED,TARGET,CNT) ; EP
;
;
;
;Required Parameters:
;
; DFN Patient identifier
; BTIUMED The drug class to search
;
; TARGET Where the medication data will be stored
; CNT The number to return
;
;
N NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,OK,RXNO,CHRONIC,LDATE,CANDATE,EXDATE,DETAILED
N INPTYPE,OUTPTYPE,TYPE,MEDTYPE,DATA,DATA1,MED,IDATE,XSTR,LLEN,DAYS,ACTVONLY,ONELIST,REASON,REFILLS
N LASTMEDT,LASTSTS,COUNT,TOTAL,SPACE60,DASH73,TEMP,LINE,TAB,HEADER,CLASSORT,COUNTER,EVENT,HIEN,IEN
N DRUGCLAS,DRUGIDX,LASTCLAS,OLDTAB,OLDHEADR,UNKNOWNS,INDIC,LSTINDIC,IDX,ID,CLININC
N %,%H,STOP,LSTFD,ARRAY ;Clean up after external calls...
S (NEXTLINE,TAB,HEADER,UNKNOWNS,CLININC)=0,LLEN=47
K @TARGET,^TMP("PS",$J),ARRAY
S ISINP=($G(^DPT(DFN,.1))'="") ; Is this an inpatient?
I ISINP S INPTYPE=1,OUTPTYPE=2
E S INPTYPE=2,OUTPTYPE=1
;
; *** Scan medication data and skip unwanted meds ***
;
S DAYS=180,ACTVONLY=0,ONELIST=0,DETAILED=1
I '$D(CNT)=CNT=1
D OCL^PSOORRL(DFN,$$FMADD^XLFDT(DT,-DAYS),"")
S INDEX=0
F S INDEX=$O(^TMP("PS",$J,INDEX)) Q:INDEX'>0 D
.S NODE=$G(^TMP("PS",$J,INDEX,0))
.S CHRONIC=""
.S STATUS=$P(NODE,U,9)
.S IDATE=$P(NODE,U,15)
.S KEEPMED=($L($P(NODE,U,2))>0) ;Discard Blank Meds
.I $P($P(NODE,U),";",2)["O" D
..S RXNO=+($P(NODE,U,1))
..S CHRONIC=$P($G(^PSRX(RXNO,9999999)),U,2)
..I STATUS="EXPIRED" D
...N X1,X2,X
...I CHRONIC S X1=DT,X2=-120 D C^%DTC S LDATE=X
...E S X1=DT,X2=-14 D C^%DTC S LDATE=X
...S EXDATE=$P($G(^PSRX(RXNO,2)),U,6)
...I EXDATE>LDATE S KEEPMED=1
..I STATUS="DISCONTINUED" D
...S X1=DT,X2=-30 D C^%DTC S LDATE=X
...S CANDATE=$P($G(^PSRX(RXNO,3)),U,5)
...I CANDATE>LDATE S KEEPMED=1
.I STATUS="PENDING" D
..S IEN=+($P(NODE,U))
..I IEN>0 S REFILLS=$P($G(^PS(52.41,IEN,0)),U,11)
..S $P(^TMP("PS",$J,INDEX,0),U,5)=REFILLS
.S TYPE=$P($P(NODE,U),";",2)
.S TYPE=$S(TYPE="O":"OP",TYPE="I":"UD",1:"")
.S KEEPMED=(TYPE'="")
.I KEEPMED D
..I $O(^TMP("PS",$J,INDEX,"A",0))>0 S TYPE="IV"
..E I $O(^TMP("PS",$J,INDEX,"B",0))>0 S TYPE="IV"
..I TYPE="OP" S MEDTYPE=OUTPTYPE
..E S MEDTYPE=INPTYPE
..I MEDTYPE=INPTYPE S KEEPMED=ISINP
..E S KEEPMED='ISINP
.S DRUGCLAS=" "
.S MED=$P(NODE,U,2)
.I KEEPMED D
..S DRUGIDX=$O(^PSDRUG("B",MED,0))
..D GETCLASS(BTIUMED)
..I BTIUMED'=DRUGCLAS S KEEPMED=0
..I KEEPMED D
...N ORDIDX,TMPCLASS,CDONE,SDONE,TMPIDX,TMPNODE,ISSUPPLY
...S ID=$P(NODE,U)
...S IDX=+ID,ID=$E(ID,$L(IDX)+1,$L(ID))
...S (DRUGIDX,ORDIDX)=0
...I ID="R;O" S DRUGIDX=+$P($G(^PSRX(IDX,0)),U,6)
...I ID="P;O" S DRUGIDX=+$P($G(^PS(52.41,IDX,0)),U,9)
...I ID="P;I" D
....I $P($G(^PS(53.1,IDX,1,0)),U,4)=1 D
.....S TMPIDX=$O(^PS(53.1,IDX,1,0)) I +TMPIDX S DRUGIDX=$P($G(^PS(53.1,IDX,1,TMPIDX,0)),U)
...I ID="U;I" D
....I $P($G(^PS(55,DFN,5,IDX,1,0)),U,4)=1 D
.....S TMPIDX=$O(^PS(55,DFN,5,IDX,1,0)) I +TMPIDX S DRUGIDX=$P($G(^PS(55,DFN,5,IDX,1,TMPIDX,0)),U)
...I ID="V;I" D
....I $P($G(^PS(55,DFN,"IV",IDX,"AD",0)),U,4)=1 D
.....S TMPIDX=$O(^PS(55,DFN,"IV",IDX,"AD",0)) I +TMPIDX D
......S TMPIDX=$P($G(^PS(55,DFN,"IV",IDX,"AD",TMPIDX,0)),U)
......I +TMPIDX S DRUGIDX=$P($G(^PS(52.6,TMPIDX,0)),U,2)
.; *** Save wanted meds in "B" temp xref, removing duplicates ***
.;
.I KEEPMED D
..S EVENT=$P(NODE,U,15)
..I EVENT="" S EVENT=$$NOW^XLFDT
..S IDATE=9999999-EVENT
..S ARRAY(IDATE,INDEX)=DRUGIDX_"^"_IDX_"^"_ID_"^"_EVENT_"^"_STATUS
;
; *** Check for empty condition ***
;
;after you get all the drugs into the array take number requested
S $P(SPACE60," ",60)=" ",$P(DASH73,"=",73)="="
S COUNTER=0,LINE=0
S TEMP="Last "_CNT_" drugs from class "_BTIUMED
D ADD^BTIUMED1(TEMP)
N I
S I="" F S I=$O(ARRAY(I)) Q:I=""!(COUNTER>=CNT) D
.S INDEX="" F S INDEX=$O(ARRAY(I,INDEX)) Q:INDEX="" D
..S COUNTER=COUNTER+1
..S NODE=^TMP("PS",$J,INDEX,0)
..S DATA=$G(ARRAY(I,INDEX))
..S STATUS=$P(DATA,U,5)
..I STATUS="HOLD" D
...S HIEN=+($P(NODE,U))
...S REASON=$$GET1^DIQ(52,HIEN,99,"E")
...S NODE=NODE_U_REASON
..D ADDMED^BTIUMED1(0)
I COUNTER=0 S LINE=LINE+1 S @TARGET@(LINE,0)="No Meds for this class found"
Q "~@"_$NA(@TARGET)
;
LISTX K ^TMP("PS",$J)
Q "~@"_$NA(@TARGET)
;
GETCLASS(BTIUMED) ; Get Drug Class, filter out supplies
I +DRUGIDX D
.N TEMPNODE
.S TEMPNODE=$G(^PSDRUG(DRUGIDX,0))
.S DRUGCLAS=$P(TEMPNODE,U,2)
Q
BTIUMED3 ; SLC/JM - Active/Recent Med Objects Routine ;30-Jul-2010 09:07;MGH
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1006**;Jun 20, 1997
+2 ;Object for last class medications
+3 QUIT
LIST(DFN,BTIUMED,TARGET,CNT) ; EP
+1 ;
+2 ;
+3 ;
+4 ;Required Parameters:
+5 ;
+6 ; DFN Patient identifier
+7 ; BTIUMED The drug class to search
+8 ;
+9 ; TARGET Where the medication data will be stored
+10 ; CNT The number to return
+11 ;
+12 ;
+13 NEW NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,OK,RXNO,CHRONIC,LDATE,CANDATE,EXDATE,DETAILED
+14 NEW INPTYPE,OUTPTYPE,TYPE,MEDTYPE,DATA,DATA1,MED,IDATE,XSTR,LLEN,DAYS,ACTVONLY,ONELIST,REASON,REFILLS
+15 NEW LASTMEDT,LASTSTS,COUNT,TOTAL,SPACE60,DASH73,TEMP,LINE,TAB,HEADER,CLASSORT,COUNTER,EVENT,HIEN,IEN
+16 NEW DRUGCLAS,DRUGIDX,LASTCLAS,OLDTAB,OLDHEADR,UNKNOWNS,INDIC,LSTINDIC,IDX,ID,CLININC
+17 ;Clean up after external calls...
NEW %,%H,STOP,LSTFD,ARRAY
+18 SET (NEXTLINE,TAB,HEADER,UNKNOWNS,CLININC)=0
SET LLEN=47
+19 KILL @TARGET,^TMP("PS",$JOB),ARRAY
+20 ; Is this an inpatient?
SET ISINP=($GET(^DPT(DFN,.1))'="")
+21 IF ISINP
SET INPTYPE=1
SET OUTPTYPE=2
+22 IF '$TEST
SET INPTYPE=2
SET OUTPTYPE=1
+23 ;
+24 ; *** Scan medication data and skip unwanted meds ***
+25 ;
+26 SET DAYS=180
SET ACTVONLY=0
SET ONELIST=0
SET DETAILED=1
+27 IF '$DATA(CNT)=CNT=1
+28 DO OCL^PSOORRL(DFN,$$FMADD^XLFDT(DT,-DAYS),"")
+29 SET INDEX=0
+30 FOR
SET INDEX=$ORDER(^TMP("PS",$JOB,INDEX))
IF INDEX'>0
QUIT
Begin DoDot:1
+31 SET NODE=$GET(^TMP("PS",$JOB,INDEX,0))
+32 SET CHRONIC=""
+33 SET STATUS=$PIECE(NODE,U,9)
+34 SET IDATE=$PIECE(NODE,U,15)
+35 ;Discard Blank Meds
SET KEEPMED=($LENGTH($PIECE(NODE,U,2))>0)
+36 IF $PIECE($PIECE(NODE,U),";",2)["O"
Begin DoDot:2
+37 SET RXNO=+($PIECE(NODE,U,1))
+38 SET CHRONIC=$PIECE($GET(^PSRX(RXNO,9999999)),U,2)
+39 IF STATUS="EXPIRED"
Begin DoDot:3
+40 NEW X1,X2,X
+41 IF CHRONIC
SET X1=DT
SET X2=-120
DO C^%DTC
SET LDATE=X
+42 IF '$TEST
SET X1=DT
SET X2=-14
DO C^%DTC
SET LDATE=X
+43 SET EXDATE=$PIECE($GET(^PSRX(RXNO,2)),U,6)
+44 IF EXDATE>LDATE
SET KEEPMED=1
End DoDot:3
+45 IF STATUS="DISCONTINUED"
Begin DoDot:3
+46 SET X1=DT
SET X2=-30
DO C^%DTC
SET LDATE=X
+47 SET CANDATE=$PIECE($GET(^PSRX(RXNO,3)),U,5)
+48 IF CANDATE>LDATE
SET KEEPMED=1
End DoDot:3
End DoDot:2
+49 IF STATUS="PENDING"
Begin DoDot:2
+50 SET IEN=+($PIECE(NODE,U))
+51 IF IEN>0
SET REFILLS=$PIECE($GET(^PS(52.41,IEN,0)),U,11)
+52 SET $PIECE(^TMP("PS",$JOB,INDEX,0),U,5)=REFILLS
End DoDot:2
+53 SET TYPE=$PIECE($PIECE(NODE,U),";",2)
+54 SET TYPE=$SELECT(TYPE="O":"OP",TYPE="I":"UD",1:"")
+55 SET KEEPMED=(TYPE'="")
+56 IF KEEPMED
Begin DoDot:2
+57 IF $ORDER(^TMP("PS",$JOB,INDEX,"A",0))>0
SET TYPE="IV"
+58 IF '$TEST
IF $ORDER(^TMP("PS",$JOB,INDEX,"B",0))>0
SET TYPE="IV"
+59 IF TYPE="OP"
SET MEDTYPE=OUTPTYPE
+60 IF '$TEST
SET MEDTYPE=INPTYPE
+61 IF MEDTYPE=INPTYPE
SET KEEPMED=ISINP
+62 IF '$TEST
SET KEEPMED='ISINP
End DoDot:2
+63 SET DRUGCLAS=" "
+64 SET MED=$PIECE(NODE,U,2)
+65 IF KEEPMED
Begin DoDot:2
+66 SET DRUGIDX=$ORDER(^PSDRUG("B",MED,0))
+67 DO GETCLASS(BTIUMED)
+68 IF BTIUMED'=DRUGCLAS
SET KEEPMED=0
+69 IF KEEPMED
Begin DoDot:3
+70 NEW ORDIDX,TMPCLASS,CDONE,SDONE,TMPIDX,TMPNODE,ISSUPPLY
+71 SET ID=$PIECE(NODE,U)
+72 SET IDX=+ID
SET ID=$EXTRACT(ID,$LENGTH(IDX)+1,$LENGTH(ID))
+73 SET (DRUGIDX,ORDIDX)=0
+74 IF ID="R;O"
SET DRUGIDX=+$PIECE($GET(^PSRX(IDX,0)),U,6)
+75 IF ID="P;O"
SET DRUGIDX=+$PIECE($GET(^PS(52.41,IDX,0)),U,9)
+76 IF ID="P;I"
Begin DoDot:4
+77 IF $PIECE($GET(^PS(53.1,IDX,1,0)),U,4)=1
Begin DoDot:5
+78 SET TMPIDX=$ORDER(^PS(53.1,IDX,1,0))
IF +TMPIDX
SET DRUGIDX=$PIECE($GET(^PS(53.1,IDX,1,TMPIDX,0)),U)
End DoDot:5
End DoDot:4
+79 IF ID="U;I"
Begin DoDot:4
+80 IF $PIECE($GET(^PS(55,DFN,5,IDX,1,0)),U,4)=1
Begin DoDot:5
+81 SET TMPIDX=$ORDER(^PS(55,DFN,5,IDX,1,0))
IF +TMPIDX
SET DRUGIDX=$PIECE($GET(^PS(55,DFN,5,IDX,1,TMPIDX,0)),U)
End DoDot:5
End DoDot:4
+82 IF ID="V;I"
Begin DoDot:4
+83 IF $PIECE($GET(^PS(55,DFN,"IV",IDX,"AD",0)),U,4)=1
Begin DoDot:5
+84 SET TMPIDX=$ORDER(^PS(55,DFN,"IV",IDX,"AD",0))
IF +TMPIDX
Begin DoDot:6
+85 SET TMPIDX=$PIECE($GET(^PS(55,DFN,"IV",IDX,"AD",TMPIDX,0)),U)
+86 IF +TMPIDX
SET DRUGIDX=$PIECE($GET(^PS(52.6,TMPIDX,0)),U,2)
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+87 ; *** Save wanted meds in "B" temp xref, removing duplicates ***
+88 ;
+89 IF KEEPMED
Begin DoDot:2
+90 SET EVENT=$PIECE(NODE,U,15)
+91 IF EVENT=""
SET EVENT=$$NOW^XLFDT
+92 SET IDATE=9999999-EVENT
+93 SET ARRAY(IDATE,INDEX)=DRUGIDX_"^"_IDX_"^"_ID_"^"_EVENT_"^"_STATUS
End DoDot:2
End DoDot:1
+94 ;
+95 ; *** Check for empty condition ***
+96 ;
+97 ;after you get all the drugs into the array take number requested
+98 SET $PIECE(SPACE60," ",60)=" "
SET $PIECE(DASH73,"=",73)="="
+99 SET COUNTER=0
SET LINE=0
+100 SET TEMP="Last "_CNT_" drugs from class "_BTIUMED
+101 DO ADD^BTIUMED1(TEMP)
+102 NEW I
+103 SET I=""
FOR
SET I=$ORDER(ARRAY(I))
IF I=""!(COUNTER>=CNT)
QUIT
Begin DoDot:1
+104 SET INDEX=""
FOR
SET INDEX=$ORDER(ARRAY(I,INDEX))
IF INDEX=""
QUIT
Begin DoDot:2
+105 SET COUNTER=COUNTER+1
+106 SET NODE=^TMP("PS",$JOB,INDEX,0)
+107 SET DATA=$GET(ARRAY(I,INDEX))
+108 SET STATUS=$PIECE(DATA,U,5)
+109 IF STATUS="HOLD"
Begin DoDot:3
+110 SET HIEN=+($PIECE(NODE,U))
+111 SET REASON=$$GET1^DIQ(52,HIEN,99,"E")
+112 SET NODE=NODE_U_REASON
End DoDot:3
+113 DO ADDMED^BTIUMED1(0)
End DoDot:2
End DoDot:1
+114 IF COUNTER=0
SET LINE=LINE+1
SET @TARGET@(LINE,0)="No Meds for this class found"
+115 QUIT "~@"_$NAME(@TARGET)
+116 ;
LISTX KILL ^TMP("PS",$JOB)
+1 QUIT "~@"_$NAME(@TARGET)
+2 ;
GETCLASS(BTIUMED) ; Get Drug Class, filter out supplies
+1 IF +DRUGIDX
Begin DoDot:1
+2 NEW TEMPNODE
+3 SET TEMPNODE=$GET(^PSDRUG(DRUGIDX,0))
+4 SET DRUGCLAS=$PIECE(TEMPNODE,U,2)
End DoDot:1
+5 QUIT
