BTIUMED8 ; SLC/JM - Active/Recent Med Objects Routine ;14-Mar-2013 16:15;DU
;;1.0;TEXT INTEGRATION UTILITIES;**1010,1011**;Jun 20, 1997;Build 13
;Patch 1011 changed to new pharmacy APIs
Q
LIST(DFN,TARGET) ; EP
;
; Medication object for detailed meds for pharmacists
;
;
;Required Parameters:
;
; DFN Patient identifier
;
; TARGET Where the medication data will be stored
;
N NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,ASTATS,PSTATS,OK,RXNO,CHRONIC,ARRAY1,ARRAY2
N STATIDX,OUTPTYPE,TYPE,MEDTYPE,CNT,DATA,DATA1,MED,IDATE,XSTR,LLEN,DAYS,AUTO,ERX
N LASTMEDT,LASTSTS,COUNT,TOTAL,SPACE60,DASH73,TEMP,LINE,TAB,HEADER,RXNUM,IEN,RX
N DRUGCLAS,DRUGIDX,LASTCLAS,OLDTAB,OLDHEADR,UNKNOWNS,INDIC,LSTINDIC,PHARM,HSTATS,CHK
N %,%H,STOP,LSTFD,ALLMEDS,CLASS,DETAILED,DRUG,REASON,REFILLS,FILLS,NRXN,HIEN,VST
N CLASSORT,CLININC,ACTVONLY,CNT1,CNT2,ONELIST,SUPPLIES
S (NEXTLINE,TAB,HEADER,UNKNOWNS)=0,LLEN=47
S PHARM=1
K @TARGET,^TMP("PS",$J)
; Check for Pharmacy Package and required patches
I '$$PATCHSOK^TIULMED3 G LISTX ;P213
S ACTVONLY=0
S ALLMEDS=3,DETAILED=1
S ONELIST=0
S CLASSORT=0
S SUPPLIES=1
S CLININC=0
S (EMPTY,HEADER)=1
I ONELIST,'CLASSORT,'CLININC S HEADER=0
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=1 S @TARGET@(1,0)="Patient is an inpatient" Q "~@"_$NA(@TARGET)
D ADDTITLE^BTIUMED1(1)
;
; *** Scan medication data and skip unwanted meds ***
;
D OCL^PSOORRL(DFN,$$FMADD^XLFDT(DT,-1),"")
;
;*** Get the visit to check on ***
S VST=$$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID",,"CONTEXT.ENCOUNTER")
I VST="" S @TARGET@(1,0)="Invalid visit" Q "~@"_$NA(@TARGET)
S X="BEHOENCX" X ^%ZOSF("TEST") I $T S VST=+$$VSTR2VIS^BEHOENCX(DFN,VST) I VST<1 S @TARGET@(1,0)="Invalid visit" Q "~@"_$NA(@TARGET)
;
;Get array of visit items
N VMIEN,NUM,NUM2
S VMIEN="",CNT1=0,CNT2=0,ARRAY1="",ARRAY2=""
F S VMIEN=$O(^AUPNVMED("AD",VST,VMIEN)) Q:'+VMIEN D
.S NUM=$P($G(^AUPNVMED(VMIEN,11)),U,2)
.I NUM'="" S ARRAY1(NUM)=""
.S NUM2=$P($G(^AUPNVMED(VMIEN,11)),U,8)
.I NUM2'="" S ARRAY2(NUM2)=""
;
Q:$D(ARRAY1)=0&($D(ARRAY2)=0)
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)) ;Prescription IEN
.S AUTO=$P($G(^PSRX(RXNO,999999921)),U,3)
.S CHRONIC=$P($G(^PSRX(RXNO,9999999)),U,2)
.S KEEPMED=($L($P(NODE,U,2))>0) ;Discard Blank Meds
.I KEEPMED D
..S STATUS=$P(NODE,U,9)
..I STATUS="SUSPENDED" S STATUS="ACTIVE (S)"
..I STATUS="ACTIVE/SUSP" 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
.I KEEPMED D
..S TYPE=$P($P(NODE,U),";",2)
..S TYPE=$S(TYPE="O":"OP",TYPE="I":"UD",1:"")
..I TYPE="UD" S KEEPMED=0
..I TYPE="" S KEEPMED=0
..;Check visit
..I TYPE="OP" D
...S KEEPMED=0
...S RX=$P($G(^PSRX(RXNO,0)),U,1)
...Q:RX=""
...I $D(ARRAY1(RX)) S KEEPMED=1
...S CHK=$P($P(NODE,U,1),";",1)
...I $D(ARRAY2(+CHK)) S KEEPMED=1
.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"
..S MEDTYPE=1
..I ALLMEDS=3 S KEEPMED=MEDTYPE
.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
....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="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 STATUS=$P(NODE,U,9)
..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,STATUS))
..;I 'OK,(IDATE>@TARGET@("B",MED,IDATE,XSTR)) S OK=1
..I 'OK,$P(@TARGET@("B",MED,IDATE,XSTR,STATUS),U,4)'=STATUS S OK=1
..I OK D
...S @TARGET@("B",MED,IDATE,XSTR,STATUS)=IDATE_U_INDEX_U_MEDTYPE_U_STATIDX_U_TYPE_U_DRUGCLAS_U_CHRONIC_U_STATUS_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,OUTPTYPE=1
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 STATUS=""
...F S STATUS=$O(@TARGET@("B",MED,IDATE,XSTR,STATUS)) Q:STATUS="" D
....S NODE=@TARGET@("B",MED,IDATE,XSTR,STATUS)
....S DATA=MED_U_$P(NODE,U,3)_U_$P(NODE,U,6)_U_$P(NODE,19),CNT=CNT+1
....S @TARGET@("C",STATUS,DATA,(9999999-$P(NODE,U))_CNT)=$P(NODE,U,2)_U_$P(NODE,U,4)_U_$P(NODE,U,6)_U_$P(NODE,U,9)
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=""
F S STATUS=$O(@TARGET@("C",STATUS)) Q:STATUS="" D
.F S DATA=$O(@TARGET@("C",STATUS,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",STATUS,DATA,CNT)) Q:CNT="" D
...S INDEX=@TARGET@("C",STATUS,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
...S HIEN=+($P(NODE,U))
...I CLININC>0 D
....S INDIC=$$GET1^DIQ(52,HIEN,9999999.21,"E")
....S $P(NODE,U,19)=INDIC
...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)"
...I ERX'="" S $P(NODE,U,31)=ERX
...S RXNUM=$P($G(^PSRX(HIEN,0)),U,1)
...S $P(NODE,U,20)=RXNUM_" "
...S $P(NODE,U,21)=$P($G(^TMP("PS",$J,INDEX,"P",0)),U,2)
...S ^TMP("PS",$J,INDEX,0)=NODE
...D FILLS
...;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 MEDTYPE=OUTPTYPE D I 1
.....D ADD^BTIUMED1($E(SPACE60,1,3)_"RX No"_$E($E(SPACE60,1,38)_"Status"_SPACE60,1,52)_"Last Fill")
....S TEMP=""
....I 'ONELIST D
.....S TEMP=TEMP_"Outpatient Medications"
....I CLASSORT D
.....S TEMP=TEMP_" (By Class)"
.....I MEDTYPE=OUTPTYPE&(CLININC>0) S TEMP=TEMP_" (By Clinical Indication)"
....S TEMP=$E(TEMP_SPACE60,1,47)
....S TEMP=TEMP_"Refills"
....S TEMP=$E(TEMP_SPACE60,1,60)
....S TEMP=TEMP_"Expiration"
....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")
K @TARGET@("C")
LISTX K ^TMP("PS",$J)
Q "~@"_$NA(@TARGET)
;
GETCLASS ; Get Drug Class, filter out supplies
D GETCLASS^TIULMED3
Q
FILLS ;Create and add nodes for fills and past fills.
;$G(^TMP("PS",$J,INDEX,0))
K FILL
N RFS,RF,RX2,RFL,FILL,II,PSIII,X,Y,Z
S RX2=$S($D(^PSRX(HIEN,2)):^PSRX(HIEN,2),1:"")
S RFL=1
D FILOOP(HIEN,RX2)
S Y=""
F PSIII=0:0 S PSIII=$O(FILL(PSIII)) Q:'PSIII D
.S X=$P($G(FILL(PSIII)),U,1)
.I X=0 Q
.S Z=$$FMTE^XLFDT(X)
.S Y=Y_Z_" "
I Y'="" D
.S ^TMP("PS",$J,INDEX,"FILL",0)=1
.S ^TMP("PS",$J,INDEX,"FILL",1,0)=Y
I CNT>0 S ^TMP("PS",$J,INDEX,"FILL",0)=1
I RFL<6 D
.K FILL
.S NRXN=$P($G(^PSRX(HIEN,"OR1")),U,3)
.I NRXN'="" D
..S RX2=$S($D(^PSRX(NRXN,2)):^PSRX(NRXN,2),1:"")
..D FILOOP(NRXN,RX2)
..S Y=""
..F PSIII=0:0 S PSIII=$O(FILL(PSIII)) Q:'PSIII D
...S X=$P($G(FILL(PSIII)),U,1)
...I X=0 Q
...S Z=$$FMTE^XLFDT(X)
...S Y=Y_Z_" "
..I Y'="" D
...S ^TMP("PS",$J,INDEX,"FILLS",0)=1
...S ^TMP("PS",$J,INDEX,"FILLS",1,0)=Y
Q
FILOOP(RX,RX2) ;
S FILL(9999999-$P(RX2,"^",2))=+$P(RX2,"^",2)_"^"_$S($P(RX2,"^",15):"(R)",1:""),FILLS=+$P(HIEN,"^",9)
F II=0:0 S II=$O(^PSRX(RX,1,II)) Q:'II S FILL(9999999-^PSRX(RX,1,II,0))=+^PSRX(RX,1,II,0)_"^"_$S($P(^(0),"^",16):"(R)",1:"") S RFL=RFL+1
Q
BTIUMED8 ; SLC/JM - Active/Recent Med Objects Routine ;14-Mar-2013 16:15;DU
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**1010,1011**;Jun 20, 1997;Build 13
+2 ;Patch 1011 changed to new pharmacy APIs
+3 QUIT
LIST(DFN,TARGET) ; EP
+1 ;
+2 ; Medication object for detailed meds for pharmacists
+3 ;
+4 ;
+5 ;Required Parameters:
+6 ;
+7 ; DFN Patient identifier
+8 ;
+9 ; TARGET Where the medication data will be stored
+10 ;
+11 NEW NEXTLINE,EMPTY,INDEX,NODE,ISINP,KEEPMED,STATUS,ASTATS,PSTATS,OK,RXNO,CHRONIC,ARRAY1,ARRAY2
+12 NEW STATIDX,OUTPTYPE,TYPE,MEDTYPE,CNT,DATA,DATA1,MED,IDATE,XSTR,LLEN,DAYS,AUTO,ERX
+13 NEW LASTMEDT,LASTSTS,COUNT,TOTAL,SPACE60,DASH73,TEMP,LINE,TAB,HEADER,RXNUM,IEN,RX
+14 NEW DRUGCLAS,DRUGIDX,LASTCLAS,OLDTAB,OLDHEADR,UNKNOWNS,INDIC,LSTINDIC,PHARM,HSTATS,CHK
+15 NEW %,%H,STOP,LSTFD,ALLMEDS,CLASS,DETAILED,DRUG,REASON,REFILLS,FILLS,NRXN,HIEN,VST
+16 NEW CLASSORT,CLININC,ACTVONLY,CNT1,CNT2,ONELIST,SUPPLIES
+17 SET (NEXTLINE,TAB,HEADER,UNKNOWNS)=0
SET LLEN=47
+18 SET PHARM=1
+19 KILL @TARGET,^TMP("PS",$JOB)
+20 ; Check for Pharmacy Package and required patches
+21 ;P213
IF '$$PATCHSOK^TIULMED3
GOTO LISTX
+22 SET ACTVONLY=0
+23 SET ALLMEDS=3
SET DETAILED=1
+24 SET ONELIST=0
+25 SET CLASSORT=0
+26 SET SUPPLIES=1
+27 SET CLININC=0
+28 SET (EMPTY,HEADER)=1
+29 IF ONELIST
IF 'CLASSORT
IF 'CLININC
SET HEADER=0
+30 SET ASTATS="^ACTIVE^REFILL^HOLD^PROVIDER HOLD^ON CALL^ACTIVE (S)^"
+31 SET PSTATS="^NON-VERIFIED^DRUG INTERACTIONS^INCOMPLETE^PENDING^"
+32 SET HSTATS="^HOLD^"
+33 ; Is this an inpatient?
SET ISINP=($GET(^DPT(DFN,.1))'="")
+34 IF ISINP=1
SET @TARGET@(1,0)="Patient is an inpatient"
QUIT "~@"_$NAME(@TARGET)
+35 DO ADDTITLE^BTIUMED1(1)
+36 ;
+37 ; *** Scan medication data and skip unwanted meds ***
+38 ;
+39 DO OCL^PSOORRL(DFN,$$FMADD^XLFDT(DT,-1),"")
+40 ;
+41 ;*** Get the visit to check on ***
+42 SET VST=$$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID",,"CONTEXT.ENCOUNTER")
+43 IF VST=""
SET @TARGET@(1,0)="Invalid visit"
QUIT "~@"_$NAME(@TARGET)
+44 SET X="BEHOENCX"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET VST=+$$VSTR2VIS^BEHOENCX(DFN,VST)
IF VST<1
SET @TARGET@(1,0)="Invalid visit"
QUIT "~@"_$NAME(@TARGET)
+45 ;
+46 ;Get array of visit items
+47 NEW VMIEN,NUM,NUM2
+48 SET VMIEN=""
SET CNT1=0
SET CNT2=0
SET ARRAY1=""
SET ARRAY2=""
+49 FOR
SET VMIEN=$ORDER(^AUPNVMED("AD",VST,VMIEN))
IF '+VMIEN
QUIT
Begin DoDot:1
+50 SET NUM=$PIECE($GET(^AUPNVMED(VMIEN,11)),U,2)
+51 IF NUM'=""
SET ARRAY1(NUM)=""
+52 SET NUM2=$PIECE($GET(^AUPNVMED(VMIEN,11)),U,8)
+53 IF NUM2'=""
SET ARRAY2(NUM2)=""
End DoDot:1
+54 ;
+55 IF $DATA(ARRAY1)=0&($DATA(ARRAY2)=0)
QUIT
+56 SET INDEX=0
SET INDIC=""
+57 FOR
SET INDEX=$ORDER(^TMP("PS",$JOB,INDEX))
IF INDEX'>0
QUIT
Begin DoDot:1
+58 SET AUTO=0
SET ERX=""
+59 SET NODE=$GET(^TMP("PS",$JOB,INDEX,0))
+60 ;Prescription IEN
SET RXNO=+($PIECE(NODE,U,1))
+61 SET AUTO=$PIECE($GET(^PSRX(RXNO,999999921)),U,3)
+62 SET CHRONIC=$PIECE($GET(^PSRX(RXNO,9999999)),U,2)
+63 ;Discard Blank Meds
SET KEEPMED=($LENGTH($PIECE(NODE,U,2))>0)
+64 IF KEEPMED
Begin DoDot:2
+65 SET STATUS=$PIECE(NODE,U,9)
+66 IF STATUS="SUSPENDED"
SET STATUS="ACTIVE (S)"
+67 IF STATUS="ACTIVE/SUSP"
SET STATUS="ACTIVE (S)"
+68 IF STATUS="PENDING"
Begin DoDot:3
+69 SET IEN=+($PIECE(NODE,U))
+70 IF IEN>0
SET REFILLS=$PIECE($GET(^PS(52.41,IEN,0)),U,11)
+71 SET $PIECE(^TMP("PS",$JOB,INDEX,0),U,5)=REFILLS
End DoDot:3
+72 IF $FIND(ASTATS,"^"_STATUS_"^")>0
SET STATIDX=1
+73 IF '$TEST
IF ($FIND(PSTATS,"^"_STATUS_"^")>0)
SET STATIDX=2
+74 IF '$TEST
SET STATIDX=3
+75 IF ACTVONLY=1
SET KEEPMED=(STATIDX<3)
+76 IF ACTVONLY=2
SET KEEPMED=(STATIDX=3)
+77 IF ACTVONLY=3
Begin DoDot:3
+78 SET KEEPMED=""
+79 IF STATUS="HOLD"
SET KEEPMED=4
End DoDot:3
+80 ;I +ONELIST S STATIDX=1
End DoDot:2
+81 IF KEEPMED
Begin DoDot:2
+82 SET TYPE=$PIECE($PIECE(NODE,U),";",2)
+83 SET TYPE=$SELECT(TYPE="O":"OP",TYPE="I":"UD",1:"")
+84 IF TYPE="UD"
SET KEEPMED=0
+85 IF TYPE=""
SET KEEPMED=0
+86 ;Check visit
+87 IF TYPE="OP"
Begin DoDot:3
+88 SET KEEPMED=0
+89 SET RX=$PIECE($GET(^PSRX(RXNO,0)),U,1)
+90 IF RX=""
QUIT
+91 IF $DATA(ARRAY1(RX))
SET KEEPMED=1
+92 SET CHK=$PIECE($PIECE(NODE,U,1),";",1)
+93 IF $DATA(ARRAY2(+CHK))
SET KEEPMED=1
End DoDot:3
End DoDot:2
+94 IF KEEPMED
Begin DoDot:2
+95 IF $ORDER(^TMP("PS",$JOB,INDEX,"A",0))>0
SET TYPE="IV"
+96 IF '$TEST
IF $ORDER(^TMP("PS",$JOB,INDEX,"B",0))>0
SET TYPE="IV"
+97 SET MEDTYPE=1
+98 IF ALLMEDS=3
SET KEEPMED=MEDTYPE
End DoDot:2
+99 SET DRUGCLAS=" "
+100 SET MED=$PIECE(NODE,U,2)
+101 IF KEEPMED
IF (CLASSORT!('SUPPLIES))
Begin DoDot:2
+102 SET DRUGIDX=$$IENNAME^TIULMED2(MED)
+103 DO GETCLASS
+104 ;Find orderable item
IF KEEPMED
IF +DRUGIDX=0
Begin DoDot:3
+105 NEW IDX,ID,ORDIDX,TMPCLASS,CDONE,SDONE,TMPIDX,TMPNODE,ISSUPPLY
+106 SET ID=$PIECE(NODE,U)
SET IDX=+ID
SET ID=$EXTRACT(ID,$LENGTH(IDX)+1,$LENGTH(ID))
+107 SET (DRUGIDX,ORDIDX)=0
+108 KILL ^TMP($JOB,"TIULMED")
+109 ; IDX is Order #; ID indicates what file. See IA 2400
+110 ; R;O MED will always be in Drug File (Unless Drug File entry was
+111 ; changed after ordering.
+112 IF ID="R;O"
Begin DoDot:4
+113 ; IA 4820
DO RX^PSO52API(DFN,"TIULMED",IDX,"","0,O")
+114 SET DRUGIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,6))
+115 SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,"OI"))
End DoDot:4
+116 IF ID="P;O"
Begin DoDot:4
+117 ; IA 4821
DO PEN^PSO5241(DFN,"TIULMED",IDX)
+118 SET DRUGIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,11))
+119 SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",DFN,IDX,8))
End DoDot:4
+120 IF ID="V;I"
Begin DoDot:4
+121 ; IA 4826
DO PSS436^PSS55(DFN,IDX,"TIULMED")
+122 ; Get ORDIDX before DRUGIDX since global is not there after DRUGIDX
+123 SET ORDIDX=+$GET(^TMP($JOB,"TIULMED",IDX,130))
+124 IF ^TMP($JOB,"TIULMED",IDX,"ADD",0)=1
Begin DoDot:5
+125 SET TMPIDX=$ORDER(^TMP($JOB,"TIULMED",IDX,"ADD",0))
IF +TMPIDX
Begin DoDot:6
+126 SET TMPIDX=+$GET(^TMP($JOB,"TIULMED",IDX,"ADD",TMPIDX,.01))
+127 ; IA 4662
IF +TMPIDX
SET DRUGIDX=$$DRGIEN^TIULMED2(TMPIDX)
End DoDot:6
End DoDot:5
End DoDot:4
+128 SET DRUGCLAS=""
+129 DO GETCLASS
+130 IF KEEPMED
IF +DRUGIDX=0
IF +ORDIDX
IF DRUGCLAS=""
Begin DoDot:4
+131 SET IDX=0
SET ISSUPPLY=2
SET CDONE='CLASSORT
SET SDONE=+SUPPLIES
+132 NEW LIST
SET LIST="TIULMED"
KILL ^TMP($JOB,LIST)
+133 ; IA 4662
DO DRGIEN^PSS50P7(ORDIDX,"",LIST)
+134 FOR
SET IDX=$ORDER(^TMP($JOB,LIST,IDX))
IF 'IDX
QUIT
Begin DoDot:5
+135 SET TMPCLASS=$$DRGCLASS^TIULMED2(IDX)
+136 SET TMPNODE=U_TMPCLASS_U_$$DEA^TIULMED2(IDX)
+137 IF 'CDONE
IF TMPCLASS=""
SET CDONE=1
SET DRUGCLAS=""
+138 IF 'CDONE
Begin DoDot:6
+139 IF DRUGCLAS=""
SET DRUGCLAS=TMPCLASS
+140 IF '$TEST
IF DRUGCLAS'=TMPCLASS
SET CDONE=1
SET DRUGCLAS=""
End DoDot:6
+141 IF 'SDONE
Begin DoDot:6
+142 SET ISSUPPLY=(($EXTRACT(TMPCLASS,1,2)="XA")&($PIECE(TMPNODE,U,3)["S"))
+143 IF 'ISSUPPLY
SET SDONE=1
End DoDot:6
End DoDot:5
IF (CDONE&SDONE)
QUIT
+144 IF 'SUPPLIES
IF (ISSUPPLY=1)
SET KEEPMED=0
End DoDot:4
End DoDot:3
+145 IF (DRUGCLAS="")!('CLASSORT)
SET DRUGCLAS=" "
+146 IF AUTO=1
Begin DoDot:3
+147 SET ERX=$PIECE($GET(^PSRX(RXNO,999999921)),U,4)
+148 IF +ERX
SET ERX=ERX_";"_RXNO
+149 SET $PIECE(^TMP("PS",$JOB,INDEX,0),U,9)=STATUS_" (X)"
End DoDot:3
End DoDot:2
+150 ;
+151 ; *** Save wanted meds in "B" temp xref, removing duplicates ***
+152 ;
+153 IF KEEPMED
Begin DoDot:2
+154 ; Get XSTR to check for duplicates
DO ADDMED^BTIUMED1(1)
+155 SET STATUS=$PIECE(NODE,U,9)
+156 SET IDATE=$PIECE(NODE,U,15)
+157 IF $PIECE($PIECE(NODE,U),";")["N"
SET IDATE=$$DT^XLFDT
+158 IF $PIECE(NODE,U,9)="PENDING"!($PIECE(NODE,U,9)="HOLD")
SET IDATE=$$DT^XLFDT
+159 SET OK='$DATA(@TARGET@("B",MED,IDATE,XSTR,STATUS))
+160 ;I 'OK,(IDATE>@TARGET@("B",MED,IDATE,XSTR)) S OK=1
+161 IF 'OK
IF $PIECE(@TARGET@("B",MED,IDATE,XSTR,STATUS),U,4)'=STATUS
SET OK=1
+162 IF OK
Begin DoDot:3
+163 SET @TARGET@("B",MED,IDATE,XSTR,STATUS)=IDATE_U_INDEX_U_MEDTYPE_U_STATIDX_U_TYPE_U_DRUGCLAS_U_CHRONIC_U_STATUS_U_ERX
+164 SET EMPTY=0
+165 IF DRUGCLAS=" "
SET UNKNOWNS=1
End DoDot:3
End DoDot:2
End DoDot:1
+166 ;
+167 ; *** Check for empty condition ***
+168 ;
+169 IF EMPTY
Begin DoDot:1
+170 DO ADD^BTIUMED1("No Medications Found")
+171 DO ADD^BTIUMED1(" ")
End DoDot:1
GOTO LISTX
+172 ;
+173 ; *** Sort Meds in "C" temp xref - sort by Med Type, Status
+174 ; Med Name, and reverse issue date, followed by a counter
+175 ; to avoid erasing meds issued on the same day
+176 ;
+177 SET MED=""
SET CNT=1000000
SET OUTPTYPE=1
+178 FOR
SET MED=$ORDER(@TARGET@("B",MED))
IF MED=""
QUIT
Begin DoDot:1
+179 SET IDATE=""
+180 FOR
SET IDATE=$ORDER(@TARGET@("B",MED,IDATE))
IF IDATE=""
QUIT
Begin DoDot:2
+181 SET XSTR=""
+182 FOR
SET XSTR=$ORDER(@TARGET@("B",MED,IDATE,XSTR))
IF XSTR=""
QUIT
Begin DoDot:3
+183 SET STATUS=""
+184 FOR
SET STATUS=$ORDER(@TARGET@("B",MED,IDATE,XSTR,STATUS))
IF STATUS=""
QUIT
Begin DoDot:4
+185 SET NODE=@TARGET@("B",MED,IDATE,XSTR,STATUS)
+186 SET DATA=MED_U_$PIECE(NODE,U,3)_U_$PIECE(NODE,U,6)_U_$PIECE(NODE,19)
SET CNT=CNT+1
+187 SET @TARGET@("C",STATUS,DATA,(9999999-$PIECE(NODE,U))_CNT)=$PIECE(NODE,U,2)_U_$PIECE(NODE,U,4)_U_$PIECE(NODE,U,6)_U_$PIECE(NODE,U,9)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+188 KILL @TARGET@("B")
+189 ;
+190 ; Read sorted data and save final version to TARGET
+191 ;
+192 SET (DATA,LASTCLAS,LSTINDIC)=""
SET (LASTMEDT,LASTSTS,COUNT,TOTAL)=0
+193 SET $PIECE(SPACE60," ",60)=" "
SET $PIECE(DASH73,"=",73)="="
+194 DO WARNING^BTIUMED1
+195 SET STATUS=""
+196 FOR
SET STATUS=$ORDER(@TARGET@("C",STATUS))
IF STATUS=""
QUIT
Begin DoDot:1
+197 FOR
SET DATA=$ORDER(@TARGET@("C",STATUS,DATA))
IF DATA=""
QUIT
Begin DoDot:2
+198 SET DATA1=$PIECE(DATA,U,2)
+199 SET MEDTYPE=$EXTRACT(DATA1)
SET STATIDX=$EXTRACT(DATA1,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 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 SET STATUS=$PIECE(NODE,U,9)
+207 IF STATUS="HOLD"
Begin DoDot:4
+208 SET HIEN=+($PIECE(NODE,U))
+209 SET REASON=$$GET1^DIQ(52,HIEN,99,"E")
+210 SET $PIECE(NODE,U,18)=REASON
End DoDot:4
+211 SET HIEN=+($PIECE(NODE,U))
+212 IF CLININC>0
Begin DoDot:4
+213 SET INDIC=$$GET1^DIQ(52,HIEN,9999999.21,"E")
+214 SET $PIECE(NODE,U,19)=INDIC
End DoDot:4
+215 IF $PIECE($PIECE(NODE,U),";")["N"
SET $PIECE(NODE,U,2)=$PIECE(NODE,U,2)_" (O)"
+216 IF CHRONIC="Y"
SET $PIECE(NODE,U,2)=$PIECE(NODE,U,2)_" (C)"
+217 IF ERX'=""
SET $PIECE(NODE,U,31)=ERX
+218 SET RXNUM=$PIECE($GET(^PSRX(HIEN,0)),U,1)
+219 SET $PIECE(NODE,U,20)=RXNUM_" "
+220 SET $PIECE(NODE,U,21)=$PIECE($GET(^TMP("PS",$JOB,INDEX,"P",0)),U,2)
+221 SET ^TMP("PS",$JOB,INDEX,0)=NODE
+222 DO FILLS
+223 ;E S $P(NODE,U,2)=" "_$P(NODE,U,2)
+224 ;I (MEDTYPE'=LASTMEDT)!(STATIDX'=LASTSTS)!(INDIC'=LSTINDIC) D ; Create Header
+225 ; Create Header
IF (MEDTYPE'=LASTMEDT)!(CLININC=2&(INDIC'=LSTINDIC))
Begin DoDot:4
+226 IF CLASSORT'=2
IF DRUGCLAS'=" "
SET LASTCLAS=DRUGCLAS
+227 IF 'HEADER
QUIT
+228 SET LASTMEDT=MEDTYPE
SET LASTSTS=STATIDX
SET TAB=0
+229 IF COUNT>0
DO ADD^BTIUMED1(" ")
+230 IF CLASSORT
DO ADD^BTIUMED1(" ")
+231 SET COUNT=0
+232 IF MEDTYPE=OUTPTYPE
Begin DoDot:5
+233 DO ADD^BTIUMED1($EXTRACT(SPACE60,1,3)_"RX No"_$EXTRACT($EXTRACT(SPACE60,1,38)_"Status"_SPACE60,1,52)_"Last Fill")
End DoDot:5
IF 1
+234 SET TEMP=""
+235 IF 'ONELIST
Begin DoDot:5
+236 SET TEMP=TEMP_"Outpatient Medications"
End DoDot:5
+237 IF CLASSORT
Begin DoDot:5
+238 SET TEMP=TEMP_" (By Class)"
+239 IF MEDTYPE=OUTPTYPE&(CLININC>0)
SET TEMP=TEMP_" (By Clinical Indication)"
End DoDot:5
+240 SET TEMP=$EXTRACT(TEMP_SPACE60,1,47)
+241 SET TEMP=TEMP_"Refills"
+242 SET TEMP=$EXTRACT(TEMP_SPACE60,1,60)
+243 SET TEMP=TEMP_"Expiration"
+244 DO ADD^BTIUMED1(TEMP)
DO ADD^BTIUMED1(DASH73)
End DoDot:4
+245 IF CLASSORT
IF DRUGCLAS'=""
IF DRUGCLAS'=LASTCLAS
Begin DoDot:4
+246 SET LASTCLAS=DRUGCLAS
SET OLDTAB=TAB
SET OLDHEADR=HEADER
End DoDot:4
+247 IF CLININC=2
IF INDIC'=LSTINDIC
Begin DoDot:4
+248 SET LSTINDIC=INDIC
SET OLDTAB=TAB
SET OLDHEADR=HEADER
+249 SET (TAB,HEADER)=0
+250 IF COUNT>0
DO ADD^BTIUMED1(" ")
+251 IF (CLASSORT=2)!(DRUGCLAS=" ")
Begin DoDot:5
+252 IF DRUGCLAS=" "
SET TEMP=" ====== Drug Class Unknown "
+253 IF '$TEST
SET TEMP=" ====== Drug Class: "_DRUGCLAS_" "
End DoDot:5
IF 1
+254 IF REASON=1
Begin DoDot:5
+255 IF INDIC=""
SET TEMP=" ====== Unknown Indication "
+256 IF '$TEST
SET TEMP=" ====== "_INDIC_" "
End DoDot:5
+257 IF '$TEST
SET TEMP=" "
+258 SET TEMP=$EXTRACT(TEMP_DASH73,1,LLEN-2)
+259 DO ADD^BTIUMED1(TEMP)
+260 SET HEADER=OLDHEADR
SET TAB=OLDTAB
End DoDot:4
+261 SET COUNT=COUNT+1
SET TOTAL=TOTAL+1
+262 DO ADDMED^BTIUMED1(0)
End DoDot:3
End DoDot:2
End DoDot:1
+263 IF COUNT'=TOTAL
Begin DoDot:1
+264 SET TAB=0
+265 DO ADD^BTIUMED1(" ")
+266 DO ADD^BTIUMED1(TOTAL_" Total Medications")
End DoDot:1
+267 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
FILLS ;Create and add nodes for fills and past fills.
+1 ;$G(^TMP("PS",$J,INDEX,0))
+2 KILL FILL
+3 NEW RFS,RF,RX2,RFL,FILL,II,PSIII,X,Y,Z
+4 SET RX2=$SELECT($DATA(^PSRX(HIEN,2)):^PSRX(HIEN,2),1:"")
+5 SET RFL=1
+6 DO FILOOP(HIEN,RX2)
+7 SET Y=""
+8 FOR PSIII=0:0
SET PSIII=$ORDER(FILL(PSIII))
IF 'PSIII
QUIT
Begin DoDot:1
+9 SET X=$PIECE($GET(FILL(PSIII)),U,1)
+10 IF X=0
QUIT
+11 SET Z=$$FMTE^XLFDT(X)
+12 SET Y=Y_Z_" "
End DoDot:1
+13 IF Y'=""
Begin DoDot:1
+14 SET ^TMP("PS",$JOB,INDEX,"FILL",0)=1
+15 SET ^TMP("PS",$JOB,INDEX,"FILL",1,0)=Y
End DoDot:1
+16 IF CNT>0
SET ^TMP("PS",$JOB,INDEX,"FILL",0)=1
+17 IF RFL<6
Begin DoDot:1
+18 KILL FILL
+19 SET NRXN=$PIECE($GET(^PSRX(HIEN,"OR1")),U,3)
+20 IF NRXN'=""
Begin DoDot:2
+21 SET RX2=$SELECT($DATA(^PSRX(NRXN,2)):^PSRX(NRXN,2),1:"")
+22 DO FILOOP(NRXN,RX2)
+23 SET Y=""
+24 FOR PSIII=0:0
SET PSIII=$ORDER(FILL(PSIII))
IF 'PSIII
QUIT
Begin DoDot:3
+25 SET X=$PIECE($GET(FILL(PSIII)),U,1)
+26 IF X=0
QUIT
+27 SET Z=$$FMTE^XLFDT(X)
+28 SET Y=Y_Z_" "
End DoDot:3
+29 IF Y'=""
Begin DoDot:3
+30 SET ^TMP("PS",$JOB,INDEX,"FILLS",0)=1
+31 SET ^TMP("PS",$JOB,INDEX,"FILLS",1,0)=Y
End DoDot:3
End DoDot:2
End DoDot:1
+32 QUIT
FILOOP(RX,RX2) ;
+1 SET FILL(9999999-$PIECE(RX2,"^",2))=+$PIECE(RX2,"^",2)_"^"_$SELECT($PIECE(RX2,"^",15):"(R)",1:"")
SET FILLS=+$PIECE(HIEN,"^",9)
+2 FOR II=0:0
SET II=$ORDER(^PSRX(RX,1,II))
IF 'II
QUIT
SET FILL(9999999-^PSRX(RX,1,II,0))=+^PSRX(RX,1,II,0)_"^"_$SELECT($PIECE(^(0),"^",16):"(R)",1:"")
SET RFL=RFL+1
+3 QUIT
