BDMDE1T ; IHS/CMI/LAB - 2017 DIABETES AUDIT ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**10**;JUN 14, 2007;Build 12
;
;
TOBACCO(P,BDATE,EDATE) ;EP
I '$G(P) Q ""
NEW BDMTOB,BDMSDX,BDMXPND,BDM1320,BDMSCPT,BDMALL,D,%,F,BDMTOBS,BDMSBD,BDMTOBC,G
S BDMSBD=BDATE
D TOBACCOS ;get last hf in BDMTOBS, BDMTOBC
;now get date of latest health factor and check for any of these next things after the HF
S BDMSBD=$P(BDMTOBS,U,3)
S BDMSDX=$$DX(P,$S(BDMSBD:BDMSBD,1:BDATE),EDATE) ;get last dx in format code^date and compare to bdmdob
I BDMSDX]"",$P(BDMSDX,U,3)>BDMSBD S BDMTOBS=BDMSDX
S BDMSBD=$P(BDMTOBS,U,3)
S BDM1320=$$DENT(P,$S(BDMSBD:BDMSBD,1:BDATE),EDATE)
I BDM1320]"",$P(BDM1320,U,3)>BDMSBD S BDMTOBS=BDM1320
S BDMSBD=$P(BDMTOBS,U,3)
S BDMSCPT=$$CPTSM(P,$S(BDMSBD:BDMSBD,1:BDATE),EDATE)
I BDMSCPT]"",$P(BDMSCPT,U,3)>BDMSBD S BDMTOBS=BDMSCPT
Q BDMTOBS
;
DX(P,BDATE,EDATE) ;EP
NEW BDMG,T,X,G,Y,F,I,Z
S BDMG=$$LASTDXT^BDMAPIU(P,BDATE,EDATE,"BGP TOBACCO DXS","E")
I BDMG]"" D Q G
.S G=""
.S I=$P(BDMG,U,6)
.S F=$P(BDMG,U,5)
.S Z=$$VALI^XBDIQ1(F,I,.01)
.; check for non smoker dxs here as well
.I '$$ICD^BDMUTL(Z,"BGP TOBACCO USER DXS",9) S G="2^2 Not a Current User "_$P(BDMG,U,2)_" "_$P(BDMG,U,3)_" "_$$DATE^BDMS9B1($P(BDMG,U,1))_U_$P(BDMG,U,1) Q
.S G="1^1 Current User "_$P(BDMG,U,2)_" "_$P(BDMG,U,3)_" "_$$DATE^BDMS9B1($P(BDMG,U,1))_U_$P(BDMG,U,1) Q
S T=$O(^ATXAX("B","BGP TOBACCO 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^BDMUTL(Y,$P(^ATXAX(T,0),U),9) ;cmi/maw 05/15/2014 p8
.S Z=$P(^ICD9(Y,0),U,1)
.;see what the non smoker dxs are here in the BGP SMOKING DXS taxonomy and if many create a new taxonomy to point to
.I '$$ICD^BDMUTL(Z,"BGP TOBACCO USER DXS",9) S G="2^2 Not a Current User "_$P($$ICDDX^BDMUTL(Y),U,2)_" PROBLEM LIST "_" "_$$DATE^BDMS9B1($P(^AUPNPROB(X,0),U,3))_U_$P(^AUPNPROB(X,0),U,3)
.S G="1^1 Current User "_$P($$ICDDX^BDMUTL(Y),U,2)_" PROBLEM LIST "_" "_$$DATE^BDMS9B1($P(^AUPNPROB(X,0),U,3))_U_$P(^AUPNPROB(X,0),U,3)
.Q
Q G
TOBACCOS ;EP
K BDM
S BDMTOBS="",BDMTOBC=""
S BDMTOBS=$$LASTHF(P,"TOBACCO (SMOKING)",BDATE,EDATE) K O,D,H
S BDMTOBC=$$LASTHF(P,"TOBACCO (SMOKELESS - CHEWING/DIP)",BDATE,EDATE) K O,D,H
I '$O(^AUTTHF("B","TOBACCO (SMOKING)",0)) S BDMTOBS=$$LASTHF(P,"TOBACCO",BDATE,EDATE) K O,D,H
;if have both then take the one that indicates tobacco use
I $P(BDMTOBS,U)=1 Q
I $P(BDMTOBC,U)=1 S BDMTOBS=BDMTOBC Q
I BDMTOBS=2 Q
I BDMTOBC=2 S BDMTOBS=BDMTOBC Q
Q
;
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 ""
NEW H,D,O,F,Z
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]"" D Q Z
.S Z=$$TUHF($$VAL^XBDIQ1(9000010.23,O(D),.01))
.S Z=Z_U_$S(Z=1:"1 Current User ",1:"2 Not a Current User ")_$$VAL^XBDIQ1(9000010.23,O(D),.01)_" "_$$DATE^BDMS9B1(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))
I D Q 2_"^2 Not a Current User "_$$VAL^XBDIQ1(9000010.23,O(D),.01)_" "_$$DATE^BDMS9B1(9999999-D)_"^"_(9999999-D)
Q "3^3 Not Documented"
;
TUHF(V) ;
I V="" Q 3
I V["CURRENT" Q 1
I V["CESSATION" Q 1
I V["HEAVY TOBACCO" Q 1
I V["LIGHT TOBACCO" Q 1
I V="SMOKELESS TOBACCO, STATUS UNKNOWN" Q 3
I V["STATUS UNKNOWN" Q 3
Q 2
;
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 "_$$DATE^BDMS9B1(BDATE)_"-"_$$DATE^BDMS9B1(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 "1^1 Current User ADA 1320 "_$$DATE^BDMS9B1($P(G,U,2))_U_$P(G,U,2)
;
CPTSM(P,BDATE,EDATE) ;EP - did pat have smoking cpt?
NEW X,G,Z
S G=""
S X=$$LASTCPTT^BDMAPIU(P,BDATE,EDATE,"BGP TOBACCO SCREEN CPTS","E")
I X="" Q ""
S Z=$$VALI^XBDIQ1(9000010.18,$P(X,U,6),.01)
I '$$ICD^BDMUTL(Z,"BGP TOBACCO USER CPTS",1) Q "2^2 Not a Current User "_$P(X,U,2)_" "_$$DATE^BDMS9B1($P(X,U,1))_U_$P(X,U,1)
Q "1^1 Current User "_$P(X,U,2)_" "_$$DATE^BDMS9B1($P(X,U,1))_U_$P(X,U,1)
ENDS(P,BD,ED) ;EP
I $G(P)="" Q ""
NEW X
S X=$$LASTHF^BDMSMU(P,"ELECTRONIC NICOTINE DELIV SYSTEM (ENDS)","B",BD,ED)
I X="" Q "2^3"
I $P(X,U,1)["CURRENT"!($P(X,U,1)["CESSATION") Q "1^1^"_X
I $P(X,U,1)["PREVIOUS"!($P(X,U,1)["NEVER") Q "1^2^"_X
Q ""
BDMDE1T ; IHS/CMI/LAB - 2017 DIABETES AUDIT ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**10**;JUN 14, 2007;Build 12
+2 ;
+3 ;
TOBACCO(P,BDATE,EDATE) ;EP
+1 IF '$GET(P)
QUIT ""
+2 NEW BDMTOB,BDMSDX,BDMXPND,BDM1320,BDMSCPT,BDMALL,D,%,F,BDMTOBS,BDMSBD,BDMTOBC,G
+3 SET BDMSBD=BDATE
+4 ;get last hf in BDMTOBS, BDMTOBC
DO TOBACCOS
+5 ;now get date of latest health factor and check for any of these next things after the HF
+6 SET BDMSBD=$PIECE(BDMTOBS,U,3)
+7 ;get last dx in format code^date and compare to bdmdob
SET BDMSDX=$$DX(P,$SELECT(BDMSBD:BDMSBD,1:BDATE),EDATE)
+8 IF BDMSDX]""
IF $PIECE(BDMSDX,U,3)>BDMSBD
SET BDMTOBS=BDMSDX
+9 SET BDMSBD=$PIECE(BDMTOBS,U,3)
+10 SET BDM1320=$$DENT(P,$SELECT(BDMSBD:BDMSBD,1:BDATE),EDATE)
+11 IF BDM1320]""
IF $PIECE(BDM1320,U,3)>BDMSBD
SET BDMTOBS=BDM1320
+12 SET BDMSBD=$PIECE(BDMTOBS,U,3)
+13 SET BDMSCPT=$$CPTSM(P,$SELECT(BDMSBD:BDMSBD,1:BDATE),EDATE)
+14 IF BDMSCPT]""
IF $PIECE(BDMSCPT,U,3)>BDMSBD
SET BDMTOBS=BDMSCPT
+15 QUIT BDMTOBS
+16 ;
DX(P,BDATE,EDATE) ;EP
+1 NEW BDMG,T,X,G,Y,F,I,Z
+2 SET BDMG=$$LASTDXT^BDMAPIU(P,BDATE,EDATE,"BGP TOBACCO DXS","E")
+3 IF BDMG]""
Begin DoDot:1
+4 SET G=""
+5 SET I=$PIECE(BDMG,U,6)
+6 SET F=$PIECE(BDMG,U,5)
+7 SET Z=$$VALI^XBDIQ1(F,I,.01)
+8 ; check for non smoker dxs here as well
+9 IF '$$ICD^BDMUTL(Z,"BGP TOBACCO USER DXS",9)
SET G="2^2 Not a Current User "_$PIECE(BDMG,U,2)_" "_$PIECE(BDMG,U,3)_" "_$$DATE^BDMS9B1($PIECE(BDMG,U,1))_U_$PIECE(BDMG,U,1)
QUIT
+10 SET G="1^1 Current User "_$PIECE(BDMG,U,2)_" "_$PIECE(BDMG,U,3)_" "_$$DATE^BDMS9B1($PIECE(BDMG,U,1))_U_$PIECE(BDMG,U,1)
QUIT
End DoDot:1
QUIT G
+11 SET T=$ORDER(^ATXAX("B","BGP TOBACCO DXS",0))
+12 SET X=0
SET G=""
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G]"")
QUIT
Begin DoDot:1
+13 IF $PIECE(^AUPNPROB(X,0),U,12)'="A"
QUIT
+14 IF $PIECE(^AUPNPROB(X,0),U,3)>EDATE
QUIT
+15 IF $PIECE(^AUPNPROB(X,0),U,3)<BDATE
QUIT
+16 SET Y=$PIECE(^AUPNPROB(X,0),U)
+17 ;cmi/maw 05/15/2014 p8
IF '$$ICD^BDMUTL(Y,$PIECE(^ATXAX(T,0),U),9)
QUIT
+18 SET Z=$PIECE(^ICD9(Y,0),U,1)
+19 ;see what the non smoker dxs are here in the BGP SMOKING DXS taxonomy and if many create a new taxonomy to point to
+20 IF '$$ICD^BDMUTL(Z,"BGP TOBACCO USER DXS",9)
SET G="2^2 Not a Current User "_$PIECE($$ICDDX^BDMUTL(Y),U,2)_" PROBLEM LIST "_" "_$$DATE^BDMS9B1($PIECE(^AUPNPROB(X,0),U,3))_U_$PIECE(^AUPNPROB(X,0),U,3)
+21 SET G="1^1 Current User "_$PIECE($$ICDDX^BDMUTL(Y),U,2)_" PROBLEM LIST "_" "_$$DATE^BDMS9B1($PIECE(^AUPNPROB(X,0),U,3))_U_$PIECE(^AUPNPROB(X,0),U,3)
+22 QUIT
End DoDot:1
+23 QUIT G
TOBACCOS ;EP
+1 KILL BDM
+2 SET BDMTOBS=""
SET BDMTOBC=""
+3 SET BDMTOBS=$$LASTHF(P,"TOBACCO (SMOKING)",BDATE,EDATE)
KILL O,D,H
+4 SET BDMTOBC=$$LASTHF(P,"TOBACCO (SMOKELESS - CHEWING/DIP)",BDATE,EDATE)
KILL O,D,H
+5 IF '$ORDER(^AUTTHF("B","TOBACCO (SMOKING)",0))
SET BDMTOBS=$$LASTHF(P,"TOBACCO",BDATE,EDATE)
KILL O,D,H
+6 ;if have both then take the one that indicates tobacco use
+7 IF $PIECE(BDMTOBS,U)=1
QUIT
+8 IF $PIECE(BDMTOBC,U)=1
SET BDMTOBS=BDMTOBC
QUIT
+9 IF BDMTOBS=2
QUIT
+10 IF BDMTOBC=2
SET BDMTOBS=BDMTOBC
QUIT
+11 QUIT
+12 ;
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 NEW H,D,O,F,Z
+4 SET (H,D)=0
KILL O
+5 FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+6 IF '$DATA(^AUPNVHF("AA",P,H))
QUIT
+7 SET D=""
FOR
SET D=$ORDER(^AUPNVHF("AA",P,H,D))
IF D'=+D
QUIT
Begin DoDot:2
+8 ;after time frame
IF (9999999-D)>EDATE
QUIT
+9 ;before time frame
IF (9999999-D)<BDATE
QUIT
+10 SET Z=$ORDER(^AUPNVHF("AA",P,H,D,0))
+11 SET F=$$VAL^XBDIQ1(9000010.23,Z,.01)
+12 IF F="SMOKER IN HOME"!(F="SMOKE FREE HOME")!(F["CEREMONIAL")!(F["EXPOSURE TO")
QUIT
+13 SET O(D)=$ORDER(^AUPNVHF("AA",P,H,D,""))
End DoDot:2
+14 QUIT
End DoDot:1
+15 SET D=$ORDER(O(0))
+16 IF D]""
Begin DoDot:1
+17 SET Z=$$TUHF($$VAL^XBDIQ1(9000010.23,O(D),.01))
+18 SET Z=Z_U_$SELECT(Z=1:"1 Current User ",1:"2 Not a Current User ")_$$VAL^XBDIQ1(9000010.23,O(D),.01)_" "_$$DATE^BDMS9B1(9999999-D)_"^"_(9999999-D)
End DoDot:1
QUIT Z
+19 SET (H,D)=0
KILL O
+20 FOR
SET H=$ORDER(^AUTTHF("AC",C,H))
IF '+H
QUIT
Begin DoDot:1
+21 IF '$DATA(^AUPNVHF("AA",P,H))
QUIT
+22 SET D=""
FOR
SET D=$ORDER(^AUPNVHF("AA",P,H,D))
IF D'=+D
QUIT
Begin DoDot:2
+23 ;after time frame
IF (9999999-D)>EDATE
QUIT
+24 ;before time frame
IF (9999999-D)<BDATE
QUIT
+25 SET Z=$ORDER(^AUPNVHF("AA",P,H,D,0))
+26 SET F=$$VAL^XBDIQ1(9000010.23,Z,.01)
+27 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
+28 QUIT
End DoDot:1
+29 SET D=$ORDER(O(0))
+30 IF D
QUIT 2_"^2 Not a Current User "_$$VAL^XBDIQ1(9000010.23,O(D),.01)_" "_$$DATE^BDMS9B1(9999999-D)_"^"_(9999999-D)
+31 QUIT "3^3 Not Documented"
+32 ;
TUHF(V) ;
+1 IF V=""
QUIT 3
+2 IF V["CURRENT"
QUIT 1
+3 IF V["CESSATION"
QUIT 1
+4 IF V["HEAVY TOBACCO"
QUIT 1
+5 IF V["LIGHT TOBACCO"
QUIT 1
+6 IF V="SMOKELESS TOBACCO, STATUS UNKNOWN"
QUIT 3
+7 IF V["STATUS UNKNOWN"
QUIT 3
+8 QUIT 2
+9 ;
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 "_$$DATE^BDMS9B1(BDATE)_"-"_$$DATE^BDMS9B1(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 "1^1 Current User ADA 1320 "_$$DATE^BDMS9B1($PIECE(G,U,2))_U_$PIECE(G,U,2)
+14 ;
CPTSM(P,BDATE,EDATE) ;EP - did pat have smoking cpt?
+1 NEW X,G,Z
+2 SET G=""
+3 SET X=$$LASTCPTT^BDMAPIU(P,BDATE,EDATE,"BGP TOBACCO SCREEN CPTS","E")
+4 IF X=""
QUIT ""
+5 SET Z=$$VALI^XBDIQ1(9000010.18,$PIECE(X,U,6),.01)
+6 IF '$$ICD^BDMUTL(Z,"BGP TOBACCO USER CPTS",1)
QUIT "2^2 Not a Current User "_$PIECE(X,U,2)_" "_$$DATE^BDMS9B1($PIECE(X,U,1))_U_$PIECE(X,U,1)
+7 QUIT "1^1 Current User "_$PIECE(X,U,2)_" "_$$DATE^BDMS9B1($PIECE(X,U,1))_U_$PIECE(X,U,1)
ENDS(P,BD,ED) ;EP
+1 IF $GET(P)=""
QUIT ""
+2 NEW X
+3 SET X=$$LASTHF^BDMSMU(P,"ELECTRONIC NICOTINE DELIV SYSTEM (ENDS)","B",BD,ED)
+4 IF X=""
QUIT "2^3"
+5 IF $PIECE(X,U,1)["CURRENT"!($PIECE(X,U,1)["CESSATION")
QUIT "1^1^"_X
+6 IF $PIECE(X,U,1)["PREVIOUS"!($PIECE(X,U,1)["NEVER")
QUIT "1^2^"_X
+7 QUIT ""
