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

BGPMUUT4.m

Go to the documentation of this file. 
  1. 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
  1.  Q
  1. FIND(DFN,TAX,BDATE,MEDTYPE,EDATE) ; EP
  1.  ;This function is designed to see if the patient has any drugs
  1.  ;in the given taxonomy that were active on the date(s) in question
  1.  ;
  1.  N BGPYR,BGPIND,BGPINDIC,BGPNODE,BGPRX,BGPTYPE,BGPIDX,BGPMED,BGPEND,FOUND
  1.  K ^TMP("PS",$J)
  1.  ;Start by getting the patients drugs from 1 year prior to
  1.  ;discharge date since prescriptions are only good for 1 year
  1.  S BDATE=$P(BDATE,".",1),EDATE=$G(EDATE)        ;don't worry about time
  1.  S BGPYR=$$FMADD^XLFDT(BDATE,-365)
  1.  I $G(EDATE) S BGPEND=EDATE
  1.  I $G(EDATE)="" S BGPEND=$$FMADD^XLFDT(BDATE,+1)
  1.  D OCL^PSOORRL(DFN,BGPYR,BGPEND)
  1.  S BGPIND=0,BGPINDIC="",FOUND=0
  1.  F  S BGPIND=$O(^TMP("PS",$J,BGPIND))  Q:'+BGPIND!(+FOUND)  D
  1.  .S BGPNODE=$G(^TMP("PS",$J,BGPIND,0))
  1.  .S BGPRX=+($P(BGPNODE,U,1))
  1.  .Q:$L($P(BGPNODE,U,2))=0   ;Discard Blank Meds
  1.  .;Only use the type of meds chosen (OP,UD,IV)
  1.  .S BGPTYPE=$P($P(BGPNODE,U),";",2)
  1.  .S BGPTYPE=$S(BGPTYPE="O":"OP",BGPTYPE="I":"UD",1:"")
  1.  .I $O(^TMP("PS",$J,BGPIND,"A",0))>0 S BGPTYPE="IV"
  1.  .E  I $O(^TMP("PS",$J,BGPIND,"B",0))>0 S BGPTYPE="IV"
  1.  .I BGPTYPE=MEDTYPE!(MEDTYPE="ALL") D
  1.  ..S BGPMED=$P(BGPNODE,U,2)
  1.  ..I MEDTYPE="OP"!(MEDTYPE="ALL") S BGPIDX=$O(^PSDRUG("B",BGPMED,0))
  1.  ..N IDX,ID
  1.  ..S ID=$P(BGPNODE,U),IDX=+ID,ID=$E(ID,$L(IDX)+1,$L(ID))
  1.  ..;Check dates on outpt RX
  1.  ..I ID="R;O" S FOUND=$$OUTPAT(BGPIDX,IDX,ID,BDATE,BGPEND,TAX) Q:+FOUND
  1.  ..;Check date on unit dose
  1.  ..I ID="U;I" S FOUND=$$INPAT(DFN,IDX,ID,BDATE,BGPEND,TAX) Q:+FOUND
  1.  ..;Save for later if we need to do IVs
  1.  ..I ID="V;I" S FOUND=$$IV(DFN,IDX,ID,BDATE,BGPEND,TAX) Q:+FOUND
  1.  ..;Check on dates for NVA med
  1.  ..;DC is Dc'd date, ST=start date, ED=documented date
  1.  ..I ID="N;O" S FOUND=$$NVA(BGPIDX,IDX,BGPEND,TAX)
  1.  ;check the V med file
  1.  I DUZ("AG")="I"&(FOUND=0) S FOUND=$$VMED(DFN,BDATE,TAX)
  1.  Q FOUND
  1. OUTPAT(BGPIDX,IDX,ID,BDATE,BGPEND,TAX) ;EP
  1.  ;Check for active prescription on date
  1.  N N0,N2,N3,ID,RTC,EXP,CA,QD,NR,END,DS,RD,RETURN
  1.  S RETURN=0
  1.  Q:'+BGPIDX 0
  1.  S N0=$G(^PSRX(IDX,0)),N2=$G(^PSRX(IDX,2)),N3=$G(^PSRX(IDX,3))
  1.  S ID=$P(N0,U,13)             ;Issue Date
  1.  I ID>BGPEND Q 0              ;Med was issued too late
  1.  S RD=$P(N2,U,13),RTC=$P(N2,U,15),EXP=$P(N2,U,6)
  1.  Q:RD="" RETURN               ;Never released
  1.  ;Q:RTC'="" RETURN             ;Return to stock
  1.  Q:EXP<BDATE RETURN           ;Expired before the date in question
  1.  S CA=$P(N3,U,5)
  1.  I +CA&(CA<BDATE) Q RETURN   ;Cancelled before the date in question
  1.  ;Med was issued on the date in question
  1.  I $P(ID,".",1)=BDATE!($P(ID,".",1)=$P(BGPEND,".",1)) D
  1.  .S RETURN=$$NDC(BGPIDX,TAX)_U_RD
  1.  ;Issue date was prior to discharge, could be already on it
  1.  I $P(ID,".",1)<BDATE D
  1.  .S DS=$P(N0,U,8),NR=$P(N0,U,9)
  1.  .;Get days supply times the number of refills and add to release
  1.  .;date to get the last date this could be active
  1.  .I NR>0 S DS=DS*NR
  1.  .S END=$$FMADD^XLFDT(RD,+DS)
  1.  .;if this date is after the discharge date, it was an active med
  1.  .;see if it is in the chosen taxonomy
  1.  .I END>BDATE S RETURN=$$NDC(BGPIDX,TAX)_U_RD
  1.  Q RETURN
  1. NVA(BGPIDX,IDX,BGPEND,TAX) ;Check Non-VA meds
  1.  N N0,STATUS,ST,ED,DC,RESULT
  1.  S N0=$G(^PS(55,DFN,"NVA",IDX,0))
  1.  S DC=$P(N0,U,7),ST=$P(N0,U,9),ED=$P(N0,U,10),STATUS=$P(N0,U,6)
  1.  S RESULT=0
  1.  Q:'+BGPIDX RESULT
  1.  I STATUS'="" Q RESULT
  1.  I +DC&(DC<BGPEND) Q RESULT         ;Discontinued before discharge
  1.  I +ST&(ST>BGPEND) Q RESULT         ;Started too late
  1.  I +ED&(ED>BGPEND) Q RESULT         ;Started too late
  1.  S RESULT=$$NDC(BGPIDX,TAX)             ;See if drug is in taxonomy
  1.  Q RESULT
  1. VMED(DFN,BDATE,TAX) ;Search for V med entries
  1.  N DRUG,VIEN,VMIEN,RESULT,VMIEN,RXNUM,DATE,RX,TEMP,RDATE,DRUG
  1.  S RESULT=0
  1.  Q:'$D(^AUPNVMED("AC",DFN)) RESULT
  1.  S (VMIEN,RXNUM)=0 F  S VMIEN=$O(^AUPNVMED("AC",DFN,VMIEN)) Q:VMIEN=""!(+RESULT)  D
  1.  .S RXNUM=$$RX(VMIEN)
  1.  .I RXNUM="" D
  1.  ..S TEMP=$G(^AUPNVMED(VMIEN,0))
  1.  ..I TEMP="" Q
  1.  ..S DRUG=$P(TEMP,U,1)
  1.  ..I DRUG=0 Q
  1.  ..I +$P(TEMP,U,8)&($P(TEMP,U,8)<BDATE) Q          ;Discontinued before discharge
  1.  ..;Get the event date/time, add the days prescribed to it
  1.  ..;If days prescribed is null, add 90 days to find an ending date
  1.  ..S RDATE=$P($G(^AUPNVMED(VMIEN,12)),U,1)
  1.  ..I +RDATE&(RDATE>BDATE) Q              ;Released after pt discharged
  1.  ..I +RDATE=0 D
  1.  ...S VIEN=$P($G(^AUPNVMED(VMIEN,0)),U,3)
  1.  ...I VIEN S RDATE=$P($G(^AUPNVSIT(VIEN,0)),U,1)
  1.  ..S DATE=+$$FMADD^XLFDT(RDATE,+365)
  1.  ..I DATE>BDATE D                ;release date+365 days is after discharge date=active
  1.  ...;Find out if this drug is in the taxonomy
  1.  ...S RESULT=$$NDC(DRUG,TAX)
  1.  ...I +RESULT S RESULT=RESULT_U_RDATE
  1.  Q RESULT
  1. 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
  1.  ;added to the list for the reminder
  1.  N RX
  1.  S RX=0 S RX=$O(^PSRX("APCC",VIEN,RX))
  1.  Q RX
  1. NDC(BGPIDX,TAX) ;Find out if this drug is in the taxonomy
  1.  N NDC,NDCCODE,NDCF
  1.  Q:'BGPIDX 0
  1.  S NDCF=0
  1.  S NDC=$P($G(^PSDRUG(BGPIDX,2)),U,4)
  1.  Q:'NDC 0
  1.  ;Setup the NDC code for a proper lookup in the taxonomy
  1.  S NDCCODE=$$RJ^XLFSTR($P(NDC,"-"),5,0)_$$RJ^XLFSTR($P(NDC,"-",2),4,0)_$$RJ^XLFSTR($P(NDC,"-",3),2,0)
  1.  ;call the taxonomy lookup
  1.  S NDCF=$$MEDTAX^BGPMUUT3(DFN,NDCCODE,TAX)
  1.  Q NDCF
  1. INPAT(DFN,IDX,ID,BDATE,BGPEND,TAX) ;EP
  1.  N RESULT,NODE,NODE2,DISP,NDC
  1.  S RESULT=0
  1.  S NODE=$G(^PS(55,DFN,5,IDX,0))
  1.  S NODE2=$G(^PS(55,DFN,5,IDX,2))
  1.  I $P(NODE2,U,2)>BDATE D              ;Med started after start date
  1.  .I ($P($P(NODE2,U,4),".",1)=$P(BGPEND,".",1))!($P(NODE2,U,4)>BGPEND) D
  1.  ..;Med was active in range suggested
  1.  ..;Now find the dispense drug(s) and see if they are in the taxonomy
  1.  ..S X=0 F  S X=$O(^PS(55,DFN,5,IDX,1,X)) Q:'+X!(+RESULT)  D
  1.  ...S DISP=$G(^PS(55,DFN,5,IDX,1,X,0))
  1.  ...S DRUG=$P(DISP,U,1)
  1.  ...I +DRUG S RESULT=$$NDC(DRUG,TAX)
  1.  ...I +RESULT S RESULT=RESULT_U_$P(NODE,U,2)
  1.  Q RESULT
  1.  Q
  1. IV(DFN,IDX,ID,BDATE,BGPEND,TAX) ;EP
  1.  N RESULT,NODE,ADD,SOL,DRUG,GDRUG
  1.  S RESULT=0
  1.  S NODE=$G(^PS(55,DFN,"IV",IDX,0))
  1.  I $P(NODE,U,2)>BDATE D     ;Med started after start date
  1.  .I ($P($P(NODE,U,3),".",1)=$P(BGPEND,".",1))!($P(NODE,U,3)<BGPEND) D
  1.  ..;Med was active, now find the dispense drug and see if in taxonomy
  1.  ..S ADD=0 F  S ADD=$O(^PS(55,DFN,"IV",IDX,"AD",ADD)) Q:ADD=""!(+RESULT)  D
  1.  ...S DRUG=$P($G(^PS(55,DFN,"IV",IDX,"AD",ADD,0)),U,1)
  1.  ...I +DRUG S GDRUG=$P($G(^PS(52.6,DRUG,0)),U,2)
  1.  ...S RESULT=$$NDC(GDRUG,TAX)
  1.  ..I '+RESULT D
  1.  ...S SOL=0 F  S SOL=$O(^PS(55,DFN,"IV",IDX,"SOL",SOL)) Q:SOL=""!(+RESULT)  D
  1.  ....S DRUG=$P($G(^PS(55,DFN,"IV",IDX,"SOL",SOL,0)),U,1)
  1.  ....I +DRUG S GDRUG=$P($G(^PS(52.7,DRUG,0)),U,2)
  1.  ....S RESULT=$$NDC(GDRUG,TAX)
  1.  ....I +RESULT S RESULT=RESULT_U_$P(NODE,U,2)
  1.  Q RESULT