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

BGPMUUT8.m

Go to the documentation of this file. 
  1. 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
  1.  Q
  1. FIND(DFN,TAX,BDATE,EP,EDATE,VALID) ; 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 EDATE=BGPEDATE
  1.  D OCL^PSOORRL(DFN,BGPYR,EDATE)
  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 outpt meds
  1.  .S BGPTYPE=$P($P(BGPNODE,U),";",2)
  1.  .I BGPTYPE="O" D
  1.  ..S BGPMED=$P(BGPNODE,U,2)
  1.  ..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,EDATE,TAX,EP,$G(VALID))
  1.  ..I EP=""&('+FOUND) D
  1.  ...I ID="N;O" S FOUND=$$NVA(BGPIDX,IDX,BDATE,EDATE,TAX)
  1.  ;check the V med file
  1.  I EP=""&('+FOUND) S FOUND=$$VMED(DFN,BDATE,EDATE,TAX)
  1.  Q FOUND
  1. OUTPAT(BGPIDX,IDX,ID,BDATE,EDATE,TAX,EP,VALID) ;EP
  1.  ;Check for active prescription on date
  1.  N MATCH,N0,N2,N3,ID,RTC,EXP,CA,QD,NR,END,DS,RD,RETURN,PROV
  1.  S RETURN=0,MATCH=0
  1.  Q:'+BGPIDX 0
  1.  S N0=$G(^PSRX(IDX,0)),N2=$G(^PSRX(IDX,2)),N3=$G(^PSRX(IDX,3))
  1.  S EP=$G(EP)
  1.  ;If the rule is that the RX has to be written by the EP, check it right away
  1.  I EP'="" D
  1.  .S PROV=$P(N0,U,4)            ;Ordering provider
  1.  .I PROV=EP  S MATCH=1         ;Quit if not EP
  1.  I EP'=""&(MATCH=0) Q RETURN
  1.  S ID=$P(N0,U,13)              ;Issue Date
  1.  I ID>EDATE Q 0                ;Med was issued too late
  1.  I VALID=1&(ID<BDATE) Q 0
  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.  ;Issue date was prior to enddate
  1.  I $P(ID,".",1)<EDATE 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(ID,+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)
  1.  Q RETURN_U_ID
  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. NVA(BGPIDX,IDX,BDATE,EDATE,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 ST="" S ST=ED
  1.  I +DC&(DC<BDATE) Q RESULT          ;Discontinued before start of reporting period
  1.  I +ST&(ST>EDATE) Q RESULT          ;Started too late
  1.  S RESULT=$$NDC(BGPIDX,TAX)         ;See if drug is in taxonomy
  1.  I +RESULT S RESULT=RESULT_U_ST
  1.  Q RESULT
  1. VMED(DFN,BDATE,EDATE,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 beginning
  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=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.  ..I +RDATE&(RDATE>EDATE) Q              ;Released after reporting period
  1.  ..I +RDATE&(RDATE<BDATE) Q              ;Released before reporting period
  1.  ..;Find out if this drug is in the taxonomy
  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