BTIUMED6 ; SLC/JM - Active/Recent Med Objects Routine ;16-Sep-2013 15:39;DU
;;1.0;TEXT INTEGRATION UTILITIES;**1009,1010,1011,1012**;Jun 20, 1997;Build 45
;Patch 1011 changes to use new pharmacy APIS
Q
LIST(DFN,TARGET,CLININC) ; EP
;
; This is the TIU Medication object for medication reconciliation .
; Combined report with all meds of the same status combined
;
;Required Parameters:
;
; DFN Patient identifier
;
; TARGET Where the medication data will be stored
;
;Optional Parameters:
;
; CLININC 1=Clinical Indication will be included
;
N NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,OK,RXNO,CHRONIC,LDATE,CANDATE,EXDATE,DETAILED
N INPTYPE,OUTPTYPE,TYPE,MEDTYPE,CNT,DATA,DATA1,MED,IDATE,XSTR,LLEN,DAYS,ACTVONLY,ONELIST
N LASTMEDT,LASTSTS,COUNT,TOTAL,SPACE60,DASH73,TEMP,LINE,TAB,HEADER,CLASSORT,ERX
N DRUGCLAS,DRUGIDX,LASTCLAS,OLDTAB,OLDHEADR,UNKNOWNS,LSTINDIC,SUPPLIES,AUTO
N IFN,NVATYPE,NVAMED,NVASTR,TIUXSTAT,CLIN,HIEN,IEN,REASON,REFILLS,COUNTER,EVENT
N %,%H,STOP,LSTFD ;Clean up after external calls...
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(CLININC)'=1 S CLININC=0
S (EMPTY,HEADER)=1
S HEADER=1
S ISINP=($G(^DPT(DFN,.1))'="") ; Is this an inpatient?
S OUTPTYPE=1,INPTYPE=2,NVATYPE=3
;
; *** Scan medication data and skip unwanted meds ***
;
S DAYS=180,ACTVONLY=0,ONELIST=0,DETAILED=1
D OCL^PSOORRL(DFN,$$FMADD^XLFDT(DT,-DAYS),"")
S INDEX=0,CLASSORT=0,SUPPLIES=0
F S INDEX=$O(^TMP("PS",$J,INDEX)) Q:INDEX'>0 D
.S CHRONIC="",AUTO=0,ERX=""
.S NODE=$G(^TMP("PS",$J,INDEX,0))
.S KEEPMED=($L($P(NODE,U,2))>0) ;Discard Blank Meds
.;Group meds by status
.S STATUS=$P(NODE,U,9)
.I STATUS="ACTIVE/SUSP" S STATUS="ACTIVE (S)"
.S IDATE=$P(NODE,U,15)
.I $P($P(NODE,U),";",2)["O" D
..S RXNO=+($P(NODE,U,1))
..S AUTO=$P($G(^PSRX(RXNO,999999921)),U,3)
.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))
.I NVAMED="N" D
..S IFN=+$P(NODE,U,8)
..S STATUS=$$NVSTS^BEHORXFN(IFN,$P(NODE,U,9))
..S $P(NODE,U,9)=STATUS
.I STATUS="EXPIRED" D
..I $P($P(NODE,U),";",2)["O" D
...S RXNO=+($P(NODE,U,1))
...S CHRONIC=$P($G(^PSRX(RXNO,9999999)),U,2)
...N X,X1,X2
...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=0
..I $P($P(NODE,U),";",2)["I" D
...S EXDATE=$P(NODE,U,4)
...S X1=DT,X2=-14 D C^%DTC S LDATE=X
...I EXDATE<LDATE S KEEPMED=0
.I STATUS["DISCONTINUED" D
..I TYPE="OP" D
...I NVAMED="N" S KEEPMED=0 Q
...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=0
..I TYPE="UD" D
...S X1=DT,X2=-2 D C^%DTC S LDATE=X
...S CANDATE=$P(NODE,U,4)
...I CANDATE<LDATE S KEEPMED=0
..I STATUS="DISCONTINUED/EDIT"!(STATUS="DISCONTINUED (EDIT)") S KEEPMED=0
.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 STATUS="HOLD"!(STATUS["TRANSFER") S STATUS="OUTSIDE "_STATUS
.I TYPE="" S KEEPMED=0
.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 NVAMED="N" S MEDTYPE=NVATYPE
.S DRUGCLAS=" "
.S MED=$P(NODE,U,2)
.I KEEPMED 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
....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
....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)
....W !,ORDIDX
...I ID="U;I" D
....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
....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,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,XSTR))
..I 'OK,(IDATE>+@TARGET@("B",MED,XSTR)) S OK=1
..I 'OK,$P(@TARGET@("B",MED,XSTR),U,4)'=STATUS S OK=1
..I OK D
...S @TARGET@("B",MED,IDATE,XSTR)=IDATE_U_INDEX_U_MEDTYPE_U_STATUS_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 Status,MedType,
; 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 STATUS=$P(NODE,U,4)
...S @TARGET@("C",STATUS,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)_U_$P(NODE,U,3)
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
S STATUS="",MEDTYPE=""
F S STATUS=$O(@TARGET@("C",STATUS)) Q:STATUS="" D
.F S DATA=$O(@TARGET@("C",STATUS,DATA)) Q:DATA="" D
..S DRUGCLAS=$P(DATA,U,2),MED=$P(DATA,U,3),CNT=""
..F S CNT=$O(@TARGET@("C",STATUS,DATA,CNT)) Q:CNT="" D
...S INDEX=@TARGET@("C",STATUS,DATA,CNT)
...S TYPE=$P(INDEX,U,2),CHRONIC=$P(INDEX,U,3),MEDTYPE=$P(INDEX,U,5),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
...I STATUS="HOLD" D
....S HIEN=+($P(NODE,U))
....S REASON=$$GET1^DIQ(52,HIEN,99,"E")
....S NODE=NODE_U_REASON
...I CLININC=1 D
....S HIEN=+($P(NODE,U))
....S CLIN=$$GET1^DIQ(52,HIEN,9999999.21,"E")
....S $P(NODE,U,2)=$P(NODE,U,2)_" "_CLIN
...E S $P(NODE,U,2)=" "_$P(NODE,U,2)
...I ERX'="" S $P(NODE,U,31)=ERX
...I (STATUS'=LASTSTS) D ; Create Header
....I 'HEADER Q
....S LASTSTS=STATUS,TAB=0
....I COUNT>0 D ADD^BTIUMED1(" ")
....S COUNT=0
....D ADD^BTIUMED1($E($E(SPACE60,1,47)_"Status"_SPACE60,1,60)_"Last Fill")
....S TEMP=STATUS_" "
....S TEMP=STATUS_" Medications"
....S TEMP=$E(TEMP_SPACE60,1,47)
....S TEMP=TEMP_"Refills"
....S TEMP=$E(TEMP_SPACE60,1,60)
....I MEDTYPE=INPTYPE S TEMP=TEMP_"Stop/Exp Dte"
....D ADD^BTIUMED1(TEMP),ADD^BTIUMED1(DASH73)
...S COUNT=COUNT+1,TOTAL=TOTAL+1
...D ADDMED^BTIUMED1(0,1)
I COUNT'=TOTAL D
.S TAB=0
.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
BTIUMED6 ; SLC/JM - Active/Recent Med Objects Routine ;16-Sep-2013 15:39;DU
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1009,1010,1011,1012**;Jun 20, 1997;Build 45
+2 ;Patch 1011 changes to use new pharmacy APIS
+3 QUIT
LIST(DFN,TARGET,CLININC) ; EP
+1 ;
+2 ; This is the TIU Medication object for medication reconciliation .
+3 ; Combined report with all meds of the same status combined
+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 ; CLININC 1=Clinical Indication will be included
+14 ;
+15 NEW NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,OK,RXNO,CHRONIC,LDATE,CANDATE,EXDATE,DETAILED
+16 NEW INPTYPE,OUTPTYPE,TYPE,MEDTYPE,CNT,DATA,DATA1,MED,IDATE,XSTR,LLEN,DAYS,ACTVONLY,ONELIST
+17 NEW LASTMEDT,LASTSTS,COUNT,TOTAL,SPACE60,DASH73,TEMP,LINE,TAB,HEADER,CLASSORT,ERX
+18 NEW DRUGCLAS,DRUGIDX,LASTCLAS,OLDTAB,OLDHEADR,UNKNOWNS,LSTINDIC,SUPPLIES,AUTO
+19 NEW IFN,NVATYPE,NVAMED,NVASTR,TIUXSTAT,CLIN,HIEN,IEN,REASON,REFILLS,COUNTER,EVENT
+20 ;Clean up after external calls...
NEW %,%H,STOP,LSTFD
+21 SET (NEXTLINE,TAB,HEADER,UNKNOWNS)=0
SET LLEN=47
+22 KILL @TARGET,^TMP("PS",$JOB)
+23 ; Check for Pharmacy Package and required patches
+24 ;P213
IF '$$PATCHSOK^TIULMED3
GOTO LISTX
+25 IF $GET(CLININC)'=1
SET CLININC=0
+26 SET (EMPTY,HEADER)=1
+27 SET HEADER=1
+28 ; Is this an inpatient?
SET ISINP=($GET(^DPT(DFN,.1))'="")
+29 SET OUTPTYPE=1
SET INPTYPE=2
SET NVATYPE=3
+30 ;
+31 ; *** Scan medication data and skip unwanted meds ***
+32 ;
+33 SET DAYS=180
SET ACTVONLY=0
SET ONELIST=0
SET DETAILED=1
+34 DO OCL^PSOORRL(DFN,$$FMADD^XLFDT(DT,-DAYS),"")
+35 SET INDEX=0
SET CLASSORT=0
SET SUPPLIES=0
+36 FOR
SET INDEX=$ORDER(^TMP("PS",$JOB,INDEX))
IF INDEX'>0
QUIT
Begin DoDot:1
+37 SET CHRONIC=""
SET AUTO=0
SET ERX=""
+38 SET NODE=$GET(^TMP("PS",$JOB,INDEX,0))
+39 ;Discard Blank Meds
SET KEEPMED=($LENGTH($PIECE(NODE,U,2))>0)
+40 ;Group meds by status
+41 SET STATUS=$PIECE(NODE,U,9)
+42 IF STATUS="ACTIVE/SUSP"
SET STATUS="ACTIVE (S)"
+43 SET IDATE=$PIECE(NODE,U,15)
+44 IF $PIECE($PIECE(NODE,U),";",2)["O"
Begin DoDot:2
+45 SET RXNO=+($PIECE(NODE,U,1))
+46 SET AUTO=$PIECE($GET(^PSRX(RXNO,999999921)),U,3)
End DoDot:2
+47 SET TYPE=$PIECE($PIECE(NODE,U),";",2)
+48 SET TYPE=$SELECT(TYPE="O":"OP",TYPE="I":"UD",1:"")
+49 SET NVAMED=$PIECE($PIECE(NODE,U),";")
+50 SET NVAMED=$EXTRACT(NVAMED,$LENGTH(NVAMED))
+51 IF NVAMED="N"
Begin DoDot:2
+52 SET IFN=+$PIECE(NODE,U,8)
+53 SET STATUS=$$NVSTS^BEHORXFN(IFN,$PIECE(NODE,U,9))
+54 SET $PIECE(NODE,U,9)=STATUS
End DoDot:2
+55 IF STATUS="EXPIRED"
Begin DoDot:2
+56 IF $PIECE($PIECE(NODE,U),";",2)["O"
Begin DoDot:3
+57 SET RXNO=+($PIECE(NODE,U,1))
+58 SET CHRONIC=$PIECE($GET(^PSRX(RXNO,9999999)),U,2)
+59 NEW X,X1,X2
+60 IF CHRONIC
SET X1=DT
SET X2=-120
DO C^%DTC
SET LDATE=X
+61 IF '$TEST
SET X1=DT
SET X2=-14
DO C^%DTC
SET LDATE=X
+62 SET EXDATE=$PIECE($GET(^PSRX(RXNO,2)),U,6)
+63 IF EXDATE<LDATE
SET KEEPMED=0
End DoDot:3
+64 IF $PIECE($PIECE(NODE,U),";",2)["I"
Begin DoDot:3
+65 SET EXDATE=$PIECE(NODE,U,4)
+66 SET X1=DT
SET X2=-14
DO C^%DTC
SET LDATE=X
+67 IF EXDATE<LDATE
SET KEEPMED=0
End DoDot:3
End DoDot:2
+68 IF STATUS["DISCONTINUED"
Begin DoDot:2
+69 IF TYPE="OP"
Begin DoDot:3
+70 IF NVAMED="N"
SET KEEPMED=0
QUIT
+71 SET X1=DT
SET X2=-30
DO C^%DTC
SET LDATE=X
+72 SET CANDATE=$PIECE($GET(^PSRX(RXNO,3)),U,5)
+73 IF CANDATE<LDATE
SET KEEPMED=0
End DoDot:3
+74 IF TYPE="UD"
Begin DoDot:3
+75 SET X1=DT
SET X2=-2
DO C^%DTC
SET LDATE=X
+76 SET CANDATE=$PIECE(NODE,U,4)
+77 IF CANDATE<LDATE
SET KEEPMED=0
End DoDot:3
+78 IF STATUS="DISCONTINUED/EDIT"!(STATUS="DISCONTINUED (EDIT)")
SET KEEPMED=0
End DoDot:2
+79 IF STATUS="PENDING"
Begin DoDot:2
+80 SET IEN=+($PIECE(NODE,U))
+81 IF IEN>0
SET REFILLS=$PIECE($GET(^PS(52.41,IEN,0)),U,11)
+82 SET $PIECE(^TMP("PS",$JOB,INDEX,0),U,5)=REFILLS
+83 ;I STATUS="HOLD"!(STATUS["TRANSFER") S STATUS="OUTSIDE "_STATUS
End DoDot:2
+84 IF TYPE=""
SET KEEPMED=0
+85 IF KEEPMED
Begin DoDot:2
+86 IF $ORDER(^TMP("PS",$JOB,INDEX,"A",0))>0
SET TYPE="IV"
+87 IF '$TEST
IF $ORDER(^TMP("PS",$JOB,INDEX,"B",0))>0
SET TYPE="IV"
+88 IF TYPE="OP"
SET MEDTYPE=OUTPTYPE
+89 IF '$TEST
SET MEDTYPE=INPTYPE
+90 IF NVAMED="N"
SET MEDTYPE=NVATYPE
End DoDot:2
+91 SET DRUGCLAS=" "
+92 SET MED=$PIECE(NODE,U,2)
+93 IF KEEPMED
Begin DoDot:2
+94 SET DRUGIDX=$$IENNAME^TIULMED2(MED)
+95 DO GETCLASS
+96 ;Find orderable item
IF KEEPMED
IF +DRUGIDX=0
Begin DoDot:3
+97 NEW IDX,ID,ORDIDX,TMPCLASS,CDONE,SDONE,TMPIDX,TMPNODE,ISSUPPLY
+98 SET ID=$PIECE(NODE,U)
SET IDX=+ID
SET ID=$EXTRACT(ID,$LENGTH(IDX)+1,$LENGTH(ID))
+99 SET (DRUGIDX,ORDIDX)=0
+100 KILL ^TMP($JOB,"TIULMED")
+101 ; IDX is Order #; ID indicates what file. See IA 2400
+102 ; R;O MED will always be in Drug File (Unless Drug File entry was
+103 ; changed after ordering.
+104 IF ID="R;O"
Begin DoDot:4
+105 ; IA 4820
DO RX^PSO52API(DFN,"TIULMED",IDX,"","0,O")
+106 SET DRUGIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,6))
+107 SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,"OI"))
End DoDot:4
+108 IF ID="P;O"
Begin DoDot:4
+109 ; IA 4821
DO PEN^PSO5241(DFN,"TIULMED",IDX)
+110 SET DRUGIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,11))
+111 SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,8))
End DoDot:4
+112 IF ID="P;I"
Begin DoDot:4
+113 IF $PIECE($GET(^PS(53.1,IDX,1,0)),U,4)=1
Begin DoDot:5
+114 SET TMPIDX=$ORDER(^PS(53.1,IDX,1,0))
IF +TMPIDX
Begin DoDot:6
+115 SET DRUGIDX=$PIECE($GET(^PS(53.1,IDX,1,TMPIDX,0)),U)
End DoDot:6
End DoDot:5
+116 SET ORDIDX=+$PIECE($GET(^PS(53.1,IDX,.2)),U)
+117 WRITE !,ORDIDX
End DoDot:4
+118 IF ID="U;I"
Begin DoDot:4
+119 ; IA 4826
DO PSS431^PSS55(DFN,IDX,"","","TIULMED")
+120 IF +$GET(^TMP($JOB,"TIULMED",IDX,"DDRUG",0))=1
Begin DoDot:5
+121 SET TMPIDX=$ORDER(^TMP($JOB,"TIULMED",IDX,"DDRUG",0))
IF TMPIDX'>0
QUIT
+122 SET DRUGIDX=+$GET(^TMP($JOB,"TIULMED",IDX,"DDRUG",TMPIDX,.01))
End DoDot:5
+123 SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",IDX,108))
End DoDot:4
+124 IF ID="V;I"
Begin DoDot:4
+125 ; IA 4826
DO PSS436^PSS55(DFN,IDX,"TIULMED")
+126 ; Get ORDIDX before DRUGIDX since global is not there after DRUGIDX
+127 SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",IDX,130))
+128 IF ^TMP($JOB,"TIULMED",IDX,"ADD",0)=1
Begin DoDot:5
+129 SET TMPIDX=$ORDER(^TMP($JOB,"TIULMED",IDX,"ADD",0))
IF +TMPIDX
Begin DoDot:6
+130 SET TMPIDX=+$GET(^TMP($JOB,"TIULMED",IDX,"ADD",TMPIDX,.01))
+131 ; IA 4662
IF +TMPIDX
SET DRUGIDX=$$DRGIEN^TIULMED2(TMPIDX)
End DoDot:6
End DoDot:5
End DoDot:4
+132 SET DRUGCLAS=""
+133 DO GETCLASS
+134 IF KEEPMED
IF +DRUGIDX=0
IF +ORDIDX
IF DRUGCLAS=""
Begin DoDot:4
+135 SET IDX=0
SET ISSUPPLY=2
SET CDONE='CLASSORT
SET SDONE=+SUPPLIES
+136 NEW LIST
SET LIST="TIULMED"
KILL ^TMP($JOB,LIST)
+137 ; IA 4662
DO DRGIEN^PSS50P7(ORDIDX,"",LIST)
+138 FOR
SET IDX=$ORDER(^TMP($JOB,LIST,IDX))
IF 'IDX
QUIT
Begin DoDot:5
+139 SET TMPCLASS=$$DRGCLASS^TIULMED2(IDX)
+140 SET TMPNODE=U_TMPCLASS_U_$$DEA^TIULMED2(IDX)
+141 IF 'CDONE
IF TMPCLASS=""
SET CDONE=1
SET DRUGCLAS=""
+142 IF 'CDONE
Begin DoDot:6
+143 IF DRUGCLAS=""
SET DRUGCLAS=TMPCLASS
+144 IF '$TEST
IF DRUGCLAS'=TMPCLASS
SET CDONE=1
SET DRUGCLAS=""
End DoDot:6
+145 IF 'SDONE
Begin DoDot:6
+146 SET ISSUPPLY=(($EXTRACT(TMPCLASS,1,2)="XA")&($PIECE(TMPNODE,U,3)["S"))
+147 IF 'ISSUPPLY
SET SDONE=1
End DoDot:6
End DoDot:5
IF (CDONE&SDONE)
QUIT
+148 IF 'SUPPLIES
IF (ISSUPPLY=1)
SET KEEPMED=0
End DoDot:4
End DoDot:3
+149 IF (DRUGCLAS="")!('CLASSORT)
SET DRUGCLAS=" "
+150 IF AUTO=1
Begin DoDot:3
+151 SET ERX=$PIECE($GET(^PSRX(RXNO,999999921)),U,4)
+152 IF +ERX
SET ERX=ERX_";"_RXNO
+153 SET $PIECE(^TMP("PS",$JOB,INDEX,0),U,9)=STATUS_" (X)"
End DoDot:3
End DoDot:2
+154 ;
+155 ; *** Save wanted meds in "B" temp xref, removing duplicates ***
+156 ;
+157 IF KEEPMED
Begin DoDot:2
+158 ; Get XSTR to check for duplicates
DO ADDMED^BTIUMED1(1,1)
+159 SET IDATE=$PIECE(NODE,U,15)
+160 IF $PIECE($PIECE(NODE,U),";")["N"
SET IDATE=$$DT^XLFDT
+161 IF $PIECE(NODE,U,9)="PENDING"!($PIECE(NODE,U,9)="HOLD")
SET IDATE=$$DT^XLFDT
+162 SET OK='$DATA(@TARGET@("B",MED,XSTR))
+163 IF 'OK
IF (IDATE>+@TARGET@("B",MED,XSTR))
SET OK=1
+164 IF 'OK
IF $PIECE(@TARGET@("B",MED,XSTR),U,4)'=STATUS
SET OK=1
+165 IF OK
Begin DoDot:3
+166 SET @TARGET@("B",MED,IDATE,XSTR)=IDATE_U_INDEX_U_MEDTYPE_U_STATUS_U_TYPE_U_DRUGCLAS_U_CHRONIC_U_ERX
+167 SET EMPTY=0
+168 IF DRUGCLAS=" "
SET UNKNOWNS=1
End DoDot:3
End DoDot:2
End DoDot:1
+169 ;
+170 ; *** Check for empty condition ***
+171 ;
+172 IF EMPTY
Begin DoDot:1
+173 DO ADD^BTIUMED1("No Medications Found")
+174 DO ADD^BTIUMED1(" ")
End DoDot:1
GOTO LISTX
+175 ;
+176 ; *** Sort Meds in "C" temp xref - sort by Status,MedType,
+177 ; Med Name, and reverse issue date, followed by a counter
+178 ; to avoid erasing meds issued on the same day
+179 ;
+180 SET MED=""
SET CNT=1000000
+181 FOR
SET MED=$ORDER(@TARGET@("B",MED))
IF MED=""
QUIT
Begin DoDot:1
+182 SET IDATE=""
+183 FOR
SET IDATE=$ORDER(@TARGET@("B",MED,IDATE))
IF IDATE=""
QUIT
Begin DoDot:2
+184 SET XSTR=""
+185 FOR
SET XSTR=$ORDER(@TARGET@("B",MED,IDATE,XSTR))
IF XSTR=""
QUIT
Begin DoDot:3
+186 SET NODE=@TARGET@("B",MED,IDATE,XSTR)
+187 SET DATA=MED_U_$PIECE(NODE,U,3)_U_$PIECE(NODE,U,5)
SET CNT=CNT+1
+188 SET STATUS=$PIECE(NODE,U,4)
+189 SET @TARGET@("C",STATUS,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)_U_$PIECE(NODE,U,3)
End DoDot:3
End DoDot:2
End DoDot:1
+190 KILL @TARGET@("B")
+191 ;
+192 ; Read sorted data and save final version to TARGET
+193 ;
+194 SET (DATA,LASTCLAS,LSTINDIC)=""
SET (LASTMEDT,LASTSTS,COUNT,TOTAL)=0
+195 SET $PIECE(SPACE60," ",60)=" "
SET $PIECE(DASH73,"=",73)="="
+196 DO WARNING^BTIUMED1
+197 SET STATUS=""
SET MEDTYPE=""
+198 FOR
SET STATUS=$ORDER(@TARGET@("C",STATUS))
IF STATUS=""
QUIT
Begin DoDot:1
+199 FOR
SET DATA=$ORDER(@TARGET@("C",STATUS,DATA))
IF DATA=""
QUIT
Begin DoDot:2
+200 SET DRUGCLAS=$PIECE(DATA,U,2)
SET MED=$PIECE(DATA,U,3)
SET CNT=""
+201 FOR
SET CNT=$ORDER(@TARGET@("C",STATUS,DATA,CNT))
IF CNT=""
QUIT
Begin DoDot:3
+202 SET INDEX=@TARGET@("C",STATUS,DATA,CNT)
+203 SET TYPE=$PIECE(INDEX,U,2)
SET CHRONIC=$PIECE(INDEX,U,3)
SET MEDTYPE=$PIECE(INDEX,U,5)
SET ERX=$PIECE(INDEX,U,4)
SET INDEX=+INDEX
+204 SET NODE=^TMP("PS",$JOB,INDEX,0)
+205 ;If hold meds, find the reason and add it to the node data
+206 IF STATUS="HOLD"
Begin DoDot:4
+207 SET HIEN=+($PIECE(NODE,U))
+208 SET REASON=$$GET1^DIQ(52,HIEN,99,"E")
+209 SET NODE=NODE_U_REASON
End DoDot:4
+210 IF CLININC=1
Begin DoDot:4
+211 SET HIEN=+($PIECE(NODE,U))
+212 SET CLIN=$$GET1^DIQ(52,HIEN,9999999.21,"E")
+213 SET $PIECE(NODE,U,2)=$PIECE(NODE,U,2)_" "_CLIN
End DoDot:4
+214 IF '$TEST
SET $PIECE(NODE,U,2)=" "_$PIECE(NODE,U,2)
+215 IF ERX'=""
SET $PIECE(NODE,U,31)=ERX
+216 ; Create Header
IF (STATUS'=LASTSTS)
Begin DoDot:4
+217 IF 'HEADER
QUIT
+218 SET LASTSTS=STATUS
SET TAB=0
+219 IF COUNT>0
DO ADD^BTIUMED1(" ")
+220 SET COUNT=0
+221 DO ADD^BTIUMED1($EXTRACT($EXTRACT(SPACE60,1,47)_"Status"_SPACE60,1,60)_"Last Fill")
+222 SET TEMP=STATUS_" "
+223 SET TEMP=STATUS_" Medications"
+224 SET TEMP=$EXTRACT(TEMP_SPACE60,1,47)
+225 SET TEMP=TEMP_"Refills"
+226 SET TEMP=$EXTRACT(TEMP_SPACE60,1,60)
+227 IF MEDTYPE=INPTYPE
SET TEMP=TEMP_"Stop/Exp Dte"
+228 DO ADD^BTIUMED1(TEMP)
DO ADD^BTIUMED1(DASH73)
End DoDot:4
+229 SET COUNT=COUNT+1
SET TOTAL=TOTAL+1
+230 DO ADDMED^BTIUMED1(0,1)
End DoDot:3
End DoDot:2
End DoDot:1
+231 IF COUNT'=TOTAL
Begin DoDot:1
+232 SET TAB=0
+233 DO ADD^BTIUMED1(" ")
+234 DO ADD^BTIUMED1("(X)behind status of medication depicts that the medication was sent to an external pharmacy")
End DoDot:1
+235 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
