BTIULMED ; SLC/JM - Active/Recent Med Objects Routine ;28-Apr-2016 10:18;DU
;;1.0;TEXT INTEGRATION UTILITIES;**1006,1011,1016**;NOV 04,2004;Build 10
;PATCH 1011 changed to use new pharmacy APIs
Q
LIST(DFN,TARGET,ACTVONLY,DETAILED,ALLMEDS,ONELIST,CLASSORT,SUPPLIES,CLININC) ; EP
;
; This is the TIU Medication objects API. Optional parameters not
; provided defaults to 0 (with the exception of SUPPLIES).
;
;Required Parameters:
;
; DFN Patient identifier
;
; TARGET Where the medication data will be stored
;
;Optional Parameters:
;
; ACTVONLY 0 - Active and recently expired meds
; 1 - Active meds only
; 2 - Recently expired meds only
; 3 - Hold meds only
;
; DETAILED 0 - One line per med only
; 1 - Detailed information on each med
;
; ALLMEDS 0 - Specifies Inpatient Meds if patient is an
; Inpatient, or Outpatient Meds if patient
; is an Outpatient
; 1 - Specifies both Inpatient and Outpatient
; 2 or "I" - Specifies Inpatient only
; 3 or "O" - Specifies Outpatient only
;
; ONELIST 0 - Separates Active, Pending and Inactive
; medications into separate lists
; 1 - Combines Active, Pending and Inactive
; medications into the same list
;
; CLASSORT 0 - Sort meds alphabetically
; 1 - Sort meds by drug class, and within the
; same drug class, sort alphabetically
; 2 - Same as #1, but show drug class in header
; SUPPLIES 0 - Supplies are excluded
; 1 - Supplies are included (Default)
; CLININC 0- Do not use
; 1- Display in detailed format
; 2- Sort by
;
N NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,ASTATS,PSTATS,OK,RXNO,CHRONIC
N STATIDX,INPTYPE,OUTPTYPE,TYPE,MEDTYPE,CNT,DATA,DATA1,MED,IDATE,XSTR,LLEN,DAYS
N LASTMEDT,LASTSTS,COUNT,TOTAL,SPACE60,DASH73,TEMP,LINE,TAB,HEADER,IEN,HIEN,HSTATS,REASON,REFILLS
N DRUGCLAS,DRUGIDX,LASTCLAS,OLDTAB,OLDHEADR,UNKNOWNS,INDIC,LSTINDIC,ERX,AUTO
N %,%H,STOP,LSTFD ;Clean up after external calls...
N NVATYPE,NVAMED,NVASTR,TIUXSTAT
S (NEXTLINE,TAB,HEADER,UNKNOWNS)=0,LLEN=47
K @TARGET,^TMP("PS",$J)
; Check for Pharmacy Package and required patches
I '$$PATCHSOK^TIULMED3 G LISTX ;P213
I '+$G(ACTVONLY) S ACTVONLY=0
I '+$G(DETAILED) S DETAILED=0
I +$D(ALLMEDS) D
.I ALLMEDS="I" S ALLMEDS=2
.E I ALLMEDS="O" S ALLMEDS=3
I '+$G(ALLMEDS) S ALLMEDS=0
I '+$G(ONELIST) S ONELIST=0
I '+$G(CLASSORT) S CLASSORT=0
I $G(SUPPLIES)'="0" S SUPPLIES=1
I '+$G(CLININC) S CLININC=0
S (EMPTY,HEADER)=1
I ONELIST,'ALLMEDS,'DETAILED,'CLASSORT,'CLININC S HEADER=0
I 'DETAILED S LLEN=60
S ASTATS="^ACTIVE^REFILL^HOLD^PROVIDER HOLD^ON CALL^ACTIVE (S)^"
S PSTATS="^NON-VERIFIED^DRUG INTERACTIONS^INCOMPLETE^PENDING^"
S HSTATS="^HOLD^"
S ISINP=($G(^DPT(DFN,.1))'="") ; Is this an inpatient?
I ISINP S INPTYPE=1,OUTPTYPE=2
E S INPTYPE=2,OUTPTYPE=1
S DAYS=$$GET^XPAR("ALL","BTIU EXPIRED MEDS",1,"E")
S:$G(DAYS)<1 DAYS=365
D ADDTITLE^BTIUMED1(DAYS)
;
; *** Scan medication data and skip unwanted meds ***
;
D OCL^PSOORRL(DFN,$$FMADD^XLFDT(DT,-DAYS),"")
S INDEX=0,INDIC=""
F S INDEX=$O(^TMP("PS",$J,INDEX)) Q:INDEX'>0 D
.S AUTO=0,ERX=""
.S NODE=$G(^TMP("PS",$J,INDEX,0))
.S RXNO=+($P(NODE,U,1))
.S CHRONIC=$P($G(^PSRX(RXNO,9999999)),U,2)
.S AUTO=$P($G(^PSRX(RXNO,999999921)),U,3)
.S KEEPMED=($L($P(NODE,U,2))>0) ;Discard Blank Meds
.I KEEPMED D
..S STATUS=$P(NODE,U,9)
..I STATUS="ACTIVE/SUSP" S STATUS="ACTIVE (S)"
..I STATUS="SUSPENDED" S STATUS="ACTIVE (S)"
..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
..I $F(ASTATS,"^"_STATUS_"^")>0 S STATIDX=1
..E I ($F(PSTATS,"^"_STATUS_"^")>0) S STATIDX=2
..E S STATIDX=3
..I ACTVONLY=1 S KEEPMED=(STATIDX<3)
..I ACTVONLY=2 S KEEPMED=(STATIDX=3)
..I ACTVONLY=3 D
...S KEEPMED=""
...I STATUS="HOLD" S KEEPMED=4
..;I +ONELIST S STATIDX=1
..; Changes for *238 required by PSO*7*294
..I $$PATCH^XPDUTL("PSO*7.0*294"),+$D(TIUDATE),STATUS["DISCONTINUED" S KEEPMED=0
.I KEEPMED D
..S TYPE=$P($P(NODE,U),";",2)
..S TYPE=$S(TYPE="O":"OP",TYPE="I":"UD",1:"")
..S NVAMED=$P($P(NODE,U),";")
..S NVAMED=$E(NVAMED,$L(NVAMED))
..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 ALLMEDS=0 D I 1
...I MEDTYPE=INPTYPE S KEEPMED=ISINP
...E S KEEPMED='ISINP
..E I ALLMEDS=2 S KEEPMED=(MEDTYPE=INPTYPE)
..E I ALLMEDS=3 S KEEPMED=(MEDTYPE=OUTPTYPE)
.S DRUGCLAS=" "
.S MED=$P(NODE,U,2)
.I KEEPMED,(CLASSORT!('SUPPLIES)) D
..S DRUGIDX=$$IENNAME^TIULMED2(MED)
..D GETCLASS
..I KEEPMED,+DRUGIDX=0 D ;Find orderable item
...N IDX,ID,ORDIDX,TMPCLASS,CDONE,SDONE,TMPIDX,TMPNODE,ISSUPPLY
...S ID=$P(NODE,U),IDX=+ID,ID=$E(ID,$L(IDX)+1,$L(ID))
...S (DRUGIDX,ORDIDX)=0
...K ^TMP($J,"TIULMED")
...; IDX is Order #; ID indicates what file. See IA 2400
...; R;O MED will always be in Drug File (Unless Drug File entry was
...; changed after ordering.
...I ID="R;O" D
....D RX^PSO52API(DFN,"TIULMED",IDX,"","0,O") ; IA 4820
....S DRUGIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,6))
....S ORDIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,"OI"))
...I ID="P;O" D ;P;O = pending outpatient order (file #52.41). P213
....D PEN^PSO5241(DFN,"TIULMED",IDX) ; IA 4821
....S DRUGIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,11))
....S ORDIDX=+$G(^TMP($J,"TIULMED",DFN,IDX,8))
...I ID="P;I" D ;P;I = pending inpatient order (file #53.1)
....I $P($G(^PS(53.1,IDX,1,0)),U,4)=1 D
.....S TMPIDX=$O(^PS(53.1,IDX,1,0)) I +TMPIDX D
......S DRUGIDX=$P($G(^PS(53.1,IDX,1,TMPIDX,0)),U)
....S ORDIDX=+$P($G(^PS(53.1,IDX,.2)),U)
...I ID="U;I" D ;U;I = unit dose order (file #55, subfile 55.06) P213
....D PSS431^PSS55(DFN,IDX,"","","TIULMED") ; IA 4826
....I +$G(^TMP($J,"TIULMED",IDX,"DDRUG",0))=1 D
.....S TMPIDX=$O(^TMP($J,"TIULMED",IDX,"DDRUG",0)) Q:TMPIDX'>0
.....S DRUGIDX=+$G(^TMP($J,"TIULMED",IDX,"DDRUG",TMPIDX,.01))
....S ORDIDX=+$G(^TMP($J,"TIULMED",IDX,108))
...I ID="V;I" D ;V;I = IV order (file #55, subfile 55.01). P213
....D PSS436^PSS55(DFN,IDX,"TIULMED") ; IA 4826
....; Get ORDIDX before DRUGIDX since global is not there after DRUGIDX
....S ORDIDX=+$G(^TMP($J,"TIULMED",IDX,130))
....I ^TMP($J,"TIULMED",IDX,"ADD",0)=1 D
.....S TMPIDX=$O(^TMP($J,"TIULMED",IDX,"ADD",0)) I +TMPIDX D
......S TMPIDX=+$G(^TMP($J,"TIULMED",IDX,"ADD",TMPIDX,.01))
......I +TMPIDX S DRUGIDX=$$DRGIEN^TIULMED2(TMPIDX) ; IA 4662
...S DRUGCLAS=""
...D GETCLASS
...I KEEPMED,+DRUGIDX=0,+ORDIDX,DRUGCLAS="" D
....S IDX=0,ISSUPPLY=2,CDONE='CLASSORT,SDONE=+SUPPLIES
....N LIST S LIST="TIULMED" K ^TMP($J,LIST)
....D DRGIEN^PSS50P7(ORDIDX,"",LIST) ; IA 4662
....F S IDX=$O(^TMP($J,LIST,IDX)) Q:'IDX D Q:(CDONE&SDONE)
.....S TMPCLASS=$$DRGCLASS^TIULMED2(IDX)
.....S TMPNODE=U_TMPCLASS_U_$$DEA^TIULMED2(IDX)
.....I 'CDONE,TMPCLASS="" S CDONE=1,DRUGCLAS=""
.....I 'CDONE D
......I DRUGCLAS="" S DRUGCLAS=TMPCLASS
......E I DRUGCLAS'=TMPCLASS S CDONE=1,DRUGCLAS=""
.....I 'SDONE D
......S ISSUPPLY=(($E(TMPCLASS,1,2)="XA")&($P(TMPNODE,U,3)["S"))
......I 'ISSUPPLY S SDONE=1
....I 'SUPPLIES,(ISSUPPLY=1) S KEEPMED=0
..I (DRUGCLAS="")!('CLASSORT) S DRUGCLAS=" "
..I AUTO=1 D
...S ERX=$P($G(^PSRX(RXNO,999999921)),U,4)
...I +ERX S ERX=ERX_";"_RXNO
...S $P(^TMP("PS",$J,INDEX,0),U,9)=STATUS_" (X)"
.;
.; *** Save wanted meds in "B" temp xref, removing duplicates ***
.;
.I KEEPMED D
..D ADDMED^BTIUMED1(1) ; Get XSTR to check for duplicates
..S IDATE=$P(NODE,U,15)
..I $P($P(NODE,U),";")["N" S IDATE=$$DT^XLFDT
..I $P(NODE,U,9)="PENDING"!($P(NODE,U,9)="HOLD") S IDATE=$$DT^XLFDT
..S OK='$D(@TARGET@("B",MED,IDATE,XSTR))
..I 'OK,(IDATE>@TARGET@("B",MED,IDATE,XSTR)) S OK=1
..I OK D
...S @TARGET@("B",MED,IDATE,XSTR)=IDATE_U_INDEX_U_MEDTYPE_U_STATIDX_U_TYPE_U_DRUGCLAS_U_CHRONIC_U_ERX
...S EMPTY=0
...I DRUGCLAS=" " S UNKNOWNS=1
;
; *** Check for empty condition ***
;
I EMPTY D G LISTX
.D ADD^BTIUMED1("No Medications Found")
.D ADD^BTIUMED1(" ")
;
; *** Sort Meds in "C" temp xref - sort by Med Type, Status
; Med Name, and reverse issue date, followed by a counter
; to avoid erasing meds issued on the same day
;
S MED="",CNT=1000000
F S MED=$O(@TARGET@("B",MED)) Q:MED="" D
.S IDATE=""
.F S IDATE=$O(@TARGET@("B",MED,IDATE)) Q:IDATE="" D
..S XSTR=""
..F S XSTR=$O(@TARGET@("B",MED,IDATE,XSTR)) Q:XSTR="" D
...S NODE=@TARGET@("B",MED,IDATE,XSTR)
...S DATA=MED_U_$P(NODE,U,3)_U_$P(NODE,U,5),CNT=CNT+1
...S @TARGET@("C",DATA,(9999999-$P(NODE,U))_CNT)=$P(NODE,U,2)_U_$P(NODE,U,5)_U_$P(NODE,U,7)_U_$P(NODE,U,8)
K @TARGET@("B")
;
; Read sorted data and save final version to TARGET
;
S (DATA,LASTCLAS,LSTINDIC)="",(LASTMEDT,LASTSTS,COUNT,TOTAL)=0
S $P(SPACE60," ",60)=" ",$P(DASH73,"=",73)="="
D WARNING^BTIUMED1
F S DATA=$O(@TARGET@("C",DATA)) Q:DATA="" D
.S DATA1=$P(DATA,U,2)
.S MEDTYPE=$E(DATA1),STATIDX=$E(DATA1,2)
.S DRUGCLAS=$P(DATA,U,2),MED=$P(DATA,U,3),CNT=""
.F S CNT=$O(@TARGET@("C",DATA,CNT)) Q:CNT="" D
..S INDEX=@TARGET@("C",DATA,CNT)
..S TYPE=$P(INDEX,U,2),CHRONIC=$P(INDEX,U,3),ERX=$P(INDEX,U,4),INDEX=+INDEX
..S NODE=^TMP("PS",$J,INDEX,0)
..;If hold meds, find the reason and add it to the node data
..S STATUS=$P(NODE,U,9)
..I STATUS="HOLD" D
...S HIEN=+($P(NODE,U))
...S REASON=$$GET1^DIQ(52,HIEN,99,"E")
...S $P(NODE,U,18)=REASON
..I DETAILED D
...S HIEN=$P(NODE,U)
...I CLININC>0 D
...;Patch 1016 changes for clinical indication
...I HIEN["R" D
....S HIEN=+HIEN
....S INDIC=$$GET1^DIQ(52,HIEN,9999999.21,"E")
....S $P(NODE,U,19)=INDIC
...I ERX'="" S $P(NODE,U,31)=ERX
..I $P($P(NODE,U),";")["N" S $P(NODE,U,2)=$P(NODE,U,2)_" (O)"
..I CHRONIC="Y" S $P(NODE,U,2)=$P(NODE,U,2)_" (C)"
..;E S $P(NODE,U,2)=" "_$P(NODE,U,2)
..;I (MEDTYPE'=LASTMEDT)!(STATIDX'=LASTSTS)!(INDIC'=LSTINDIC) D ; Create Header
..I (MEDTYPE'=LASTMEDT)!(CLININC=2&(INDIC'=LSTINDIC)) D ; Create Header
...I CLASSORT'=2,DRUGCLAS'=" " S LASTCLAS=DRUGCLAS
...I 'HEADER Q
...S LASTMEDT=MEDTYPE,LASTSTS=STATIDX,TAB=0
...I COUNT>0 D ADD^BTIUMED1(" ")
...I CLASSORT D ADD^BTIUMED1(" ")
...S COUNT=0
...I DETAILED D
....I MEDTYPE=OUTPTYPE D I 1
.....D ADD^BTIUMED1($E($E(SPACE60,1,47)_"Status"_SPACE60,1,60)_"Last Fill")
....E D ADD^BTIUMED1(SPACE60_"Start Date")
...S TEMP=""
...I 'ONELIST D
....S TEMP=TEMP_$S(MEDTYPE=INPTYPE:"Inpatient",1:"Outpatient")
....I ACTVONLY=3 S TEMP="HOLD"
....S TEMP=" "_TEMP_" Medications"
...I CLASSORT D
....I DETAILED S TEMP=TEMP_" (By Class)"
....E S TEMP=TEMP_" (By Drug Class)"
....I MEDTYPE=OUTPTYPE&(CLININC>0) S TEMP=TEMP_" (By Clinical Indication)"
...I DETAILED D I 1
....S TEMP=$E(TEMP_SPACE60,1,47)
....I MEDTYPE=INPTYPE S TEMP=TEMP_"Status"
....E S TEMP=TEMP_"Refills"
....S TEMP=$E(TEMP_SPACE60,1,60)
....I MEDTYPE=INPTYPE S TEMP=TEMP_"Stop Date"
....E S TEMP=TEMP_"Expiration"
...E D
....S TEMP=$E(TEMP_SPACE60,1,60)_"Status"
...D ADD^BTIUMED1(TEMP),ADD^BTIUMED1(DASH73)
..I CLASSORT,DRUGCLAS'="",DRUGCLAS'=LASTCLAS D
...S LASTCLAS=DRUGCLAS,OLDTAB=TAB,OLDHEADR=HEADER
..I CLININC=2,INDIC'=LSTINDIC D
...S LSTINDIC=INDIC,OLDTAB=TAB,OLDHEADR=HEADER
...S (TAB,HEADER)=0
...I COUNT>0 D ADD^BTIUMED1(" ")
...I (CLASSORT=2)!(DRUGCLAS=" ") D I 1
....I DRUGCLAS=" " S TEMP=" ====== Drug Class Unknown "
....E S TEMP=" ====== Drug Class: "_DRUGCLAS_" "
...I REASON=1 D
....I INDIC="" S TEMP=" ====== Unknown Indication "
....E S TEMP=" ====== "_INDIC_" "
...E S TEMP=" "
...S TEMP=$E(TEMP_DASH73,1,LLEN-2)
...D ADD^BTIUMED1(TEMP)
...S HEADER=OLDHEADR,TAB=OLDTAB
..S COUNT=COUNT+1,TOTAL=TOTAL+1
..D ADDMED^BTIUMED1(0)
I COUNT'=TOTAL D
.S TAB=0
.D ADD^BTIUMED1(" ")
.D ADD^BTIUMED1(TOTAL_" Total Medications")
D ADD^BTIUMED1(" ")
D ADD^BTIUMED1("(X)behind status of medication depicts that the medication was sent to an external pharmacy")
K @TARGET@("C")
LISTX K ^TMP("PS",$J)
Q "~@"_$NA(@TARGET)
;
GETCLASS ; Get Drug Class, filter out supplies
D GETCLASS^TIULMED3
Q
BTIULMED ; SLC/JM - Active/Recent Med Objects Routine ;28-Apr-2016 10:18;DU
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1006,1011,1016**;NOV 04,2004;Build 10
+2 ;PATCH 1011 changed to use new pharmacy APIs
+3 QUIT
LIST(DFN,TARGET,ACTVONLY,DETAILED,ALLMEDS,ONELIST,CLASSORT,SUPPLIES,CLININC) ; EP
+1 ;
+2 ; This is the TIU Medication objects API. Optional parameters not
+3 ; provided defaults to 0 (with the exception of SUPPLIES).
+4 ;
+5 ;Required Parameters:
+6 ;
+7 ; DFN Patient identifier
+8 ;
+9 ; TARGET Where the medication data will be stored
+10 ;
+11 ;Optional Parameters:
+12 ;
+13 ; ACTVONLY 0 - Active and recently expired meds
+14 ; 1 - Active meds only
+15 ; 2 - Recently expired meds only
+16 ; 3 - Hold meds only
+17 ;
+18 ; DETAILED 0 - One line per med only
+19 ; 1 - Detailed information on each med
+20 ;
+21 ; ALLMEDS 0 - Specifies Inpatient Meds if patient is an
+22 ; Inpatient, or Outpatient Meds if patient
+23 ; is an Outpatient
+24 ; 1 - Specifies both Inpatient and Outpatient
+25 ; 2 or "I" - Specifies Inpatient only
+26 ; 3 or "O" - Specifies Outpatient only
+27 ;
+28 ; ONELIST 0 - Separates Active, Pending and Inactive
+29 ; medications into separate lists
+30 ; 1 - Combines Active, Pending and Inactive
+31 ; medications into the same list
+32 ;
+33 ; CLASSORT 0 - Sort meds alphabetically
+34 ; 1 - Sort meds by drug class, and within the
+35 ; same drug class, sort alphabetically
+36 ; 2 - Same as #1, but show drug class in header
+37 ; SUPPLIES 0 - Supplies are excluded
+38 ; 1 - Supplies are included (Default)
+39 ; CLININC 0- Do not use
+40 ; 1- Display in detailed format
+41 ; 2- Sort by
+42 ;
+43 NEW NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,ASTATS,PSTATS,OK,RXNO,CHRONIC
+44 NEW STATIDX,INPTYPE,OUTPTYPE,TYPE,MEDTYPE,CNT,DATA,DATA1,MED,IDATE,XSTR,LLEN,DAYS
+45 NEW LASTMEDT,LASTSTS,COUNT,TOTAL,SPACE60,DASH73,TEMP,LINE,TAB,HEADER,IEN,HIEN,HSTATS,REASON,REFILLS
+46 NEW DRUGCLAS,DRUGIDX,LASTCLAS,OLDTAB,OLDHEADR,UNKNOWNS,INDIC,LSTINDIC,ERX,AUTO
+47 ;Clean up after external calls...
NEW %,%H,STOP,LSTFD
+48 NEW NVATYPE,NVAMED,NVASTR,TIUXSTAT
+49 SET (NEXTLINE,TAB,HEADER,UNKNOWNS)=0
SET LLEN=47
+50 KILL @TARGET,^TMP("PS",$JOB)
+51 ; Check for Pharmacy Package and required patches
+52 ;P213
IF '$$PATCHSOK^TIULMED3
GOTO LISTX
+53 IF '+$GET(ACTVONLY)
SET ACTVONLY=0
+54 IF '+$GET(DETAILED)
SET DETAILED=0
+55 IF +$DATA(ALLMEDS)
Begin DoDot:1
+56 IF ALLMEDS="I"
SET ALLMEDS=2
+57 IF '$TEST
IF ALLMEDS="O"
SET ALLMEDS=3
End DoDot:1
+58 IF '+$GET(ALLMEDS)
SET ALLMEDS=0
+59 IF '+$GET(ONELIST)
SET ONELIST=0
+60 IF '+$GET(CLASSORT)
SET CLASSORT=0
+61 IF $GET(SUPPLIES)'="0"
SET SUPPLIES=1
+62 IF '+$GET(CLININC)
SET CLININC=0
+63 SET (EMPTY,HEADER)=1
+64 IF ONELIST
IF 'ALLMEDS
IF 'DETAILED
IF 'CLASSORT
IF 'CLININC
SET HEADER=0
+65 IF 'DETAILED
SET LLEN=60
+66 SET ASTATS="^ACTIVE^REFILL^HOLD^PROVIDER HOLD^ON CALL^ACTIVE (S)^"
+67 SET PSTATS="^NON-VERIFIED^DRUG INTERACTIONS^INCOMPLETE^PENDING^"
+68 SET HSTATS="^HOLD^"
+69 ; Is this an inpatient?
SET ISINP=($GET(^DPT(DFN,.1))'="")
+70 IF ISINP
SET INPTYPE=1
SET OUTPTYPE=2
+71 IF '$TEST
SET INPTYPE=2
SET OUTPTYPE=1
+72 SET DAYS=$$GET^XPAR("ALL","BTIU EXPIRED MEDS",1,"E")
+73 IF $GET(DAYS)<1
SET DAYS=365
+74 DO ADDTITLE^BTIUMED1(DAYS)
+75 ;
+76 ; *** Scan medication data and skip unwanted meds ***
+77 ;
+78 DO OCL^PSOORRL(DFN,$$FMADD^XLFDT(DT,-DAYS),"")
+79 SET INDEX=0
SET INDIC=""
+80 FOR
SET INDEX=$ORDER(^TMP("PS",$JOB,INDEX))
IF INDEX'>0
QUIT
Begin DoDot:1
+81 SET AUTO=0
SET ERX=""
+82 SET NODE=$GET(^TMP("PS",$JOB,INDEX,0))
+83 SET RXNO=+($PIECE(NODE,U,1))
+84 SET CHRONIC=$PIECE($GET(^PSRX(RXNO,9999999)),U,2)
+85 SET AUTO=$PIECE($GET(^PSRX(RXNO,999999921)),U,3)
+86 ;Discard Blank Meds
SET KEEPMED=($LENGTH($PIECE(NODE,U,2))>0)
+87 IF KEEPMED
Begin DoDot:2
+88 SET STATUS=$PIECE(NODE,U,9)
+89 IF STATUS="ACTIVE/SUSP"
SET STATUS="ACTIVE (S)"
+90 IF STATUS="SUSPENDED"
SET STATUS="ACTIVE (S)"
+91 IF STATUS="PENDING"
Begin DoDot:3
+92 SET IEN=+($PIECE(NODE,U))
+93 IF IEN>0
SET REFILLS=$PIECE($GET(^PS(52.41,IEN,0)),U,11)
+94 SET $PIECE(^TMP("PS",$JOB,INDEX,0),U,5)=REFILLS
End DoDot:3
+95 IF $FIND(ASTATS,"^"_STATUS_"^")>0
SET STATIDX=1
+96 IF '$TEST
IF ($FIND(PSTATS,"^"_STATUS_"^")>0)
SET STATIDX=2
+97 IF '$TEST
SET STATIDX=3
+98 IF ACTVONLY=1
SET KEEPMED=(STATIDX<3)
+99 IF ACTVONLY=2
SET KEEPMED=(STATIDX=3)
+100 IF ACTVONLY=3
Begin DoDot:3
+101 SET KEEPMED=""
+102 IF STATUS="HOLD"
SET KEEPMED=4
End DoDot:3
+103 ;I +ONELIST S STATIDX=1
+104 ; Changes for *238 required by PSO*7*294
+105 IF $$PATCH^XPDUTL("PSO*7.0*294")
IF +$DATA(TIUDATE)
IF STATUS["DISCONTINUED"
SET KEEPMED=0
End DoDot:2
+106 IF KEEPMED
Begin DoDot:2
+107 SET TYPE=$PIECE($PIECE(NODE,U),";",2)
+108 SET TYPE=$SELECT(TYPE="O":"OP",TYPE="I":"UD",1:"")
+109 SET NVAMED=$PIECE($PIECE(NODE,U),";")
+110 SET NVAMED=$EXTRACT(NVAMED,$LENGTH(NVAMED))
+111 SET KEEPMED=(TYPE'="")
End DoDot:2
+112 IF KEEPMED
Begin DoDot:2
+113 IF $ORDER(^TMP("PS",$JOB,INDEX,"A",0))>0
SET TYPE="IV"
+114 IF '$TEST
IF $ORDER(^TMP("PS",$JOB,INDEX,"B",0))>0
SET TYPE="IV"
+115 IF TYPE="OP"
SET MEDTYPE=OUTPTYPE
+116 IF '$TEST
SET MEDTYPE=INPTYPE
+117 IF ALLMEDS=0
Begin DoDot:3
+118 IF MEDTYPE=INPTYPE
SET KEEPMED=ISINP
+119 IF '$TEST
SET KEEPMED='ISINP
End DoDot:3
IF 1
+120 IF '$TEST
IF ALLMEDS=2
SET KEEPMED=(MEDTYPE=INPTYPE)
+121 IF '$TEST
IF ALLMEDS=3
SET KEEPMED=(MEDTYPE=OUTPTYPE)
End DoDot:2
+122 SET DRUGCLAS=" "
+123 SET MED=$PIECE(NODE,U,2)
+124 IF KEEPMED
IF (CLASSORT!('SUPPLIES))
Begin DoDot:2
+125 SET DRUGIDX=$$IENNAME^TIULMED2(MED)
+126 DO GETCLASS
+127 ;Find orderable item
IF KEEPMED
IF +DRUGIDX=0
Begin DoDot:3
+128 NEW IDX,ID,ORDIDX,TMPCLASS,CDONE,SDONE,TMPIDX,TMPNODE,ISSUPPLY
+129 SET ID=$PIECE(NODE,U)
SET IDX=+ID
SET ID=$EXTRACT(ID,$LENGTH(IDX)+1,$LENGTH(ID))
+130 SET (DRUGIDX,ORDIDX)=0
+131 KILL ^TMP($JOB,"TIULMED")
+132 ; IDX is Order #; ID indicates what file. See IA 2400
+133 ; R;O MED will always be in Drug File (Unless Drug File entry was
+134 ; changed after ordering.
+135 IF ID="R;O"
Begin DoDot:4
+136 ; IA 4820
DO RX^PSO52API(DFN,"TIULMED",IDX,"","0,O")
+137 SET DRUGIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,6))
+138 SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,"OI"))
End DoDot:4
+139 ;P;O = pending outpatient order (file #52.41). P213
IF ID="P;O"
Begin DoDot:4
+140 ; IA 4821
DO PEN^PSO5241(DFN,"TIULMED",IDX)
+141 SET DRUGIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,11))
+142 SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,8))
End DoDot:4
+143 ;P;I = pending inpatient order (file #53.1)
IF ID="P;I"
Begin DoDot:4
+144 IF $PIECE($GET(^PS(53.1,IDX,1,0)),U,4)=1
Begin DoDot:5
+145 SET TMPIDX=$ORDER(^PS(53.1,IDX,1,0))
IF +TMPIDX
Begin DoDot:6
+146 SET DRUGIDX=$PIECE($GET(^PS(53.1,IDX,1,TMPIDX,0)),U)
End DoDot:6
End DoDot:5
+147 SET ORDIDX=+$PIECE($GET(^PS(53.1,IDX,.2)),U)
End DoDot:4
+148 ;U;I = unit dose order (file #55, subfile 55.06) P213
IF ID="U;I"
Begin DoDot:4
+149 ; IA 4826
DO PSS431^PSS55(DFN,IDX,"","","TIULMED")
+150 IF +$GET(^TMP($JOB,"TIULMED",IDX,"DDRUG",0))=1
Begin DoDot:5
+151 SET TMPIDX=$ORDER(^TMP($JOB,"TIULMED",IDX,"DDRUG",0))
IF TMPIDX'>0
QUIT
+152 SET DRUGIDX=+$GET(^TMP($JOB,"TIULMED",IDX,"DDRUG",TMPIDX,.01))
End DoDot:5
+153 SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",IDX,108))
End DoDot:4
+154 ;V;I = IV order (file #55, subfile 55.01). P213
IF ID="V;I"
Begin DoDot:4
+155 ; IA 4826
DO PSS436^PSS55(DFN,IDX,"TIULMED")
+156 ; Get ORDIDX before DRUGIDX since global is not there after DRUGIDX
+157 SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",IDX,130))
+158 IF ^TMP($JOB,"TIULMED",IDX,"ADD",0)=1
Begin DoDot:5
+159 SET TMPIDX=$ORDER(^TMP($JOB,"TIULMED",IDX,"ADD",0))
IF +TMPIDX
Begin DoDot:6
+160 SET TMPIDX=+$GET(^TMP($JOB,"TIULMED",IDX,"ADD",TMPIDX,.01))
+161 ; IA 4662
IF +TMPIDX
SET DRUGIDX=$$DRGIEN^TIULMED2(TMPIDX)
End DoDot:6
End DoDot:5
End DoDot:4
+162 SET DRUGCLAS=""
+163 DO GETCLASS
+164 IF KEEPMED
IF +DRUGIDX=0
IF +ORDIDX
IF DRUGCLAS=""
Begin DoDot:4
+165 SET IDX=0
SET ISSUPPLY=2
SET CDONE='CLASSORT
SET SDONE=+SUPPLIES
+166 NEW LIST
SET LIST="TIULMED"
KILL ^TMP($JOB,LIST)
+167 ; IA 4662
DO DRGIEN^PSS50P7(ORDIDX,"",LIST)
+168 FOR
SET IDX=$ORDER(^TMP($JOB,LIST,IDX))
IF 'IDX
QUIT
Begin DoDot:5
+169 SET TMPCLASS=$$DRGCLASS^TIULMED2(IDX)
+170 SET TMPNODE=U_TMPCLASS_U_$$DEA^TIULMED2(IDX)
+171 IF 'CDONE
IF TMPCLASS=""
SET CDONE=1
SET DRUGCLAS=""
+172 IF 'CDONE
Begin DoDot:6
+173 IF DRUGCLAS=""
SET DRUGCLAS=TMPCLASS
+174 IF '$TEST
IF DRUGCLAS'=TMPCLASS
SET CDONE=1
SET DRUGCLAS=""
End DoDot:6
+175 IF 'SDONE
Begin DoDot:6
+176 SET ISSUPPLY=(($EXTRACT(TMPCLASS,1,2)="XA")&($PIECE(TMPNODE,U,3)["S"))
+177 IF 'ISSUPPLY
SET SDONE=1
End DoDot:6
End DoDot:5
IF (CDONE&SDONE)
QUIT
+178 IF 'SUPPLIES
IF (ISSUPPLY=1)
SET KEEPMED=0
End DoDot:4
End DoDot:3
+179 IF (DRUGCLAS="")!('CLASSORT)
SET DRUGCLAS=" "
+180 IF AUTO=1
Begin DoDot:3
+181 SET ERX=$PIECE($GET(^PSRX(RXNO,999999921)),U,4)
+182 IF +ERX
SET ERX=ERX_";"_RXNO
+183 SET $PIECE(^TMP("PS",$JOB,INDEX,0),U,9)=STATUS_" (X)"
End DoDot:3
End DoDot:2
+184 ;
+185 ; *** Save wanted meds in "B" temp xref, removing duplicates ***
+186 ;
+187 IF KEEPMED
Begin DoDot:2
+188 ; Get XSTR to check for duplicates
DO ADDMED^BTIUMED1(1)
+189 SET IDATE=$PIECE(NODE,U,15)
+190 IF $PIECE($PIECE(NODE,U),";")["N"
SET IDATE=$$DT^XLFDT
+191 IF $PIECE(NODE,U,9)="PENDING"!($PIECE(NODE,U,9)="HOLD")
SET IDATE=$$DT^XLFDT
+192 SET OK='$DATA(@TARGET@("B",MED,IDATE,XSTR))
+193 IF 'OK
IF (IDATE>@TARGET@("B",MED,IDATE,XSTR))
SET OK=1
+194 IF OK
Begin DoDot:3
+195 SET @TARGET@("B",MED,IDATE,XSTR)=IDATE_U_INDEX_U_MEDTYPE_U_STATIDX_U_TYPE_U_DRUGCLAS_U_CHRONIC_U_ERX
+196 SET EMPTY=0
+197 IF DRUGCLAS=" "
SET UNKNOWNS=1
End DoDot:3
End DoDot:2
End DoDot:1
+198 ;
+199 ; *** Check for empty condition ***
+200 ;
+201 IF EMPTY
Begin DoDot:1
+202 DO ADD^BTIUMED1("No Medications Found")
+203 DO ADD^BTIUMED1(" ")
End DoDot:1
GOTO LISTX
+204 ;
+205 ; *** Sort Meds in "C" temp xref - sort by Med Type, Status
+206 ; Med Name, and reverse issue date, followed by a counter
+207 ; to avoid erasing meds issued on the same day
+208 ;
+209 SET MED=""
SET CNT=1000000
+210 FOR
SET MED=$ORDER(@TARGET@("B",MED))
IF MED=""
QUIT
Begin DoDot:1
+211 SET IDATE=""
+212 FOR
SET IDATE=$ORDER(@TARGET@("B",MED,IDATE))
IF IDATE=""
QUIT
Begin DoDot:2
+213 SET XSTR=""
+214 FOR
SET XSTR=$ORDER(@TARGET@("B",MED,IDATE,XSTR))
IF XSTR=""
QUIT
Begin DoDot:3
+215 SET NODE=@TARGET@("B",MED,IDATE,XSTR)
+216 SET DATA=MED_U_$PIECE(NODE,U,3)_U_$PIECE(NODE,U,5)
SET CNT=CNT+1
+217 SET @TARGET@("C",DATA,(9999999-$PIECE(NODE,U))_CNT)=$PIECE(NODE,U,2)_U_$PIECE(NODE,U,5)_U_$PIECE(NODE,U,7)_U_$PIECE(NODE,U,8)
End DoDot:3
End DoDot:2
End DoDot:1
+218 KILL @TARGET@("B")
+219 ;
+220 ; Read sorted data and save final version to TARGET
+221 ;
+222 SET (DATA,LASTCLAS,LSTINDIC)=""
SET (LASTMEDT,LASTSTS,COUNT,TOTAL)=0
+223 SET $PIECE(SPACE60," ",60)=" "
SET $PIECE(DASH73,"=",73)="="
+224 DO WARNING^BTIUMED1
+225 FOR
SET DATA=$ORDER(@TARGET@("C",DATA))
IF DATA=""
QUIT
Begin DoDot:1
+226 SET DATA1=$PIECE(DATA,U,2)
+227 SET MEDTYPE=$EXTRACT(DATA1)
SET STATIDX=$EXTRACT(DATA1,2)
+228 SET DRUGCLAS=$PIECE(DATA,U,2)
SET MED=$PIECE(DATA,U,3)
SET CNT=""
+229 FOR
SET CNT=$ORDER(@TARGET@("C",DATA,CNT))
IF CNT=""
QUIT
Begin DoDot:2
+230 SET INDEX=@TARGET@("C",DATA,CNT)
+231 SET TYPE=$PIECE(INDEX,U,2)
SET CHRONIC=$PIECE(INDEX,U,3)
SET ERX=$PIECE(INDEX,U,4)
SET INDEX=+INDEX
+232 SET NODE=^TMP("PS",$JOB,INDEX,0)
+233 ;If hold meds, find the reason and add it to the node data
+234 SET STATUS=$PIECE(NODE,U,9)
+235 IF STATUS="HOLD"
Begin DoDot:3
+236 SET HIEN=+($PIECE(NODE,U))
+237 SET REASON=$$GET1^DIQ(52,HIEN,99,"E")
+238 SET $PIECE(NODE,U,18)=REASON
End DoDot:3
+239 IF DETAILED
Begin DoDot:3
+240 SET HIEN=$PIECE(NODE,U)
+241 IF CLININC>0
Begin DoDot:4
End DoDot:4
+242 ;Patch 1016 changes for clinical indication
+243 IF HIEN["R"
Begin DoDot:4
+244 SET HIEN=+HIEN
+245 SET INDIC=$$GET1^DIQ(52,HIEN,9999999.21,"E")
+246 SET $PIECE(NODE,U,19)=INDIC
End DoDot:4
+247 IF ERX'=""
SET $PIECE(NODE,U,31)=ERX
End DoDot:3
+248 IF $PIECE($PIECE(NODE,U),";")["N"
SET $PIECE(NODE,U,2)=$PIECE(NODE,U,2)_" (O)"
+249 IF CHRONIC="Y"
SET $PIECE(NODE,U,2)=$PIECE(NODE,U,2)_" (C)"
+250 ;E S $P(NODE,U,2)=" "_$P(NODE,U,2)
+251 ;I (MEDTYPE'=LASTMEDT)!(STATIDX'=LASTSTS)!(INDIC'=LSTINDIC) D ; Create Header
+252 ; Create Header
IF (MEDTYPE'=LASTMEDT)!(CLININC=2&(INDIC'=LSTINDIC))
Begin DoDot:3
+253 IF CLASSORT'=2
IF DRUGCLAS'=" "
SET LASTCLAS=DRUGCLAS
+254 IF 'HEADER
QUIT
+255 SET LASTMEDT=MEDTYPE
SET LASTSTS=STATIDX
SET TAB=0
+256 IF COUNT>0
DO ADD^BTIUMED1(" ")
+257 IF CLASSORT
DO ADD^BTIUMED1(" ")
+258 SET COUNT=0
+259 IF DETAILED
Begin DoDot:4
+260 IF MEDTYPE=OUTPTYPE
Begin DoDot:5
+261 DO ADD^BTIUMED1($EXTRACT($EXTRACT(SPACE60,1,47)_"Status"_SPACE60,1,60)_"Last Fill")
End DoDot:5
IF 1
+262 IF '$TEST
DO ADD^BTIUMED1(SPACE60_"Start Date")
End DoDot:4
+263 SET TEMP=""
+264 IF 'ONELIST
Begin DoDot:4
+265 SET TEMP=TEMP_$SELECT(MEDTYPE=INPTYPE:"Inpatient",1:"Outpatient")
+266 IF ACTVONLY=3
SET TEMP="HOLD"
+267 SET TEMP=" "_TEMP_" Medications"
End DoDot:4
+268 IF CLASSORT
Begin DoDot:4
+269 IF DETAILED
SET TEMP=TEMP_" (By Class)"
+270 IF '$TEST
SET TEMP=TEMP_" (By Drug Class)"
+271 IF MEDTYPE=OUTPTYPE&(CLININC>0)
SET TEMP=TEMP_" (By Clinical Indication)"
End DoDot:4
+272 IF DETAILED
Begin DoDot:4
+273 SET TEMP=$EXTRACT(TEMP_SPACE60,1,47)
+274 IF MEDTYPE=INPTYPE
SET TEMP=TEMP_"Status"
+275 IF '$TEST
SET TEMP=TEMP_"Refills"
+276 SET TEMP=$EXTRACT(TEMP_SPACE60,1,60)
+277 IF MEDTYPE=INPTYPE
SET TEMP=TEMP_"Stop Date"
+278 IF '$TEST
SET TEMP=TEMP_"Expiration"
End DoDot:4
IF 1
+279 IF '$TEST
Begin DoDot:4
+280 SET TEMP=$EXTRACT(TEMP_SPACE60,1,60)_"Status"
End DoDot:4
+281 DO ADD^BTIUMED1(TEMP)
DO ADD^BTIUMED1(DASH73)
End DoDot:3
+282 IF CLASSORT
IF DRUGCLAS'=""
IF DRUGCLAS'=LASTCLAS
Begin DoDot:3
+283 SET LASTCLAS=DRUGCLAS
SET OLDTAB=TAB
SET OLDHEADR=HEADER
End DoDot:3
+284 IF CLININC=2
IF INDIC'=LSTINDIC
Begin DoDot:3
+285 SET LSTINDIC=INDIC
SET OLDTAB=TAB
SET OLDHEADR=HEADER
+286 SET (TAB,HEADER)=0
+287 IF COUNT>0
DO ADD^BTIUMED1(" ")
+288 IF (CLASSORT=2)!(DRUGCLAS=" ")
Begin DoDot:4
+289 IF DRUGCLAS=" "
SET TEMP=" ====== Drug Class Unknown "
+290 IF '$TEST
SET TEMP=" ====== Drug Class: "_DRUGCLAS_" "
End DoDot:4
IF 1
+291 IF REASON=1
Begin DoDot:4
+292 IF INDIC=""
SET TEMP=" ====== Unknown Indication "
+293 IF '$TEST
SET TEMP=" ====== "_INDIC_" "
End DoDot:4
+294 IF '$TEST
SET TEMP=" "
+295 SET TEMP=$EXTRACT(TEMP_DASH73,1,LLEN-2)
+296 DO ADD^BTIUMED1(TEMP)
+297 SET HEADER=OLDHEADR
SET TAB=OLDTAB
End DoDot:3
+298 SET COUNT=COUNT+1
SET TOTAL=TOTAL+1
+299 DO ADDMED^BTIUMED1(0)
End DoDot:2
End DoDot:1
+300 IF COUNT'=TOTAL
Begin DoDot:1
+301 SET TAB=0
+302 DO ADD^BTIUMED1(" ")
+303 DO ADD^BTIUMED1(TOTAL_" Total Medications")
End DoDot:1
+304 DO ADD^BTIUMED1(" ")
+305 DO ADD^BTIUMED1("(X)behind status of medication depicts that the medication was sent to an external pharmacy")
+306 KILL @TARGET@("C")
LISTX KILL ^TMP("PS",$JOB)
+1 QUIT "~@"_$NAME(@TARGET)
+2 ;
GETCLASS ; Get Drug Class, filter out supplies
+1 DO GETCLASS^TIULMED3
+2 QUIT
