BGP3D862 ; IHS/CMI/LAB - measure C ;
;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
;
RHEUAR(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 RHEUMATOID ARTHRITIS DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_BDATE S E=$$START1^APCLDF(X,Y)
S H="" I $D(BGPG(1)) S H=$$DATE^BGP3UTL($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 RHEUMATOID ARTHRITIS 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)'="A"
.Q:'$$ICD^ATXCHK(Y,T,9)
.S H=$$DATE^BGP3UTL($P(^AUPNPROB(X,0),U,8))_" "_$P($$ICDDX^ICDCODE(Y),U,2)_" Problem list"
.Q
I H="" Q "" ;don't go further as patient does not have RHEU arthritis 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 RHEUMATOID ARTHRITIS DXS;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,Y)
I $D(BGPG(2)) S C="2 dxs: "_$$DATE^BGP3UTL($P(BGPG(2),U))_" "_$$DATE^BGP3UTL($P(BGPG(1),U))
I H=""!(C="") Q ""
Q "1^prior: "_H_" rpt period: "_C
;
UG(P,BDATE,EDATE) ;
K BGPC
S BGPC=0
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP URINE GLUCOSE LOINC",0))
S BGPLT=$O(^ATXLAB("B","BGP URINE GLUCOSE",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^BGP3D21(J,T)
...S BGPC=1_U_(9999999-D)_U_"LOINC"
...Q
Q BGPC
;
BGP3D862 ; IHS/CMI/LAB - measure C ;
+1 ;;13.0;IHS CLINICAL REPORTING;;NOV 20, 2012;Build 81
+2 ;
RHEUAR(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 RHEUMATOID ARTHRITIS DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_BDATE
SET E=$$START1^APCLDF(X,Y)
+9 SET H=""
IF $DATA(BGPG(1))
SET H=$$DATE^BGP3UTL($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 RHEUMATOID ARTHRITIS 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)'="A"
QUIT
+17 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+18 SET H=$$DATE^BGP3UTL($PIECE(^AUPNPROB(X,0),U,8))_" "_$PIECE($$ICDDX^ICDCODE(Y),U,2)_" Problem list"
+19 QUIT
End DoDot:1
+20 ;don't go further as patient does not have RHEU arthritis 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 RHEUMATOID ARTHRITIS DXS;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,Y)
+4 IF $DATA(BGPG(2))
SET C="2 dxs: "_$$DATE^BGP3UTL($PIECE(BGPG(2),U))_" "_$$DATE^BGP3UTL($PIECE(BGPG(1),U))
+5 IF H=""!(C="")
QUIT ""
+6 QUIT "1^prior: "_H_" rpt period: "_C
+7 ;
UG(P,BDATE,EDATE) ;
+1 KILL BGPC
+2 SET BGPC=0
+3 ;now get all loinc/taxonomy tests
+4 SET T=$ORDER(^ATXAX("B","BGP URINE GLUCOSE LOINC",0))
+5 SET BGPLT=$ORDER(^ATXLAB("B","BGP URINE GLUCOSE",0))
+6 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
+7 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L!($PIECE(BGPC,U))
QUIT
Begin DoDot:2
+8 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X!($PIECE(BGPC,U))
QUIT
Begin DoDot:3
+9 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+10 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
+11 IF 'T
QUIT
+12 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+13 IF '$$LOINC^BGP3D21(J,T)
QUIT
+14 SET BGPC=1_U_(9999999-D)_U_"LOINC"
+15 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT BGPC
+17 ;
