- BGP7D82 ; IHS/CMI/LAB - measure C 14 Mar 2010 11:49 AM ;
- ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
- ;
- 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^BGP7D22(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^BGP7UTL($P(BGPCREAT,U,2))_" CREAT",1:"")
- I BGPOSTEO,BGPCBC S BGPVALUE=BGPVALUE_$S(BGPCREAT:", ",1:""),BGPVALUE=BGPVALUE_$S(BGPCBC:$$DATE^BGP7UTL($P(BGPCBC,U,2))_" CBC",1:"")
- I BGPOSTEO,BGPLFT S BGPVALUE=BGPVALUE_$S(BGPCREAT!(BGPCBC):", ",1:""),BGPVALUE=BGPVALUE_$S(BGPLFT:$$DATE^BGP7UTL($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^BGP7UTL($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^BGP7UTL2(Y,T,9)
- .S H=$$DATE^BGP7UTL($P(^AUPNPROB(X,0),U,8))_" "_$P($$ICDDX^BGP7UTL2(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^BGP7UTL($P(BGPG(2),U))_" "_$$DATE^BGP7UTL($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^BGP7UTL2(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^BGP7D81(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^BGP7UTL2(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^BGP7D81(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^BGP7DU(P,BDATE,EDATE,E)
- I %]"" S BGPC=1_U_$P(%,U,2)_U_"85025"
- S %="",E=+$$CODEN^ICPTCOD(85027),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
- I %]"" S BGPC=1_U_$P(%,U,2)_U_"85027"
- S %="",E=+$$CODEN^ICPTCOD(85025),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
- I %]"" S BGPC=1_U_$P(%,U,2)_U_"85025 TRAN"
- S %="",E=+$$CODEN^ICPTCOD(85027),%=$$TRANI^BGP7DU(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^BGP7D21(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^BGP7DU(P,BDATE,EDATE,E)
- I %]"" S BGPC=1_U_$P(%,U,2)_U_"84460"
- S %="",E=+$$CODEN^ICPTCOD(84450),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
- I %]"" S BGPC=1_U_$P(%,U,2)_U_"84450"
- S %="",E=+$$CODEN^ICPTCOD(80076),%=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
- I %]"" S BGPC=1_U_$P(%,U,2)_U_"80076"
- ;TRAN
- S %="",E=+$$CODEN^ICPTCOD(84460),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
- I %]"" S BGPC=1_U_$P(%,U,2)_U_"84460"
- S %="",E=+$$CODEN^ICPTCOD(84450),%=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
- I %]"" S BGPC=1_U_$P(%,U,2)_U_"84450"
- S %="",E=+$$CODEN^ICPTCOD(80076),%=$$TRANI^BGP7DU(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^BGP7D21(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^BGP7D21(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^BGP7D21(J,T)
- ...S BGPC=1_U_(9999999-D)_U_"LOINC"
- ...Q
- Q BGPC
- BGP7D82 ; IHS/CMI/LAB - measure C 14 Mar 2010 11:49 AM ;
- +1 ;;17.1;IHS CLINICAL REPORTING;;MAY 10, 2017;Build 29
- +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^BGP7D22(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^BGP7UTL($PIECE(BGPCREAT,U,2))_" CREAT",1:"")
- +24 IF BGPOSTEO
- IF BGPCBC
- SET BGPVALUE=BGPVALUE_$SELECT(BGPCREAT:", ",1:"")
- SET BGPVALUE=BGPVALUE_$SELECT(BGPCBC:$$DATE^BGP7UTL($PIECE(BGPCBC,U,2))_" CBC",1:"")
- +25 IF BGPOSTEO
- IF BGPLFT
- SET BGPVALUE=BGPVALUE_$SELECT(BGPCREAT!(BGPCBC):", ",1:"")
- SET BGPVALUE=BGPVALUE_$SELECT(BGPLFT:$$DATE^BGP7UTL($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^BGP7UTL($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^BGP7UTL2(Y,T,9)
- QUIT
- +19 SET H=$$DATE^BGP7UTL($PIECE(^AUPNPROB(X,0),U,8))_" "_$PIECE($$ICDDX^BGP7UTL2(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^BGP7UTL($PIECE(BGPG(2),U))_" "_$$DATE^BGP7UTL($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^BGP7UTL2(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^BGP7D81(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^BGP7UTL2(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^BGP7D81(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^BGP7DU(P,BDATE,EDATE,E)
- +4 IF %]""
- SET BGPC=1_U_$PIECE(%,U,2)_U_"85025"
- +5 SET %=""
- SET E=+$$CODEN^ICPTCOD(85027)
- SET %=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
- +6 IF %]""
- SET BGPC=1_U_$PIECE(%,U,2)_U_"85027"
- +7 SET %=""
- SET E=+$$CODEN^ICPTCOD(85025)
- SET %=$$TRANI^BGP7DU(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^BGP7DU(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^BGP7D21(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^BGP7DU(P,BDATE,EDATE,E)
- +4 IF %]""
- SET BGPC=1_U_$PIECE(%,U,2)_U_"84460"
- +5 SET %=""
- SET E=+$$CODEN^ICPTCOD(84450)
- SET %=$$CPTI^BGP7DU(P,BDATE,EDATE,E)
- +6 IF %]""
- SET BGPC=1_U_$PIECE(%,U,2)_U_"84450"
- +7 SET %=""
- SET E=+$$CODEN^ICPTCOD(80076)
- SET %=$$CPTI^BGP7DU(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^BGP7DU(P,BDATE,EDATE,E)
- +11 IF %]""
- SET BGPC=1_U_$PIECE(%,U,2)_U_"84460"
- +12 SET %=""
- SET E=+$$CODEN^ICPTCOD(84450)
- SET %=$$TRANI^BGP7DU(P,BDATE,EDATE,E)
- +13 IF %]""
- SET BGPC=1_U_$PIECE(%,U,2)_U_"84450"
- +14 SET %=""
- SET E=+$$CODEN^ICPTCOD(80076)
- SET %=$$TRANI^BGP7DU(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^BGP7D21(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^BGP7D21(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^BGP7D21(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