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

BGP7D82.m

Go to the documentation of this file.
  1. BGP7D82 ; IHS/CMI/LAB - measure C 14 Mar 2010 11:49 AM ;
  1. ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
  1. ;
  1. IRAA ;EP
  1. S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12)=0
  1. I 'BGPACTCL S BGPSTOP=1 Q
  1. I BGPAGEB<16 S BGPSTOP=1 Q ;must be 16 or older
  1. I '$$OSTEOAR(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 Q ;no OSTEOARTHRITIS
  1. S BGPV=$$MEDSPRE(DFN,BGPBDATE,BGPEDATE)
  1. I '$P(BGPV,U) S BGPSTOP=1 K ^TMP($J,"A") Q ;no meds prescribed per logic
  1. S BGPOSTEO=$P(BGPV,U,1)
  1. ;S BGPGLUC=$P(BGPV,U,2)
  1. I BGPACTCL S BGPD1=1
  1. I BGPACTUP S BGPD2=1
  1. I BGPAGEB>54,BGPAGEB<65,BGPD1 S BGPD3=1
  1. I BGPAGEB>64,BGPAGEB<75,BGPD1 S BGPD4=1
  1. I BGPAGEB>74,BGPAGEB<85,BGPD1 S BGPD5=1
  1. I BGPAGEB>84,BGPD1 S BGPD6=1
  1. S BGPCBC=$$CBC(DFN,BGPBDATE,BGPEDATE)
  1. S BGPLFT=$$LFT(DFN,BGPBDATE,BGPEDATE)
  1. S BGPCREAT=$$CREAT^BGP7D22(DFN,BGPBDATE,BGPEDATE)
  1. S BGPN1=0
  1. I BGPOSTEO S BGPN1=$S('BGPCBC:0,'BGPLFT:0,'BGPCREAT:0,1:1)
  1. ;I BGPGLUC S BGPN1=$S('BGPUG:0,1:1)
  1. S BGPVALUE=$S(BGPD1:"AC",1:"")_$P(BGPV,U,5)_"|||"
  1. I BGPOSTEO S BGPVALUE=BGPVALUE_$S(BGPN1:"YES: ",1:"NO: ")
  1. I BGPOSTEO,BGPCREAT S BGPVALUE=BGPVALUE_$S(BGPCREAT:$$DATE^BGP7UTL($P(BGPCREAT,U,2))_" CREAT",1:"")
  1. I BGPOSTEO,BGPCBC S BGPVALUE=BGPVALUE_$S(BGPCREAT:", ",1:""),BGPVALUE=BGPVALUE_$S(BGPCBC:$$DATE^BGP7UTL($P(BGPCBC,U,2))_" CBC",1:"")
  1. I BGPOSTEO,BGPLFT S BGPVALUE=BGPVALUE_$S(BGPCREAT!(BGPCBC):", ",1:""),BGPVALUE=BGPVALUE_$S(BGPLFT:$$DATE^BGP7UTL($P(BGPLFT,U,2))_" LFT",1:"")
  1. K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
  1. K ^TMP($J,"A")
  1. Q
  1. OSTEOAR(P,BDATE,EDATE) ;EP
  1. ;must have osteoarthritis on pl prior to BDATE or have a pov prior to bdate
  1. ;and have 2 povs between bdate and edate
  1. I '$G(P) Q ""
  1. S (G,X,Y,A,H,C)=""
  1. ;first check for pov prior to bdate
  1. K BGPG
  1. S Y="BGPG("
  1. S X=P_"^LAST DX [BGP OSTEOARTHRITIS DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_BDATE S E=$$START1^APCLDF(X,Y)
  1. S H="" I $D(BGPG(1)) S H=$$DATE^BGP7UTL($P(BGPG(1),U))_" "_$P(BGPG(1),U,2)
  1. I H]"" G RPDXS
  1. ;now check for pl entry prior to BDATE
  1. S T=$O(^ATXAX("B","BGP OSTEOARTHRITIS DXS",0))
  1. S (X,B)=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(H) D
  1. .Q:$P(^AUPNPROB(X,0),U,8)>BDATE ;if added to pl after beginning of time period, no go
  1. .S Y=$P(^AUPNPROB(X,0),U)
  1. .Q:$P(^AUPNPROB(X,0),U,12)="D"
  1. .Q:$P(^AUPNPROB(X,0),U,12)="I"
  1. .Q:'$$ICD^BGP7UTL2(Y,T,9)
  1. .S H=$$DATE^BGP7UTL($P(^AUPNPROB(X,0),U,8))_" "_$P($$ICDDX^BGP7UTL2(Y),U,2)_" Problem list"
  1. .Q
  1. I H="" Q "" ;don't go further as patient does not have osteoarthritis prior to the report period
  1. RPDXS ;check for 2 dxs in time period
  1. K BGPG
  1. S Y="BGPG(",C=""
  1. S X=P_"^LAST 2 DX [BGP OSTEOARTHRITIS DXS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
  1. I $D(BGPG(2)) S C="2 dxs: "_$$DATE^BGP7UTL($P(BGPG(2),U))_" "_$$DATE^BGP7UTL($P(BGPG(1),U))
  1. I H=""!(C="") Q ""
  1. Q "1^prior: "_H_" rpt period: "_C
  1. ;
  1. MEDSPRE(P,BDATE,EDATE) ;were meds prescribed in time frame and before?
  1. I $G(P)="" Q ""
  1. S (A,B,C,D,E,F,G,H,I,J)=""
  1. K BGPMEDS1
  1. D GETMEDS^BGP7UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
  1. I '$D(BGPMEDS1) Q ""
  1. S T1=$O(^ATXAX("B","BGP RA OA NSAID MEDS",0))
  1. S T4=$O(^ATXAX("B","BGP RA OA NSAID VAPI",0))
  1. S T2=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
  1. 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
  1. .Q:'$D(^AUPNVSIT(V,0))
  1. .Q:'$D(^AUPNVMED(Y,0))
  1. .Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
  1. .S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
  1. .Q:Z="" ;BAD POINTER
  1. .I $D(^ATXAX(T1,21,"B",Z))!($$VAPI^BGP7D81(Z,T4)) S A=1 Q
  1. .I $D(^ATXAX(T2,21,"B",Z)) S A=1 Q
  1. ;now check for B
  1. ;S T1=$O(^ATXAX("B","BGP OA GLUCOCORTICOIDS MEDS",0))
  1. ;S T4=$O(^ATXAX("B","BGP OA GLUCOCORTICOIDS CLASS",0))
  1. ;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
  1. ;.Q:'$D(^AUPNVSIT(V,0))
  1. ;.S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
  1. ;.Q:Z="" ;BAD POINTER
  1. ;.I $D(^ATXAX(T1,21,"B",Z))!($$CLASS(Z,T4)) S B=1
  1. I 'A Q "" ;none within time frame
  1. S BDATE=$$FMADD^XLFDT(EDATE,-465)
  1. K BGPMEDS1
  1. D GETMEDS^BGP7UTL2(P,BDATE,EDATE,,,,,.BGPMEDS1)
  1. I '$D(BGPMEDS1) Q ""
  1. S C=0
  1. S T1=$O(^ATXAX("B","BGP RA OA NSAID MEDS",0))
  1. S T4=$O(^ATXAX("B","BGP RA OA NSAID VAPI",0))
  1. S T2=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
  1. 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
  1. .Q:'$D(^AUPNVSIT(V,0))
  1. .Q:'$D(^AUPNVMED(Y,0))
  1. .Q:$$UP^XLFSTR($P($G(^AUPNVMED(Y,11)),U))["RETURNED TO STOCK"
  1. .S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
  1. .Q:Z="" ;BAD POINTER
  1. .I $D(^ATXAX(T1,21,"B",Z))!($$VAPI^BGP7D81(Z,T4)) S C=C+$$DAYS(Y,V,EDATE) Q
  1. .I $D(^ATXAX(T2,21,"B",Z)) S C=C+$$DAYS(Y,V,EDATE)
  1. ;GLUCX ;now check for B
  1. ;S D=0
  1. ;S T1=$O(^ATXAX("B","BGP OA GLUCOCORTICOIDS MEDS",0))
  1. ;S T4=$O(^ATXAX("B","BGP OA GLUCOCORTICOIDS CLASS",0))
  1. ;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
  1. ;.Q:'$D(^AUPNVSIT(V,0))
  1. ;.S Z=$P($G(^AUPNVMED(Y,0)),U) ;get drug ien
  1. ;.Q:Z="" ;BAD POINTER
  1. ;.I $D(^ATXAX(T1,21,"B",Z))!($$CLASS(Z,T4)) S D=D+$$DAYS(Y,V,EDATE)
  1. CHCK ;
  1. S E=.75*($$FMDIFF^XLFDT(EDATE,BDATE))
  1. 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:"")
  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:"")
  1. Q V
  1. DAYS(Y,V,E) ;EP
  1. NEW %,N,S,D
  1. S N=$P(^AUPNVMED(Y,0),U,7) ;DAYS SUPPLY
  1. S %=$P(^AUPNVMED(Y,0),U,8) ;DATE DISCONTINUED
  1. ;I %="" Q N
  1. S D=$P($P($G(^AUPNVSIT(V,0)),U),".")
  1. ;I D="" Q N
  1. I $$FMADD^XLFDT(D,N)>E S N=$$FMDIFF^XLFDT(E,D)
  1. I %="" Q N
  1. I D="" Q N
  1. S S=$$FMDIFF^XLFDT(%,D)
  1. I S>0,S<N Q S
  1. Q N
  1. NDC(A,B) ;
  1. ;a is drug ien
  1. ;b is taxonomy ien
  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. CLASS(A,B) ;EP
  1. ;a is drug ien
  1. ;b is taxonomy ien
  1. S BGPNDC=$P($G(^PSDRUG(A,0)),U,2)
  1. I BGPNDC]"",B,$D(^ATXAX(B,21,"B",BGPNDC)) Q 1
  1. Q 0
  1. CBC(P,BDATE,EDATE) ;
  1. K BGPC
  1. S BGPC=0
  1. S %="",E=+$$CODEN^ICPTCOD(85025),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=1_U_$P(%,U,2)_U_"85025"
  1. S %="",E=+$$CODEN^ICPTCOD(85027),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=1_U_$P(%,U,2)_U_"85027"
  1. S %="",E=+$$CODEN^ICPTCOD(85025),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=1_U_$P(%,U,2)_U_"85025 TRAN"
  1. S %="",E=+$$CODEN^ICPTCOD(85027),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=1_U_$P(%,U,2)_U_"85027 TRAN"
  1. ;now get all loinc/taxonomy tests
  1. S T=$O(^ATXAX("B","BGP CBC LOINC",0))
  1. S BGPLT=$O(^ATXLAB("B","BGP CBC TESTS",0))
  1. 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
  1. .S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!($P(BGPC,U)) D
  1. ..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U)) D
  1. ...Q:'$D(^AUPNVLAB(X,0))
  1. ...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
  1. ...Q:'T
  1. ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1. ...Q:'$$LOINC^BGP7D21(J,T)
  1. ...S BGPC=1_U_(9999999-D)_U_"LOINC"
  1. ...Q
  1. Q BGPC
  1. LFT(P,BDATE,EDATE) ;
  1. K BGPC
  1. S BGPC=0
  1. S %="",E=+$$CODEN^ICPTCOD(84460),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=1_U_$P(%,U,2)_U_"84460"
  1. S %="",E=+$$CODEN^ICPTCOD(84450),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=1_U_$P(%,U,2)_U_"84450"
  1. S %="",E=+$$CODEN^ICPTCOD(80076),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=1_U_$P(%,U,2)_U_"80076"
  1. ;TRAN
  1. S %="",E=+$$CODEN^ICPTCOD(84460),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=1_U_$P(%,U,2)_U_"84460"
  1. S %="",E=+$$CODEN^ICPTCOD(84450),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=1_U_$P(%,U,2)_U_"84450"
  1. S %="",E=+$$CODEN^ICPTCOD(80076),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
  1. I %]"" S BGPC=1_U_$P(%,U,2)_U_"80076"
  1. ;now get all loinc/taxonomy tests
  1. S T=$O(^ATXAX("B","BGP ALT LOINC",0))
  1. S BGPLT=$O(^ATXLAB("B","DM AUDIT ALT TAX",0))
  1. 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
  1. .S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!($P(BGPC,U)) D
  1. ..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U)) D
  1. ...Q:'$D(^AUPNVLAB(X,0))
  1. ...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
  1. ...Q:'T
  1. ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1. ...Q:'$$LOINC^BGP7D21(J,T)
  1. ...S BGPC=1_U_(9999999-D)_U_"LOINC"
  1. ...Q
  1. I BGPC Q BGPC
  1. ;now get all AST
  1. S T=$O(^ATXAX("B","BGP AST LOINC",0))
  1. S BGPLT=$O(^ATXLAB("B","DM AUDIT AST TAX",0))
  1. 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
  1. .S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!($P(BGPC,U)) D
  1. ..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U)) D
  1. ...Q:'$D(^AUPNVLAB(X,0))
  1. ...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
  1. ...Q:'T
  1. ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1. ...Q:'$$LOINC^BGP7D21(J,T)
  1. ...S BGPC=1_U_(9999999-D)_U_"LOINC"
  1. ...Q
  1. I BGPC Q BGPC
  1. ;now get all loinc/taxonomy tests
  1. S T=$O(^ATXAX("B","BGP LIVER FUNCTION LOINC",0))
  1. S BGPLT=$O(^ATXLAB("B","BGP LIVER FUNCTION TESTS",0))
  1. 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
  1. .S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L!($P(BGPC,U)) D
  1. ..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X!($P(BGPC,U)) D
  1. ...Q:'$D(^AUPNVLAB(X,0))
  1. ...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
  1. ...Q:'T
  1. ...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
  1. ...Q:'$$LOINC^BGP7D21(J,T)
  1. ...S BGPC=1_U_(9999999-D)_U_"LOINC"
  1. ...Q
  1. Q BGPC