BGPMUUT4 ;IHS/MSC/MGH - Find is med is active on date ;02-Mar-2011 16:53;MGH
;;11.1;IHS CLINICAL REPORTING SYSTEM;**1**;JUN 27, 2011;Build 106
Q
FIND(DFN,TAX,BDATE,MEDTYPE,EDATE) ; EP
;This function is designed to see if the patient has any drugs
;in the given taxonomy that were active on the date(s) in question
;
N BGPYR,BGPIND,BGPINDIC,BGPNODE,BGPRX,BGPTYPE,BGPIDX,BGPMED,BGPEND,FOUND
K ^TMP("PS",$J)
;Start by getting the patients drugs from 1 year prior to
;discharge date since prescriptions are only good for 1 year
S BDATE=$P(BDATE,".",1),EDATE=$G(EDATE) ;don't worry about time
S BGPYR=$$FMADD^XLFDT(BDATE,-365)
I $G(EDATE) S BGPEND=EDATE
I $G(EDATE)="" S BGPEND=$$FMADD^XLFDT(BDATE,+1)
D OCL^PSOORRL(DFN,BGPYR,BGPEND)
S BGPIND=0,BGPINDIC="",FOUND=0
F S BGPIND=$O(^TMP("PS",$J,BGPIND)) Q:'+BGPIND!(+FOUND) D
.S BGPNODE=$G(^TMP("PS",$J,BGPIND,0))
.S BGPRX=+($P(BGPNODE,U,1))
.Q:$L($P(BGPNODE,U,2))=0 ;Discard Blank Meds
.;Only use the type of meds chosen (OP,UD,IV)
.S BGPTYPE=$P($P(BGPNODE,U),";",2)
.S BGPTYPE=$S(BGPTYPE="O":"OP",BGPTYPE="I":"UD",1:"")
.I $O(^TMP("PS",$J,BGPIND,"A",0))>0 S BGPTYPE="IV"
.E I $O(^TMP("PS",$J,BGPIND,"B",0))>0 S BGPTYPE="IV"
.I BGPTYPE=MEDTYPE!(MEDTYPE="ALL") D
..S BGPMED=$P(BGPNODE,U,2)
..I MEDTYPE="OP"!(MEDTYPE="ALL") S BGPIDX=$O(^PSDRUG("B",BGPMED,0))
..N IDX,ID
..S ID=$P(BGPNODE,U),IDX=+ID,ID=$E(ID,$L(IDX)+1,$L(ID))
..;Check dates on outpt RX
..I ID="R;O" S FOUND=$$OUTPAT(BGPIDX,IDX,ID,BDATE,BGPEND,TAX) Q:+FOUND
..;Check date on unit dose
..I ID="U;I" S FOUND=$$INPAT(DFN,IDX,ID,BDATE,BGPEND,TAX) Q:+FOUND
..;Save for later if we need to do IVs
..I ID="V;I" S FOUND=$$IV(DFN,IDX,ID,BDATE,BGPEND,TAX) Q:+FOUND
..;Check on dates for NVA med
..;DC is Dc'd date, ST=start date, ED=documented date
..I ID="N;O" S FOUND=$$NVA(BGPIDX,IDX,BGPEND,TAX)
;check the V med file
I DUZ("AG")="I"&(FOUND=0) S FOUND=$$VMED(DFN,BDATE,TAX)
Q FOUND
OUTPAT(BGPIDX,IDX,ID,BDATE,BGPEND,TAX) ;EP
;Check for active prescription on date
N N0,N2,N3,ID,RTC,EXP,CA,QD,NR,END,DS,RD,RETURN
S RETURN=0
Q:'+BGPIDX 0
S N0=$G(^PSRX(IDX,0)),N2=$G(^PSRX(IDX,2)),N3=$G(^PSRX(IDX,3))
S ID=$P(N0,U,13) ;Issue Date
I ID>BGPEND Q 0 ;Med was issued too late
S RD=$P(N2,U,13),RTC=$P(N2,U,15),EXP=$P(N2,U,6)
Q:RD="" RETURN ;Never released
;Q:RTC'="" RETURN ;Return to stock
Q:EXP<BDATE RETURN ;Expired before the date in question
S CA=$P(N3,U,5)
I +CA&(CA<BDATE) Q RETURN ;Cancelled before the date in question
;Med was issued on the date in question
I $P(ID,".",1)=BDATE!($P(ID,".",1)=$P(BGPEND,".",1)) D
.S RETURN=$$NDC(BGPIDX,TAX)_U_RD
;Issue date was prior to discharge, could be already on it
I $P(ID,".",1)<BDATE D
.S DS=$P(N0,U,8),NR=$P(N0,U,9)
.;Get days supply times the number of refills and add to release
.;date to get the last date this could be active
.I NR>0 S DS=DS*NR
.S END=$$FMADD^XLFDT(RD,+DS)
.;if this date is after the discharge date, it was an active med
.;see if it is in the chosen taxonomy
.I END>BDATE S RETURN=$$NDC(BGPIDX,TAX)_U_RD
Q RETURN
NVA(BGPIDX,IDX,BGPEND,TAX) ;Check Non-VA meds
N N0,STATUS,ST,ED,DC,RESULT
S N0=$G(^PS(55,DFN,"NVA",IDX,0))
S DC=$P(N0,U,7),ST=$P(N0,U,9),ED=$P(N0,U,10),STATUS=$P(N0,U,6)
S RESULT=0
Q:'+BGPIDX RESULT
I STATUS'="" Q RESULT
I +DC&(DC<BGPEND) Q RESULT ;Discontinued before discharge
I +ST&(ST>BGPEND) Q RESULT ;Started too late
I +ED&(ED>BGPEND) Q RESULT ;Started too late
S RESULT=$$NDC(BGPIDX,TAX) ;See if drug is in taxonomy
Q RESULT
VMED(DFN,BDATE,TAX) ;Search for V med entries
N DRUG,VIEN,VMIEN,RESULT,VMIEN,RXNUM,DATE,RX,TEMP,RDATE,DRUG
S RESULT=0
Q:'$D(^AUPNVMED("AC",DFN)) RESULT
S (VMIEN,RXNUM)=0 F S VMIEN=$O(^AUPNVMED("AC",DFN,VMIEN)) Q:VMIEN=""!(+RESULT) D
.S RXNUM=$$RX(VMIEN)
.I RXNUM="" D
..S TEMP=$G(^AUPNVMED(VMIEN,0))
..I TEMP="" Q
..S DRUG=$P(TEMP,U,1)
..I DRUG=0 Q
..I +$P(TEMP,U,8)&($P(TEMP,U,8)<BDATE) Q ;Discontinued before discharge
..;Get the event date/time, add the days prescribed to it
..;If days prescribed is null, add 90 days to find an ending date
..S RDATE=$P($G(^AUPNVMED(VMIEN,12)),U,1)
..I +RDATE&(RDATE>BDATE) Q ;Released after pt discharged
..I +RDATE=0 D
...S VIEN=$P($G(^AUPNVMED(VMIEN,0)),U,3)
...I VIEN S RDATE=$P($G(^AUPNVSIT(VIEN,0)),U,1)
..S DATE=+$$FMADD^XLFDT(RDATE,+365)
..I DATE>BDATE D ;release date+365 days is after discharge date=active
...;Find out if this drug is in the taxonomy
...S RESULT=$$NDC(DRUG,TAX)
...I +RESULT S RESULT=RESULT_U_RDATE
Q RESULT
RX(VIEN) ;Send the V Med ien and check it against the cross reference in
;the prescription file. If its not there, this med will need to be
;added to the list for the reminder
N RX
S RX=0 S RX=$O(^PSRX("APCC",VIEN,RX))
Q RX
NDC(BGPIDX,TAX) ;Find out if this drug is in the taxonomy
N NDC,NDCCODE,NDCF
Q:'BGPIDX 0
S NDCF=0
S NDC=$P($G(^PSDRUG(BGPIDX,2)),U,4)
Q:'NDC 0
;Setup the NDC code for a proper lookup in the taxonomy
S NDCCODE=$$RJ^XLFSTR($P(NDC,"-"),5,0)_$$RJ^XLFSTR($P(NDC,"-",2),4,0)_$$RJ^XLFSTR($P(NDC,"-",3),2,0)
;call the taxonomy lookup
S NDCF=$$MEDTAX^BGPMUUT3(DFN,NDCCODE,TAX)
Q NDCF
INPAT(DFN,IDX,ID,BDATE,BGPEND,TAX) ;EP
N RESULT,NODE,NODE2,DISP,NDC
S RESULT=0
S NODE=$G(^PS(55,DFN,5,IDX,0))
S NODE2=$G(^PS(55,DFN,5,IDX,2))
I $P(NODE2,U,2)>BDATE D ;Med started after start date
.I ($P($P(NODE2,U,4),".",1)=$P(BGPEND,".",1))!($P(NODE2,U,4)>BGPEND) D
..;Med was active in range suggested
..;Now find the dispense drug(s) and see if they are in the taxonomy
..S X=0 F S X=$O(^PS(55,DFN,5,IDX,1,X)) Q:'+X!(+RESULT) D
...S DISP=$G(^PS(55,DFN,5,IDX,1,X,0))
...S DRUG=$P(DISP,U,1)
...I +DRUG S RESULT=$$NDC(DRUG,TAX)
...I +RESULT S RESULT=RESULT_U_$P(NODE,U,2)
Q RESULT
Q
IV(DFN,IDX,ID,BDATE,BGPEND,TAX) ;EP
N RESULT,NODE,ADD,SOL,DRUG,GDRUG
S RESULT=0
S NODE=$G(^PS(55,DFN,"IV",IDX,0))
I $P(NODE,U,2)>BDATE D ;Med started after start date
.I ($P($P(NODE,U,3),".",1)=$P(BGPEND,".",1))!($P(NODE,U,3)<BGPEND) D
..;Med was active, now find the dispense drug and see if in taxonomy
..S ADD=0 F S ADD=$O(^PS(55,DFN,"IV",IDX,"AD",ADD)) Q:ADD=""!(+RESULT) D
...S DRUG=$P($G(^PS(55,DFN,"IV",IDX,"AD",ADD,0)),U,1)
...I +DRUG S GDRUG=$P($G(^PS(52.6,DRUG,0)),U,2)
...S RESULT=$$NDC(GDRUG,TAX)
..I '+RESULT D
...S SOL=0 F S SOL=$O(^PS(55,DFN,"IV",IDX,"SOL",SOL)) Q:SOL=""!(+RESULT) D
....S DRUG=$P($G(^PS(55,DFN,"IV",IDX,"SOL",SOL,0)),U,1)
....I +DRUG S GDRUG=$P($G(^PS(52.7,DRUG,0)),U,2)
....S RESULT=$$NDC(GDRUG,TAX)
....I +RESULT S RESULT=RESULT_U_$P(NODE,U,2)
Q RESULT
BGPMUUT4 ;IHS/MSC/MGH - Find is med is active on date ;02-Mar-2011 16:53;MGH
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;**1**;JUN 27, 2011;Build 106
+2 QUIT
FIND(DFN,TAX,BDATE,MEDTYPE,EDATE) ; EP
+1 ;This function is designed to see if the patient has any drugs
+2 ;in the given taxonomy that were active on the date(s) in question
+3 ;
+4 NEW BGPYR,BGPIND,BGPINDIC,BGPNODE,BGPRX,BGPTYPE,BGPIDX,BGPMED,BGPEND,FOUND
+5 KILL ^TMP("PS",$JOB)
+6 ;Start by getting the patients drugs from 1 year prior to
+7 ;discharge date since prescriptions are only good for 1 year
+8 ;don't worry about time
SET BDATE=$PIECE(BDATE,".",1)
SET EDATE=$GET(EDATE)
+9 SET BGPYR=$$FMADD^XLFDT(BDATE,-365)
+10 IF $GET(EDATE)
SET BGPEND=EDATE
+11 IF $GET(EDATE)=""
SET BGPEND=$$FMADD^XLFDT(BDATE,+1)
+12 DO OCL^PSOORRL(DFN,BGPYR,BGPEND)
+13 SET BGPIND=0
SET BGPINDIC=""
SET FOUND=0
+14 FOR
SET BGPIND=$ORDER(^TMP("PS",$JOB,BGPIND))
IF '+BGPIND!(+FOUND)
QUIT
Begin DoDot:1
+15 SET BGPNODE=$GET(^TMP("PS",$JOB,BGPIND,0))
+16 SET BGPRX=+($PIECE(BGPNODE,U,1))
+17 ;Discard Blank Meds
IF $LENGTH($PIECE(BGPNODE,U,2))=0
QUIT
+18 ;Only use the type of meds chosen (OP,UD,IV)
+19 SET BGPTYPE=$PIECE($PIECE(BGPNODE,U),";",2)
+20 SET BGPTYPE=$SELECT(BGPTYPE="O":"OP",BGPTYPE="I":"UD",1:"")
+21 IF $ORDER(^TMP("PS",$JOB,BGPIND,"A",0))>0
SET BGPTYPE="IV"
+22 IF '$TEST
IF $ORDER(^TMP("PS",$JOB,BGPIND,"B",0))>0
SET BGPTYPE="IV"
+23 IF BGPTYPE=MEDTYPE!(MEDTYPE="ALL")
Begin DoDot:2
+24 SET BGPMED=$PIECE(BGPNODE,U,2)
+25 IF MEDTYPE="OP"!(MEDTYPE="ALL")
SET BGPIDX=$ORDER(^PSDRUG("B",BGPMED,0))
+26 NEW IDX,ID
+27 SET ID=$PIECE(BGPNODE,U)
SET IDX=+ID
SET ID=$EXTRACT(ID,$LENGTH(IDX)+1,$LENGTH(ID))
+28 ;Check dates on outpt RX
+29 IF ID="R;O"
SET FOUND=$$OUTPAT(BGPIDX,IDX,ID,BDATE,BGPEND,TAX)
IF +FOUND
QUIT
+30 ;Check date on unit dose
+31 IF ID="U;I"
SET FOUND=$$INPAT(DFN,IDX,ID,BDATE,BGPEND,TAX)
IF +FOUND
QUIT
+32 ;Save for later if we need to do IVs
+33 IF ID="V;I"
SET FOUND=$$IV(DFN,IDX,ID,BDATE,BGPEND,TAX)
IF +FOUND
QUIT
+34 ;Check on dates for NVA med
+35 ;DC is Dc'd date, ST=start date, ED=documented date
+36 IF ID="N;O"
SET FOUND=$$NVA(BGPIDX,IDX,BGPEND,TAX)
End DoDot:2
End DoDot:1
+37 ;check the V med file
+38 IF DUZ("AG")="I"&(FOUND=0)
SET FOUND=$$VMED(DFN,BDATE,TAX)
+39 QUIT FOUND
OUTPAT(BGPIDX,IDX,ID,BDATE,BGPEND,TAX) ;EP
+1 ;Check for active prescription on date
+2 NEW N0,N2,N3,ID,RTC,EXP,CA,QD,NR,END,DS,RD,RETURN
+3 SET RETURN=0
+4 IF '+BGPIDX
QUIT 0
+5 SET N0=$GET(^PSRX(IDX,0))
SET N2=$GET(^PSRX(IDX,2))
SET N3=$GET(^PSRX(IDX,3))
+6 ;Issue Date
SET ID=$PIECE(N0,U,13)
+7 ;Med was issued too late
IF ID>BGPEND
QUIT 0
+8 SET RD=$PIECE(N2,U,13)
SET RTC=$PIECE(N2,U,15)
SET EXP=$PIECE(N2,U,6)
+9 ;Never released
IF RD=""
QUIT RETURN
+10 ;Q:RTC'="" RETURN ;Return to stock
+11 ;Expired before the date in question
IF EXP<BDATE
QUIT RETURN
+12 SET CA=$PIECE(N3,U,5)
+13 ;Cancelled before the date in question
IF +CA&(CA<BDATE)
QUIT RETURN
+14 ;Med was issued on the date in question
+15 IF $PIECE(ID,".",1)=BDATE!($PIECE(ID,".",1)=$PIECE(BGPEND,".",1))
Begin DoDot:1
+16 SET RETURN=$$NDC(BGPIDX,TAX)_U_RD
End DoDot:1
+17 ;Issue date was prior to discharge, could be already on it
+18 IF $PIECE(ID,".",1)<BDATE
Begin DoDot:1
+19 SET DS=$PIECE(N0,U,8)
SET NR=$PIECE(N0,U,9)
+20 ;Get days supply times the number of refills and add to release
+21 ;date to get the last date this could be active
+22 IF NR>0
SET DS=DS*NR
+23 SET END=$$FMADD^XLFDT(RD,+DS)
+24 ;if this date is after the discharge date, it was an active med
+25 ;see if it is in the chosen taxonomy
+26 IF END>BDATE
SET RETURN=$$NDC(BGPIDX,TAX)_U_RD
End DoDot:1
+27 QUIT RETURN
NVA(BGPIDX,IDX,BGPEND,TAX) ;Check Non-VA meds
+1 NEW N0,STATUS,ST,ED,DC,RESULT
+2 SET N0=$GET(^PS(55,DFN,"NVA",IDX,0))
+3 SET DC=$PIECE(N0,U,7)
SET ST=$PIECE(N0,U,9)
SET ED=$PIECE(N0,U,10)
SET STATUS=$PIECE(N0,U,6)
+4 SET RESULT=0
+5 IF '+BGPIDX
QUIT RESULT
+6 IF STATUS'=""
QUIT RESULT
+7 ;Discontinued before discharge
IF +DC&(DC<BGPEND)
QUIT RESULT
+8 ;Started too late
IF +ST&(ST>BGPEND)
QUIT RESULT
+9 ;Started too late
IF +ED&(ED>BGPEND)
QUIT RESULT
+10 ;See if drug is in taxonomy
SET RESULT=$$NDC(BGPIDX,TAX)
+11 QUIT RESULT
VMED(DFN,BDATE,TAX) ;Search for V med entries
+1 NEW DRUG,VIEN,VMIEN,RESULT,VMIEN,RXNUM,DATE,RX,TEMP,RDATE,DRUG
+2 SET RESULT=0
+3 IF '$DATA(^AUPNVMED("AC",DFN))
QUIT RESULT
+4 SET (VMIEN,RXNUM)=0
FOR
SET VMIEN=$ORDER(^AUPNVMED("AC",DFN,VMIEN))
IF VMIEN=""!(+RESULT)
QUIT
Begin DoDot:1
+5 SET RXNUM=$$RX(VMIEN)
+6 IF RXNUM=""
Begin DoDot:2
+7 SET TEMP=$GET(^AUPNVMED(VMIEN,0))
+8 IF TEMP=""
QUIT
+9 SET DRUG=$PIECE(TEMP,U,1)
+10 IF DRUG=0
QUIT
+11 ;Discontinued before discharge
IF +$PIECE(TEMP,U,8)&($PIECE(TEMP,U,8)<BDATE)
QUIT
+12 ;Get the event date/time, add the days prescribed to it
+13 ;If days prescribed is null, add 90 days to find an ending date
+14 SET RDATE=$PIECE($GET(^AUPNVMED(VMIEN,12)),U,1)
+15 ;Released after pt discharged
IF +RDATE&(RDATE>BDATE)
QUIT
+16 IF +RDATE=0
Begin DoDot:3
+17 SET VIEN=$PIECE($GET(^AUPNVMED(VMIEN,0)),U,3)
+18 IF VIEN
SET RDATE=$PIECE($GET(^AUPNVSIT(VIEN,0)),U,1)
End DoDot:3
+19 SET DATE=+$$FMADD^XLFDT(RDATE,+365)
+20 ;release date+365 days is after discharge date=active
IF DATE>BDATE
Begin DoDot:3
+21 ;Find out if this drug is in the taxonomy
+22 SET RESULT=$$NDC(DRUG,TAX)
+23 IF +RESULT
SET RESULT=RESULT_U_RDATE
End DoDot:3
End DoDot:2
End DoDot:1
+24 QUIT RESULT
RX(VIEN) ;Send the V Med ien and check it against the cross reference in
+1 ;the prescription file. If its not there, this med will need to be
+2 ;added to the list for the reminder
+3 NEW RX
+4 SET RX=0
SET RX=$ORDER(^PSRX("APCC",VIEN,RX))
+5 QUIT RX
NDC(BGPIDX,TAX) ;Find out if this drug is in the taxonomy
+1 NEW NDC,NDCCODE,NDCF
+2 IF 'BGPIDX
QUIT 0
+3 SET NDCF=0
+4 SET NDC=$PIECE($GET(^PSDRUG(BGPIDX,2)),U,4)
+5 IF 'NDC
QUIT 0
+6 ;Setup the NDC code for a proper lookup in the taxonomy
+7 SET NDCCODE=$$RJ^XLFSTR($PIECE(NDC,"-"),5,0)_$$RJ^XLFSTR($PIECE(NDC,"-",2),4,0)_$$RJ^XLFSTR($PIECE(NDC,"-",3),2,0)
+8 ;call the taxonomy lookup
+9 SET NDCF=$$MEDTAX^BGPMUUT3(DFN,NDCCODE,TAX)
+10 QUIT NDCF
INPAT(DFN,IDX,ID,BDATE,BGPEND,TAX) ;EP
+1 NEW RESULT,NODE,NODE2,DISP,NDC
+2 SET RESULT=0
+3 SET NODE=$GET(^PS(55,DFN,5,IDX,0))
+4 SET NODE2=$GET(^PS(55,DFN,5,IDX,2))
+5 ;Med started after start date
IF $PIECE(NODE2,U,2)>BDATE
Begin DoDot:1
+6 IF ($PIECE($PIECE(NODE2,U,4),".",1)=$PIECE(BGPEND,".",1))!($PIECE(NODE2,U,4)>BGPEND)
Begin DoDot:2
+7 ;Med was active in range suggested
+8 ;Now find the dispense drug(s) and see if they are in the taxonomy
+9 SET X=0
FOR
SET X=$ORDER(^PS(55,DFN,5,IDX,1,X))
IF '+X!(+RESULT)
QUIT
Begin DoDot:3
+10 SET DISP=$GET(^PS(55,DFN,5,IDX,1,X,0))
+11 SET DRUG=$PIECE(DISP,U,1)
+12 IF +DRUG
SET RESULT=$$NDC(DRUG,TAX)
+13 IF +RESULT
SET RESULT=RESULT_U_$PIECE(NODE,U,2)
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT RESULT
+15 QUIT
IV(DFN,IDX,ID,BDATE,BGPEND,TAX) ;EP
+1 NEW RESULT,NODE,ADD,SOL,DRUG,GDRUG
+2 SET RESULT=0
+3 SET NODE=$GET(^PS(55,DFN,"IV",IDX,0))
+4 ;Med started after start date
IF $PIECE(NODE,U,2)>BDATE
Begin DoDot:1
+5 IF ($PIECE($PIECE(NODE,U,3),".",1)=$PIECE(BGPEND,".",1))!($PIECE(NODE,U,3)<BGPEND)
Begin DoDot:2
+6 ;Med was active, now find the dispense drug and see if in taxonomy
+7 SET ADD=0
FOR
SET ADD=$ORDER(^PS(55,DFN,"IV",IDX,"AD",ADD))
IF ADD=""!(+RESULT)
QUIT
Begin DoDot:3
+8 SET DRUG=$PIECE($GET(^PS(55,DFN,"IV",IDX,"AD",ADD,0)),U,1)
+9 IF +DRUG
SET GDRUG=$PIECE($GET(^PS(52.6,DRUG,0)),U,2)
+10 SET RESULT=$$NDC(GDRUG,TAX)
End DoDot:3
+11 IF '+RESULT
Begin DoDot:3
+12 SET SOL=0
FOR
SET SOL=$ORDER(^PS(55,DFN,"IV",IDX,"SOL",SOL))
IF SOL=""!(+RESULT)
QUIT
Begin DoDot:4
+13 SET DRUG=$PIECE($GET(^PS(55,DFN,"IV",IDX,"SOL",SOL,0)),U,1)
+14 IF +DRUG
SET GDRUG=$PIECE($GET(^PS(52.7,DRUG,0)),U,2)
+15 SET RESULT=$$NDC(GDRUG,TAX)
+16 IF +RESULT
SET RESULT=RESULT_U_$PIECE(NODE,U,2)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+17 QUIT RESULT
