- 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 ""
