BGP4D82 ; IHS/CMI/LAB - measure C 14 Mar 2010 11:49 AM ;
;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
;
IRAA ;EP
S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12)=0
I 'BGPACTCL S BGPSTOP=1 Q
I BGPAGEB<16 S BGPSTOP=1 Q ;must be 16 or older
I '$$OSTEOAR(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 Q ;no OSTEOARTHRITIS
S BGPV=$$MEDSPRE(DFN,BGPBDATE,BGPEDATE)
I '$P(BGPV,U) S BGPSTOP=1 K ^TMP($J,"A") Q ;no meds prescribed per logic
S BGPOSTEO=$P(BGPV,U,1)
;S BGPGLUC=$P(BGPV,U,2)
I BGPACTCL S BGPD1=1
I BGPACTUP S BGPD2=1
I BGPAGEB>54,BGPAGEB<65,BGPD1 S BGPD3=1
I BGPAGEB>64,BGPAGEB<75,BGPD1 S BGPD4=1
I BGPAGEB>74,BGPAGEB<85,BGPD1 S BGPD5=1
I BGPAGEB>84,BGPD1 S BGPD6=1
S BGPCBC=$$CBC(DFN,BGPBDATE,BGPEDATE)
S BGPLFT=$$LFT(DFN,BGPBDATE,BGPEDATE)
S BGPCREAT=$$CREAT^BGP4D22(DFN,BGPBDATE,BGPEDATE)
S BGPN1=0
I BGPOSTEO S BGPN1=$S('BGPCBC:0,'BGPLFT:0,'BGPCREAT:0,1:1)
;I BGPGLUC S BGPN1=$S('BGPUG:0,1:1)
S BGPVALUE=$S(BGPD1:"AC",1:"")_$P(BGPV,U,5)_"|||"
I BGPOSTEO S BGPVALUE=BGPVALUE_$S(BGPN1:"YES: ",1:"NO: ")
I BGPOSTEO,BGPCREAT S BGPVALUE=BGPVALUE_$S(BGPCREAT:$$DATE^BGP4UTL($P(BGPCREAT,U,2))_" CREAT",1:"")
I BGPOSTEO,BGPCBC S BGPVALUE=BGPVALUE_$S(BGPCREAT:", ",1:""),BGPVALUE=BGPVALUE_$S(BGPCBC:$$DATE^BGP4UTL($P(BGPCBC,U,2))_" CBC",1:"")
I BGPOSTEO,BGPLFT S BGPVALUE=BGPVALUE_$S(BGPCREAT!(BGPCBC):", ",1:""),BGPVALUE=BGPVALUE_$S(BGPLFT:$$DATE^BGP4UTL($P(BGPLFT,U,2))_" LFT",1:"")
K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
K ^TMP($J,"A")
Q
OSTEOAR(P,BDATE,EDATE) ;EP
;must have osteoarthritis on pl prior to BDATE or have a pov prior to bdate
;and have 2 povs between bdate and edate
I '$G(P) Q ""
S (G,X,Y,A,H,C)=""
;first check for pov prior to bdate
K BGPG
S Y="BGPG("
S X=P_"^LAST DX [BGP OSTEOARTHRITIS DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_BDATE S E=$$START1^APCLDF(X,Y)
S H="" I $D(BGPG(1)) S H=$$DATE^BGP4UTL($P(BGPG(1),U))_" "_$P(BGPG(1),U,2)
I H]"" G RPDXS
;now check for pl entry prior to BDATE
S T=$O(^ATXAX("B","BGP OSTEOARTHRITIS DXS",0))
S (X,B)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(H) D
.Q:$P(^AUPNPROB(X,0),U,8)>BDATE ;if added to pl after beginning of time period, no go
.S Y=$P(^AUPNPROB(X,0),U)
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.Q:$P(^AUPNPROB(X,0),U,12)="I"
.Q:'$$ICD^BGP4UTL2(Y,T,9)
.S H=$$DATE^BGP4UTL($P(^AUPNPROB(X,0),U,8))_" "_$P($$ICDDX^BGP4UTL2(Y),U,2)_" Problem list"
.Q
I H="" Q "" ;don't go further as patient does not have osteoarthritis prior to the report period
RPDXS ;check for 2 dxs in time period
K BGPG
S Y="BGPG(",C=""
S X=P_"^LAST 2 DX [BGP OSTEOARTHRITIS DXS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
I $D(BGPG(2)) S C="2 dxs: "_$$DATE^BGP4UTL($P(BGPG(2),U))_" "_$$DATE^BGP4UTL($P(BGPG(1),U))
I H=""!(C="") Q ""
Q "1^prior: "_H_" rpt period: "_C
;
MEDSPRE(P,BDATE,EDATE) ;were meds prescribed in time frame and before?
I $G(P)="" Q ""
S (A,B,C,D,E,F,G,H,I,J)=""
K BGPMEDS1
D GETMEDS^BGP4UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
I '$D(BGPMEDS1) Q ""
S T1=$O(^ATXAX("B","BGP RA OA NSAID MEDS",0))
S T4=$O(^ATXAX("B","BGP RA OA NSAID VAPI",0))
S T2=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
S (X,G,M,E)=0,D="" F S X=$O(BGPMEDS1(X)) Q:X'=+X S V=$P(BGPMEDS1(X),U,5),Y=+$P(BGPMEDS1(X),U,4) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$D(^AUPNVMED(Y,0))
.Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
.S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
.Q:Z="" ;BAD POINTER
.I $D(^ATXAX(T1,21,"B",Z))!($$VAPI^BGP4D81(Z,T4)) S A=1 Q
.I $D(^ATXAX(T2,21,"B",Z)) S A=1 Q
;now check for B
;S T1=$O(^ATXAX("B","BGP OA GLUCOCORTICOIDS MEDS",0))
;S T4=$O(^ATXAX("B","BGP OA GLUCOCORTICOIDS CLASS",0))
;S (X,G,M,E)=0,C="" F S X=$O(BGPMEDS1(X)) Q:X'=+X S V=$P(BGPMEDS1(X),U,5),Y=+$P(BGPMEDS1(X),U,4) D
;.Q:'$D(^AUPNVSIT(V,0))
;.S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
;.Q:Z="" ;BAD POINTER
;.I $D(^ATXAX(T1,21,"B",Z))!($$CLASS(Z,T4)) S B=1
I 'A Q "" ;none within time frame
S BDATE=$$FMADD^XLFDT(EDATE,-465)
K BGPMEDS1
D GETMEDS^BGP4UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
I '$D(BGPMEDS1) Q ""
S C=0
S T1=$O(^ATXAX("B","BGP RA OA NSAID MEDS",0))
S T4=$O(^ATXAX("B","BGP RA OA NSAID VAPI",0))
S T2=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
S X=0 F S X=$O(BGPMEDS1(X)) Q:X'=+X S V=$P(BGPMEDS1(X),U,5),Y=+$P(BGPMEDS1(X),U,4) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$D(^AUPNVMED(Y,0))
.Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
.S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
.Q:Z="" ;BAD POINTER
.I $D(^ATXAX(T1,21,"B",Z))!($$VAPI^BGP4D81(Z,T4)) S C=C+$$DAYS(Y,V,EDATE) Q
.I $D(^ATXAX(T2,21,"B",Z)) S C=C+$$DAYS(Y,V,EDATE)
;GLUCX ;now check for B
;S D=0
;S T1=$O(^ATXAX("B","BGP OA GLUCOCORTICOIDS MEDS",0))
;S T4=$O(^ATXAX("B","BGP OA GLUCOCORTICOIDS CLASS",0))
;S X=0 F S X=$O(BGPMEDS1(X)) Q:X'=+X S V=$P(BGPMEDS1(X),U,5),Y=+$P(BGPMEDS1(X),U,4) D
;.Q:'$D(^AUPNVSIT(V,0))
;.S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
;.Q:Z="" ;BAD POINTER
;.I $D(^ATXAX(T1,21,"B",Z))!($$CLASS(Z,T4)) S D=D+$$DAYS(Y,V,EDATE)
CHCK ;
S E=.75*($$FMDIFF^XLFDT(EDATE,BDATE))
S V="" ;I B,D'<E S $P(V,U,2)=1,$P(V,U,4)=D S $P(V,U,5)=$P(V,U,5)_" "_$S(B:D_" days of glucocorticoids",1:"")
I A,C'<E S $P(V,U)=1,$P(V,U,3)=C S $P(V,U,5)=$P(V,U,5)_" "_$S(A:C_" days of NSAID ",1:"")
Q V
DAYS(Y,V,E) ;EP
NEW %,N,S,D
S N=$P(^AUPNVMED(Y,0),U,7) ;DAYS SUPPLY
S %=$P(^AUPNVMED(Y,0),U,8) ;DATE DISCONTINUED
;I %="" Q N
S D=$P($P($G(^AUPNVSIT(V,0)),U),".")
;I D="" Q N
I $$FMADD^XLFDT(D,N)>E S N=$$FMDIFF^XLFDT(E,D)
I %="" Q N
I D="" Q N
S S=$$FMDIFF^XLFDT(%,D)
I S>0,S<N Q S
Q N
NDC(A,B) ;
;a is drug ien
;b is taxonomy ien
S BGPNDC=$P($G(^PSDRUG(A,2)),U,4)
I BGPNDC]"",B,$D(^ATXAX(B,21,"B",BGPNDC)) Q 1
Q 0
CLASS(A,B) ;EP
;a is drug ien
;b is taxonomy ien
S BGPNDC=$P($G(^PSDRUG(A,0)),U,2)
I BGPNDC]"",B,$D(^ATXAX(B,21,"B",BGPNDC)) Q 1
Q 0
CBC(P,BDATE,EDATE) ;
K BGPC
S BGPC=0
S %="",E=+$$CODEN^ICPTCOD(85025),%=$$CPTI^BGP4DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"85025"
S %="",E=+$$CODEN^ICPTCOD(85027),%=$$CPTI^BGP4DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"85027"
S %="",E=+$$CODEN^ICPTCOD(85025),%=$$TRANI^BGP4DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"85025 TRAN"
S %="",E=+$$CODEN^ICPTCOD(85027),%=$$TRANI^BGP4DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"85027 TRAN"
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP CBC LOINC",0))
S BGPLT=$O(^ATXLAB("B","BGP CBC TESTS",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!($P(BGPC,U)) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!($P(BGPC,U)) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U)) D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_(9999999-D)_U_"LAB" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP4D21(J,T)
...S BGPC=1_U_(9999999-D)_U_"LOINC"
...Q
Q BGPC
LFT(P,BDATE,EDATE) ;
K BGPC
S BGPC=0
S %="",E=+$$CODEN^ICPTCOD(84460),%=$$CPTI^BGP4DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"84460"
S %="",E=+$$CODEN^ICPTCOD(84450),%=$$CPTI^BGP4DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"84450"
S %="",E=+$$CODEN^ICPTCOD(80076),%=$$CPTI^BGP4DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"80076"
;TRAN
S %="",E=+$$CODEN^ICPTCOD(84460),%=$$TRANI^BGP4DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"84460"
S %="",E=+$$CODEN^ICPTCOD(84450),%=$$TRANI^BGP4DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"84450"
S %="",E=+$$CODEN^ICPTCOD(80076),%=$$TRANI^BGP4DU(P,BDATE,EDATE,E)
I %]"" S BGPC=1_U_$P(%,U,2)_U_"80076"
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP ALT LOINC",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT ALT TAX",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!($P(BGPC,U)) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!($P(BGPC,U)) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U)) D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_(9999999-D)_U_"LAB" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP4D21(J,T)
...S BGPC=1_U_(9999999-D)_U_"LOINC"
...Q
I BGPC Q BGPC
;now get all AST
S T=$O(^ATXAX("B","BGP AST LOINC",0))
S BGPLT=$O(^ATXLAB("B","DM AUDIT AST TAX",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!($P(BGPC,U)) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!($P(BGPC,U)) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U)) D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_(9999999-D)_U_"LAB" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP4D21(J,T)
...S BGPC=1_U_(9999999-D)_U_"LOINC"
...Q
I BGPC Q BGPC
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP LIVER FUNCTION LOINC",0))
S BGPLT=$O(^ATXLAB("B","BGP LIVER FUNCTION TESTS",0))
S B=9999999-BDATE,E=9999999-EDATE S D=E-1 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(D>B)!($P(BGPC,U)) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!($P(BGPC,U)) D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U)) D
...Q:'$D(^AUPNVLAB(X,0))
...I BGPLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BGPLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BGPC=1_U_(9999999-D)_U_"LAB" Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC^BGP4D21(J,T)
...S BGPC=1_U_(9999999-D)_U_"LOINC"
...Q
Q BGPC
BGP4D82 ; IHS/CMI/LAB - measure C 14 Mar 2010 11:49 AM ;
+1 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114
+2 ;
IRAA ;EP
+1 SET (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12)=0
+2 IF 'BGPACTCL
SET BGPSTOP=1
QUIT
+3 ;must be 16 or older
IF BGPAGEB<16
SET BGPSTOP=1
QUIT
+4 ;no OSTEOARTHRITIS
IF '$$OSTEOAR(DFN,BGPBDATE,BGPEDATE)
SET BGPSTOP=1
QUIT
+5 SET BGPV=$$MEDSPRE(DFN,BGPBDATE,BGPEDATE)
+6 ;no meds prescribed per logic
IF '$PIECE(BGPV,U)
SET BGPSTOP=1
KILL ^TMP($JOB,"A")
QUIT
+7 SET BGPOSTEO=$PIECE(BGPV,U,1)
+8 ;S BGPGLUC=$P(BGPV,U,2)
+9 IF BGPACTCL
SET BGPD1=1
+10 IF BGPACTUP
SET BGPD2=1
+11 IF BGPAGEB>54
IF BGPAGEB<65
IF BGPD1
SET BGPD3=1
+12 IF BGPAGEB>64
IF BGPAGEB<75
IF BGPD1
SET BGPD4=1
+13 IF BGPAGEB>74
IF BGPAGEB<85
IF BGPD1
SET BGPD5=1
+14 IF BGPAGEB>84
IF BGPD1
SET BGPD6=1
+15 SET BGPCBC=$$CBC(DFN,BGPBDATE,BGPEDATE)
+16 SET BGPLFT=$$LFT(DFN,BGPBDATE,BGPEDATE)
+17 SET BGPCREAT=$$CREAT^BGP4D22(DFN,BGPBDATE,BGPEDATE)
+18 SET BGPN1=0
+19 IF BGPOSTEO
SET BGPN1=$SELECT('BGPCBC:0,'BGPLFT:0,'BGPCREAT:0,1:1)
+20 ;I BGPGLUC S BGPN1=$S('BGPUG:0,1:1)
+21 SET BGPVALUE=$SELECT(BGPD1:"AC",1:"")_$PIECE(BGPV,U,5)_"|||"
+22 IF BGPOSTEO
SET BGPVALUE=BGPVALUE_$SELECT(BGPN1:"YES: ",1:"NO: ")
+23 IF BGPOSTEO
IF BGPCREAT
SET BGPVALUE=BGPVALUE_$SELECT(BGPCREAT:$$DATE^BGP4UTL($PIECE(BGPCREAT,U,2))_" CREAT",1:"")
+24 IF BGPOSTEO
IF BGPCBC
SET BGPVALUE=BGPVALUE_$SELECT(BGPCREAT:", ",1:"")
SET BGPVALUE=BGPVALUE_$SELECT(BGPCBC:$$DATE^BGP4UTL($PIECE(BGPCBC,U,2))_" CBC",1:"")
+25 IF BGPOSTEO
IF BGPLFT
SET BGPVALUE=BGPVALUE_$SELECT(BGPCREAT!(BGPCBC):", ",1:"")
SET BGPVALUE=BGPVALUE_$SELECT(BGPLFT:$$DATE^BGP4UTL($PIECE(BGPLFT,U,2))_" LFT",1:"")
+26 KILL X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
+27 KILL ^TMP($JOB,"A")
+28 QUIT
OSTEOAR(P,BDATE,EDATE) ;EP
+1 ;must have osteoarthritis on pl prior to BDATE or have a pov prior to bdate
+2 ;and have 2 povs between bdate and edate
+3 IF '$GET(P)
QUIT ""
+4 SET (G,X,Y,A,H,C)=""
+5 ;first check for pov prior to bdate
+6 KILL BGPG
+7 SET Y="BGPG("
+8 SET X=P_"^LAST DX [BGP OSTEOARTHRITIS DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_BDATE
SET E=$$START1^APCLDF(X,Y)
+9 SET H=""
IF $DATA(BGPG(1))
SET H=$$DATE^BGP4UTL($PIECE(BGPG(1),U))_" "_$PIECE(BGPG(1),U,2)
+10 IF H]""
GOTO RPDXS
+11 ;now check for pl entry prior to BDATE
+12 SET T=$ORDER(^ATXAX("B","BGP OSTEOARTHRITIS DXS",0))
+13 SET (X,B)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(H)
QUIT
Begin DoDot:1
+14 ;if added to pl after beginning of time period, no go
IF $PIECE(^AUPNPROB(X,0),U,8)>BDATE
QUIT
+15 SET Y=$PIECE(^AUPNPROB(X,0),U)
+16 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+17 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+18 IF '$$ICD^BGP4UTL2(Y,T,9)
QUIT
+19 SET H=$$DATE^BGP4UTL($PIECE(^AUPNPROB(X,0),U,8))_" "_$PIECE($$ICDDX^BGP4UTL2(Y),U,2)_" Problem list"
+20 QUIT
End DoDot:1
+21 ;don't go further as patient does not have osteoarthritis prior to the report period
IF H=""
QUIT ""
RPDXS ;check for 2 dxs in time period
+1 KILL BGPG
+2 SET Y="BGPG("
SET C=""
+3 SET X=P_"^LAST 2 DX [BGP OSTEOARTHRITIS DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+4 IF $DATA(BGPG(2))
SET C="2 dxs: "_$$DATE^BGP4UTL($PIECE(BGPG(2),U))_" "_$$DATE^BGP4UTL($PIECE(BGPG(1),U))
+5 IF H=""!(C="")
QUIT ""
+6 QUIT "1^prior: "_H_" rpt period: "_C
+7 ;
MEDSPRE(P,BDATE,EDATE) ;were meds prescribed in time frame and before?
+1 IF $GET(P)=""
QUIT ""
+2 SET (A,B,C,D,E,F,G,H,I,J)=""
+3 KILL BGPMEDS1
+4 DO GETMEDS^BGP4UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
+5 IF '$DATA(BGPMEDS1)
QUIT ""
+6 SET T1=$ORDER(^ATXAX("B","BGP RA OA NSAID MEDS",0))
+7 SET T4=$ORDER(^ATXAX("B","BGP RA OA NSAID VAPI",0))
+8 SET T2=$ORDER(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
+9 SET (X,G,M,E)=0
SET D=""
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X
QUIT
SET V=$PIECE(BGPMEDS1(X),U,5)
SET Y=+$PIECE(BGPMEDS1(X),U,4)
Begin DoDot:1
+10 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+11 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+12 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+13 ;get drug ien
SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+14 ;BAD POINTER
IF Z=""
QUIT
+15 IF $DATA(^ATXAX(T1,21,"B",Z))!($$VAPI^BGP4D81(Z,T4))
SET A=1
QUIT
+16 IF $DATA(^ATXAX(T2,21,"B",Z))
SET A=1
QUIT
End DoDot:1
+17 ;now check for B
+18 ;S T1=$O(^ATXAX("B","BGP OA GLUCOCORTICOIDS MEDS",0))
+19 ;S T4=$O(^ATXAX("B","BGP OA GLUCOCORTICOIDS CLASS",0))
+20 ;S (X,G,M,E)=0,C="" F S X=$O(BGPMEDS1(X)) Q:X'=+X S V=$P(BGPMEDS1(X),U,5),Y=+$P(BGPMEDS1(X),U,4) D
+21 ;.Q:'$D(^AUPNVSIT(V,0))
+22 ;.S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
+23 ;.Q:Z="" ;BAD POINTER
+24 ;.I $D(^ATXAX(T1,21,"B",Z))!($$CLASS(Z,T4)) S B=1
+25 ;none within time frame
IF 'A
QUIT ""
+26 SET BDATE=$$FMADD^XLFDT(EDATE,-465)
+27 KILL BGPMEDS1
+28 DO GETMEDS^BGP4UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
+29 IF '$DATA(BGPMEDS1)
QUIT ""
+30 SET C=0
+31 SET T1=$ORDER(^ATXAX("B","BGP RA OA NSAID MEDS",0))
+32 SET T4=$ORDER(^ATXAX("B","BGP RA OA NSAID VAPI",0))
+33 SET T2=$ORDER(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
+34 SET X=0
FOR
SET X=$ORDER(BGPMEDS1(X))
IF X'=+X
QUIT
SET V=$PIECE(BGPMEDS1(X),U,5)
SET Y=+$PIECE(BGPMEDS1(X),U,4)
Begin DoDot:1
+35 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+36 IF '$DATA(^AUPNVMED(Y,0))
QUIT
+37 IF $$UP^XLFSTR($PIECE($GET(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
QUIT
+38 ;get drug ien
SET Z=$PIECE($GET(^AUPNVMED(Y,0)),U)
+39 ;BAD POINTER
IF Z=""
QUIT
+40 IF $DATA(^ATXAX(T1,21,"B",Z))!($$VAPI^BGP4D81(Z,T4))
SET C=C+$$DAYS(Y,V,EDATE)
QUIT
+41 IF $DATA(^ATXAX(T2,21,"B",Z))
SET C=C+$$DAYS(Y,V,EDATE)
End DoDot:1
+42 ;GLUCX ;now check for B
+43 ;S D=0
+44 ;S T1=$O(^ATXAX("B","BGP OA GLUCOCORTICOIDS MEDS",0))
+45 ;S T4=$O(^ATXAX("B","BGP OA GLUCOCORTICOIDS CLASS",0))
+46 ;S X=0 F S X=$O(BGPMEDS1(X)) Q:X'=+X S V=$P(BGPMEDS1(X),U,5),Y=+$P(BGPMEDS1(X),U,4) D
+47 ;.Q:'$D(^AUPNVSIT(V,0))
+48 ;.S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
+49 ;.Q:Z="" ;BAD POINTER
+50 ;.I $D(^ATXAX(T1,21,"B",Z))!($$CLASS(Z,T4)) S D=D+$$DAYS(Y,V,EDATE)
CHCK ;
+1 SET E=.75*($$FMDIFF^XLFDT(EDATE,BDATE))
+2 ;I B,D'<E S $P(V,U,2)=1,$P(V,U,4)=D S $P(V,U,5)=$P(V,U,5)_" "_$S(B:D_" days of glucocorticoids",1:"")
SET V=""
+3 IF A
IF C'<E
SET $PIECE(V,U)=1
SET $PIECE(V,U,3)=C
SET $PIECE(V,U,5)=$PIECE(V,U,5)_" "_$SELECT(A:C_" days of NSAID ",1:"")
+4 QUIT V
DAYS(Y,V,E) ;EP
+1 NEW %,N,S,D
+2 ;DAYS SUPPLY
SET N=$PIECE(^AUPNVMED(Y,0),U,7)
+3 ;DATE DISCONTINUED
SET %=$PIECE(^AUPNVMED(Y,0),U,8)
+4 ;I %="" Q N
+5 SET D=$PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+6 ;I D="" Q N
+7 IF $$FMADD^XLFDT(D,N)>E
SET N=$$FMDIFF^XLFDT(E,D)
+8 IF %=""
QUIT N
+9 IF D=""
QUIT N
+10 SET S=$$FMDIFF^XLFDT(%,D)
+11 IF S>0
IF S<N
QUIT S
+12 QUIT N
NDC(A,B) ;
+1 ;a is drug ien
+2 ;b is taxonomy ien
+3 SET BGPNDC=$PIECE($GET(^PSDRUG(A,2)),U,4)
+4 IF BGPNDC]""
IF B
IF $DATA(^ATXAX(B,21,"B",BGPNDC))
QUIT 1
+5 QUIT 0
CLASS(A,B) ;EP
+1 ;a is drug ien
+2 ;b is taxonomy ien
+3 SET BGPNDC=$PIECE($GET(^PSDRUG(A,0)),U,2)
+4 IF BGPNDC]""
IF B
IF $DATA(^ATXAX(B,21,"B",BGPNDC))
QUIT 1
+5 QUIT 0
CBC(P,BDATE,EDATE) ;
+1 KILL BGPC
+2 SET BGPC=0
+3 SET %=""
SET E=+$$CODEN^ICPTCOD(85025)
SET %=$$CPTI^BGP4DU(P,BDATE,EDATE,E)
+4 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"85025"
+5 SET %=""
SET E=+$$CODEN^ICPTCOD(85027)
SET %=$$CPTI^BGP4DU(P,BDATE,EDATE,E)
+6 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"85027"
+7 SET %=""
SET E=+$$CODEN^ICPTCOD(85025)
SET %=$$TRANI^BGP4DU(P,BDATE,EDATE,E)
+8 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"85025 TRAN"
+9 SET %=""
SET E=+$$CODEN^ICPTCOD(85027)
SET %=$$TRANI^BGP4DU(P,BDATE,EDATE,E)
+10 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"85027 TRAN"
+11 ;now get all loinc/taxonomy tests
+12 SET T=$ORDER(^ATXAX("B","BGP CBC LOINC",0))
+13 SET BGPLT=$ORDER(^ATXLAB("B","BGP CBC TESTS",0))
+14 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!($PIECE(BGPC,U))
QUIT
Begin DoDot:1
+15 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!($PIECE(BGPC,U))
QUIT
Begin DoDot:2
+16 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!($PIECE(BGPC,U))
QUIT
Begin DoDot:3
+17 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+18 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_(9999999-D)_U_"LAB"
QUIT
+19 IF 'T
QUIT
+20 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+21 IF '$$LOINC^BGP4D21(J,T)
QUIT
+22 SET BGPC=1_U_(9999999-D)_U_"LOINC"
+23 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+24 QUIT BGPC
LFT(P,BDATE,EDATE) ;
+1 KILL BGPC
+2 SET BGPC=0
+3 SET %=""
SET E=+$$CODEN^ICPTCOD(84460)
SET %=$$CPTI^BGP4DU(P,BDATE,EDATE,E)
+4 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"84460"
+5 SET %=""
SET E=+$$CODEN^ICPTCOD(84450)
SET %=$$CPTI^BGP4DU(P,BDATE,EDATE,E)
+6 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"84450"
+7 SET %=""
SET E=+$$CODEN^ICPTCOD(80076)
SET %=$$CPTI^BGP4DU(P,BDATE,EDATE,E)
+8 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"80076"
+9 ;TRAN
+10 SET %=""
SET E=+$$CODEN^ICPTCOD(84460)
SET %=$$TRANI^BGP4DU(P,BDATE,EDATE,E)
+11 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"84460"
+12 SET %=""
SET E=+$$CODEN^ICPTCOD(84450)
SET %=$$TRANI^BGP4DU(P,BDATE,EDATE,E)
+13 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"84450"
+14 SET %=""
SET E=+$$CODEN^ICPTCOD(80076)
SET %=$$TRANI^BGP4DU(P,BDATE,EDATE,E)
+15 IF %]""
SET BGPC=1_U_$PIECE(%,U,2)_U_"80076"
+16 ;now get all loinc/taxonomy tests
+17 SET T=$ORDER(^ATXAX("B","BGP ALT LOINC",0))
+18 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT ALT TAX",0))
+19 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!($PIECE(BGPC,U))
QUIT
Begin DoDot:1
+20 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!($PIECE(BGPC,U))
QUIT
Begin DoDot:2
+21 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!($PIECE(BGPC,U))
QUIT
Begin DoDot:3
+22 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+23 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_(9999999-D)_U_"LAB"
QUIT
+24 IF 'T
QUIT
+25 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+26 IF '$$LOINC^BGP4D21(J,T)
QUIT
+27 SET BGPC=1_U_(9999999-D)_U_"LOINC"
+28 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+29 IF BGPC
QUIT BGPC
+30 ;now get all AST
+31 SET T=$ORDER(^ATXAX("B","BGP AST LOINC",0))
+32 SET BGPLT=$ORDER(^ATXLAB("B","DM AUDIT AST TAX",0))
+33 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!($PIECE(BGPC,U))
QUIT
Begin DoDot:1
+34 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!($PIECE(BGPC,U))
QUIT
Begin DoDot:2
+35 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!($PIECE(BGPC,U))
QUIT
Begin DoDot:3
+36 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+37 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_(9999999-D)_U_"LAB"
QUIT
+38 IF 'T
QUIT
+39 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+40 IF '$$LOINC^BGP4D21(J,T)
QUIT
+41 SET BGPC=1_U_(9999999-D)_U_"LOINC"
+42 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+43 IF BGPC
QUIT BGPC
+44 ;now get all loinc/taxonomy tests
+45 SET T=$ORDER(^ATXAX("B","BGP LIVER FUNCTION LOINC",0))
+46 SET BGPLT=$ORDER(^ATXLAB("B","BGP LIVER FUNCTION TESTS",0))
+47 SET B=9999999-BDATE
SET E=9999999-EDATE
SET D=E-1
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(D>B)!($PIECE(BGPC,U))
QUIT
Begin DoDot:1
+48 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!($PIECE(BGPC,U))
QUIT
Begin DoDot:2
+49 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!($PIECE(BGPC,U))
QUIT
Begin DoDot:3
+50 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+51 IF BGPLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BGPLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BGPC=1_U_(9999999-D)_U_"LAB"
QUIT
+52 IF 'T
QUIT
+53 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+54 IF '$$LOINC^BGP4D21(J,T)
QUIT
+55 SET BGPC=1_U_(9999999-D)_U_"LOINC"
+56 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+57 QUIT BGPC
