Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BTIUMED2

BTIUMED2.m

Go to the documentation of this file. 
BTIUMED2 ; IHS/MSC/MGH - Active/Recent Med Objects Routine ;12-Dec-2013 16:03;DU

 ;;1.0;TEXT INTEGRATION UTILITIES;**1006,1007,1009,1010,1011,1012,1013**;Jun 20, 1997;Build 33

 ;Patch 1011 changed to use new pharmacy APIS

 Q

LIST(DFN,TARGET,CLININC) ; EP

 ;

 ; This is the TIU Medication object for medication reconciliation .

 ;

 ;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

 N IFN,DRUGCLAS,DRUGIDX,LASTCLAS,OLDTAB,OLDHEADR,UNKNOWNS,LSTINDIC,SUPPLIES,AUTO

 N 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

 .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(NODE,U)["R;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 $P($P(NODE,U),";")["N" D

 ..I STATUS="HOLD"!(STATUS["TRANSFER") S STATUS=STATUS

 ..E  S STATUS="ACTIVE"

 .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

 ..;I MEDTYPE=INPTYPE S KEEPMED=ISINP

 ..;E  S KEEPMED='ISINP

 .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)

 ...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)) I +TMPIDX'>0 D

 .....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

 ....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 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

 ...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),TYPE=$P(NODE,U,3)

 ...S @TARGET@("C",STATUS,TYPE,DATA,(9999999-$P(NODE,U))_CNT)=$P(NODE,U,2)_U_$P(NODE,U,5)_U_$P(NODE,U,6)_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 MEDTYPE=$O(@TARGET@("C",STATUS,MEDTYPE)) Q:MEDTYPE=""  D

 ..F  S DATA=$O(@TARGET@("C",STATUS,MEDTYPE,DATA)) Q:DATA=""  D

 ...S DRUGCLAS=$P(DATA,U,2),MED=$P(DATA,U,3),CNT=""

 ...F  S CNT=$O(@TARGET@("C",STATUS,MEDTYPE,DATA,CNT)) Q:CNT=""  D

 ....S INDEX=@TARGET@("C",STATUS,MEDTYPE,DATA,CNT)

 ....S TYPE=$P(INDEX,U,2),CHRONIC=$P(INDEX,U,3),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 (MEDTYPE'=LASTMEDT)!(STATUS'=LASTSTS)!(CLIN'=LSTINDIC) D  ; Create Header

 ....I (STATUS'=LASTSTS)!(MEDTYPE'=LASTMEDT) D  ; Create Header

 .....I 'HEADER Q

 .....S LASTSTS=STATUS,LASTMEDT=MEDTYPE,TAB=0

 .....I COUNT>0 D ADD^BTIUMED1(" ")

 .....S COUNT=0

 .....I MEDTYPE=OUTPTYPE D  I 1

 ......;D ADD^BTIUMED1(SPACE60_"Issue Date")

 ......;D ADD^BTIUMED1(SPACE60)

 ......I STATUS["OUTSIDE" D ADD^BTIUMED1($E($E(SPACE60,1,47)_"Status"_SPACE60,1,60))

 ......E  I STATUS'="OUTSIDE" D ADD^BTIUMED1($E($E(SPACE60,1,47)_"Status"_SPACE60,1,60)_"Last Fill")

 .....S TEMP=STATUS_" "

 .....;S TEMP=$S(STATIDX=1:"Active",STATIDX=2:"Pending",1:"Inactive")_" "

 .....S TEMP=TEMP_$S(MEDTYPE=INPTYPE:"Inpatient",MEDTYPE=NVATYPE:$$GET^XPAR("ALL","BEHORX NONVA LABEL"),1:"Outpatient")

 .....S TEMP="     "_TEMP_" Medications"

 .....S TEMP=$E(TEMP_SPACE60,1,47)

 .....I MEDTYPE=INPTYPE S TEMP=TEMP_"Status"

 .....E  I STATUS="OUTSIDE" S TEMP=TEMP

 .....E  S TEMP=TEMP_"Refills"

 .....S TEMP=$E(TEMP_SPACE60,1,60)

 .....I MEDTYPE=INPTYPE S TEMP=TEMP_"Stop Date"

 .....E  I STATUS'="OUTSIDE" S TEMP=TEMP_"Expiration"

 .....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