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

BGP8D89.m

Go to the documentation of this file. 
  1. BGP8D89 ; IHS/CMI/LAB - measure C 03 Jul 2010 7:05 AM ;
  1.  ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
  1.  ;
  1. PRIMMED ;
  1.  ;
  1.  S (BGPD1,BGPN1)=0
  1.  I 'BGPACTCL S BGPSTOP=1 Q  ;not active clinical pt
  1.  I BGPAGEB<18 S BGPSTOP=1 Q  ;only 18 and older
  1.  ;bgpd1 = TOTAL # OF PRESCRIPTIONS
  1.  ;bgpn1 = # returned to stock
  1.  S (BGPD1,BGPN1)=0
  1.  NEW BGPP,IFN,D,FD,SD,FDS,R
  1.  S SD=$$FMADD^XLFDT(BGPBDATE,-180)
  1.  K ^TMP($J,"A")
  1.  NEW A,B,E,Z,X,D,V,Y,G,M,T,T1
  1.  K BGPMEDS1
  1.  D GETMEDS^BGP8UTL2(DFN,SD,BGPEDATE,,,,,.BGPMEDS1)
  1.  I '$D(BGPMEDS1) Q  ;
  1.  S BGPVALUE="",BGPDX="",BGPNX=""
  1.  ;loop through prescription file and get all chronic meds (defined by taxonomy), array by fill date
  1.  S BGPP=0
  1.  F  S BGPP=$O(BGPMEDS1(BGPP)) Q:BGPP=""  D
  1.  .S M=$P(BGPMEDS1(BGPP),U,4)
  1.  .S D=$P(^AUPNVMED(M,0),U,1)
  1.  .S P=$S($D(^PSRX("APCC",M)):$O(^(M,0)),1:0)
  1.  .I 'P K BGPMEDS1(BGPP) Q  ;NO PRESCRIPTION
  1.  .I '$D(^PSRX(P,0)) K BGPMEDS1(BGPP) Q  ;NO PRESCRIPTION
  1.  .I $P($G(^PSRX(P,"STA")),"^")=13 K BGPMEDS1(BGPP) Q  ;deleted
  1.  .I $E($P(^PSRX(P,0),U,1))="X" K BGPMEDS1(BGPP) Q
  1.  .;get order number and skip if not electronic
  1.  .S O=$P($G(^PSRX(P,"OR1")),U,2)  ;order number
  1.  .I 'O K BGPMEDS1(BGPP) Q
  1.  .S B=$P($G(^OR(100,O,8,1,0)),U,12)
  1.  .I B="" K BGPMEDS1(BGPP) Q  ;Q:B=""
  1.  .I B'=8 K BGPMEDS1(BGPP) Q   ;must be electronic
  1.  .S FD=$$VD^APCLV($P(BGPMEDS1(BGPP),U,5))
  1.  .I FD>BGPEDATE K BGPMEDS1(BGPP) Q
  1.  .I FD<BGPBDATE K BGPMEDS1(BGPP) Q
  1.  .I '$$CHRONIC(D) K BGPMEDS1(BGPP) Q  ;must be from one of these taxonomies
  1.  .;was that another V MED in previous 180 days.
  1.  .K BGPG
  1.  .S %=DFN_"^LAST MED `"_D_";DURING "_$$FMADD^XLFDT(FD,-180)_"-"_$$FMADD^XLFDT(FD,-1),E=$$START1^APCLDF(%,"BGPG(")
  1.  .I $D(BGPG(1)) K BGPMEDS1(BGPP) Q  ;had one 180 prior
  1.  .S BGPD1=BGPD1+1
  1.  .I BGPDX]"" S BGPDX=BGPDX_"; "
  1.  .S BGPDX=BGPDX_BGPD1_") "_$$DATE^BGP8UTL(FD)_" "_$$VAL^XBDIQ1(50,D,.01)
  1.  .I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" S BGPN1=BGPN1+1 D  Q
  1.  ..I BGPNX]"" S BGPNX=BGPNX_"; "
  1.  ..S BGPNX=BGPNX_BGPD1_") "_$$DATE^BGP8UTL(FD)_" "_$$VAL^XBDIQ1(50,D,.01)_"-RTS"
  1.  S BGPVALUE="AC "_BGPDX_"|||"_BGPNX
  1.  K BGPMEDS1
  1.  Q
  1. NDC(A,B) ;
  1.  ;a is drug ien
  1.  ;b is taxonomy ien
  1.  NEW BGPNDC
  1.  S BGPNDC=$P($G(^PSDRUG(A,2)),U,4)
  1.  I BGPNDC]"",B,$D(^ATXAX(B,21,"B",BGPNDC)) Q 1
  1.  Q 0
  1. CHRONIC(D) ;
  1.  I '$G(D) Q 0
  1.  NEW TM,TN
  1.  S TM=$O(^ATXAX("B","BGP PQA ASTHMA INHALE STER MED",0))
  1.  S TN=$O(^ATXAX("B","BGP PQA ASTHMA INHALE STER NDC",0))
  1.  I $D(^ATXAX(TM,21,"B",D))!($$NDC(D,TN)) Q 1
  1.  S TM=$O(^ATXAX("B","BGP PQA COPD MEDS",0))
  1.  S TN=$O(^ATXAX("B","BGP PQA COPD NDC",0))
  1.  I $D(^ATXAX(TM,21,"B",D))!($$NDC(D,TN)) Q 1
  1.  S TM=$O(^ATXAX("B","BGP PQA DIABETES ALL CLASS",0))
  1.  S TN=$O(^ATXAX("B","BGP PQA DIABETES ALL CLASS NDC",0))
  1.  I $D(^ATXAX(TM,21,"B",D))!($$NDC(D,TN)) Q 1
  1.  S TM=$O(^ATXAX("B","BGP PQA RASA MEDS",0))
  1.  S TN=$O(^ATXAX("B","BGP PQA RASA NDC",0))
  1.  I $D(^ATXAX(TM,21,"B",D))!($$NDC(D,TN)) Q 1
  1.  S TM=$O(^ATXAX("B","BGP PQA STATIN MEDS",0))
  1.  S TN=$O(^ATXAX("B","BGP PQA STATIN NDC",0))
  1.  I $D(^ATXAX(TM,21,"B",D))!($$NDC(D,TN)) Q 1
  1.  Q 0