BGP8D89 ; IHS/CMI/LAB - measure C 03 Jul 2010 7:05 AM ;
;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
;
PRIMMED ;
;
S (BGPD1,BGPN1)=0
I 'BGPACTCL S BGPSTOP=1 Q ;not active clinical pt
I BGPAGEB<18 S BGPSTOP=1 Q ;only 18 and older
;bgpd1 = TOTAL # OF PRESCRIPTIONS
;bgpn1 = # returned to stock
S (BGPD1,BGPN1)=0
NEW BGPP,IFN,D,FD,SD,FDS,R
S SD=$$FMADD^XLFDT(BGPBDATE,-180)
K ^TMP($J,"A")
NEW A,B,E,Z,X,D,V,Y,G,M,T,T1
K BGPMEDS1
D GETMEDS^BGP8UTL2(DFN,SD,BGPEDATE,,,,,.BGPMEDS1)
I '$D(BGPMEDS1) Q ;
S BGPVALUE="",BGPDX="",BGPNX=""
;loop through prescription file and get all chronic meds (defined by taxonomy), array by fill date
S BGPP=0
F S BGPP=$O(BGPMEDS1(BGPP)) Q:BGPP="" D
.S M=$P(BGPMEDS1(BGPP),U,4)
.S D=$P(^AUPNVMED(M,0),U,1)
.S P=$S($D(^PSRX("APCC",M)):$O(^(M,0)),1:0)
.I 'P K BGPMEDS1(BGPP) Q ;NO PRESCRIPTION
.I '$D(^PSRX(P,0)) K BGPMEDS1(BGPP) Q ;NO PRESCRIPTION
.I $P($G(^PSRX(P,"STA")),"^")=13 K BGPMEDS1(BGPP) Q ;deleted
.I $E($P(^PSRX(P,0),U,1))="X" K BGPMEDS1(BGPP) Q
.;get order number and skip if not electronic
.S O=$P($G(^PSRX(P,"OR1")),U,2) ;order number
.I 'O K BGPMEDS1(BGPP) Q
.S B=$P($G(^OR(100,O,8,1,0)),U,12)
.I B="" K BGPMEDS1(BGPP) Q ;Q:B=""
.I B'=8 K BGPMEDS1(BGPP) Q ;must be electronic
.S FD=$$VD^APCLV($P(BGPMEDS1(BGPP),U,5))
.I FD>BGPEDATE K BGPMEDS1(BGPP) Q
.I FD<BGPBDATE K BGPMEDS1(BGPP) Q
.I '$$CHRONIC(D) K BGPMEDS1(BGPP) Q ;must be from one of these taxonomies
.;was that another V MED in previous 180 days.
.K BGPG
.S %=DFN_"^LAST MED `"_D_";DURING "_$$FMADD^XLFDT(FD,-180)_"-"_$$FMADD^XLFDT(FD,-1),E=$$START1^APCLDF(%,"BGPG(")
.I $D(BGPG(1)) K BGPMEDS1(BGPP) Q ;had one 180 prior
.S BGPD1=BGPD1+1
.I BGPDX]"" S BGPDX=BGPDX_"; "
.S BGPDX=BGPDX_BGPD1_") "_$$DATE^BGP8UTL(FD)_" "_$$VAL^XBDIQ1(50,D,.01)
.I $$UP^XLFSTR($P($G(^AUPNVMED(M,11)),U))["RETURNED TO STOCK" S BGPN1=BGPN1+1 D Q
..I BGPNX]"" S BGPNX=BGPNX_"; "
..S BGPNX=BGPNX_BGPD1_") "_$$DATE^BGP8UTL(FD)_" "_$$VAL^XBDIQ1(50,D,.01)_"-RTS"
S BGPVALUE="AC "_BGPDX_"|||"_BGPNX
K BGPMEDS1
Q
NDC(A,B) ;
;a is drug ien
;b is taxonomy ien
NEW BGPNDC
S BGPNDC=$P($G(^PSDRUG(A,2)),U,4)
I BGPNDC]"",B,$D(^ATXAX(B,21,"B",BGPNDC)) Q 1
Q 0
CHRONIC(D) ;
I '$G(D) Q 0
NEW TM,TN
S TM=$O(^ATXAX("B","BGP PQA ASTHMA INHALE STER MED",0))
S TN=$O(^ATXAX("B","BGP PQA ASTHMA INHALE STER NDC",0))
I $D(^ATXAX(TM,21,"B",D))!($$NDC(D,TN)) Q 1
S TM=$O(^ATXAX("B","BGP PQA COPD MEDS",0))
S TN=$O(^ATXAX("B","BGP PQA COPD NDC",0))
I $D(^ATXAX(TM,21,"B",D))!($$NDC(D,TN)) Q 1
S TM=$O(^ATXAX("B","BGP PQA DIABETES ALL CLASS",0))
S TN=$O(^ATXAX("B","BGP PQA DIABETES ALL CLASS NDC",0))
I $D(^ATXAX(TM,21,"B",D))!($$NDC(D,TN)) Q 1
S TM=$O(^ATXAX("B","BGP PQA RASA MEDS",0))
S TN=$O(^ATXAX("B","BGP PQA RASA NDC",0))
I $D(^ATXAX(TM,21,"B",D))!($$NDC(D,TN)) Q 1
S TM=$O(^ATXAX("B","BGP PQA STATIN MEDS",0))
S TN=$O(^ATXAX("B","BGP PQA STATIN NDC",0))
I $D(^ATXAX(TM,21,"B",D))!($$NDC(D,TN)) Q 1
Q 0
BGP8D89 ; IHS/CMI/LAB - measure C 03 Jul 2010 7:05 AM ;
+1 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
+2 ;
PRIMMED ;
+1 ;
+2 SET (BGPD1,BGPN1)=0
+3 ;not active clinical pt
IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+4 ;only 18 and older
IF BGPAGEB<18
SET BGPSTOP=1
QUIT
+5 ;bgpd1 = TOTAL # OF PRESCRIPTIONS
+6 ;bgpn1 = # returned to stock
+7 SET (BGPD1,BGPN1)=0
+8 NEW BGPP,IFN,D,FD,SD,FDS,R
+9 SET SD=$$FMADD^XLFDT(BGPBDATE,-180)
+10 KILL ^TMP($JOB,"A")
+11 NEW A,B,E,Z,X,D,V,Y,G,M,T,T1
+12 KILL BGPMEDS1
+13 DO GETMEDS^BGP8UTL2(DFN,SD,BGPEDATE,,,,,.BGPMEDS1)
+14 ;
IF '$DATA(BGPMEDS1)
QUIT
+15 SET BGPVALUE=""
SET BGPDX=""
SET BGPNX=""
+16 ;loop through prescription file and get all chronic meds (defined by taxonomy), array by fill date
+17 SET BGPP=0
+18 FOR
SET BGPP=$ORDER(BGPMEDS1(BGPP))
IF BGPP=""
QUIT
Begin DoDot:1
+19 SET M=$PIECE(BGPMEDS1(BGPP),U,4)
+20 SET D=$PIECE(^AUPNVMED(M,0),U,1)
+21 SET P=$SELECT($DATA(^PSRX("APCC",M)):$ORDER(^(M,0)),1:0)
+22 ;NO PRESCRIPTION
IF 'P
KILL BGPMEDS1(BGPP)
QUIT
+23 ;NO PRESCRIPTION
IF '$DATA(^PSRX(P,0))
KILL BGPMEDS1(BGPP)
QUIT
+24 ;deleted
IF $PIECE($GET(^PSRX(P,"STA")),"^")=13
KILL BGPMEDS1(BGPP)
QUIT
+25 IF $EXTRACT($PIECE(^PSRX(P,0),U,1))="X"
KILL BGPMEDS1(BGPP)
QUIT
+26 ;get order number and skip if not electronic
+27 ;order number
SET O=$PIECE($GET(^PSRX(P,"OR1")),U,2)
+28 IF 'O
KILL BGPMEDS1(BGPP)
QUIT
+29 SET B=$PIECE($GET(^OR(100,O,8,1,0)),U,12)
+30 ;Q:B=""
IF B=""
KILL BGPMEDS1(BGPP)
QUIT
+31 ;must be electronic
IF B'=8
KILL BGPMEDS1(BGPP)
QUIT
+32 SET FD=$$VD^APCLV($PIECE(BGPMEDS1(BGPP),U,5))
+33 IF FD>BGPEDATE
KILL BGPMEDS1(BGPP)
QUIT
+34 IF FD<BGPBDATE
KILL BGPMEDS1(BGPP)
QUIT
+35 ;must be from one of these taxonomies
IF '$$CHRONIC(D)
KILL BGPMEDS1(BGPP)
QUIT
+36 ;was that another V MED in previous 180 days.
+37 KILL BGPG
+38 SET %=DFN_"^LAST MED `"_D_";DURING "_$$FMADD^XLFDT(FD,-180)_"-"_$$FMADD^XLFDT(FD,-1)
SET E=$$START1^APCLDF(%,"BGPG(")
+39 ;had one 180 prior
IF $DATA(BGPG(1))
KILL BGPMEDS1(BGPP)
QUIT
+40 SET BGPD1=BGPD1+1
+41 IF BGPDX]""
SET BGPDX=BGPDX_"; "
+42 SET BGPDX=BGPDX_BGPD1_") "_$$DATE^BGP8UTL(FD)_" "_$$VAL^XBDIQ1(50,D,.01)
+43 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(M,11)),U))["RETURNED TO STOCK"
SET BGPN1=BGPN1+1
Begin DoDot:2
+44 IF BGPNX]""
SET BGPNX=BGPNX_"; "
+45 SET BGPNX=BGPNX_BGPD1_") "_$$DATE^BGP8UTL(FD)_" "_$$VAL^XBDIQ1(50,D,.01)_"-RTS"
End DoDot:2
QUIT
End DoDot:1
+46 SET BGPVALUE="AC "_BGPDX_"|||"_BGPNX
+47 KILL BGPMEDS1
+48 QUIT
NDC(A,B) ;
+1 ;a is drug ien
+2 ;b is taxonomy ien
+3 NEW BGPNDC
+4 SET BGPNDC=$PIECE($GET(^PSDRUG(A,2)),U,4)
+5 IF BGPNDC]""
IF B
IF $DATA(^ATXAX(B,21,"B",BGPNDC))
QUIT 1
+6 QUIT 0
CHRONIC(D) ;
+1 IF '$GET(D)
QUIT 0
+2 NEW TM,TN
+3 SET TM=$ORDER(^ATXAX("B","BGP PQA ASTHMA INHALE STER MED",0))
+4 SET TN=$ORDER(^ATXAX("B","BGP PQA ASTHMA INHALE STER NDC",0))
+5 IF $DATA(^ATXAX(TM,21,"B",D))!($$NDC(D,TN))
QUIT 1
+6 SET TM=$ORDER(^ATXAX("B","BGP PQA COPD MEDS",0))
+7 SET TN=$ORDER(^ATXAX("B","BGP PQA COPD NDC",0))
+8 IF $DATA(^ATXAX(TM,21,"B",D))!($$NDC(D,TN))
QUIT 1
+9 SET TM=$ORDER(^ATXAX("B","BGP PQA DIABETES ALL CLASS",0))
+10 SET TN=$ORDER(^ATXAX("B","BGP PQA DIABETES ALL CLASS NDC",0))
+11 IF $DATA(^ATXAX(TM,21,"B",D))!($$NDC(D,TN))
QUIT 1
+12 SET TM=$ORDER(^ATXAX("B","BGP PQA RASA MEDS",0))
+13 SET TN=$ORDER(^ATXAX("B","BGP PQA RASA NDC",0))
+14 IF $DATA(^ATXAX(TM,21,"B",D))!($$NDC(D,TN))
QUIT 1
+15 SET TM=$ORDER(^ATXAX("B","BGP PQA STATIN MEDS",0))
+16 SET TN=$ORDER(^ATXAX("B","BGP PQA STATIN NDC",0))
+17 IF $DATA(^ATXAX(TM,21,"B",D))!($$NDC(D,TN))
QUIT 1
+18 QUIT 0
