BDMD91T ; IHS/CMI/LAB - 2009 DIABETES AUDIT ; [ 02/23/2009 12:39 PM ]
;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
;
;cmi/anch/maw 9/12/2007 code set versioning in TOBACCO1,ASAPOV
;
TOBACCO(P,BDATE,EDATE) ;EP
I '$G(P) Q ""
NEW BDMTOB,BDMSDX,BDMXPND,BDM1320,BDMSCPT,BDMALL,D,%,F
S BDMTOB=$$TOBACCOS(P,BDATE,EDATE) ;get last recorded HF
I BDMTOB]"" S BDMALL(9999999-$P(BDMTOB,U,3))=BDMTOB
S BDMSDX=$$DX(P,BDATE,EDATE)
I BDMSDX]"" S D=$P(BDMSDX,U,3),D=9999999-D I '$D(BDMALL(D)) S BDMALL(D)=BDMSDX
S BDMXPND=$$PED(P,BDATE,EDATE)
I BDMXPND]"" S D=$P(BDMXPND,U,3),D=9999999-D I '$D(BDMALL(D)) S BDMALL(D)=BDMXPND
S BDM1320=$$DENT(P,BDATE,EDATE)
I BDM1320]"" S D=$P(BDM1320,U,3),D=9999999-D I '$D(BDMALL(D)) S BDMALL(D)=BDM1320
S BDMSCPT=$$CPTSM(P,BDATE,EDATE)
I BDMSCPT]"" S D=$P(BDMSCPT,U,3),D=9999999-D I '$D(BDMALL(D)) S BDMALL(D)=BDMSCPT
K ^TMP($J,"A")
I '$D(BDMALL) Q "3 Not Documented "
S D=0,D=$O(BDMALL(D))
S F=$P(BDMALL(D),U)
I F["305.13"!(F["V15.82")!(F="1036F") Q "2 Not a Current User "_$P(BDMALL(D),U,1)_" "_$P(BDMALL(D),U,2)
I F="SMOKER IN HOME"!(F="SMOKE FREE HOME")!(F["CEREMONIAL")!(F["NON-TOBACCO")!(F["PREVIOUS")!(F["EXPOSURE TO") Q "2 Not a Current User "_$P(BDMALL(D),U,1)_" "_$P(BDMALL(D),U,2)
Q "1 Current User "_$P(BDMALL(D),U,1)_" "_$P(BDMALL(D),U,2)
;
DX(P,BDATE,EDATE) ;EP
NEW BDMG,T,X,G,Y
S BDMG=$$LASTDXT^BDMAPIU(P,BDATE,EDATE,"BGP GPRA SMOKING DXS","E")
I BDMG]"" Q $P($$ICDDX^ICDCODE($P(BDMG,U,4),$P(BDMG,U,1)),U,2)_U_$P(BDMG,U,3)
S T=$O(^ATXAX("B","BGP GPRA SMOKING DXS",0))
S X=0,G="" 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,3)>EDATE
.Q:$P(^AUPNPROB(X,0),U,3)<BDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^ATXCHK(Y,T,9)
.S G=$P($$ICDDX^ICDCODE(Y),U,2)_" PROBLEM LIST "_U_$$FMTE^XLFDT($P(^AUPNPROB(X,0),U,3))_U_$P(^AUPNPROB(X,0),U,3)
.Q
Q G
TOBACCOS(P,BDATE,EDATE) ;EP
K BDMTOB,BDM
K BDMTOB S BDMTOB=$$LASTHF(P,"TOBACCO",BDATE,EDATE) K O,D,H
Q BDMTOB
;
LASTHF(P,C,BDATE,EDATE) ;EP - get last factor in category C for patient P
S C=$O(^AUTTHF("B",C,0)) ;ien of category passed
I '$G(C) Q ""
S (H,D)=0 K O
F S H=$O(^AUTTHF("AC",C,H)) Q:'+H D
.Q:'$D(^AUPNVHF("AA",P,H))
.S D="" F S D=$O(^AUPNVHF("AA",P,H,D)) Q:D'=+D D
..Q:(9999999-D)>EDATE ;after time frame
..Q:(9999999-D)<BDATE ;before time frame
..S Z=$O(^AUPNVHF("AA",P,H,D,0))
..S F=$$VAL^XBDIQ1(9000010.23,Z,.01)
..I F="SMOKER IN HOME"!(F="SMOKE FREE HOME")!(F["CEREMONIAL")!(F["EXPOSURE TO") Q
..S O(D)=$O(^AUPNVHF("AA",P,H,D,""))
.Q
S D=$O(O(0))
;I D="" Q D
I D]"" Q $$VAL^XBDIQ1(9000010.23,O(D),.01)_"^"_$$FMTE^XLFDT(9999999-D)_"^"_(9999999-D)
S (H,D)=0 K O
F S H=$O(^AUTTHF("AC",C,H)) Q:'+H D
.Q:'$D(^AUPNVHF("AA",P,H))
.S D="" F S D=$O(^AUPNVHF("AA",P,H,D)) Q:D'=+D D
..Q:(9999999-D)>EDATE ;after time frame
..Q:(9999999-D)<BDATE ;before time frame
..S Z=$O(^AUPNVHF("AA",P,H,D,0))
..S F=$$VAL^XBDIQ1(9000010.23,Z,.01)
..I F="SMOKER IN HOME"!(F="SMOKE FREE HOME")!(F["CEREMONIAL")!(F["EXPOSURE TO") S O(D)=$O(^AUPNVHF("AA",P,H,D,""))
.Q
S D=$O(O(0))
Q D
;
PED(P,BDATE,EDATE) ;EP
NEW BDMG,X,Y,T,D,%
S Y="BDMG("
S X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I '$D(BGPG) Q ""
S (X,D)=0,%="",T="" F S X=$O(BDMG(X)) Q:X'=+X!(%]"") D
.S T=$P(^AUPNVPED(+$P(BDMG(X),U,4),0),U)
.Q:'T
.Q:'$D(^AUTTEDT(T,0))
.S T=$P(^AUTTEDT(T,0),U,2)
.I $P(T,"-")="TO" S %=T_U_$$FMTE^XLFDT($P(BDMG(X),U))_U_$P(BDMG(X),U) Q
.I $P(T,"-",2)="TO" S %=T_U_$$FMTE^XLFDT($P(BDMG(X),U))_U_$P(BDMG(X),U) Q
.I $P(T,"-",2)="SHS" S %=T_U_$$FMTE^XLFDT($P(BDMG(X),U))_U_$P(BDMG(X),U) Q
.I $P(T,"-")="305.1" S %=T_U_$$FMTE^XLFDT($P(BDMG(X),U))_U_$P(BDMG(X),U) Q
.I $P(T,"-")="305.10" S %=T_U_$$FMTE^XLFDT($P(BDMG(X),U))_U_$P(BDMG(X),U) Q
.I $P(T,"-")="305.11" S %=T_U_$$FMTE^XLFDT($P(BDMG(X),U))_U_$P(BDMG(X),U) Q
.I $P(T,"-")="305.12" S %=T_U_$$FMTE^XLFDT($P(BDMG(X),U))_U_$P(BDMG(X),U) Q
.I $P(T,"-")="305.13" S %=T_U_$$FMTE^XLFDT($P(BDMG(X),U))_U_$P(BDMG(X),U) Q
.I $P(T,"-")="649.00" S %=T_U_$$FMTE^XLFDT($P(BDMG(X),U))_U_$P(BDMG(X),U) Q
.I $P(T,"-")="649.01" S %=T_U_$$FMTE^XLFDT($P(BDMG(X),U))_U_$P(BDMG(X),U) Q
.I $P(T,"-")="649.02" S %=T_U_$$FMTE^XLFDT($P(BDMG(X),U))_U_$P(BDMG(X),U) Q
.I $P(T,"-")="649.03" S %=T_U_$$FMTE^XLFDT($P(BDMG(X),U))_U_$P(BDMG(X),U) Q
.I $P(T,"-")="649.04" S %=T_U_$$FMTE^XLFDT($P(BDMG(X),U))_U_$P(BDMG(X),U) Q
.I $P(T,"-")="V15.82" S %=T_U_$$FMTE^XLFDT($P(BDMG(X),U))_U_$P(BDMG(X),U) Q
Q %
;
DENT(P,BDATE,EDATE) ;EP
K ^TMP($J,"A")
NEW A,B,E,X,G,Z
S A="^TMP($J,""A"",",B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(B,A)
I '$D(^TMP($J,"A",1)) Q ""
S (X,G)=0 F S X=$O(^TMP($J,"A",X)) Q:X'=+X!(G) S V=$P(^TMP($J,"A",X),U,5) D
.Q:'$D(^AUPNVSIT(V,0))
.Q:'$P(^AUPNVSIT(V,0),U,9)
.Q:$P(^AUPNVSIT(V,0),U,11)
.S Z=0 F S Z=$O(^AUPNVDEN("AD",V,Z)) Q:Z'=+Z!(G) S B=$P($G(^AUPNVDEN(Z,0)),U) I B S B=$P($G(^AUTTADA(B,0)),U) I B=1320 S G=1_U_$P($P(^AUPNVSIT(V,0),U),".")
.Q
K ^TMP($J,"A")
I G=0 Q ""
Q "ADA 1320"_U_$$FMTE^XLFDT($P(G,U,2))_U_$P(G,U,2)
;
CPTSM(P,BDATE,EDATE) ;EP - did pat have smoking cpt?
NEW X
S X=$$LASTCPTT^BDMAPIU(P,BDATE,EDATE,$O(^ATXAX("B","BGP SMOKING CPTS",0)),"E")
I X]"" Q $P(X,U,2)_U_$$FMTE^XLFDT($P(X,U,1))_U_$P(X,U,1)
Q ""
BDMD91T ; IHS/CMI/LAB - 2009 DIABETES AUDIT ; [ 02/23/2009 12:39 PM ]
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
+2 ;
+3 ;cmi/anch/maw 9/12/2007 code set versioning in TOBACCO1,ASAPOV
+4 ;
TOBACCO(P,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW BDMTOB,BDMSDX,BDMXPND,BDM1320,BDMSCPT,BDMALL,D,%,F
+3 ;get last recorded HF
SET BDMTOB=$$TOBACCOS(P,BDATE,EDATE)
+4 IF BDMTOB]""
SET BDMALL(9999999-$PIECE(BDMTOB,U,3))=BDMTOB
+5 SET BDMSDX=$$DX(P,BDATE,EDATE)
+6 IF BDMSDX]""
SET D=$PIECE(BDMSDX,U,3)
SET D=9999999-D
IF '$DATA(BDMALL(D))
SET BDMALL(D)=BDMSDX
+7 SET BDMXPND=$$PED(P,BDATE,EDATE)
+8 IF BDMXPND]""
SET D=$PIECE(BDMXPND,U,3)
SET D=9999999-D
IF '$DATA(BDMALL(D))
SET BDMALL(D)=BDMXPND
+9 SET BDM1320=$$DENT(P,BDATE,EDATE)
+10 IF BDM1320]""
SET D=$PIECE(BDM1320,U,3)
SET D=9999999-D
IF '$DATA(BDMALL(D))
SET BDMALL(D)=BDM1320
+11 SET BDMSCPT=$$CPTSM(P,BDATE,EDATE)
+12 IF BDMSCPT]""
SET D=$PIECE(BDMSCPT,U,3)
SET D=9999999-D
IF '$DATA(BDMALL(D))
SET BDMALL(D)=BDMSCPT
+13 KILL ^TMP($JOB,"A")
+14 IF '$DATA(BDMALL)
QUIT "3 Not Documented "
+15 SET D=0
SET D=$ORDER(BDMALL(D))
+16 SET F=$PIECE(BDMALL(D),U)
+17 IF F["305.13"!(F["V15.82")!(F="1036F")
QUIT "2 Not a Current User "_$PIECE(BDMALL(D),U,1)_" "_$PIECE(BDMALL(D),U,2)
+18 IF F="SMOKER IN HOME"!(F="SMOKE FREE HOME")!(F["CEREMONIAL")!(F["NON-TOBACCO")!(F["PREVIOUS")!(F["EXPOSURE TO")
QUIT "2 Not a Current User "_$PIECE(BDMALL(D),U,1)_" "_$PIECE(BDMALL(D),U,2)
+19 QUIT "1 Current User "_$PIECE(BDMALL(D),U,1)_" "_$PIECE(BDMALL(D),U,2)
+20 ;
DX(P,BDATE,EDATE) ;EP
+1 NEW BDMG,T,X,G,Y
+2 SET BDMG=$$LASTDXT^BDMAPIU(P,BDATE,EDATE,"BGP GPRA SMOKING DXS","E")
+3 IF BDMG]""
QUIT $PIECE($$ICDDX^ICDCODE($PIECE(BDMG,U,4),$PIECE(BDMG,U,1)),U,2)_U_$PIECE(BDMG,U,3)
+4 SET T=$ORDER(^ATXAX("B","BGP GPRA SMOKING DXS",0))
+5 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+6 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+7 IF $PIECE(^AUPNPROB(X,0),U,3)>EDATE
QUIT
+8 IF $PIECE(^AUPNPROB(X,0),U,3)<BDATE
QUIT
+9 SET Y=$PIECE(^AUPNPROB(X,0),U)
+10 IF '$$ICD^ATXCHK(Y,T,9)
QUIT
+11 SET G=$PIECE($$ICDDX^ICDCODE(Y),U,2)_" PROBLEM LIST "_U_$$FMTE^XLFDT($PIECE(^AUPNPROB(X,0),U,3))_U_$PIECE(^AUPNPROB(X,0),U,3)
+12 QUIT
End DoDot:1
+13 QUIT G
TOBACCOS(P,BDATE,EDATE) ;EP
+1 KILL BDMTOB,BDM
+2 KILL BDMTOB
SET BDMTOB=$$LASTHF(P,"TOBACCO",BDATE,EDATE)
KILL O,D,H
+3 QUIT BDMTOB
+4 ;
LASTHF(P,C,BDATE,EDATE) ;EP - get last factor in category C for patient P
+1 ;ien of category passed
SET C=$ORDER(^AUTTHF("B",C,0))
+2 IF '$GET(C)
QUIT ""
+3 SET (H,D)=0
KILL O
+4 FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUPNVHF("AA",P,H))
QUIT
+6 SET D=""
FOR
SET D=$ORDER(^AUPNVHF("AA",P,H,D))
IF D'=+D
QUIT
Begin DoDot:2
+7 ;after time frame
IF (9999999-D)>EDATE
QUIT
+8 ;before time frame
IF (9999999-D)<BDATE
QUIT
+9 SET Z=$ORDER(^AUPNVHF("AA",P,H,D,0))
+10 SET F=$$VAL^XBDIQ1(9000010.23,Z,.01)
+11 IF F="SMOKER IN HOME"!(F="SMOKE FREE HOME")!(F["CEREMONIAL")!(F["EXPOSURE TO")
QUIT
+12 SET O(D)=$ORDER(^AUPNVHF("AA",P,H,D,""))
End DoDot:2
+13 QUIT
End DoDot:1
+14 SET D=$ORDER(O(0))
+15 ;I D="" Q D
+16 IF D]""
QUIT $$VAL^XBDIQ1(9000010.23,O(D),.01)_"^"_$$FMTE^XLFDT(9999999-D)_"^"_(9999999-D)
+17 SET (H,D)=0
KILL O
+18 FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+19 IF '$DATA(^AUPNVHF("AA",P,H))
QUIT
+20 SET D=""
FOR
SET D=$ORDER(^AUPNVHF("AA",P,H,D))
IF D'=+D
QUIT
Begin DoDot:2
+21 ;after time frame
IF (9999999-D)>EDATE
QUIT
+22 ;before time frame
IF (9999999-D)<BDATE
QUIT
+23 SET Z=$ORDER(^AUPNVHF("AA",P,H,D,0))
+24 SET F=$$VAL^XBDIQ1(9000010.23,Z,.01)
+25 IF F="SMOKER IN HOME"!(F="SMOKE FREE HOME")!(F["CEREMONIAL")!(F["EXPOSURE TO")
SET O(D)=$ORDER(^AUPNVHF("AA",P,H,D,""))
End DoDot:2
+26 QUIT
End DoDot:1
+27 SET D=$ORDER(O(0))
+28 QUIT D
+29 ;
PED(P,BDATE,EDATE) ;EP
+1 NEW BDMG,X,Y,T,D,%
+2 SET Y="BDMG("
+3 SET X=P_"^ALL EDUC;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+4 IF '$DATA(BGPG)
QUIT ""
+5 SET (X,D)=0
SET %=""
SET T=""
FOR
SET X=$ORDER(BDMG(X))
IF X'=+X!(%]"")
QUIT
Begin DoDot:1
+6 SET T=$PIECE(^AUPNVPED(+$PIECE(BDMG(X),U,4),0),U)
+7 IF 'T
QUIT
+8 IF '$DATA(^AUTTEDT(T,0))
QUIT
+9 SET T=$PIECE(^AUTTEDT(T,0),U,2)
+10 IF $PIECE(T,"-")="TO"
SET %=T_U_$$FMTE^XLFDT($PIECE(BDMG(X),U))_U_$PIECE(BDMG(X),U)
QUIT
+11 IF $PIECE(T,"-",2)="TO"
SET %=T_U_$$FMTE^XLFDT($PIECE(BDMG(X),U))_U_$PIECE(BDMG(X),U)
QUIT
+12 IF $PIECE(T,"-",2)="SHS"
SET %=T_U_$$FMTE^XLFDT($PIECE(BDMG(X),U))_U_$PIECE(BDMG(X),U)
QUIT
+13 IF $PIECE(T,"-")="305.1"
SET %=T_U_$$FMTE^XLFDT($PIECE(BDMG(X),U))_U_$PIECE(BDMG(X),U)
QUIT
+14 IF $PIECE(T,"-")="305.10"
SET %=T_U_$$FMTE^XLFDT($PIECE(BDMG(X),U))_U_$PIECE(BDMG(X),U)
QUIT
+15 IF $PIECE(T,"-")="305.11"
SET %=T_U_$$FMTE^XLFDT($PIECE(BDMG(X),U))_U_$PIECE(BDMG(X),U)
QUIT
+16 IF $PIECE(T,"-")="305.12"
SET %=T_U_$$FMTE^XLFDT($PIECE(BDMG(X),U))_U_$PIECE(BDMG(X),U)
QUIT
+17 IF $PIECE(T,"-")="305.13"
SET %=T_U_$$FMTE^XLFDT($PIECE(BDMG(X),U))_U_$PIECE(BDMG(X),U)
QUIT
+18 IF $PIECE(T,"-")="649.00"
SET %=T_U_$$FMTE^XLFDT($PIECE(BDMG(X),U))_U_$PIECE(BDMG(X),U)
QUIT
+19 IF $PIECE(T,"-")="649.01"
SET %=T_U_$$FMTE^XLFDT($PIECE(BDMG(X),U))_U_$PIECE(BDMG(X),U)
QUIT
+20 IF $PIECE(T,"-")="649.02"
SET %=T_U_$$FMTE^XLFDT($PIECE(BDMG(X),U))_U_$PIECE(BDMG(X),U)
QUIT
+21 IF $PIECE(T,"-")="649.03"
SET %=T_U_$$FMTE^XLFDT($PIECE(BDMG(X),U))_U_$PIECE(BDMG(X),U)
QUIT
+22 IF $PIECE(T,"-")="649.04"
SET %=T_U_$$FMTE^XLFDT($PIECE(BDMG(X),U))_U_$PIECE(BDMG(X),U)
QUIT
+23 IF $PIECE(T,"-")="V15.82"
SET %=T_U_$$FMTE^XLFDT($PIECE(BDMG(X),U))_U_$PIECE(BDMG(X),U)
QUIT
End DoDot:1
+24 QUIT %
+25 ;
DENT(P,BDATE,EDATE) ;EP
+1 KILL ^TMP($JOB,"A")
+2 NEW A,B,E,X,G,Z
+3 SET A="^TMP($J,""A"","
SET B=P_"^ALL VISITS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(B,A)
+4 IF '$DATA(^TMP($JOB,"A",1))
QUIT ""
+5 SET (X,G)=0
FOR
SET X=$ORDER(^TMP($JOB,"A",X))
IF X'=+X!(G)
QUIT
SET V=$PIECE(^TMP($JOB,"A",X),U,5)
Begin DoDot:1
+6 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+7 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+8 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+9 SET Z=0
FOR
SET Z=$ORDER(^AUPNVDEN("AD",V,Z))
IF Z'=+Z!(G)
QUIT
SET B=$PIECE($GET(^AUPNVDEN(Z,0)),U)
IF B
SET B=$PIECE($GET(^AUTTADA(B,0)),U)
IF B=1320
SET G=1_U_$PIECE($PIECE(^AUPNVSIT(V,0),U),".")
+10 QUIT
End DoDot:1
+11 KILL ^TMP($JOB,"A")
+12 IF G=0
QUIT ""
+13 QUIT "ADA 1320"_U_$$FMTE^XLFDT($PIECE(G,U,2))_U_$PIECE(G,U,2)
+14 ;
CPTSM(P,BDATE,EDATE) ;EP - did pat have smoking cpt?
+1 NEW X
+2 SET X=$$LASTCPTT^BDMAPIU(P,BDATE,EDATE,$ORDER(^ATXAX("B","BGP SMOKING CPTS",0)),"E")
+3 IF X]""
QUIT $PIECE(X,U,2)_U_$$FMTE^XLFDT($PIECE(X,U,1))_U_$PIECE(X,U,1)
+4 QUIT ""
