APCLD713 ; IHS/CMI/LAB - 2007 DIABETES AUDIT ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;LORI - ADD V04,81
;
;cmi/anch/maw 9/12/2007 code set versioning in PLDMDXS
;
FLU(P,BDATE,EDATE) ;EP
NEW APCL,X,E,%,%DT,BD,B,D,C,Y,LFLU,TFLU,Z,G,T
S X=EDATE,%DT="P" D ^%DT S (BD,E)=Y
S (B,BD)=$$FMADD^XLFDT(BD,-(15*30)),BD=$$FMTE^XLFDT(BD)
;B-int fm beg
;E-int fm end
S LFLU="" K TFLU
I $$BI D LASTFLUN
I '$$BI D LASTFLUO
S LFLU=$O(TFLU(0))
I LFLU]"" S LFLU=9999999-LFLU
K APCL S %=P_"^LAST DX V04.8;DURING "_BD_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) D
.Q:LFLU>$P(APCL(1),U)
.S LFLU=$P(APCL(1),U)
K APCL S %=P_"^LAST DX V04.81;DURING "_BD_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) D
.Q:LFLU>$P(APCL(1),U)
.S LFLU=$P(APCL(1),U)
K APCL S %=P_"^LAST DX V06.6;DURING "_BD_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) D
.Q:LFLU>$P(APCL(1),U)
.S LFLU=$P(APCL(1),U)
K APCL S %=P_"^LAST PROCEDURE 99.52;DURING "_BD_"-"_EDATE,E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) D
.Q:LFLU>$P(APCL(1),U)
.S LFLU=$P(APCL(1),U)
;check CPT codes in year prior to date range
S X=EDATE,%DT="P" D ^%DT S ED=Y
S X=BD,%DT="P" D ^%DT S BD=Y
S T=$O(^ATXAX("B","DM AUDIT FLU CPTS",0))
K APCL I T S APCL(1)=$$CPT^APCLD712(P,BD,ED,T,3) D
.I APCL(1)="" K APCL Q
.Q:LFLU>$P(APCL(1),U)
.S LFLU=$P(APCL(1),U)
I LFLU]"" Q "Yes "_$$DATE(LFLU)
;
NEW G S G=$$REFUSAL^APCLD717(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:88,1:12),0)),BD,EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "No - Not Medically Indicated"
S G=$$REFUSAL^APCLD717(P,9999999.14,$O(^AUTTIMM("C",15,0)),BD,EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "No - Not Medically Indicated"
S G=$$REFUSAL^APCLD717(P,9999999.14,$O(^AUTTIMM("C",16,0)),BD,EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "No - Not Medically Indicated"
S G=$$REFUSAL^APCLD717(P,9999999.14,$O(^AUTTIMM("C",111,0)),BD,EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "No - Not Medically Indicated"
S G="" F Z=15,16,88,111 Q:G S X=0,Y=$O(^AUTTIMM("C",Z,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.Q:$P(^BICONT(R,0),U,1)'["Refusal"
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.Q:$P(^BIPC(X,0),U,4)<BD
.Q:$P(^BIPC(X,0),U,4)>ED
.S G=1
I G Q "Refused"
Q "No"
PNEU(P,EDATE) ;EP
NEW APCL,X,E,B,%DT,Y,TPN,D,LPN,G,C,Z,T
K TPN
S %DT="P",X=EDATE D ^%DT S E=Y ;set E = ending date in fm format
S B=$$DOB^AUPNPAT(P) ;b is DOB
I '$$BI D LASTPNO ;pre v7
I $$BI D LASTPNN ;get td from v imm
S LPN=$O(TPN(0))
I LPN]"" S LPN=9999999-LPN
;now check cpt codes
S T=$O(^ATXAX("B","DM AUDIT PNEUMO CPTS",0))
K C I T S C=$$CPT^APCLD712(P,B,E,T,3) D
.I C="" Q
.Q:LPN>$P(C,U)
.S LPN=$P(C,U)
I LPN]"" Q "Yes - "_$$DATE(LPN)
S G=$$REFUSAL^APCLD717(P,9999999.14,$O(^AUTTIMM("C",$S($$BI:33,1:19),0)),$$DOB^AUPNPAT(P,"E"),EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "No - Not Medically Indicated"
I '$$BI Q "No"
S G=$$REFUSAL^APCLD717(P,9999999.14,$O(^AUTTIMM("C",100,0)),$$DOB^AUPNPAT(P,"E"),EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "No - Not Medically Indicated"
S G=$$REFUSAL^APCLD717(P,9999999.14,$O(^AUTTIMM("C",109,0)),$$DOB^AUPNPAT(P,"E"),EDATE)
I G,$P(G,U,2)'="N" Q "Refused"
I G Q "No - Not Medically Indicated"
S X=EDATE,%DT="P" D ^%DT S E=Y
S G="" F Z=33,100,109 Q:G S X=0,Y=$O(^AUTTIMM("C",Z,0)) I Y F S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G) D
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.Q:$P(^BICONT(R,0),U,1)'["Refusal"
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.Q:$P(^BIPC(X,0),U,4)>ED
.S G=1
I G Q "Refused"
Q "No"
LASTFLUN ;
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.S Y=$P(^AUPNVIMM(X,0),U) Q:'Y
.Q:'$D(^AUTTIMM(Y,0))
.S Y=$P(^AUTTIMM(Y,0),U,3)
.S D=$P(^AUPNVIMM(X,0),U,3) Q:'D
.S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
.I D<B Q ;too early
.I D>E Q ;after time frame
.I Y=88 S TFLU(9999999-D)="" Q
.I Y=15 S TFLU(9999999-D)="" Q
.I Y=16 S TFLU(9999999-D)="" Q
.I Y=111 S TFLU(9999999-D)="" Q
Q
LASTFLUO ;
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.S Y=$P(^AUPNVIMM(X,0),U) Q:'Y
.S Y=$P(^AUTTIMM(Y,0),U,3)
.S D=$P(^AUPNVIMM(X,0),U,3) Q:'D
.S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
.I D<B Q ;too early
.I D>E Q ;after time frame
.I Y=12 S TFLU(9999999-D)="" Q
Q
LASTPNN ;
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.S Y=$P(^AUPNVIMM(X,0),U) Q:'Y
.Q:'$D(^AUTTIMM(Y,0))
.S Y=$P(^AUTTIMM(Y,0),U,3)
.S D=$P(^AUPNVIMM(X,0),U,3) Q:'D
.S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
.I D<B Q ;too early
.I D>E Q ;after time frame
.I Y=33 S TPN(9999999-D)="" Q
.I Y=100 S TPN(9999999-D)="" Q
.I Y=109 S TPN(9999999-D)="" Q
Q
LASTPNO ;
S X=0 F S X=$O(^AUPNVIMM("AC",P,X)) Q:X'=+X D
.S Y=$P(^AUPNVIMM(X,0),U) Q:'Y
.S Y=$P(^AUTTIMM(Y,0),U,3)
.S D=$P(^AUPNVIMM(X,0),U,3) Q:'D
.S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
.I D<B Q ;too early
.I D>E Q ;after time frame
.I Y=19 S TPN(9999999-D)="" Q
Q
BI() ;
Q $S($O(^AUTTIMM(0))>100:1,1:0)
BPS(P,BDATE,EDATE,F) ;EP ;
I $G(F)="" S F="E"
NEW X,APCL,E,APCLL,APCLLL,APCLV
S APCLLL=0,APCLV=""
K APCL
S X=P_"^LAST 50 MEAS BP;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(")
S APCLL=0 F S APCLL=$O(APCL(APCLL)) Q:APCLL'=+APCLL!(APCLLL=3) S APCLBP=$P($G(APCL(APCLL)),U,2) D
.Q:$$CLINIC^APCLV($P(APCL(APCLL),U,5),"C")=30
.S APCLLL=APCLLL+1
.I F="E" S $P(APCLV,";",APCLLL)=APCLBP_" "_$$FMTE^XLFDT($P(APCL(APCLL),U))
.I F="I" S $P(APCLV,";",APCLLL)=$P(APCLBP," ")
Q APCLV
HTNDX(P,EDATE) ;EP - is HTN on problem list
I '$G(P) Q ""
I '$D(^DPT(P)) Q ""
NEW %,APCL,E,X
K APCL
S %=P_"^PROBLEM [DM AUDIT PROBLEM HTN DIAGNOSES" S E=$$START1^APCLDF(%,"APCL(")
I $D(APCL(1)) Q "Yes"
K APCL
S X=P_"^LAST 3 DX [SURVEILLANCE HYPERTENSION;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE S E=$$START1^APCLDF(X,"APCL(") I $D(APCL(3)) Q "Yes"
Q "No"
LASTHT(P,EDATE,F) ;PEP - return last ht and date
I 'P Q ""
I $G(F)="" S F="E"
I '$D(^AUPNVSIT("AC",P)) Q ""
NEW %,APCLARRY,H,E,W,BDATE
S %DT="P",X=EDATE D ^%DT S EDATE=Y
S BDATE=$P(^DPT(P,0),U,3)
S %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE NEW X S E=$$START1^APCLDF(%,"APCLARRY(") S H=$P($G(APCLARRY(1)),U,2)
I H="" Q H
I F="I" Q H
S H=$J(H,5,2)
Q H_" inches "_$$DATE($P(APCLARRY(1),U))
LASTWT(P,EDATE,F) ;PEP - return last wt
I 'P Q ""
I $G(F)="" S F="E"
NEW %,APCLARRY,E,APCLW,X,APCLN,APCL,APCLD,APCLZ,APCLX,W,H
S %DT="P",X=EDATE D ^%DT S EDATE=Y
S BDATE=$$FMADD^XLFDT(EDATE,-(2*365))
NEW APCLV221 S APCLV221=$O(^ICD9("BA","V22.1 ",""))
K APCL S APCLW="" S APCLX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(APCLX,"APCL(")
S APCLN=0 F S APCLN=$O(APCL(APCLN)) Q:APCLN'=+APCLN!(APCLW]"") D
. S APCLZ=$P(APCL(APCLN),U,5)
. I '$D(^AUPNVPOV("AD",APCLZ)) S APCLW=$P(APCL(APCLN),U,2)_" lbs "_$$DATE($P(APCL(APCLN),U)) Q
. S APCLD=0 F S APCLD=$O(^AUPNVPOV("AD",APCLZ,APCLD)) Q:'APCLD!(APCLW]"") D
.. I $P(^AUPNVPOV(APCLD,0),U)'=APCLV221 S APCLW=$P(APCL(APCLN),U,2)_" lbs "_$$DATE($P(APCL(APCLN),U))
..Q
Q $S(F="E":APCLW,1:+APCLW)
CMSFDX(P,R,T) ;EP - return date/dx of dm in register
I '$G(P) Q ""
I '$G(R) Q ""
I $G(T)="" Q ""
NEW D1,Y,X,D,G S X=0,(D,Y)="" F S X=$O(^ACM(44,"C",P,X)) Q:X'=+X I $P(^ACM(44,X,0),U,4)=R D
.S D=$P($G(^ACM(44,X,"SV")),U,2),D1=D,D=$$FMTE^XLFDT(D)
.S Y=$$VAL^XBDIQ1(9002244,X,.01)
.I D1="" S D1=0
.S G(9999999-D1)=D_"^"_D1_"^"_Y
I '$O(G(0)) Q ""
S Y=0,G=$O(G(Y))
S D=$P(G(G),U),D1=$P(G(G),U,2),Y=$P(G(G),U,3)
Q $S(T="D":$G(D),T="DX":$G(Y),T="ID":$G(D1),1:"")
;
PLDMDOO(P,F) ;EP
I '$G(P) Q ""
I $G(F)="" S F="E"
NEW T S T=$O(^ATXAX("B","SURVEILLANCE DIABETES",0))
I 'T Q ""
NEW D,X,I S D="",X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.S I=$P(^AUPNPROB(X,0),U)
.I $$ICD^ATXCHK(I,T,9) D
..I $P(^AUPNPROB(X,0),U,13)]"" S D($P(^AUPNPROB(X,0),U,13))=""
..Q
.Q
S D=$O(D(0)) Q $S(F="E":$$FMTE^XLFDT(D),1:$O(D(0)))
PLDMDXS(P) ;EP - get all DM dxs from problem list
I '$G(P) Q ""
NEW T S T=$O(^ATXAX("B","SURVEILLANCE DIABETES",0))
I 'T Q "<diabetes taxonomy missing>"
NEW D,X,I S D="",X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.S I=$P(^AUPNPROB(X,0),U)
.;I $$ICD^ATXCHK(I,T,9) S:D]"" D=D_";" S D=D_$P(^ICD9(I,0),U) ;cmi/anch/maw 9/12/2007 orig line
.I $$ICD^ATXCHK(I,T,9) S:D]"" D=D_";" S D=D_$P($$ICDDX^ICDCODE(I),U,2) ;cmi/anch/maw 9/12/2007 csv
.Q
Q D
;
FRSTDMDX(P,F) ;EP return date of first dm dx
I '$G(P) Q ""
I $G(F)="" S F="E"
NEW X,E,APCL,Y
S Y="APCL("
S X=P_"^FIRST DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,Y) S Y=$P($G(APCL(1)),U)
Q $S(F="E":$$FMTE^XLFDT(Y),1:Y)
LASTDMDX(P,D) ;EP - last pcc dm dx
I '$G(P) Q ""
NEW X,E,APCL,Y
S Y="APCL("
S X=P_"^LAST DX [DM AUDIT TYPE II DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D S E=$$START1^APCLDF(X,Y)
I $D(APCL(1)) Q "Type 2"
K APCL S X=P_"^LAST DX [DM AUDIT TYPE I DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D S E=$$START1^APCLDF(X,Y)
I $D(APCL(1)) Q "Type 1"
Q ""
INCHES ;
NEW F,FI,Z
S (X,Z)=$$LASTHT^APCLD713(APCLPD,APCLRED,"I")
Q:X=""
S X=X/12 ;get feet
S F=$P(X,".")
S FI=F*12 ;GET INCHES
S X=Z-FI
S X=$J(X,5,2)
;W !,Z," ",F," ",FI," ",X H 1
;I X S X=X/12,X=$P(X,"."),X=X*12,X=Z=X,X=$J(X,5,2)
Q
DATE(D) ;EP
I D="" Q D
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
APCLD713 ; IHS/CMI/LAB - 2007 DIABETES AUDIT ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;LORI - ADD V04,81
+3 ;
+4 ;cmi/anch/maw 9/12/2007 code set versioning in PLDMDXS
+5 ;
FLU(P,BDATE,EDATE) ;EP
+1 NEW APCL,X,E,%,%DT,BD,B,D,C,Y,LFLU,TFLU,Z,G,T
+2 SET X=EDATE
SET %DT="P"
DO ^%DT
SET (BD,E)=Y
+3 SET (B,BD)=$$FMADD^XLFDT(BD,-(15*30))
SET BD=$$FMTE^XLFDT(BD)
+4 ;B-int fm beg
+5 ;E-int fm end
+6 SET LFLU=""
KILL TFLU
+7 IF $$BI
DO LASTFLUN
+8 IF '$$BI
DO LASTFLUO
+9 SET LFLU=$ORDER(TFLU(0))
+10 IF LFLU]""
SET LFLU=9999999-LFLU
+11 KILL APCL
SET %=P_"^LAST DX V04.8;DURING "_BD_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+12 IF $DATA(APCL(1))
Begin DoDot:1
+13 IF LFLU>$PIECE(APCL(1),U)
QUIT
+14 SET LFLU=$PIECE(APCL(1),U)
End DoDot:1
+15 KILL APCL
SET %=P_"^LAST DX V04.81;DURING "_BD_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+16 IF $DATA(APCL(1))
Begin DoDot:1
+17 IF LFLU>$PIECE(APCL(1),U)
QUIT
+18 SET LFLU=$PIECE(APCL(1),U)
End DoDot:1
+19 KILL APCL
SET %=P_"^LAST DX V06.6;DURING "_BD_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+20 IF $DATA(APCL(1))
Begin DoDot:1
+21 IF LFLU>$PIECE(APCL(1),U)
QUIT
+22 SET LFLU=$PIECE(APCL(1),U)
End DoDot:1
+23 KILL APCL
SET %=P_"^LAST PROCEDURE 99.52;DURING "_BD_"-"_EDATE
SET E=$$START1^APCLDF(%,"APCL(")
+24 IF $DATA(APCL(1))
Begin DoDot:1
+25 IF LFLU>$PIECE(APCL(1),U)
QUIT
+26 SET LFLU=$PIECE(APCL(1),U)
End DoDot:1
+27 ;check CPT codes in year prior to date range
+28 SET X=EDATE
SET %DT="P"
DO ^%DT
SET ED=Y
+29 SET X=BD
SET %DT="P"
DO ^%DT
SET BD=Y
+30 SET T=$ORDER(^ATXAX("B","DM AUDIT FLU CPTS",0))
+31 KILL APCL
IF T
SET APCL(1)=$$CPT^APCLD712(P,BD,ED,T,3)
Begin DoDot:1
+32 IF APCL(1)=""
KILL APCL
QUIT
+33 IF LFLU>$PIECE(APCL(1),U)
QUIT
+34 SET LFLU=$PIECE(APCL(1),U)
End DoDot:1
+35 IF LFLU]""
QUIT "Yes "_$$DATE(LFLU)
+36 ;
+37 NEW G
SET G=$$REFUSAL^APCLD717(P,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:88,1:12),0)),BD,EDATE)
+38 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+39 IF G
QUIT "No - Not Medically Indicated"
+40 SET G=$$REFUSAL^APCLD717(P,9999999.14,$ORDER(^AUTTIMM("C",15,0)),BD,EDATE)
+41 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+42 IF G
QUIT "No - Not Medically Indicated"
+43 SET G=$$REFUSAL^APCLD717(P,9999999.14,$ORDER(^AUTTIMM("C",16,0)),BD,EDATE)
+44 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+45 IF G
QUIT "No - Not Medically Indicated"
+46 SET G=$$REFUSAL^APCLD717(P,9999999.14,$ORDER(^AUTTIMM("C",111,0)),BD,EDATE)
+47 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+48 IF G
QUIT "No - Not Medically Indicated"
+49 SET G=""
FOR Z=15,16,88,111
IF G
QUIT
SET X=0
SET Y=$ORDER(^AUTTIMM("C",Z,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+50 SET R=$PIECE(^BIPC(X,0),U,3)
+51 IF R=""
QUIT
+52 IF '$DATA(^BICONT(R,0))
QUIT
+53 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+54 SET D=$PIECE(^BIPC(X,0),U,4)
+55 IF D=""
QUIT
+56 IF $PIECE(^BIPC(X,0),U,4)<BD
QUIT
+57 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+58 SET G=1
End DoDot:1
+59 IF G
QUIT "Refused"
+60 QUIT "No"
PNEU(P,EDATE) ;EP
+1 NEW APCL,X,E,B,%DT,Y,TPN,D,LPN,G,C,Z,T
+2 KILL TPN
+3 ;set E = ending date in fm format
SET %DT="P"
SET X=EDATE
DO ^%DT
SET E=Y
+4 ;b is DOB
SET B=$$DOB^AUPNPAT(P)
+5 ;pre v7
IF '$$BI
DO LASTPNO
+6 ;get td from v imm
IF $$BI
DO LASTPNN
+7 SET LPN=$ORDER(TPN(0))
+8 IF LPN]""
SET LPN=9999999-LPN
+9 ;now check cpt codes
+10 SET T=$ORDER(^ATXAX("B","DM AUDIT PNEUMO CPTS",0))
+11 KILL C
IF T
SET C=$$CPT^APCLD712(P,B,E,T,3)
Begin DoDot:1
+12 IF C=""
QUIT
+13 IF LPN>$PIECE(C,U)
QUIT
+14 SET LPN=$PIECE(C,U)
End DoDot:1
+15 IF LPN]""
QUIT "Yes - "_$$DATE(LPN)
+16 SET G=$$REFUSAL^APCLD717(P,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:33,1:19),0)),$$DOB^AUPNPAT(P,"E"),EDATE)
+17 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+18 IF G
QUIT "No - Not Medically Indicated"
+19 IF '$$BI
QUIT "No"
+20 SET G=$$REFUSAL^APCLD717(P,9999999.14,$ORDER(^AUTTIMM("C",100,0)),$$DOB^AUPNPAT(P,"E"),EDATE)
+21 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+22 IF G
QUIT "No - Not Medically Indicated"
+23 SET G=$$REFUSAL^APCLD717(P,9999999.14,$ORDER(^AUTTIMM("C",109,0)),$$DOB^AUPNPAT(P,"E"),EDATE)
+24 IF G
IF $PIECE(G,U,2)'="N"
QUIT "Refused"
+25 IF G
QUIT "No - Not Medically Indicated"
+26 SET X=EDATE
SET %DT="P"
DO ^%DT
SET E=Y
+27 SET G=""
FOR Z=33,100,109
IF G
QUIT
SET X=0
SET Y=$ORDER(^AUTTIMM("C",Z,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+28 SET R=$PIECE(^BIPC(X,0),U,3)
+29 IF R=""
QUIT
+30 IF '$DATA(^BICONT(R,0))
QUIT
+31 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+32 SET D=$PIECE(^BIPC(X,0),U,4)
+33 IF D=""
QUIT
+34 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+35 SET G=1
End DoDot:1
+36 IF G
QUIT "Refused"
+37 QUIT "No"
LASTFLUN ;
+1 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+2 SET Y=$PIECE(^AUPNVIMM(X,0),U)
IF 'Y
QUIT
+3 IF '$DATA(^AUTTIMM(Y,0))
QUIT
+4 SET Y=$PIECE(^AUTTIMM(Y,0),U,3)
+5 SET D=$PIECE(^AUPNVIMM(X,0),U,3)
IF 'D
QUIT
+6 SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+7 ;too early
IF D<B
QUIT
+8 ;after time frame
IF D>E
QUIT
+9 IF Y=88
SET TFLU(9999999-D)=""
QUIT
+10 IF Y=15
SET TFLU(9999999-D)=""
QUIT
+11 IF Y=16
SET TFLU(9999999-D)=""
QUIT
+12 IF Y=111
SET TFLU(9999999-D)=""
QUIT
End DoDot:1
+13 QUIT
LASTFLUO ;
+1 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+2 SET Y=$PIECE(^AUPNVIMM(X,0),U)
IF 'Y
QUIT
+3 SET Y=$PIECE(^AUTTIMM(Y,0),U,3)
+4 SET D=$PIECE(^AUPNVIMM(X,0),U,3)
IF 'D
QUIT
+5 SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+6 ;too early
IF D<B
QUIT
+7 ;after time frame
IF D>E
QUIT
+8 IF Y=12
SET TFLU(9999999-D)=""
QUIT
End DoDot:1
+9 QUIT
LASTPNN ;
+1 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+2 SET Y=$PIECE(^AUPNVIMM(X,0),U)
IF 'Y
QUIT
+3 IF '$DATA(^AUTTIMM(Y,0))
QUIT
+4 SET Y=$PIECE(^AUTTIMM(Y,0),U,3)
+5 SET D=$PIECE(^AUPNVIMM(X,0),U,3)
IF 'D
QUIT
+6 SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+7 ;too early
IF D<B
QUIT
+8 ;after time frame
IF D>E
QUIT
+9 IF Y=33
SET TPN(9999999-D)=""
QUIT
+10 IF Y=100
SET TPN(9999999-D)=""
QUIT
+11 IF Y=109
SET TPN(9999999-D)=""
QUIT
End DoDot:1
+12 QUIT
LASTPNO ;
+1 SET X=0
FOR
SET X=$ORDER(^AUPNVIMM("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+2 SET Y=$PIECE(^AUPNVIMM(X,0),U)
IF 'Y
QUIT
+3 SET Y=$PIECE(^AUTTIMM(Y,0),U,3)
+4 SET D=$PIECE(^AUPNVIMM(X,0),U,3)
IF 'D
QUIT
+5 SET D=$PIECE($PIECE($GET(^AUPNVSIT(D,0)),U),".")
+6 ;too early
IF D<B
QUIT
+7 ;after time frame
IF D>E
QUIT
+8 IF Y=19
SET TPN(9999999-D)=""
QUIT
End DoDot:1
+9 QUIT
BI() ;
+1 QUIT $SELECT($ORDER(^AUTTIMM(0))>100:1,1:0)
BPS(P,BDATE,EDATE,F) ;EP ;
+1 IF $GET(F)=""
SET F="E"
+2 NEW X,APCL,E,APCLL,APCLLL,APCLV
+3 SET APCLLL=0
SET APCLV=""
+4 KILL APCL
+5 SET X=P_"^LAST 50 MEAS BP;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
+6 SET APCLL=0
FOR
SET APCLL=$ORDER(APCL(APCLL))
IF APCLL'=+APCLL!(APCLLL=3)
QUIT
SET APCLBP=$PIECE($GET(APCL(APCLL)),U,2)
Begin DoDot:1
+7 IF $$CLINIC^APCLV($PIECE(APCL(APCLL),U,5),"C")=30
QUIT
+8 SET APCLLL=APCLLL+1
+9 IF F="E"
SET $PIECE(APCLV,";",APCLLL)=APCLBP_" "_$$FMTE^XLFDT($PIECE(APCL(APCLL),U))
+10 IF F="I"
SET $PIECE(APCLV,";",APCLLL)=$PIECE(APCLBP," ")
End DoDot:1
+11 QUIT APCLV
HTNDX(P,EDATE) ;EP - is HTN on problem list
+1 IF '$GET(P)
QUIT ""
+2 IF '$DATA(^DPT(P))
QUIT ""
+3 NEW %,APCL,E,X
+4 KILL APCL
+5 SET %=P_"^PROBLEM [DM AUDIT PROBLEM HTN DIAGNOSES"
SET E=$$START1^APCLDF(%,"APCL(")
+6 IF $DATA(APCL(1))
QUIT "Yes"
+7 KILL APCL
+8 SET X=P_"^LAST 3 DX [SURVEILLANCE HYPERTENSION;DURING "_$$FMTE^XLFDT($$DOB^AUPNPAT(P))_"-"_EDATE
SET E=$$START1^APCLDF(X,"APCL(")
IF $DATA(APCL(3))
QUIT "Yes"
+9 QUIT "No"
LASTHT(P,EDATE,F) ;PEP - return last ht and date
+1 IF 'P
QUIT ""
+2 IF $GET(F)=""
SET F="E"
+3 IF '$DATA(^AUPNVSIT("AC",P))
QUIT ""
+4 NEW %,APCLARRY,H,E,W,BDATE
+5 SET %DT="P"
SET X=EDATE
DO ^%DT
SET EDATE=Y
+6 SET BDATE=$PIECE(^DPT(P,0),U,3)
+7 SET %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE
NEW X
SET E=$$START1^APCLDF(%,"APCLARRY(")
SET H=$PIECE($GET(APCLARRY(1)),U,2)
+8 IF H=""
QUIT H
+9 IF F="I"
QUIT H
+10 SET H=$JUSTIFY(H,5,2)
+11 QUIT H_" inches "_$$DATE($PIECE(APCLARRY(1),U))
LASTWT(P,EDATE,F) ;PEP - return last wt
+1 IF 'P
QUIT ""
+2 IF $GET(F)=""
SET F="E"
+3 NEW %,APCLARRY,E,APCLW,X,APCLN,APCL,APCLD,APCLZ,APCLX,W,H
+4 SET %DT="P"
SET X=EDATE
DO ^%DT
SET EDATE=Y
+5 SET BDATE=$$FMADD^XLFDT(EDATE,-(2*365))
+6 NEW APCLV221
SET APCLV221=$ORDER(^ICD9("BA","V22.1 ",""))
+7 KILL APCL
SET APCLW=""
SET APCLX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE
SET E=$$START1^APCLDF(APCLX,"APCL(")
+8 SET APCLN=0
FOR
SET APCLN=$ORDER(APCL(APCLN))
IF APCLN'=+APCLN!(APCLW]"")
QUIT
Begin DoDot:1
+9 SET APCLZ=$PIECE(APCL(APCLN),U,5)
+10 IF '$DATA(^AUPNVPOV("AD",APCLZ))
SET APCLW=$PIECE(APCL(APCLN),U,2)_" lbs "_$$DATE($PIECE(APCL(APCLN),U))
QUIT
+11 SET APCLD=0
FOR
SET APCLD=$ORDER(^AUPNVPOV("AD",APCLZ,APCLD))
IF 'APCLD!(APCLW]"")
QUIT
Begin DoDot:2
+12 IF $PIECE(^AUPNVPOV(APCLD,0),U)'=APCLV221
SET APCLW=$PIECE(APCL(APCLN),U,2)_" lbs "_$$DATE($PIECE(APCL(APCLN),U))
+13 QUIT
End DoDot:2
End DoDot:1
+14 QUIT $SELECT(F="E":APCLW,1:+APCLW)
CMSFDX(P,R,T) ;EP - return date/dx of dm in register
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(R)
QUIT ""
+3 IF $GET(T)=""
QUIT ""
+4 NEW D1,Y,X,D,G
SET X=0
SET (D,Y)=""
FOR
SET X=$ORDER(^ACM(44,"C",P,X))
IF X'=+X
QUIT
IF $PIECE(^ACM(44,X,0),U,4)=R
Begin DoDot:1
+5 SET D=$PIECE($GET(^ACM(44,X,"SV")),U,2)
SET D1=D
SET D=$$FMTE^XLFDT(D)
+6 SET Y=$$VAL^XBDIQ1(9002244,X,.01)
+7 IF D1=""
SET D1=0
+8 SET G(9999999-D1)=D_"^"_D1_"^"_Y
End DoDot:1
+9 IF '$ORDER(G(0))
QUIT ""
+10 SET Y=0
SET G=$ORDER(G(Y))
+11 SET D=$PIECE(G(G),U)
SET D1=$PIECE(G(G),U,2)
SET Y=$PIECE(G(G),U,3)
+12 QUIT $SELECT(T="D":$GET(D),T="DX":$GET(Y),T="ID":$GET(D1),1:"")
+13 ;
PLDMDOO(P,F) ;EP
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(F)=""
SET F="E"
+3 NEW T
SET T=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",0))
+4 IF 'T
QUIT ""
+5 NEW D,X,I
SET D=""
SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET I=$PIECE(^AUPNPROB(X,0),U)
+7 IF $$ICD^ATXCHK(I,T,9)
Begin DoDot:2
+8 IF $PIECE(^AUPNPROB(X,0),U,13)]""
SET D($PIECE(^AUPNPROB(X,0),U,13))=""
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 SET D=$ORDER(D(0))
QUIT $SELECT(F="E":$$FMTE^XLFDT(D),1:$ORDER(D(0)))
PLDMDXS(P) ;EP - get all DM dxs from problem list
+1 IF '$GET(P)
QUIT ""
+2 NEW T
SET T=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",0))
+3 IF 'T
QUIT "<diabetes taxonomy missing>"
+4 NEW D,X,I
SET D=""
SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+5 SET I=$PIECE(^AUPNPROB(X,0),U)
+6 ;I $$ICD^ATXCHK(I,T,9) S:D]"" D=D_";" S D=D_$P(^ICD9(I,0),U) ;cmi/anch/maw 9/12/2007 orig line
+7 ;cmi/anch/maw 9/12/2007 csv
IF $$ICD^ATXCHK(I,T,9)
IF D]""
SET D=D_";"
SET D=D_$PIECE($$ICDDX^ICDCODE(I),U,2)
+8 QUIT
End DoDot:1
+9 QUIT D
+10 ;
FRSTDMDX(P,F) ;EP return date of first dm dx
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(F)=""
SET F="E"
+3 NEW X,E,APCL,Y
+4 SET Y="APCL("
+5 SET X=P_"^FIRST DX [SURVEILLANCE DIABETES"
SET E=$$START1^APCLDF(X,Y)
SET Y=$PIECE($GET(APCL(1)),U)
+6 QUIT $SELECT(F="E":$$FMTE^XLFDT(Y),1:Y)
LASTDMDX(P,D) ;EP - last pcc dm dx
+1 IF '$GET(P)
QUIT ""
+2 NEW X,E,APCL,Y
+3 SET Y="APCL("
+4 SET X=P_"^LAST DX [DM AUDIT TYPE II DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D
SET E=$$START1^APCLDF(X,Y)
+5 IF $DATA(APCL(1))
QUIT "Type 2"
+6 KILL APCL
SET X=P_"^LAST DX [DM AUDIT TYPE I DXS;DURING "_$$DOB^AUPNPAT(P,"E")_"-"_D
SET E=$$START1^APCLDF(X,Y)
+7 IF $DATA(APCL(1))
QUIT "Type 1"
+8 QUIT ""
INCHES ;
+1 NEW F,FI,Z
+2 SET (X,Z)=$$LASTHT^APCLD713(APCLPD,APCLRED,"I")
+3 IF X=""
QUIT
+4 ;get feet
SET X=X/12
+5 SET F=$PIECE(X,".")
+6 ;GET INCHES
SET FI=F*12
+7 SET X=Z-FI
+8 SET X=$JUSTIFY(X,5,2)
+9 ;W !,Z," ",F," ",FI," ",X H 1
+10 ;I X S X=X/12,X=$P(X,"."),X=X*12,X=Z=X,X=$J(X,5,2)
+11 QUIT
DATE(D) ;EP
+1 IF D=""
QUIT D
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
