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