- BGP2D862 ; IHS/CMI/LAB - measure C ;
- ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
- ;
- 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^BGP2UTL($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^BGP2UTL($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^BGP2UTL($P(BGPG(2),U))_" "_$$DATE^BGP2UTL($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^BGP2D21(J,T)
- ...S BGPC=1_U_(9999999-D)_U_"LOINC"
- ...Q
- Q BGPC
- ;
- BGP2D862 ; IHS/CMI/LAB - measure C ;
- +1 ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
- +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^BGP2UTL($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^BGP2UTL($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^BGP2UTL($PIECE(BGPG(2),U))_" "_$$DATE^BGP2UTL($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^BGP2D21(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 ;
