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

BGP5D89.m

Go to the documentation of this file. 
  1. BGP5D89 ; IHS/CMI/LAB - measure C 03 Jul 2010 7:05 AM ;
  1.  ;;15.1;IHS CLINICAL REPORTING;;MAY 06, 2015;Build 143
  1.  ;
  1. VS ;EP
  1.  S (BGPN1,BGPN2,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11)=0
  1.  I 'BGPACTCL S BGPSTOP=1 Q  ;not active clinical pt
  1.  ;SET UP DENOMINATORS
  1.  S BGPD1=1  ;all A/C
  1.  I BGPAGEB>1,BGPAGEB<19 S BGPD2=1
  1.  I BGPAGEB>4 S BGPD3=1
  1.  I BGPAGEB>11,BGPAGEB<19 S BGPD4=1
  1.  I BGPAGEB>11,BGPAGEB<76 S BGPD5=1
  1.  I BGPSEX="F",BGPAGEB>14,BGPAGEB<41 S BGPD6=1
  1.  I BGPSEX="F",BGPAGEB>14,BGPAGEB<45 S BGPD7=1
  1.  I BGPAGEB>17 S BGPD8=1
  1.  I BGPAGEB>64 S BGPD9=1
  1.  I $$TOBUSER(DFN,BGPBDATE) S BGPD10=1
  1.  S BGPQV=$$VISIT(DFN,BGPBDATE,BGPEDATE)
  1.  I 'BGPQV S BGPN1=1
  1.  S BGPURO=$$UCONLY(DFN,BGP3YE,BGPEDATE)
  1.  I 'BGPURO S BGPN2=1  ;urgent care only visit
  1.  S D="AC"
  1.  I BGPD2 S D=D_",AC 2-18"
  1.  I BGPD3 S D=D_",AC =>5"
  1.  I BGPD4 S D=D_",AC 12-18"
  1.  I BGPD5 S D=D_",AC 12-75"
  1.  I BGPD6 S D=D_",FEM AC 15-40"
  1.  I BGPD7 S D=D_",FEM AC 15-44"
  1.  I BGPD8 S D=D_",AC =>18"
  1.  I BGPD9 S D=D_",AC =>65"
  1.  I BGPD10 S D=D_",TOB"
  1.  S BGPVALUE="AC"_$S(BGPD10:",TOB",1:"")_"|||"_$S('BGPN1:"No visit in time period",1:"Visit in time period "_$$DATE^BGP5UTL(BGPQV))_" Urgent Care Only: "_$$DATE^BGP5UTL(BGPURO)
  1.  S BGPVALUD="AC"_$S(BGPD10:",TOB",1:"")_"|||"
  1.  K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
  1.  K BGPEDUC,BGPHIV
  1.  Q
  1. VISIT(P,BDATE,EDATE) ;
  1.  K ^TMP($J,"A")
  1.  NEW A,C,B,E,X,G,V
  1.  S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
  1.  I '$D(^TMP($J,"A",1)) Q ""
  1.  S (X,G)=0 F  S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G)  S V=$P(^TMP($J,"A",X),U,5) D
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)
  1.  .Q:"SAHOR"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .Q:$P(^AUPNVSIT(V,0),U,6)=""
  1.  .S C=$$CLINIC^APCLV(V,"C")
  1.  .Q:C=42
  1.  .Q:C=51
  1.  .Q:C=52
  1.  .Q:C=53
  1.  .S G=$$VD^APCLV(V)
  1.  .Q
  1.  Q G
  1. TOBUSER(P,BDATE) ;EP
  1.  NEW BGPTUSER,%,BGPTOBP,BGPSDX,BGPSCPT,F
  1.  S BGPTUSER=""
  1.  S BGPTOBP=$$TOBHF^BGP5D712(P,$$DOB^AUPNPAT(P),$$FMADD^XLFDT(BDATE,-1))
  1.  S BGPSDX=$$DXU^BGP5D7(P,$$DOB^AUPNPAT(P),$$FMADD^XLFDT(BDATE,-1))
  1.  S BGPSCPT=$$CPTSM^BGP5D7(P,$$DOB^AUPNPAT(P),$$FMADD^XLFDT(BDATE,-1))
  1.  S %=""
  1.  ;I BGPSDX]"",$P(BGPSDX,U)="V15.82" S %=1
  1.  ;I BGPSDX]"",$P(BGPSDX,U)="305.13" S %=1
  1.  S T=$O(^ATXAX("B","BGP TOBACCO PAST USE DXS",0))
  1.  I BGPSDX]"" S I=$P(BGPSDX,U,3) I $$ICD^BGP5UTL2(I,T,9) S %=1
  1.  S F=BGPTOBP
  1.  D
  1.  .I $P(F,U,1)["CURRENT"!($P(F,U,1)["CESSATION")!($P(F,U,1)="HEAVY TOBACCO SMOKER")!($P(F,U,1)="LIGHT TOBACCO SMOKER") S BGPTUSER=1 Q
  1.  .I $P(F,U,4)["CURRENT"!($P(F,U,4)["CESSATION") S BGPTUSER=1 Q
  1.  .I (BGPSDX]""&(%="")) S BGPTUSER=1 Q
  1.  .I ($P(BGPSCPT,U)="1034F")!($P(BGPSCPT,U)="1035F")!($P(BGPSCPT,U)="G0376")!($P(BGPSCPT,U)="G0375")!($P(BGPSCPT,U)=99407)!($P(BGPSCPT,U)="G9276") S BGPTUSER=1 Q
  1.  .I $P(BGPSCPT,U)=99406!($P(BGPSCPT,U)="G8455")!($P(BGPSCPT,U)="G8456")!($P(BGPSCPT,U)="G8402")!($P(BGPSCPT,U)="G8453") S BGPTUSER=1 Q
  1.  ;S F=$P(BGPTOBP,U,1)
  1.  ;I $P(BGPTOBP,U,1)["CURRENT"!(BGPSDX]""&(%=""))!(F["CESSATION")!($P(BGPSCPT,U)="1034F")!($P(BGPSCPT,U)="1035F")!($P(BGPSCPT,U)="G0376")!($P(BGPSCPT,U)="G0375")!($P(BGPSCPT,U)=99407) S BGPTUSER=1
  1.  ;I $P(BGPSCPT,U)=99406!($P(BGPSCPT,U)="G8455")!($P(BGPSCPT,U)="G8456")!($P(BGPSCPT,U)="G8402")!($P(BGPSCPT,U)="G8453") S BGPTUSER=1
  1.  Q BGPTUSER
  1. UCONLY(P,BDATE,EDATE) ;EP - clinical user
  1.  K ^TMP($J,"A")
  1.  NEW A,C,B,E,X,G,V,UCC,ALV
  1.  S (UCC,ALV)=0
  1.  ;UCC - urgent care clinic count
  1.  ;ALV - all visit count
  1.  S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
  1.  I '$D(^TMP($J,"A",1)) Q ""
  1.  S (X,G,F,S)=0 F  S X=$O(^TMP($J,"A",X)) Q:X'=+X!(F)  S V=$P(^TMP($J,"A",X),U,5) D
  1.  .Q:'$D(^AUPNVSIT(V,0))
  1.  .Q:'$P(^AUPNVSIT(V,0),U,9)
  1.  .Q:$P(^AUPNVSIT(V,0),U,11)
  1.  .Q:'$D(^AUPNVPRV("AD",V))
  1.  .Q:"SAHO"'[$P(^AUPNVSIT(V,0),U,7)
  1.  .Q:"V"[$P(^AUPNVSIT(V,0),U,3)
  1.  .Q:$P(^AUPNVSIT(V,0),U,6)=""
  1.  .S B=$$CLINIC^APCLV(V,"C")
  1.  .Q:B=""
  1.  .I B=80 S UCC=UCC+1 Q
  1.  .I 'G,$D(^BGPCTRL($O(^BGPCTRL("B",2015,0)),11,"B",B)) S G=V  ;must be a primary clinic S G=V
  1.  .I V'=G,$D(^BGPCTRL($O(^BGPCTRL("B",2015,0)),12,"B",B)) S S=1
  1.  .I G,S S F=1
  1.  .Q
  1.  Q $S(F:1,1:0)
  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^BGP5UTL2(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^BGP5UTL(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^BGP5UTL(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