BGPMUUT8 ;IHS/MSC/MGH - Find is med is active on date ;14-Jul-2011 11:20;DU
;;11.1;IHS CLINICAL REPORTING SYSTEM;**1**;JUN 27, 2011;Build 106
Q
FIND(DFN,TAX,BDATE,EP,EDATE,VALID) ; 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 EDATE=BGPEDATE
D OCL^PSOORRL(DFN,BGPYR,EDATE)
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 outpt meds
.S BGPTYPE=$P($P(BGPNODE,U),";",2)
.I BGPTYPE="O" D
..S BGPMED=$P(BGPNODE,U,2)
..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,EDATE,TAX,EP,$G(VALID))
..I EP=""&('+FOUND) D
...I ID="N;O" S FOUND=$$NVA(BGPIDX,IDX,BDATE,EDATE,TAX)
;check the V med file
I EP=""&('+FOUND) S FOUND=$$VMED(DFN,BDATE,EDATE,TAX)
Q FOUND
OUTPAT(BGPIDX,IDX,ID,BDATE,EDATE,TAX,EP,VALID) ;EP
;Check for active prescription on date
N MATCH,N0,N2,N3,ID,RTC,EXP,CA,QD,NR,END,DS,RD,RETURN,PROV
S RETURN=0,MATCH=0
Q:'+BGPIDX 0
S N0=$G(^PSRX(IDX,0)),N2=$G(^PSRX(IDX,2)),N3=$G(^PSRX(IDX,3))
S EP=$G(EP)
;If the rule is that the RX has to be written by the EP, check it right away
I EP'="" D
.S PROV=$P(N0,U,4) ;Ordering provider
.I PROV=EP S MATCH=1 ;Quit if not EP
I EP'=""&(MATCH=0) Q RETURN
S ID=$P(N0,U,13) ;Issue Date
I ID>EDATE Q 0 ;Med was issued too late
I VALID=1&(ID<BDATE) Q 0
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
;Issue date was prior to enddate
I $P(ID,".",1)<EDATE 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(ID,+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)
Q RETURN_U_ID
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
NVA(BGPIDX,IDX,BDATE,EDATE,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 ST="" S ST=ED
I +DC&(DC<BDATE) Q RESULT ;Discontinued before start of reporting period
I +ST&(ST>EDATE) Q RESULT ;Started too late
S RESULT=$$NDC(BGPIDX,TAX) ;See if drug is in taxonomy
I +RESULT S RESULT=RESULT_U_ST
Q RESULT
VMED(DFN,BDATE,EDATE,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 beginning
..;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=0 D
...S VIEN=$P($G(^AUPNVMED(VMIEN,0)),U,3)
...I VIEN S RDATE=$P($G(^AUPNVSIT(VIEN,0)),U,1)
..I +RDATE&(RDATE>EDATE) Q ;Released after reporting period
..I +RDATE&(RDATE<BDATE) Q ;Released before reporting period
..;Find out if this drug is in the taxonomy
..;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
BGPMUUT8 ;IHS/MSC/MGH - Find is med is active on date ;14-Jul-2011 11:20;DU
+1 ;;11.1;IHS CLINICAL REPORTING SYSTEM;**1**;JUN 27, 2011;Build 106
+2 QUIT
FIND(DFN,TAX,BDATE,EP,EDATE,VALID) ; 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 EDATE=BGPEDATE
+11 DO OCL^PSOORRL(DFN,BGPYR,EDATE)
+12 SET BGPIND=0
SET BGPINDIC=""
SET FOUND=0
+13 FOR
SET BGPIND=$ORDER(^TMP("PS",$JOB,BGPIND))
IF '+BGPIND!(+FOUND)
QUIT
Begin DoDot:1
+14 SET BGPNODE=$GET(^TMP("PS",$JOB,BGPIND,0))
+15 SET BGPRX=+($PIECE(BGPNODE,U,1))
+16 ;Discard Blank Meds
IF $LENGTH($PIECE(BGPNODE,U,2))=0
QUIT
+17 ;Only use outpt meds
+18 SET BGPTYPE=$PIECE($PIECE(BGPNODE,U),";",2)
+19 IF BGPTYPE="O"
Begin DoDot:2
+20 SET BGPMED=$PIECE(BGPNODE,U,2)
+21 SET BGPIDX=$ORDER(^PSDRUG("B",BGPMED,0))
+22 NEW IDX,ID
+23 SET ID=$PIECE(BGPNODE,U)
SET IDX=+ID
SET ID=$EXTRACT(ID,$LENGTH(IDX)+1,$LENGTH(ID))
+24 ;Check dates on outpt RX
+25 IF ID="R;O"
SET FOUND=$$OUTPAT(BGPIDX,IDX,ID,BDATE,EDATE,TAX,EP,$GET(VALID))
+26 IF EP=""&('+FOUND)
Begin DoDot:3
+27 IF ID="N;O"
SET FOUND=$$NVA(BGPIDX,IDX,BDATE,EDATE,TAX)
End DoDot:3
End DoDot:2
End DoDot:1
+28 ;check the V med file
+29 IF EP=""&('+FOUND)
SET FOUND=$$VMED(DFN,BDATE,EDATE,TAX)
+30 QUIT FOUND
OUTPAT(BGPIDX,IDX,ID,BDATE,EDATE,TAX,EP,VALID) ;EP
+1 ;Check for active prescription on date
+2 NEW MATCH,N0,N2,N3,ID,RTC,EXP,CA,QD,NR,END,DS,RD,RETURN,PROV
+3 SET RETURN=0
SET MATCH=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 SET EP=$GET(EP)
+7 ;If the rule is that the RX has to be written by the EP, check it right away
+8 IF EP'=""
Begin DoDot:1
+9 ;Ordering provider
SET PROV=$PIECE(N0,U,4)
+10 ;Quit if not EP
IF PROV=EP
SET MATCH=1
End DoDot:1
+11 IF EP'=""&(MATCH=0)
QUIT RETURN
+12 ;Issue Date
SET ID=$PIECE(N0,U,13)
+13 ;Med was issued too late
IF ID>EDATE
QUIT 0
+14 IF VALID=1&(ID<BDATE)
QUIT 0
+15 SET RD=$PIECE(N2,U,13)
SET RTC=$PIECE(N2,U,15)
SET EXP=$PIECE(N2,U,6)
+16 ;Q:RD="" RETURN ;Never released
+17 ;Q:RTC'="" RETURN ;Return to stock
+18 ;Expired before the date in question
IF EXP<BDATE
QUIT RETURN
+19 SET CA=$PIECE(N3,U,5)
+20 ;Cancelled before the date in question
IF +CA&(CA<BDATE)
QUIT RETURN
+21 ;Issue date was prior to enddate
+22 IF $PIECE(ID,".",1)<EDATE
Begin DoDot:1
+23 SET DS=$PIECE(N0,U,8)
SET NR=$PIECE(N0,U,9)
+24 ;Get days supply times the number of refills and add to release
+25 ;date to get the last date this could be active
+26 IF NR>0
SET DS=DS*NR
+27 SET END=$$FMADD^XLFDT(ID,+DS)
+28 ;if this date is after the discharge date, it was an active med
+29 ;see if it is in the chosen taxonomy
+30 IF END>BDATE
SET RETURN=$$NDC(BGPIDX,TAX)
End DoDot:1
+31 QUIT RETURN_U_ID
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
NVA(BGPIDX,IDX,BDATE,EDATE,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 IF ST=""
SET ST=ED
+8 ;Discontinued before start of reporting period
IF +DC&(DC<BDATE)
QUIT RESULT
+9 ;Started too late
IF +ST&(ST>EDATE)
QUIT RESULT
+10 ;See if drug is in taxonomy
SET RESULT=$$NDC(BGPIDX,TAX)
+11 IF +RESULT
SET RESULT=RESULT_U_ST
+12 QUIT RESULT
VMED(DFN,BDATE,EDATE,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 beginning
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 IF +RDATE=0
Begin DoDot:3
+16 SET VIEN=$PIECE($GET(^AUPNVMED(VMIEN,0)),U,3)
+17 IF VIEN
SET RDATE=$PIECE($GET(^AUPNVSIT(VIEN,0)),U,1)
End DoDot:3
+18 ;Released after reporting period
IF +RDATE&(RDATE>EDATE)
QUIT
+19 ;Released before reporting period
IF +RDATE&(RDATE<BDATE)
QUIT
+20 ;Find out if this drug is in the taxonomy
+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: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
