BUD0RP7C ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2010 5:11 PM ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
;
DM ;EP - list of DM
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUDBDB=($E(BUDBD,1,3)-85)_"0101"
S BUDBDE=($E(BUDBD,1,3)-18)_"1231"
Q:BUDDOB>BUDBDE
Q:BUDDOB<BUDBDB
Q:BUDMEDV<2
;
S BUDP=$$DMDX(DFN,$$DOB^AUPNPAT(DFN),BUDED)
I '$P(BUDP,U) Q ;not dx'ed before end of report period
S BUDOVAR=$$OVAR(DFN,BUDBD,BUDED)
S BUD2DM=$$DM2(DFN,BUDBD,BUDED)
I $P(BUDOVAR,U),$P(BUD2DM,U) Q ;had 2 dx of dm during report period and an ovary dx
I $$GESTDX(DFN,BUDBD,BUDED) Q ;had gestational dx during report period
S BUDRACEX=$$RACE^BUD0RPTC(DFN),BUDRACE=$P(BUDRACEX,U,2),BUDRACEP=$P(BUDRACEX,U,5)
S BUDRACEE=$$RACE^BUD0RP7I(BUDRACE)
;S BUDRACE=$$RACE^BUD0RP7I(BUDRACE)
S BUDR=""
S BUDETHN=$P($$HISP^BUD0RPTC(DFN),U,1)
I +BUDETHN=1 S BUDETHNN="Hispanic or Latino"
I +BUDETHN=2 S BUDETHNN="Non-Hispanic/Latino"
I +BUDETHN=3 S BUDETHNN="Unreported/Refused to Report"
I BUDRACEP=16!(+BUDETHN=3) S BUDR=17 G SETSECTC
I +BUDETHN=1 S BUDR=BUDRACEP G SETSECTC
I +BUDETHN=2!(+BUDETHN=3) S BUDR=BUDRACEP+8
SETSECTC ;
S $P(BUDSECTC(9),U,BUDR)=$P($G(BUDSECTC(9)),U,BUDR)+1
S $P(BUDSECTC(10),U,BUDR)=$P($G(BUDSECTC(10)),U,BUDR)+1
S $P(BUDSECTC(9),U,18)=$P($G(BUDSECTC(9)),U,18)+1
S $P(BUDSECTC(10),U,18)=$P($G(BUDSECTC(10)),U,18)+1
;S $P(BUDSECTF(9),U,BUDETHN)=$P($G(BUDSECTF(9)),U,BUDETHN)+1
;S $P(BUDSECTF(10),U,BUDETHN)=$P($G(BUDSECTF(10)),U,BUDETHN)+1
;S $P(BUDSECTF(9),U,3)=$P($G(BUDSECTF(9)),U,3)+1
;S $P(BUDSECTF(10),U,3)=$P($G(BUDSECTF(10)),U,3)+1
I $G(BUDDMRL) S ^XTMP("BUD0RP7",BUDJ,BUDH,"DMR",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
;I $G(BUDDMEL) S ^XTMP("BUD0RP7",BUDJ,BUDH,"DME",BUDETHNN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
;get last hgba1c value and set counters/lists
S BUDHGB=$$HGBA1C(DFN,BUDBD,BUDED)
SET ;
S BUDLINE=$P(BUDHGB,U)
;W !,DFN," ",BUDLINE
S $P(BUDSECTC(BUDLINE),U,BUDR)=$P($G(BUDSECTC(BUDLINE)),U,BUDR)+1,$P(BUDSECTC(BUDLINE),U,18)=$P($G(BUDSECTC(BUDLINE)),U,18)+1
S $P(BUDSECTF(BUDLINE),U,BUDETHN)=$P($G(BUDSECTF(BUDLINE)),U,BUDETHN)+1,$P(BUDSECTF(BUDLINE),U,9)=$P($G(BUDSECTF(BUDLINE)),U,9)+1
I $G(BUDDMR1L),BUDLINE=11 S ^XTMP("BUD0RP7",BUDJ,BUDH,"DMR1",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"^"_$P(BUDHGB,U,2)
I $G(BUDDMR2L),BUDLINE=12 S ^XTMP("BUD0RP7",BUDJ,BUDH,"DMR2",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"^"_$P(BUDHGB,U,2)
I $G(BUDDMR3L),BUDLINE=13 S ^XTMP("BUD0RP7",BUDJ,BUDH,"DMR3",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"^"_$P(BUDHGB,U,2)
;I $G(BUDDME1L),BUDLINE=11 S ^XTMP("BUD0RP7",BUDJ,BUDH,"DME1",BUDETHNN,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDHGB,U,2)
;I $G(BUDDME2L),BUDLINE=12 S ^XTMP("BUD0RP7",BUDJ,BUDH,"DME2",BUDETHNN,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDHGB,U,2)
;I $G(BUDDME3L),BUDLINE=13 S ^XTMP("BUD0RP7",BUDJ,BUDH,"DME3",BUDETHNN,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDHGB,U,2)
Q
;
HGBA1C(P,BDATE,EDATE) ;EP
NEW BUDG,BUDT,BUDC,E,%,L,T,BUDLT,D,X,J,C,G
S BUDC=0
S G=$$CPT^BUD0DU(P,BDATE,EDATE,$O(^ATXAX("B","BUD HGBA1C CPTS",0)),5)
I G]"" S BUDC=BUDC+1,BUDT((9999999-$P(G,U,1)),BUDC)=U_"CPT "_$P(G,U,2)
;now get all loinc/taxonomy tests
S T=$O(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
S BUDLT=$O(^ATXLAB("B","DM AUDIT HGB A1C 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) D
.S L=0 F S L=$O(^AUPNVLAB("AE",P,D,L)) Q:L'=+L D
..S X=0 F S X=$O(^AUPNVLAB("AE",P,D,L,X)) Q:X'=+X D
...Q:'$D(^AUPNVLAB(X,0))
...I BUDLT,$P(^AUPNVLAB(X,0),U),$D(^ATXLAB(BUDLT,21,"B",$P(^AUPNVLAB(X,0),U))) S BUDC=BUDC+1,BUDT(D,BUDC)=$P(^AUPNVLAB(X,0),U,4)_U_"LAB: "_$$VAL^XBDIQ1(9000010.09,X,.01) Q
...Q:'T
...S J=$P($G(^AUPNVLAB(X,11)),U,13) Q:J=""
...Q:'$$LOINC(J,T)
...S BUDC=BUDC+1,BUDT(D,BUDC)=$P(^AUPNVLAB(X,0),U,4)_U_"LAB LOINC: "_$$VAL^XBDIQ1(9000010.09,X,.01)_" "_$P(^AUPNVLAB(X,11),U,13)
...Q
; now got though and set return value of done 1 or 0^numerator 2-7^date^value
I '$D(BUDT) Q 13_U_"NO A1C TEST DURING THE REPORT PERIOD" ;no tests so is hit in numerator
; now get rid of all on same day where 1 has a result and the other doesn't
S D=0,BUDC=0 F S D=$O(BUDT(D)) Q:D'=+D S C=0,G=0 F S C=$O(BUDT(D,C)) Q:C'=+C D
.I $P(BUDT(D,C),U,1)]"" S BUDC=BUDC+1
.I BUDC>0,$P(BUDT(D,C),U,1)="" K BUDT(D,C)
S D=0,G=""
S D=$O(BUDT(D))
S C=0,C=$O(BUDT(D,C))
S X=$P(BUDT(D,C),U,1)
I $$UP^XLFSTR(X)="COMMENT" Q 13_U_$P(BUDT(D,C),U,2)_" "_$$DATE^BUD0UTL1(9999999-D)_" (no result) "_X
I X="" D Q G
.S G=""
.I $P(BUDT(D,C),U,2)="CPT 3046F" S G=13_U_$P(BUDT(D,C),U,2)_" "_$$DATE^BUD0UTL1(9999999-D) Q
.I $P(BUDT(D,C),U,2)="CPT 3045F" S G=12_U_$P(BUDT(D,C),U,2)_" "_$$DATE^BUD0UTL1(9999999-D) Q
.I $P(BUDT(D,C),U,2)="CPT 3044F" S G=11_U_$P(BUDT(D,C),U,2)_" "_$$DATE^BUD0UTL1(9999999-D) Q
.I $P(BUDT(D,C),U,2)="CPT 83036" S G=13_U_$P(BUDT(D,C),U,2)_" "_$$DATE^BUD0UTL1(9999999-D) Q
.I $P(BUDT(D,C),U,2)="CPT 83037" S G=13_U_$P(BUDT(D,C),U,2)_" "_$$DATE^BUD0UTL1(9999999-D) Q
.S G=13_U_$P(BUDT(D,C),U,2)_" DID NOT HAVE A RESULT "_$$DATE^BUD0UTL1(9999999-D) Q
S X=$$STRIP^XLFSTR(X," ") ;strip spaces
I X[">9" Q 13_U_$P(BUDT(D,C),U,2)_" "_X_" "_X_$$DATE^BUD0UTL1(9999999-D)
S X=$$STV(X)
I X="" Q 13_U_$P(BUDT(D,C),U,2)_" DID NOT HAVE A RESULT "_$$DATE^BUD0UTL1(9999999-D)
I +X>9 Q 13_U_$P(BUDT(D,C),U,2)_" "_X_" "_$$DATE^BUD0UTL1(9999999-D)
I +X<7 Q 11_U_$P(BUDT(D,C),U,2)_" "_X_" "_$$DATE^BUD0UTL1(9999999-D)
Q 12_U_$P(BUDT(D,C),U,2)_" "_X_" "_$$DATE^BUD0UTL1(9999999-D)
;Q 0_U_$P(BUDT(D,C),U,2)_" "_$$DATE^BUD0UTL1(9999999-D)_" result: "_X
;
RACE(R) ;EP
I R="Unreported" Q 8
I R="Asian" Q 1
I R="Native Hawaiian" Q 2
I R="Other Pacific Islander" Q 3
I R="Black/African American" Q 4
I R="American Indian/Alaska Native" Q 5
I R="White" Q 6
Q ""
DMDX(P,BDATE,EDATE,STOP) ;EP
NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL,BUDMEDS1
S STOP=$G(STOP)
S B=0,CNT=0,BUDD="",BUDALL="" ;if there is one before time frame set this to 1
K BUDG
S Y="BUDG("
S X=P_"^LAST DX [BUD DIABETES DXS FOR TABLE 7;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BUDG(1)) Q 1_"^"_$P(BUDG(1),U,5)_"|"_$P(BUDG(1),U,2)
I STOP Q ""
PROBDX S T=$O(^ATXAX("B","BUD DIABETES DXS FOR TABLE 7",0))
S (X,G)=0,Z="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,12)'="A"
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.Q:$P(^AUPNPROB(X,0),U,8)<BDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^ATXCHK(Y,T,9)
.S G=$P(^AUPNPROB(X,0),U,8),Z=X
.Q
I G Q 1_U_"Problem List: "_$$VAL^XBDIQ1(9000011,Z,.01)_" on "_$$FMTE^XLFDT($P(^AUPNPROB(Z,0),U,8))
PROBDMM ;now check for med
K BUDMEDS1 D GETMEDS^BUD0UTL2(P,BDATE,EDATE,"BUD DIABETES MEDS TAX","BUD DIABETES MEDS NDC",,,.BUDMEDS1)
I $D(BUDMEDS1(1)) Q 1_"^"_$P(BUDMEDS1(1),U,5)_"|"_$E($P(BUDMEDS1(1),U,2),1,15)
Q ""
;
OVAR(P,BDATE,EDATE,STOP) ;EP
NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL
S STOP=$G(STOP)
S B=0,CNT=0,BUDD="",BUDALL="" ;if there is one before time frame set this to 1
K BUDG
S Y="BUDG("
S X=P_"^LAST DX 256.4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BUDG(1)) Q 1_"^"_$P(BUDG(1),U,5)_"|"_$P(BUDG(1),U,2)
I STOP Q ""
PROBOV ;
S (X,G)=0,Z="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,12)'="A"
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.Q:$P(^AUPNPROB(X,0),U,8)<BDATE
.S Y=$$VAL^XBDIQ1(9000011,X,.01)
.Q:Y'="256.4"
.S G=$P(^AUPNPROB(X,0),U,8),Z=X
.Q
I G Q 1
Q ""
DM2(P,BDATE,EDATE,STOP) ;EP
NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL
S STOP=$G(STOP)
S B=0,CNT=0,BUDD="",BUDALL="" ;if there is one before time frame set this to 1
K BUDG
S Y="BUDG("
S X=P_"^LAST 2 DX [SURVEILLANCE DIABETES;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BUDG(2)) Q 1_"^"_$P(BUDG(1),U,5)_"|"_$P(BUDG(1),U,2)
Q ""
GESTDX(P,BDATE,EDATE,STOP) ;EP
NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL
S STOP=$G(STOP)
S B=0,CNT=0,BUDD="",BUDALL="" ;if there is one before time frame set this to 1
K BUDG
S Y="BUDG("
S X=P_"^LAST DX [BUD GEST/STEROID DM DX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BUDG(1)) Q 1_"^"_$P(BUDG(1),U,5)_"|"_$P(BUDG(1),U,2)
I STOP Q ""
GESTPL S T=$O(^ATXAX("B","BUD GEST/STEROID DM DX",0))
S (X,G)=0,Z="" F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(G) D
.Q:$P(^AUPNPROB(X,0),U,12)'="A"
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.Q:$P(^AUPNPROB(X,0),U,8)<BDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^ATXCHK(Y,T,9)
.S G=$P(^AUPNPROB(X,0),U,8),Z=X
.Q
I G Q 1
Q ""
;
LOINC(A,B) ;EP
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
STV(X) ;EP - strip all characters besides numbers and a "."
I X="" Q X
NEW A,B,L
S L=$L(X)
F B=1:1:L S A=$E(X,B) Q:A="" I A'?1N,A'?1"." S X=$$STRIP^XLFSTR(X,A) S B=B-1
Q X
;
BUD0RP7C ; IHS/CMI/LAB - UDS REPORT PROCESSOR 01 Dec 2010 5:11 PM ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
+2 ;
DM ;EP - list of DM
+1 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+2 SET BUDBDB=($EXTRACT(BUDBD,1,3)-85)_"0101"
+3 SET BUDBDE=($EXTRACT(BUDBD,1,3)-18)_"1231"
+4 IF BUDDOB>BUDBDE
QUIT
+5 IF BUDDOB<BUDBDB
QUIT
+6 IF BUDMEDV<2
QUIT
+7 ;
+8 SET BUDP=$$DMDX(DFN,$$DOB^AUPNPAT(DFN),BUDED)
+9 ;not dx'ed before end of report period
IF '$PIECE(BUDP,U)
QUIT
+10 SET BUDOVAR=$$OVAR(DFN,BUDBD,BUDED)
+11 SET BUD2DM=$$DM2(DFN,BUDBD,BUDED)
+12 ;had 2 dx of dm during report period and an ovary dx
IF $PIECE(BUDOVAR,U)
IF $PIECE(BUD2DM,U)
QUIT
+13 ;had gestational dx during report period
IF $$GESTDX(DFN,BUDBD,BUDED)
QUIT
+14 SET BUDRACEX=$$RACE^BUD0RPTC(DFN)
SET BUDRACE=$PIECE(BUDRACEX,U,2)
SET BUDRACEP=$PIECE(BUDRACEX,U,5)
+15 SET BUDRACEE=$$RACE^BUD0RP7I(BUDRACE)
+16 ;S BUDRACE=$$RACE^BUD0RP7I(BUDRACE)
+17 SET BUDR=""
+18 SET BUDETHN=$PIECE($$HISP^BUD0RPTC(DFN),U,1)
+19 IF +BUDETHN=1
SET BUDETHNN="Hispanic or Latino"
+20 IF +BUDETHN=2
SET BUDETHNN="Non-Hispanic/Latino"
+21 IF +BUDETHN=3
SET BUDETHNN="Unreported/Refused to Report"
+22 IF BUDRACEP=16!(+BUDETHN=3)
SET BUDR=17
GOTO SETSECTC
+23 IF +BUDETHN=1
SET BUDR=BUDRACEP
GOTO SETSECTC
+24 IF +BUDETHN=2!(+BUDETHN=3)
SET BUDR=BUDRACEP+8
SETSECTC ;
+1 SET $PIECE(BUDSECTC(9),U,BUDR)=$PIECE($GET(BUDSECTC(9)),U,BUDR)+1
+2 SET $PIECE(BUDSECTC(10),U,BUDR)=$PIECE($GET(BUDSECTC(10)),U,BUDR)+1
+3 SET $PIECE(BUDSECTC(9),U,18)=$PIECE($GET(BUDSECTC(9)),U,18)+1
+4 SET $PIECE(BUDSECTC(10),U,18)=$PIECE($GET(BUDSECTC(10)),U,18)+1
+5 ;S $P(BUDSECTF(9),U,BUDETHN)=$P($G(BUDSECTF(9)),U,BUDETHN)+1
+6 ;S $P(BUDSECTF(10),U,BUDETHN)=$P($G(BUDSECTF(10)),U,BUDETHN)+1
+7 ;S $P(BUDSECTF(9),U,3)=$P($G(BUDSECTF(9)),U,3)+1
+8 ;S $P(BUDSECTF(10),U,3)=$P($G(BUDSECTF(10)),U,3)+1
+9 IF $GET(BUDDMRL)
SET ^XTMP("BUD0RP7",BUDJ,BUDH,"DMR",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BUDP,"^",2)
+10 ;I $G(BUDDMEL) S ^XTMP("BUD0RP7",BUDJ,BUDH,"DME",BUDETHNN,BUDCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)
+11 ;get last hgba1c value and set counters/lists
+12 SET BUDHGB=$$HGBA1C(DFN,BUDBD,BUDED)
SET ;
+1 SET BUDLINE=$PIECE(BUDHGB,U)
+2 ;W !,DFN," ",BUDLINE
+3 SET $PIECE(BUDSECTC(BUDLINE),U,BUDR)=$PIECE($GET(BUDSECTC(BUDLINE)),U,BUDR)+1
SET $PIECE(BUDSECTC(BUDLINE),U,18)=$PIECE($GET(BUDSECTC(BUDLINE)),U,18)+1
+4 SET $PIECE(BUDSECTF(BUDLINE),U,BUDETHN)=$PIECE($GET(BUDSECTF(BUDLINE)),U,BUDETHN)+1
SET $PIECE(BUDSECTF(BUDLINE),U,9)=$PIECE($GET(BUDSECTF(BUDLINE)),U,9)+1
+5 IF $GET(BUDDMR1L)
IF BUDLINE=11
SET ^XTMP("BUD0RP7",BUDJ,BUDH,"DMR1",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BUDP,"^",2)_"^"_$PIECE(BUDHGB,U,2)
+6 IF $GET(BUDDMR2L)
IF BUDLINE=12
SET ^XTMP("BUD0RP7",BUDJ,BUDH,"DMR2",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BUDP,"^",2)_"^"_$PIECE(BUDHGB,U,2)
+7 IF $GET(BUDDMR3L)
IF BUDLINE=13
SET ^XTMP("BUD0RP7",BUDJ,BUDH,"DMR3",BUDRACEP,+BUDETHN,BUDCOM,BUDAGE,$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BUDP,"^",2)_"^"_$PIECE(BUDHGB,U,2)
+8 ;I $G(BUDDME1L),BUDLINE=11 S ^XTMP("BUD0RP7",BUDJ,BUDH,"DME1",BUDETHNN,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDHGB,U,2)
+9 ;I $G(BUDDME2L),BUDLINE=12 S ^XTMP("BUD0RP7",BUDJ,BUDH,"DME2",BUDETHNN,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDHGB,U,2)
+10 ;I $G(BUDDME3L),BUDLINE=13 S ^XTMP("BUD0RP7",BUDJ,BUDH,"DME3",BUDETHNN,$P(^DPT(DFN,0),U),BUDCOM,DFN)=$P(BUDP,"^",2)_"^"_$P(BUDHGB,U,2)
+11 QUIT
+12 ;
HGBA1C(P,BDATE,EDATE) ;EP
+1 NEW BUDG,BUDT,BUDC,E,%,L,T,BUDLT,D,X,J,C,G
+2 SET BUDC=0
+3 SET G=$$CPT^BUD0DU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BUD HGBA1C CPTS",0)),5)
+4 IF G]""
SET BUDC=BUDC+1
SET BUDT((9999999-$PIECE(G,U,1)),BUDC)=U_"CPT "_$PIECE(G,U,2)
+5 ;now get all loinc/taxonomy tests
+6 SET T=$ORDER(^ATXAX("B","BGP HGBA1C LOINC CODES",0))
+7 SET BUDLT=$ORDER(^ATXLAB("B","DM AUDIT HGB A1C TAX",0))
+8 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)
QUIT
Begin DoDot:1
+9 SET L=0
FOR
SET L=$ORDER(^AUPNVLAB("AE",P,D,L))
IF L'=+L
QUIT
Begin DoDot:2
+10 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,L,X))
IF X'=+X
QUIT
Begin DoDot:3
+11 IF '$DATA(^AUPNVLAB(X,0))
QUIT
+12 IF BUDLT
IF $PIECE(^AUPNVLAB(X,0),U)
IF $DATA(^ATXLAB(BUDLT,21,"B",$PIECE(^AUPNVLAB(X,0),U)))
SET BUDC=BUDC+1
SET BUDT(D,BUDC)=$PIECE(^AUPNVLAB(X,0),U,4)_U_"LAB: "_$$VAL^XBDIQ1(9000010.09,X,.01)
QUIT
+13 IF 'T
QUIT
+14 SET J=$PIECE($GET(^AUPNVLAB(X,11)),U,13)
IF J=""
QUIT
+15 IF '$$LOINC(J,T)
QUIT
+16 SET BUDC=BUDC+1
SET BUDT(D,BUDC)=$PIECE(^AUPNVLAB(X,0),U,4)_U_"LAB LOINC: "_$$VAL^XBDIQ1(9000010.09,X,.01)_" "_$PIECE(^AUPNVLAB(X,11),U,13)
+17 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+18 ; now got though and set return value of done 1 or 0^numerator 2-7^date^value
+19 ;no tests so is hit in numerator
IF '$DATA(BUDT)
QUIT 13_U_"NO A1C TEST DURING THE REPORT PERIOD"
+20 ; now get rid of all on same day where 1 has a result and the other doesn't
+21 SET D=0
SET BUDC=0
FOR
SET D=$ORDER(BUDT(D))
IF D'=+D
QUIT
SET C=0
SET G=0
FOR
SET C=$ORDER(BUDT(D,C))
IF C'=+C
QUIT
Begin DoDot:1
+22 IF $PIECE(BUDT(D,C),U,1)]""
SET BUDC=BUDC+1
+23 IF BUDC>0
IF $PIECE(BUDT(D,C),U,1)=""
KILL BUDT(D,C)
End DoDot:1
+24 SET D=0
SET G=""
+25 SET D=$ORDER(BUDT(D))
+26 SET C=0
SET C=$ORDER(BUDT(D,C))
+27 SET X=$PIECE(BUDT(D,C),U,1)
+28 IF $$UP^XLFSTR(X)="COMMENT"
QUIT 13_U_$PIECE(BUDT(D,C),U,2)_" "_$$DATE^BUD0UTL1(9999999-D)_" (no result) "_X
+29 IF X=""
Begin DoDot:1
+30 SET G=""
+31 IF $PIECE(BUDT(D,C),U,2)="CPT 3046F"
SET G=13_U_$PIECE(BUDT(D,C),U,2)_" "_$$DATE^BUD0UTL1(9999999-D)
QUIT
+32 IF $PIECE(BUDT(D,C),U,2)="CPT 3045F"
SET G=12_U_$PIECE(BUDT(D,C),U,2)_" "_$$DATE^BUD0UTL1(9999999-D)
QUIT
+33 IF $PIECE(BUDT(D,C),U,2)="CPT 3044F"
SET G=11_U_$PIECE(BUDT(D,C),U,2)_" "_$$DATE^BUD0UTL1(9999999-D)
QUIT
+34 IF $PIECE(BUDT(D,C),U,2)="CPT 83036"
SET G=13_U_$PIECE(BUDT(D,C),U,2)_" "_$$DATE^BUD0UTL1(9999999-D)
QUIT
+35 IF $PIECE(BUDT(D,C),U,2)="CPT 83037"
SET G=13_U_$PIECE(BUDT(D,C),U,2)_" "_$$DATE^BUD0UTL1(9999999-D)
QUIT
+36 SET G=13_U_$PIECE(BUDT(D,C),U,2)_" DID NOT HAVE A RESULT "_$$DATE^BUD0UTL1(9999999-D)
QUIT
End DoDot:1
QUIT G
+37 ;strip spaces
SET X=$$STRIP^XLFSTR(X," ")
+38 IF X[">9"
QUIT 13_U_$PIECE(BUDT(D,C),U,2)_" "_X_" "_X_$$DATE^BUD0UTL1(9999999-D)
+39 SET X=$$STV(X)
+40 IF X=""
QUIT 13_U_$PIECE(BUDT(D,C),U,2)_" DID NOT HAVE A RESULT "_$$DATE^BUD0UTL1(9999999-D)
+41 IF +X>9
QUIT 13_U_$PIECE(BUDT(D,C),U,2)_" "_X_" "_$$DATE^BUD0UTL1(9999999-D)
+42 IF +X<7
QUIT 11_U_$PIECE(BUDT(D,C),U,2)_" "_X_" "_$$DATE^BUD0UTL1(9999999-D)
+43 QUIT 12_U_$PIECE(BUDT(D,C),U,2)_" "_X_" "_$$DATE^BUD0UTL1(9999999-D)
+44 ;Q 0_U_$P(BUDT(D,C),U,2)_" "_$$DATE^BUD0UTL1(9999999-D)_" result: "_X
+45 ;
RACE(R) ;EP
+1 IF R="Unreported"
QUIT 8
+2 IF R="Asian"
QUIT 1
+3 IF R="Native Hawaiian"
QUIT 2
+4 IF R="Other Pacific Islander"
QUIT 3
+5 IF R="Black/African American"
QUIT 4
+6 IF R="American Indian/Alaska Native"
QUIT 5
+7 IF R="White"
QUIT 6
+8 QUIT ""
DMDX(P,BDATE,EDATE,STOP) ;EP
+1 NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL,BUDMEDS1
+2 SET STOP=$GET(STOP)
+3 ;if there is one before time frame set this to 1
SET B=0
SET CNT=0
SET BUDD=""
SET BUDALL=""
+4 KILL BUDG
+5 SET Y="BUDG("
+6 SET X=P_"^LAST DX [BUD DIABETES DXS FOR TABLE 7;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 IF $DATA(BUDG(1))
QUIT 1_"^"_$PIECE(BUDG(1),U,5)_"|"_$PIECE(BUDG(1),U,2)
+8 IF STOP
QUIT ""
PROBDX SET T=$ORDER(^ATXAX("B","BUD DIABETES DXS FOR TABLE 7",0))
+1 SET (X,G)=0
SET Z=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+2 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+3 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+4 IF $PIECE(^AUPNPROB(X,0),U,8)<BDATE
QUIT
+5 SET Y=$PIECE(^AUPNPROB(X,0),U)
+6 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+7 SET G=$PIECE(^AUPNPROB(X,0),U,8)
SET Z=X
+8 QUIT
End DoDot:1
+9 IF G
QUIT 1_U_"Problem List: "_$$VAL^XBDIQ1(9000011,Z,.01)_" on "_$$FMTE^XLFDT($PIECE(^AUPNPROB(Z,0),U,8))
PROBDMM ;now check for med
+1 KILL BUDMEDS1
DO GETMEDS^BUD0UTL2(P,BDATE,EDATE,"BUD DIABETES MEDS TAX","BUD DIABETES MEDS NDC",,,.BUDMEDS1)
+2 IF $DATA(BUDMEDS1(1))
QUIT 1_"^"_$PIECE(BUDMEDS1(1),U,5)_"|"_$EXTRACT($PIECE(BUDMEDS1(1),U,2),1,15)
+3 QUIT ""
+4 ;
OVAR(P,BDATE,EDATE,STOP) ;EP
+1 NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL
+2 SET STOP=$GET(STOP)
+3 ;if there is one before time frame set this to 1
SET B=0
SET CNT=0
SET BUDD=""
SET BUDALL=""
+4 KILL BUDG
+5 SET Y="BUDG("
+6 SET X=P_"^LAST DX 256.4;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 IF $DATA(BUDG(1))
QUIT 1_"^"_$PIECE(BUDG(1),U,5)_"|"_$PIECE(BUDG(1),U,2)
+8 IF STOP
QUIT ""
PROBOV ;
+1 SET (X,G)=0
SET Z=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+2 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+3 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+4 IF $PIECE(^AUPNPROB(X,0),U,8)<BDATE
QUIT
+5 SET Y=$$VAL^XBDIQ1(9000011,X,.01)
+6 IF Y'="256.4"
QUIT
+7 SET G=$PIECE(^AUPNPROB(X,0),U,8)
SET Z=X
+8 QUIT
End DoDot:1
+9 IF G
QUIT 1
+10 QUIT ""
DM2(P,BDATE,EDATE,STOP) ;EP
+1 NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL
+2 SET STOP=$GET(STOP)
+3 ;if there is one before time frame set this to 1
SET B=0
SET CNT=0
SET BUDD=""
SET BUDALL=""
+4 KILL BUDG
+5 SET Y="BUDG("
+6 SET X=P_"^LAST 2 DX [SURVEILLANCE DIABETES;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 IF $DATA(BUDG(2))
QUIT 1_"^"_$PIECE(BUDG(1),U,5)_"|"_$PIECE(BUDG(1),U,2)
+8 QUIT ""
GESTDX(P,BDATE,EDATE,STOP) ;EP
+1 NEW BUDDX,B,CNT,BUDD,BUDG,BUDALL
+2 SET STOP=$GET(STOP)
+3 ;if there is one before time frame set this to 1
SET B=0
SET CNT=0
SET BUDD=""
SET BUDALL=""
+4 KILL BUDG
+5 SET Y="BUDG("
+6 SET X=P_"^LAST DX [BUD GEST/STEROID DM DX;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+7 IF $DATA(BUDG(1))
QUIT 1_"^"_$PIECE(BUDG(1),U,5)_"|"_$PIECE(BUDG(1),U,2)
+8 IF STOP
QUIT ""
GESTPL SET T=$ORDER(^ATXAX("B","BUD GEST/STEROID DM DX",0))
+1 SET (X,G)=0
SET Z=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+2 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+3 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+4 IF $PIECE(^AUPNPROB(X,0),U,8)<BDATE
QUIT
+5 SET Y=$PIECE(^AUPNPROB(X,0),U)
+6 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+7 SET G=$PIECE(^AUPNPROB(X,0),U,8)
SET Z=X
+8 QUIT
End DoDot:1
+9 IF G
QUIT 1
+10 QUIT ""
+11 ;
LOINC(A,B) ;EP
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
STV(X) ;EP - strip all characters besides numbers and a "."
+1 IF X=""
QUIT X
+2 NEW A,B,L
+3 SET L=$LENGTH(X)
+4 FOR B=1:1:L
SET A=$EXTRACT(X,B)
IF A=""
QUIT
IF A'?1N
IF A'?1"."
SET X=$$STRIP^XLFSTR(X,A)
SET B=B-1
+5 QUIT X
+6 ;
