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

BKMQQCR4.m

Go to the documentation of this file. 
  1. BKMQQCR4 ;PRXM/HC/BWF - BKMV Quality of Care Report; [ 1/19/2005  7:16 PM ] ; 13 Apr 2005  4:47 PM
  1.  ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011
  1.  ; Quality of Care Audit Report
  1.  Q
  1. ARVM03 ; EP - ARV Therapy
  1.  ; M.03 TAXONOMIES
  1.  N ARVM03DT,SITETAX,NDCTAX,GLOBAL,TOTPTS,BKMDFN
  1.  S ARVM03DT=$$FMADD^XLFDT(EDATE,-122)
  1.  S SITETAX="BKMV NRTI MEDS"
  1.  S NDCTAX="BKMV NRTI MED NDCS"
  1.  S GLOBAL=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""ARVM03"",VSTDT,TEST)"
  1.  S TOTPTS=$P(GLOB,")")_",""HIVCHK"",""ARVM03CNT"")"
  1.  S BKMDFN=0,@TOTPTS=0
  1.  F  S BKMDFN=$O(@GLOB@("HIVCHK",BKMDFN)) Q:'BKMDFN  D
  1.  .D MEDTAX^BKMIXX(BKMDFN,SITETAX,EDATE,ARVM03DT,GLOBAL)
  1.  .D NDCTAX^BKMIXX1(BKMDFN,NDCTAX,EDATE,ARVM03DT,GLOBAL)
  1.  .; Store Medication refusals in same global as regular Medications.
  1.  .;D REFUSAL^BKMIXX2(BKMDFN,50,SITETAX,EDATE,ARVM03DT,GLOBAL)
  1.  .;D REFUSAL^BKMIXX2(BKMDFN,50,NDCTAX,EDATE,ARVM03DT,GLOBAL)
  1.  .;
  1.  .I $D(@GLOB@("HIVCHK",BKMDFN,"ARVM03")) D MEDLP("ARVM03")
  1.  .;
  1.  .I $D(@GLOB@("HIVCHK",BKMDFN,"ARVM03")) S @TOTPTS=@TOTPTS+1
  1.  Q
  1. ARVM02 ; EP - ARV Therapy
  1.  ; M.02 TAXONOMIES
  1.  N ARVM02DT,SITETAX,NDCTAX,GLOBAL,TOTPTS,BKMDFN
  1.  S ARVM02DT=$$FMADD^XLFDT(EDATE,-122)
  1.  S SITETAX="BKMV NNRTI MEDS"
  1.  S NDCTAX="BKMV NNRTI MED NDCS"
  1.  S GLOBAL=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""ARVM02"",VSTDT,TEST)"
  1.  S TOTPTS=$P(GLOB,")")_",""HIVCHK"",""ARVM02CNT"")"
  1.  S BKMDFN=0,@TOTPTS=0
  1.  F  S BKMDFN=$O(@GLOB@("HIVCHK",BKMDFN)) Q:'BKMDFN  D
  1.  .D MEDTAX^BKMIXX(BKMDFN,SITETAX,EDATE,ARVM02DT,GLOBAL)
  1.  .D NDCTAX^BKMIXX1(BKMDFN,NDCTAX,EDATE,ARVM02DT,GLOBAL)
  1.  .; Store Medication refusals in same global as regular Medications.
  1.  .;D REFUSAL^BKMIXX2(BKMDFN,50,SITETAX,EDATE,ARVM02DT,GLOBAL)
  1.  .;D REFUSAL^BKMIXX2(BKMDFN,50,NDCTAX,EDATE,ARVM02DT,GLOBAL)
  1.  .;
  1.  .I $D(@GLOB@("HIVCHK",BKMDFN,"ARVM02")) D MEDLP("ARVM02")
  1.  .;
  1.  .I $D(@GLOB@("HIVCHK",BKMDFN,"ARVM02")) S @TOTPTS=@TOTPTS+1
  1.  Q
  1. ARVM01 ; EP - ARV Therapy
  1.  ; M.01 TAXONOMIES
  1.  N ARVM01DT,SITETAX,NDCTAX,GLOBAL,TOTPTS,BKMDFN
  1.  S ARVM01DT=$$FMADD^XLFDT(EDATE,-122)
  1.  S SITETAX="BKMV MAC PROPH MEDS"
  1.  S NDCTAX="BKMV MAC PROPH MED NDCS"
  1.  S GLOBAL=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""ARVM01"",VSTDT,TEST)"
  1.  S TOTPTS=$P(GLOB,")")_",""HIVCHK"",""ARVM01CNT"")"
  1.  S BKMDFN=0,@TOTPTS=0
  1.  F  S BKMDFN=$O(@GLOB@("HIVCHK",BKMDFN)) Q:'BKMDFN  D
  1.  .D MEDTAX^BKMIXX(BKMDFN,SITETAX,EDATE,ARVM01DT,GLOBAL)
  1.  .D NDCTAX^BKMIXX1(BKMDFN,NDCTAX,EDATE,ARVM01DT,GLOBAL)
  1.  .; Store Medication refusals in same global as regular Medications.
  1.  .;D REFUSAL^BKMIXX2(BKMDFN,50,SITETAX,EDATE,ARVM01DT,GLOBAL)
  1.  .;D REFUSAL^BKMIXX2(BKMDFN,50,NDCTAX,EDATE,ARVM01DT,GLOBAL)
  1.  .;
  1.  .I $D(@GLOB@("HIVCHK",BKMDFN,"ARVM01")) D MEDLP("ARVM01")
  1.  .;
  1.  .I $D(@GLOB@("HIVCHK",BKMDFN,"ARVM01")) S @TOTPTS=@TOTPTS+1
  1.  Q
  1. ARVM05 ; EP - ARV Therapy
  1.  ; M.05 TAXONOMIES
  1.  N ARVM05DT,SITETAX,NDCTAX,GLOBAL,TOTPTS,BKMDFN
  1.  S ARVM05DT=$$FMADD^XLFDT(EDATE,-122)
  1.  S SITETAX="BKMV PI MEDS"
  1.  S NDCTAX="BKMV PI MED NDCS"
  1.  S GLOBAL=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""ARVM05"",VSTDT,TEST)"
  1.  S TOTPTS=$P(GLOB,")")_",""HIVCHK"",""ARVM05CNT"")"
  1.  S BKMDFN=0,@TOTPTS=0
  1.  F  S BKMDFN=$O(@GLOB@("HIVCHK",BKMDFN)) Q:'BKMDFN  D
  1.  .D MEDTAX^BKMIXX(BKMDFN,SITETAX,EDATE,ARVM05DT,GLOBAL)
  1.  .D NDCTAX^BKMIXX1(BKMDFN,NDCTAX,EDATE,ARVM05DT,GLOBAL)
  1.  .; Store Medication refusals in same global as regular Medications.
  1.  .;D REFUSAL^BKMIXX2(BKMDFN,50,SITETAX,EDATE,ARVM05DT,GLOBAL)
  1.  .;D REFUSAL^BKMIXX2(BKMDFN,50,NDCTAX,EDATE,ARVM05DT,GLOBAL)
  1.  .;
  1.  .I $D(@GLOB@("HIVCHK",BKMDFN,"ARVM05")) D MEDLP("ARVM05")
  1.  .;
  1.  .I $D(@GLOB@("HIVCHK",BKMDFN,"ARVM05")) S @TOTPTS=@TOTPTS+1
  1.  Q
  1. ARVM09 ; EP - ARV Therapy
  1.  ; M.09 TAXONOMIES
  1.  N ARVM09DT,SITETAX,NDCTAX,GLOBAL,TOTPTS,BKMDFN
  1.  S ARVM09DT=$$FMADD^XLFDT(EDATE,-122)
  1.  S SITETAX="BKMV EI MEDS"
  1.  S NDCTAX="BKMV EI MED NDCS"
  1.  S GLOBAL=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""ARVM09"",VSTDT,TEST)"
  1.  S TOTPTS=$P(GLOB,")")_",""HIVCHK"",""ARVM09CNT"")"
  1.  S BKMDFN=0,@TOTPTS=0
  1.  F  S BKMDFN=$O(@GLOB@("HIVCHK",BKMDFN)) Q:'BKMDFN  D
  1.  .D MEDTAX^BKMIXX(BKMDFN,SITETAX,EDATE,ARVM09DT,GLOBAL)
  1.  .D NDCTAX^BKMIXX1(BKMDFN,NDCTAX,EDATE,ARVM09DT,GLOBAL)
  1.  .; Store Medication refusals in same global as regular Medications.
  1.  .;D REFUSAL^BKMIXX2(BKMDFN,50,SITETAX,EDATE,ARVM09DT,GLOBAL)
  1.  .;D REFUSAL^BKMIXX2(BKMDFN,50,NDCTAX,EDATE,ARVM09DT,GLOBAL)
  1.  .;
  1.  .I $D(@GLOB@("HIVCHK",BKMDFN,"ARVM09")) D MEDLP("ARVM09")
  1.  .;
  1.  .I $D(@GLOB@("HIVCHK",BKMDFN,"ARVM09")) S @TOTPTS=@TOTPTS+1
  1.  Q
  1. ARVM10 ; EP - ARV Therapy
  1.  ; M.10 TAXONOMIES
  1.  N ARVM10DT,SITETAX,NDCTAX,GLOBAL,TOTPTS,BKMDFN
  1.  S ARVM10DT=$$FMADD^XLFDT(EDATE,-122)
  1.  S SITETAX="BKMV II MEDS"
  1.  S NDCTAX="BKMV II MED NDCS"
  1.  S GLOBAL=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""ARVM10"",VSTDT,TEST)"
  1.  S TOTPTS=$P(GLOB,")")_",""HIVCHK"",""ARVM10CNT"")"
  1.  S BKMDFN=0,@TOTPTS=0
  1.  F  S BKMDFN=$O(@GLOB@("HIVCHK",BKMDFN)) Q:'BKMDFN  D
  1.  .D MEDTAX^BKMIXX(BKMDFN,SITETAX,EDATE,ARVM10DT,GLOBAL)
  1.  .D NDCTAX^BKMIXX1(BKMDFN,NDCTAX,EDATE,ARVM10DT,GLOBAL)
  1.  .; Store Medication refusals in same global as regular Medications.
  1.  .;D REFUSAL^BKMIXX2(BKMDFN,50,SITETAX,EDATE,ARVM10DT,GLOBAL)
  1.  .;D REFUSAL^BKMIXX2(BKMDFN,50,NDCTAX,EDATE,ARVM10DT,GLOBAL)
  1.  .;
  1.  .I $D(@GLOB@("HIVCHK",BKMDFN,"ARVM10")) D MEDLP("ARVM10")
  1.  .;
  1.  .I $D(@GLOB@("HIVCHK",BKMDFN,"ARVM10")) S @TOTPTS=@TOTPTS+1
  1.  Q
  1. ARVM11 ; EP - ARV Therapy
  1.  ; M.11 TAXONOMIES
  1.  N ARVM11DT,SITETAX,NDCTAX,GLOBAL,TOTPTS,BKMDFN
  1.  S ARVM11DT=$$FMADD^XLFDT(EDATE,-122)
  1.  S SITETAX="BKMV NRTI/NNRTI MEDS"
  1.  S NDCTAX="BKMV NRTI/NNRTI MED NDCS"
  1.  S GLOBAL=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""ARVM11"",VSTDT,TEST)"
  1.  S TOTPTS=$P(GLOB,")")_",""HIVCHK"",""ARVM11CNT"")"
  1.  S BKMDFN=0,@TOTPTS=0
  1.  F  S BKMDFN=$O(@GLOB@("HIVCHK",BKMDFN)) Q:'BKMDFN  D
  1.  .D MEDTAX^BKMIXX(BKMDFN,SITETAX,EDATE,ARVM11DT,GLOBAL)
  1.  .D NDCTAX^BKMIXX1(BKMDFN,NDCTAX,EDATE,ARVM11DT,GLOBAL)
  1.  .; Store Medication refusals in same global as regular Medications.
  1.  .;D REFUSAL^BKMIXX2(BKMDFN,50,SITETAX,EDATE,ARVM11DT,GLOBAL)
  1.  .;D REFUSAL^BKMIXX2(BKMDFN,50,NDCTAX,EDATE,ARVM11DT,GLOBAL)
  1.  .;
  1.  .I $D(@GLOB@("HIVCHK",BKMDFN,"ARVM11")) D MEDLP("ARVM11")
  1.  .;
  1.  .I $D(@GLOB@("HIVCHK",BKMDFN,"ARVM11")) S @TOTPTS=@TOTPTS+1
  1.  Q
  1. ARVM12 ; EP - ARV Therapy
  1.  ; M.12 TAXONOMIES
  1.  N ARVM12DT,SITETAX,NDCTAX,GLOBAL,TOTPTS,BKMDFN
  1.  S ARVM12DT=$$FMADD^XLFDT(EDATE,-122)
  1.  S SITETAX="BKMV NRTI COMBO MEDS"
  1.  S NDCTAX="BKMV NRTI COMBO MED NDCS"
  1.  S GLOBAL=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""ARVM12"",VSTDT,TEST)"
  1.  S TOTPTS=$P(GLOB,")")_",""HIVCHK"",""ARVM12CNT"")"
  1.  S BKMDFN=0,@TOTPTS=0
  1.  F  S BKMDFN=$O(@GLOB@("HIVCHK",BKMDFN)) Q:'BKMDFN  D
  1.  .D MEDTAX^BKMIXX(BKMDFN,SITETAX,EDATE,ARVM12DT,GLOBAL)
  1.  .D NDCTAX^BKMIXX1(BKMDFN,NDCTAX,EDATE,ARVM12DT,GLOBAL)
  1.  .;
  1.  .I $D(@GLOB@("HIVCHK",BKMDFN,"ARVM12")) D MEDLP("ARVM12")
  1.  .;
  1.  .I $D(@GLOB@("HIVCHK",BKMDFN,"ARVM12")) S @TOTPTS=@TOTPTS+1
  1.  Q
  1. ARVM13 ; EP - ARV Therapy
  1.  ; M.13 TAXONOMIES
  1.  N ARVM13DT,SITETAX,NDCTAX,GLOBAL,TOTPTS,BKMDFN
  1.  S ARVM13DT=$$FMADD^XLFDT(EDATE,-122)
  1.  S SITETAX="BKMV PI BOOSTER MEDS"
  1.  S NDCTAX="BKMV PI BOOSTER MED NDCS"
  1.  S GLOBAL=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""ARVM13"",VSTDT,TEST)"
  1.  S TOTPTS=$P(GLOB,")")_",""HIVCHK"",""ARVM13CNT"")"
  1.  S BKMDFN=0,@TOTPTS=0
  1.  F  S BKMDFN=$O(@GLOB@("HIVCHK",BKMDFN)) Q:'BKMDFN  D
  1.  .D MEDTAX^BKMIXX(BKMDFN,SITETAX,EDATE,ARVM13DT,GLOBAL)
  1.  .D NDCTAX^BKMIXX1(BKMDFN,NDCTAX,EDATE,ARVM13DT,GLOBAL)
  1.  .; Store Medication refusals in same global as regular Medications.
  1.  .;D REFUSAL^BKMIXX2(BKMDFN,50,SITETAX,EDATE,ARVM13DT,GLOBAL)
  1.  .;D REFUSAL^BKMIXX2(BKMDFN,50,NDCTAX,EDATE,ARVM13DT,GLOBAL)
  1.  .;
  1.  .I $D(@GLOB@("HIVCHK",BKMDFN,"ARVM13")) D MEDLP("ARVM13")
  1.  .;
  1.  .I $D(@GLOB@("HIVCHK",BKMDFN,"ARVM13")) S @TOTPTS=@TOTPTS+1
  1.  Q
  1. PCP ; EP - PCP Prophylaxis
  1.  N SITETAX,NDCTAX,GLOBAL,BKMDFN,VSTDT,TEST,RESULT,TOTPTS,FOUND
  1.  S SITETAX="BKMV PCP PROPH MEDS"
  1.  S NDCTAX="BKMV PCP PROPH MED NDCS"
  1.  S GLOBAL=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""PCP"",VSTDT,TEST)"
  1.  S TOTPTS=$P(GLOB,")")_",""HIVCHK"",""PCPPTCNT"")"
  1.  S BKMDFN=0,@TOTPTS=0
  1.  F  S BKMDFN=$O(@GLOB@("HIVCHK",BKMDFN)) Q:'BKMDFN  D
  1.  .I '$D(@GLOB@("HIVCHK",BKMDFN,"CD4ABS12")) Q
  1.  .S VSTDT=""
  1.  .S FOUND=0
  1.  .; Find earliest CD4 Absolute with results between 50 and 199.
  1.  .F  S VSTDT=$O(@GLOB@("HIVCHK",BKMDFN,"CD4ABS12",VSTDT)) Q:VSTDT=""  D  Q:FOUND
  1.  ..S TEST=""
  1.  ..F  S TEST=$O(@GLOB@("HIVCHK",BKMDFN,"CD4ABS12",VSTDT,TEST)) Q:TEST=""  D  Q:FOUND
  1.  ...S RESULT=$P($G(@GLOB@("HIVCHK",BKMDFN,"CD4ABS12",VSTDT,TEST)),U)
  1.  ...I RESULT="" Q
  1.  ...I RESULT'<200 Q
  1.  ...;I RESULT<50 Q
  1.  ...S FOUND=1
  1.  .I 'FOUND Q
  1.  .; select meds prescribed since the defined CD4 visit
  1.  .D MEDTAX^BKMIXX(BKMDFN,SITETAX,EDATE,VSTDT,GLOBAL)
  1.  .D NDCTAX^BKMIXX1(BKMDFN,NDCTAX,EDATE,VSTDT,GLOBAL)
  1.  .I $D(@GLOB@("HIVCHK",BKMDFN,"PCP")) S @TOTPTS=@TOTPTS+1
  1.  Q
  1. MAC ; EP - MAC Prophylaxis
  1.  N SITETAX,NDCTAX,GLOBAL,BKMDFN,VSTDT,TEST,RESULT,TOTPTS,FOUND
  1.  S SITETAX="BKMV MAC PROPH MEDS"
  1.  S NDCTAX="BKMV MAC PROPH MED NDCS"
  1.  S GLOBAL=$P(GLOB,")")_",""HIVCHK"",BKMDFN,""MAC"",VSTDT,TEST)"
  1.  S TOTPTS=$P(GLOB,")")_",""HIVCHK"",""MACPTCNT"")"
  1.  S BKMDFN=0,@TOTPTS=0
  1.  F  S BKMDFN=$O(@GLOB@("HIVCHK",BKMDFN)) Q:'BKMDFN  D
  1.  .I '$D(@GLOB@("HIVCHK",BKMDFN,"CD4ABS12")) Q
  1.  .S VSTDT=""
  1.  .S FOUND=0
  1.  .; Find earliest CD4 Absolute with results less than 50.
  1.  .F  S VSTDT=$O(@GLOB@("HIVCHK",BKMDFN,"CD4ABS12",VSTDT)) Q:VSTDT=""  D  Q:FOUND
  1.  ..S TEST=""
  1.  ..F  S TEST=$O(@GLOB@("HIVCHK",BKMDFN,"CD4ABS12",VSTDT,TEST)) Q:TEST=""  D  Q:FOUND
  1.  ...S RESULT=$G(@GLOB@("HIVCHK",BKMDFN,"CD4ABS12",VSTDT,TEST))
  1.  ...I RESULT="" Q
  1.  ...I RESULT'<50 Q
  1.  ...S FOUND=1
  1.  .I 'FOUND Q
  1.  .; select meds prescribed since the defined CD4 visit
  1.  .D MEDTAX^BKMIXX(BKMDFN,SITETAX,EDATE,VSTDT,GLOBAL)
  1.  .D NDCTAX^BKMIXX1(BKMDFN,NDCTAX,EDATE,VSTDT,GLOBAL)
  1.  .I $D(@GLOB@("HIVCHK",BKMDFN,"MAC")) S @TOTPTS=@TOTPTS+1
  1.  Q
  1.  ;
  1. MEDLP(ARV) ; Loop through medications found and determine if they are active
  1.  NEW VSTDT,TEST
  1.  S (VSTDT,TEST)=""
  1.  F  S VSTDT=$O(@GLOB@("HIVCHK",BKMDFN,ARV,VSTDT)) Q:'VSTDT  D
  1.  . F  S TEST=$O(@GLOB@("HIVCHK",BKMDFN,ARV,VSTDT,TEST)) Q:'TEST  D
  1.  .. I '$$ACTMED(TEST) K @GLOB@("HIVCHK",BKMDFN,ARV,VSTDT,TEST)
  1.  Q
  1.  ;
  1. ACTMED(VMEDIEN) ;EP - Is this an active medication?
  1.  ;*** only need VMEDIEN - all calls shd be revised ***
  1.  ;
  1.  ; Taken from APCHPMH3 and revised to be a self-contained extrinsic function
  1.  ;
  1.  ; Input:
  1.  ;     VMEDIEN - the V MEDICATION internal entry number
  1.  ;
  1.  ; Output:
  1.  ;     '1' if the rx is currently active
  1.  ;
  1.  NEW VMEDDATA,PSIEN,DCDT,EDATE,EXPDT,RXIEN,STOP,ACT,STAT
  1.  I '$D(^AUPNVMED(VMEDIEN,0)) Q 0
  1.  S VMEDDATA=^AUPNVMED(VMEDIEN,0),PSIEN=$P(VMEDDATA,U,1) I PSIEN="" Q 0
  1.  I '$D(^PSDRUG(PSIEN)) Q 0
  1.  S EDATE=DT ; use only the current date for medications to reduce the risk of a prescribing error
  1.  S DCDT=$P(VMEDDATA,U,8) I DCDT'="",DCDT'>EDATE Q 0 ;date discontinued
  1.  ;
  1.  S EXPDT=""
  1.  ; Get Prescription ien
  1.  S RXIEN=$S($D(^PSRX("APCC",VMEDIEN)):$O(^PSRX("APCC",VMEDIEN,0)),1:0)
  1.  I RXIEN>0,'$D(^PSRX(RXIEN,"STA")) S ACT=0 D  Q ACT
  1.  . ; Is this an expired prescription?
  1.  . S EXPDT=$P($G(^PSRX(RXIEN,2)),U,6)
  1.  . I EXPDT,$$EXPMED(EDATE,EXPDT) Q
  1.  . ; Calculate RX status if V6
  1.  . S STAT=$$RXSTAT(RXIEN,EDATE)
  1.  . I STAT=11 S ACT=1 Q  ; EXPIRED within acceptable timeframe
  1.  . I STAT>10 Q
  1.  . I $P($G(^AUPNVMED(VMEDIEN,11)),U,8)'="" S ACT=1 Q  ; OUTSIDE MEDICATION (AORX mnemonic in the pharmacy package)
  1.  . I STAT=0 S ACT=1 Q  ; ACTIVE
  1.  . I STAT=3 S ACT=1 Q  ; HOLD
  1.  . I STAT=5 S ACT=1 Q  ; SUSPENDED
  1.  ;
  1.  S STAT=$G(^PSRX(RXIEN,"STA")) ;Status is in "STA" node in V 7
  1.  ;
  1.  I STAT=11,'$$EXPMED(RXIEN,EXPDT) Q 1 ;EXPIRED within acceptable timeframe
  1.  I $P($G(^AUPNVMED(VMEDIEN,11)),U,8)'="" Q 1 ; OUTSIDE MEDICATION (AORX mnemonic in the pharmacy package)
  1.  I STAT=0 Q 1 ;ACTIVE
  1.  I STAT=3 Q 1 ;HOLD
  1.  I STAT=5 Q 1 ;SUSPENDED
  1.  Q 0
  1.  ;
  1. RXSTAT(RX,DATE) ; EP - return status of rx
  1.  ;
  1.  ; Taken from APCHPMH3 and revised to be a self-contained extrinsic function
  1.  ;... APCHPMH3 had taken this from the PSOFUNC routine
  1.  ; Note: piece 15 of ^PSRX(RX,0) is not documented in ^DD (probably pre-V 7)
  1.  ;
  1.  ; Input:
  1.  ;     RX   - the PRESCRIPTION internal entry number
  1.  ;     DATE - date against which to compare the prescription expiration date
  1.  ;
  1.  NEW RX0,RX2,J,ST0,ST,ST1
  1.  I $D(^PSRX(RX,"STA")) Q "" ;USING V7
  1.  I RX'>0 Q ""
  1.  S DATE=$G(DATE,DT)
  1.  S RX0=$G(^PSRX(RX,0)),RX2=$G(^PSRX(RX,2))
  1.  S J=RX,ST0=$P(RX0,U,15) I ST0'="" S ST0=+ST0
  1.  I ST0<12 D
  1.  . S ST1=$O(^PS(52.5,"B",J,0)) Q:ST1=""
  1.  . I $D(^PS(52.5,ST1,0)),'$G(^PS(52.5,ST1,"P")) S ST0=5
  1.  I ST0<12,$P(RX2,U,6),$P(RX2,U,6)'>DATE S ST0=11
  1.  Q ST0
  1.  ;
  1. EXPMED(RXIEN,EXPDT) ; Is this an expired prescription?
  1.  ; Chronic medications - greater than 120 days
  1.  ; All other medications - greater than 14 days
  1.  ;
  1.  NEW CHR
  1.  I 'EXPDT Q 0
  1.  S CHR=($$GET1^DIQ(52,RXIEN,9999999.02,"I")="Y")
  1.  I CHR,$$FMDIFF^XLFDT(EXPDT,DT)>120 Q 1
  1.  I 'CHR,$$FMDIFF^XLFDT(EXPDT,DT)>14 Q 1
  1.  Q 0