BUDERP7C ;IHS/CMI/LAB - UDS REPORT T7;
;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
;
DM ;EP - list of DM
S BUDDOB=$P(^DPT(DFN,0),U,3)
S BUDDDB=($E(BUDBD,1,3)-75)_"0101"
S BUDDDE=($E(BUDBD,1,3)-18)_"1231"
Q:BUDDOB>BUDDDE
Q:BUDDOB<BUDDDB
Q:BUDMEDV<1
;
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)
;START HERE LORI AND FIX DM2/GESTDX/OVAR
S BUDX2DM=$$DM2(DFN,($E(BUDBD,1,3)-1)_$E(BUDBD,4,7),BUDED)
I $P(BUDOVAR,U),'$P(BUDX2DM,U) Q ;DID NOT HAVE 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^BUDERPTC(DFN),BUDRACE=$P(BUDRACEX,U,2),BUDRACEP=$P(BUDRACEX,U,5)
S BUDRACEE=$$RACE^BUDERP7I(BUDRACE)
;S BUDRACE=$$RACE^BUDERP7I(BUDRACE)
S BUDETHN=$P($$HISP^BUDERPTC(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=8,+BUDETHN=3 S BUDR=1 G SETSECTC
I +BUDETHN=1 S BUDR=BUDRACEP G SETSECTC
I +BUDETHN=2 S BUDR=BUDRACEP G SETSECTC
SETSECTC ;
S $P(BUDSECTC(+BUDETHN,BUDR),U,1)=$P($G(BUDSECTC(+BUDETHN,BUDR)),U,1)+1 ;COL 1
S $P(BUDSECTC(+BUDETHN,BUDR),U,2)=$P($G(BUDSECTC(+BUDETHN,BUDR)),U,2)+1 ;COL 2
;TOTAL LINE
S $P(BUDSECTC(4),U,1)=$P($G(BUDSECTC(4)),U,1)+1
S $P(BUDSECTC(4),U,2)=$P($G(BUDSECTC(4)),U,2)+1
;SUBTOTAL LINE
S $P(BUDSECTC(+BUDETHN),U,1)=$P($G(BUDSECTC(+BUDETHN)),U,1)+1
S $P(BUDSECTC(+BUDETHN),U,2)=$P($G(BUDSECTC(+BUDETHN)),U,2)+1
I $G(BUDDMRL) S ^XTMP("BUDERP7",BUDJ,BUDH,"DMR",BUDRACEP,+BUDETHN,BUDCCOM,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)
S BUDPIEC=$S(BUDLINE=13:5,BUDLINE=11:4,1:"")
;W !,DFN," ",BUDLINE
S $P(BUDSECTC(+BUDETHN,BUDR),U,BUDPIEC)=$P($G(BUDSECTC(+BUDETHN,BUDR)),U,BUDPIEC)+1 ;COL 1
;TOTAL LINE
S $P(BUDSECTC(4),U,BUDPIEC)=$P($G(BUDSECTC(4)),U,BUDPIEC)+1
S $P(BUDSECTC(+BUDETHN),U,BUDPIEC)=$P($G(BUDSECTC(+BUDETHN)),U,BUDPIEC)+1
I $G(BUDDMR1L),BUDLINE=11 S ^XTMP("BUDERP7",BUDJ,BUDH,"DMR1",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"^"_$P(BUDHGB,U,2)
I $G(BUDDMR2L),BUDLINE=13 S ^XTMP("BUDERP7",BUDJ,BUDH,"DMR2",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"^"_$P(BUDHGB,U,2)
;I $G(BUDDMR3L),BUDLINE=12.2 S ^XTMP("BUDERP7",BUDJ,BUDH,"DMR3",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"^"_$P(BUDHGB,U,2)
;I $G(BUDDMR3L),BUDLINE=13 S ^XTMP("BUDERP7",BUDJ,BUDH,"DMR3",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"^"_$P(BUDHGB,U,2)
Q
;
HGBA1C(P,BDATE,EDATE) ;EP
NEW BUDG,BUDT,BUDD,E,%,L,T,BUDLT,D,X,J,C,G
S BUDD=0
S G=$$CPT^BUDEDU(P,BDATE,EDATE,$O(^ATXAX("B","BUD HGBA1C CPTS",0)),5)
I G]"" S BUDD=BUDD+1,BUDT((9999999-$P(G,U,1)),BUDD)=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 BUDD=BUDD+1,BUDT(D,BUDD)=$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 BUDD=BUDD+1,BUDT(D,BUDD)=$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,BUDD=0 K BUDX 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 BUDD=BUDD+1
.;I BUDD>0,$P(BUDT(D,C),U,1)="" K BUDT(D,C)
.I $P(BUDT(D,C),U,1)="" Q
.S BUDX(D,C)=BUDT(D,C)
I '$D(BUDX) D
.S D=$O(BUDT(0))
.I D S C=$O(BUDT(D,0))
.I C S BUDX(D,C)=BUDT(D,C)
S D=0,G=""
S D=$O(BUDX(D))
S C=0,C=$O(BUDX(D,C))
S X=$P(BUDX(D,C),U,1)
I $$UP^XLFSTR(X)="COMMENT" Q 13_U_$P(BUDX(D,C),U,2)_" "_$$DATE^BUDEUTL1(9999999-D)_" (no result) "_X
I X="" D Q G
.S G=""
.I $P(BUDX(D,C),U,2)="CPT 3046F" S G=13_U_$P(BUDX(D,C),U,2)_" "_$$DATE^BUDEUTL1(9999999-D) Q
.I $P(BUDX(D,C),U,2)="CPT 3045F" S G=12.2_U_$P(BUDX(D,C),U,2)_" "_$$DATE^BUDEUTL1(9999999-D) Q
.I $P(BUDX(D,C),U,2)="CPT 3044F" S G=11_U_$P(BUDX(D,C),U,2)_" "_$$DATE^BUDEUTL1(9999999-D) Q
.I $P(BUDX(D,C),U,2)="CPT 83036" S G=13_U_$P(BUDX(D,C),U,2)_" "_$$DATE^BUDEUTL1(9999999-D) Q
.I $P(BUDX(D,C),U,2)="CPT 83037" S G=13_U_$P(BUDX(D,C),U,2)_" "_$$DATE^BUDEUTL1(9999999-D) Q
.S G=13_U_$P(BUDX(D,C),U,2)_" DID NOT HAVE A RESULT "_$$DATE^BUDEUTL1(9999999-D) Q
S X=$$STRIP^XLFSTR(X," ") ;strip spaces
I X[">9" Q 13_U_$P(BUDX(D,C),U,2)_" "_X_" "_X_$$DATE^BUDEUTL1(9999999-D)
S X=$$STV(X)
I X="" Q 13_U_$P(BUDX(D,C),U,2)_" DID NOT HAVE A RESULT "_$$DATE^BUDEUTL1(9999999-D)
I +X>9 Q 13_U_$P(BUDX(D,C),U,2)_" "_X_" "_$$DATE^BUDEUTL1(9999999-D)
I +X<8 Q 11_U_$P(BUDX(D,C),U,2)_" "_X_" "_$$DATE^BUDEUTL1(9999999-D)
Q "" ;12.2_U_$P(BUDX(D,C),U,2)_" "_X_" "_$$DATE^BUDEUTL1(9999999-D)
;Q 0_U_$P(BUDX(D,C),U,2)_" "_$$DATE^BUDEUTL1(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,Z,Y,T,X
S STOP=$G(STOP)
S B=0,CNT=0,BUDD="",BUDALL="" ;if there is one before time frame set this to 1
;
;V10.0 ICD10
K BUDG S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDETSSC("B","T7 DIABETES DIAGNOSES",0))
S X=0,G="" F S X=$O(BUDG(X)) Q:X'=+X!(G) D
.S Y=+$P(BUDG(X),U,4)
.S Z=$P($G(^AUPNVPOV(Y,0)),U,1)
.S V=$P(BUDG(X),U,5)
.S C=$$PRIMPROV^APCLV(V,"D")
.Q:C=53
.Q:$P(^AUPNVSIT(V,0),U,7)="C"
.I $D(^BUDETSSC("AD",Z,T)) S G=1_"^"_$P(BUDG(X),U,5)_"|"_$P(BUDG(X),U,2) Q
.S S=$$VAL^XBDIQ1(9000010.07,Y,1101) I S]"",$D(^BUDETSSC("AS",S,T)) S G=1_"^"_$P(BUDG(X),U,5)_"|"_S Q
I G]"" Q G
PROBDX ;
S G=$$PLCL^BUDEDU(P,"T7 DIABETES DIAGNOSES",EDATE,0)
I G Q 1_U_"Problem List: "_$P(G,U,2)_" on "_$$DATE^BUDEUTL1($P(G,U,3))
PROBDMM ;now check for med
K BUDMEDS1 D GETMEDS^BUDEUTL2(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)
S X=P_"^LAST DX E28.2;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)="D"
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.Q:$P(^AUPNPROB(X,0),U,8)<BDATE
.S Y=$$VAL^XBDIQ1(9000011,X,.01)
.I Y'="256.4",Y'="E28.2" Q
.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
;
;V10.0 ICD10
K BUDG S %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE,E=$$START1^APCLDF(%,"BUDG(")
S T=$O(^BUDETSSC("B","T7 DIABETES DIAGNOSES",0))
S X=0,G="" F S X=$O(BUDG(X)) Q:X'=+X!(CNT>1) D
.S Y=+$P(BUDG(X),U,4)
.S Z=$P($G(^AUPNVPOV(Y,0)),U,1)
.S V=$P(BUDG(X),U,5)
.S C=$$PRIMPROV^APCLV(V,"F")
.Q:C=53
.Q:$P(^AUPNVSIT(V,0),U,7)="C"
.I $D(^BUDETSSC("AD",Z,T)) S CNT=CNT+1 S G=1_"^"_$P(BUDG(X),U,5)_"|"_$P(BUDG(X),U,2) Q
.S S=$$VAL^XBDIQ1(9000010.07,Y,1101) I S]"",$D(^BUDETSSC("AS",S,T)) S CNT=CNT+1 S G=1_"^"_$P(BUDG(X),U,5)_"|"_S Q
I CNT>1 Q G
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)="D"
.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
;
BUDERP7C ;IHS/CMI/LAB - UDS REPORT T7;
+1 ;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
+2 ;
DM ;EP - list of DM
+1 SET BUDDOB=$PIECE(^DPT(DFN,0),U,3)
+2 SET BUDDDB=($EXTRACT(BUDBD,1,3)-75)_"0101"
+3 SET BUDDDE=($EXTRACT(BUDBD,1,3)-18)_"1231"
+4 IF BUDDOB>BUDDDE
QUIT
+5 IF BUDDOB<BUDDDB
QUIT
+6 IF BUDMEDV<1
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 ;START HERE LORI AND FIX DM2/GESTDX/OVAR
+12 SET BUDX2DM=$$DM2(DFN,($EXTRACT(BUDBD,1,3)-1)_$EXTRACT(BUDBD,4,7),BUDED)
+13 ;DID NOT HAVE had 2 dx of dm during report period and an ovary dx
IF $PIECE(BUDOVAR,U)
IF '$PIECE(BUDX2DM,U)
QUIT
+14 ;had gestational dx during report period
IF $$GESTDX(DFN,BUDBD,BUDED)
QUIT
+15 SET BUDRACEX=$$RACE^BUDERPTC(DFN)
SET BUDRACE=$PIECE(BUDRACEX,U,2)
SET BUDRACEP=$PIECE(BUDRACEX,U,5)
+16 SET BUDRACEE=$$RACE^BUDERP7I(BUDRACE)
+17 ;S BUDRACE=$$RACE^BUDERP7I(BUDRACE)
+18 SET BUDETHN=$PIECE($$HISP^BUDERPTC(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=8
IF +BUDETHN=3
SET BUDR=1
GOTO SETSECTC
+23 IF +BUDETHN=1
SET BUDR=BUDRACEP
GOTO SETSECTC
+24 IF +BUDETHN=2
SET BUDR=BUDRACEP
GOTO SETSECTC
SETSECTC ;
+1 ;COL 1
SET $PIECE(BUDSECTC(+BUDETHN,BUDR),U,1)=$PIECE($GET(BUDSECTC(+BUDETHN,BUDR)),U,1)+1
+2 ;COL 2
SET $PIECE(BUDSECTC(+BUDETHN,BUDR),U,2)=$PIECE($GET(BUDSECTC(+BUDETHN,BUDR)),U,2)+1
+3 ;TOTAL LINE
+4 SET $PIECE(BUDSECTC(4),U,1)=$PIECE($GET(BUDSECTC(4)),U,1)+1
+5 SET $PIECE(BUDSECTC(4),U,2)=$PIECE($GET(BUDSECTC(4)),U,2)+1
+6 ;SUBTOTAL LINE
+7 SET $PIECE(BUDSECTC(+BUDETHN),U,1)=$PIECE($GET(BUDSECTC(+BUDETHN)),U,1)+1
+8 SET $PIECE(BUDSECTC(+BUDETHN),U,2)=$PIECE($GET(BUDSECTC(+BUDETHN)),U,2)+1
+9 IF $GET(BUDDMRL)
SET ^XTMP("BUDERP7",BUDJ,BUDH,"DMR",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BUDP,"^",2)
+10 ;get last hgba1c value and set counters/lists
+11 SET BUDHGB=$$HGBA1C(DFN,BUDBD,BUDED)
SET ;
+1 SET BUDLINE=$PIECE(BUDHGB,U)
+2 SET BUDPIEC=$SELECT(BUDLINE=13:5,BUDLINE=11:4,1:"")
+3 ;W !,DFN," ",BUDLINE
+4 ;COL 1
SET $PIECE(BUDSECTC(+BUDETHN,BUDR),U,BUDPIEC)=$PIECE($GET(BUDSECTC(+BUDETHN,BUDR)),U,BUDPIEC)+1
+5 ;TOTAL LINE
+6 SET $PIECE(BUDSECTC(4),U,BUDPIEC)=$PIECE($GET(BUDSECTC(4)),U,BUDPIEC)+1
+7 SET $PIECE(BUDSECTC(+BUDETHN),U,BUDPIEC)=$PIECE($GET(BUDSECTC(+BUDETHN)),U,BUDPIEC)+1
+8 IF $GET(BUDDMR1L)
IF BUDLINE=11
SET ^XTMP("BUDERP7",BUDJ,BUDH,"DMR1",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BUDP,"^",2)_"^"_$PIECE(BUDHGB,U,2)
+9 IF $GET(BUDDMR2L)
IF BUDLINE=13
SET ^XTMP("BUDERP7",BUDJ,BUDH,"DMR2",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BUDP,"^",2)_"^"_$PIECE(BUDHGB,U,2)
+10 ;I $G(BUDDMR3L),BUDLINE=12.2 S ^XTMP("BUDERP7",BUDJ,BUDH,"DMR3",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"^"_$P(BUDHGB,U,2)
+11 ;I $G(BUDDMR3L),BUDLINE=13 S ^XTMP("BUDERP7",BUDJ,BUDH,"DMR3",BUDRACEP,+BUDETHN,BUDCCOM,BUDAGE,$P(^DPT(DFN,0),U),DFN)=$P(BUDP,"^",2)_"^"_$P(BUDHGB,U,2)
+12 QUIT
+13 ;
HGBA1C(P,BDATE,EDATE) ;EP
+1 NEW BUDG,BUDT,BUDD,E,%,L,T,BUDLT,D,X,J,C,G
+2 SET BUDD=0
+3 SET G=$$CPT^BUDEDU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BUD HGBA1C CPTS",0)),5)
+4 IF G]""
SET BUDD=BUDD+1
SET BUDT((9999999-$PIECE(G,U,1)),BUDD)=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 BUDD=BUDD+1
SET BUDT(D,BUDD)=$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 BUDD=BUDD+1
SET BUDT(D,BUDD)=$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 BUDD=0
KILL BUDX
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 ;I $P(BUDT(D,C),U,1)]"" S BUDD=BUDD+1
+23 ;I BUDD>0,$P(BUDT(D,C),U,1)="" K BUDT(D,C)
+24 IF $PIECE(BUDT(D,C),U,1)=""
QUIT
+25 SET BUDX(D,C)=BUDT(D,C)
End DoDot:1
+26 IF '$DATA(BUDX)
Begin DoDot:1
+27 SET D=$ORDER(BUDT(0))
+28 IF D
SET C=$ORDER(BUDT(D,0))
+29 IF C
SET BUDX(D,C)=BUDT(D,C)
End DoDot:1
+30 SET D=0
SET G=""
+31 SET D=$ORDER(BUDX(D))
+32 SET C=0
SET C=$ORDER(BUDX(D,C))
+33 SET X=$PIECE(BUDX(D,C),U,1)
+34 IF $$UP^XLFSTR(X)="COMMENT"
QUIT 13_U_$PIECE(BUDX(D,C),U,2)_" "_$$DATE^BUDEUTL1(9999999-D)_" (no result) "_X
+35 IF X=""
Begin DoDot:1
+36 SET G=""
+37 IF $PIECE(BUDX(D,C),U,2)="CPT 3046F"
SET G=13_U_$PIECE(BUDX(D,C),U,2)_" "_$$DATE^BUDEUTL1(9999999-D)
QUIT
+38 IF $PIECE(BUDX(D,C),U,2)="CPT 3045F"
SET G=12.2_U_$PIECE(BUDX(D,C),U,2)_" "_$$DATE^BUDEUTL1(9999999-D)
QUIT
+39 IF $PIECE(BUDX(D,C),U,2)="CPT 3044F"
SET G=11_U_$PIECE(BUDX(D,C),U,2)_" "_$$DATE^BUDEUTL1(9999999-D)
QUIT
+40 IF $PIECE(BUDX(D,C),U,2)="CPT 83036"
SET G=13_U_$PIECE(BUDX(D,C),U,2)_" "_$$DATE^BUDEUTL1(9999999-D)
QUIT
+41 IF $PIECE(BUDX(D,C),U,2)="CPT 83037"
SET G=13_U_$PIECE(BUDX(D,C),U,2)_" "_$$DATE^BUDEUTL1(9999999-D)
QUIT
+42 SET G=13_U_$PIECE(BUDX(D,C),U,2)_" DID NOT HAVE A RESULT "_$$DATE^BUDEUTL1(9999999-D)
QUIT
End DoDot:1
QUIT G
+43 ;strip spaces
SET X=$$STRIP^XLFSTR(X," ")
+44 IF X[">9"
QUIT 13_U_$PIECE(BUDX(D,C),U,2)_" "_X_" "_X_$$DATE^BUDEUTL1(9999999-D)
+45 SET X=$$STV(X)
+46 IF X=""
QUIT 13_U_$PIECE(BUDX(D,C),U,2)_" DID NOT HAVE A RESULT "_$$DATE^BUDEUTL1(9999999-D)
+47 IF +X>9
QUIT 13_U_$PIECE(BUDX(D,C),U,2)_" "_X_" "_$$DATE^BUDEUTL1(9999999-D)
+48 IF +X<8
QUIT 11_U_$PIECE(BUDX(D,C),U,2)_" "_X_" "_$$DATE^BUDEUTL1(9999999-D)
+49 ;12.2_U_$P(BUDX(D,C),U,2)_" "_X_" "_$$DATE^BUDEUTL1(9999999-D)
QUIT ""
+50 ;Q 0_U_$P(BUDX(D,C),U,2)_" "_$$DATE^BUDEUTL1(9999999-D)_" result: "_X
+51 ;
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,Z,Y,T,X
+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 ;
+5 ;V10.0 ICD10
+6 KILL BUDG
SET %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+7 SET T=$ORDER(^BUDETSSC("B","T7 DIABETES DIAGNOSES",0))
+8 SET X=0
SET G=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+9 SET Y=+$PIECE(BUDG(X),U,4)
+10 SET Z=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+11 SET V=$PIECE(BUDG(X),U,5)
+12 SET C=$$PRIMPROV^APCLV(V,"D")
+13 IF C=53
QUIT
+14 IF $PIECE(^AUPNVSIT(V,0),U,7)="C"
QUIT
+15 IF $DATA(^BUDETSSC("AD",Z,T))
SET G=1_"^"_$PIECE(BUDG(X),U,5)_"|"_$PIECE(BUDG(X),U,2)
QUIT
+16 SET S=$$VAL^XBDIQ1(9000010.07,Y,1101)
IF S]""
IF $DATA(^BUDETSSC("AS",S,T))
SET G=1_"^"_$PIECE(BUDG(X),U,5)_"|"_S
QUIT
End DoDot:1
+17 IF G]""
QUIT G
PROBDX ;
+1 SET G=$$PLCL^BUDEDU(P,"T7 DIABETES DIAGNOSES",EDATE,0)
+2 IF G
QUIT 1_U_"Problem List: "_$PIECE(G,U,2)_" on "_$$DATE^BUDEUTL1($PIECE(G,U,3))
PROBDMM ;now check for med
+1 KILL BUDMEDS1
DO GETMEDS^BUDEUTL2(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 SET X=P_"^LAST DX E28.2;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+9 IF $DATA(BUDG(1))
QUIT 1_"^"_$PIECE(BUDG(1),U,5)_"|"_$PIECE(BUDG(1),U,2)
+10 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)="D"
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"
IF Y'="E28.2"
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 ;
+5 ;V10.0 ICD10
+6 KILL BUDG
SET %=P_"^ALL DX;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(%,"BUDG(")
+7 SET T=$ORDER(^BUDETSSC("B","T7 DIABETES DIAGNOSES",0))
+8 SET X=0
SET G=""
FOR
SET X=$ORDER(BUDG(X))
IF X'=+X!(CNT>1)
QUIT
Begin DoDot:1
+9 SET Y=+$PIECE(BUDG(X),U,4)
+10 SET Z=$PIECE($GET(^AUPNVPOV(Y,0)),U,1)
+11 SET V=$PIECE(BUDG(X),U,5)
+12 SET C=$$PRIMPROV^APCLV(V,"F")
+13 IF C=53
QUIT
+14 IF $PIECE(^AUPNVSIT(V,0),U,7)="C"
QUIT
+15 IF $DATA(^BUDETSSC("AD",Z,T))
SET CNT=CNT+1
SET G=1_"^"_$PIECE(BUDG(X),U,5)_"|"_$PIECE(BUDG(X),U,2)
QUIT
+16 SET S=$$VAL^XBDIQ1(9000010.07,Y,1101)
IF S]""
IF $DATA(^BUDETSSC("AS",S,T))
SET CNT=CNT+1
SET G=1_"^"_$PIECE(BUDG(X),U,5)_"|"_S
QUIT
End DoDot:1
+17 IF CNT>1
QUIT G
+18 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)="D"
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 ;
