BDMDC1B ; IHS/CMI/LAB - get dm audit values ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**8**;JUN 14, 2007;Build 53
;
TD(P,EDATE) ;EP
;
NEW BDM1
S BDM1=$$TD^BDMS9B3(P,$$DOB^AUPNPAT(P),EDATE)
NEW D,X S D=$P(BDM1," ",2),X=""
I D]"" NEW X S X=D D ^%DT S X=$$FMTE^XLFDT(Y)
I $E(BDM1)="Y" Q "1 "_$P(BDM1," ",1)_" "_X
I $E(BDM1)="N" Q "2 "_$P(BDM1," ",1)_" "_X
I $E(BDM1)="R" Q "3 "_$P(BDM1," ",1)_" "_X
Q ""
TDAP(P,BDMSED,F) ;EP
NEW BDMY,X,E,B,%DT,Y,TDD
S TDD=$$LASTTDAP(P,BDMSED)
I TDD Q "1 Yes "_$S($G(F)="A":$$FMTE^XLFDT(TDD),1:$$DATE^BDMS9B1(TDD))
S R="",G="" F R=115 Q:R=""!(G) D
.S G=$$REFUSAL^BDMDC17(P,9999999.14,$O(^AUTTIMM("C",R,0)),$$FMADD^XLFDT(DT,-365),DT,"R")
I G Q "3 Refused "_$P(G,U,3)
;; BI REFUSALS
S G="" F Z=115 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:D<$$FMADD^XLFDT(DT,-365)
.S G=1_U_D
I G Q "3 Refused "_$S($G(F)="A":$$FMTE^XLFDT($P(G,U,2)),1:$$DATE^BDMS9B1($P(G,U,2)))
Q "2 No "_$S($G(F)="A":$$FMTE^XLFDT(TDD),1:$$DATE^BDMS9B1(TDD))
LASTTDAP(BDMPDFN,BDMED) ;PEP - date of last TD
;
I $G(BDMPDFN)="" Q ""
S BDMBD=$$DOB^AUPNPAT(BDMPDFN)
I $G(BDMED)="" S BDMED=DT
NEW BDMLAST,BDMVAL,BDMX,R,X,Y,V,E,T,G,BDMY,BDMF
S BDMLAST=""
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"115","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
S BDMF=$$LASTCPTI^BDMSMU2(BDMPDFN,90715,BDMBD,BDMED)
I BDMF,$P(BDMF,U,3)>$P(BDMVAL,U,1) Q $P(BDMF,U,3)
Q $P(BDMVAL,U,1)
PREG(P,BDATE,EDATE,NORXCHR,NORX) ;EP
NEW BDMDX,B,CNT,BDMD,BDMG,Y,X,D,C,T,G,%
S B=0,CNT=0,BDMD="" ;if there is one before time frame set this to 1
S NORXCHR=$G(NORXCHR)
S NORX=$G(NORX)
K BDMG
S Y="BDMG("
S X=P_"^ALL DX [BGP PREGNANCY DIAGNOSES 2;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
;now reorder by date of diagnosis and eliminate all chr and rx if necessary
I '$D(BDMG) G PROB ;no diagnoses
S B=0,X=0 F S X=$O(BDMG(X)) Q:X'=+X D
.;get date
.S D=$P(BDMG(X),U,1)
.S C=$$CLINIC^APCLV($P(BDMG(X),U,5),"C")
.I NORXCHR,C=39 Q
.I NORX,C=39 Q
.S C=$$PRIMPROV^APCLV($P(BDMG(X),U,5),"D")
.I NORXCHR,C=53 Q ;no chr as primary provider
.S BDMDX(D)="",CNT=CNT+1 I CNT=2 S BDMD=D
.I D>$$FMADD^XLFDT(EDATE,-365) S B=1
.Q
I CNT>1,B G MA
PROB ;
I '$G(B) Q "" ;no pregnancy visit during time period ;-Lori fix in 09
S T=$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
S (X,G)=0 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,12)="I"
.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^BDMUTL(Y,"BGP PREGNANCY DIAGNOSES 2",9)
.S G=$P(^AUPNPROB(X,0),U,8)
.Q
I G=0,BDMD="" Q 0
S BDMD=G
MA ;now check for abortion or miscarriage
;abortion first
K BDMG S Y="BDMG(" S X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_$$FMTE^XLFDT(BDMD)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
I $D(BDMG(1)) Q 0 ;HAD MIS/AB
S BDMG=$$LASTPRCT^APCLAPIU(P,BDATE,EDATE,"BGP ABORTION PROCEDURES")
I BDMG Q 0
S T=$O(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
S (X,G)=0 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,12)="I"
.Q:$P(^AUPNPROB(X,0),U,8)<BDMD
.Q:$P(^AUPNPROB(X,0),U,8)>EDATE
.S Y=$P(^AUPNPROB(X,0),U)
.Q:'$$ICD^BDMUTL(Y,"BGP MISCARRIAGE/ABORTION DXS",9)
.S G=1
.Q
I G Q 0
;now check CPTs for Abortion and Miscarriage
S T=$O(^ATXAX("B","BGP CPT ABORTION",0))
S %=$$LASTCPTT^BDMAPIU(P,BDMD,EDATE,"BGP CPT ABORTION","E")
I %]"" Q 0
S T=$O(^ATXAX("B","BGP CPT MISCARRIAGE",0))
S %=$$LASTCPTT^BDMAPIU(P,BDMD,EDATE,"BGP CPT MISCARRIAGE","E")
I %]"" Q 0
Q 1
BDMDC1B ; IHS/CMI/LAB - get dm audit values ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**8**;JUN 14, 2007;Build 53
+2 ;
TD(P,EDATE) ;EP
+1 ;
+2 NEW BDM1
+3 SET BDM1=$$TD^BDMS9B3(P,$$DOB^AUPNPAT(P),EDATE)
+4 NEW D,X
SET D=$PIECE(BDM1," ",2)
SET X=""
+5 IF D]""
NEW X
SET X=D
DO ^%DT
SET X=$$FMTE^XLFDT(Y)
+6 IF $EXTRACT(BDM1)="Y"
QUIT "1 "_$PIECE(BDM1," ",1)_" "_X
+7 IF $EXTRACT(BDM1)="N"
QUIT "2 "_$PIECE(BDM1," ",1)_" "_X
+8 IF $EXTRACT(BDM1)="R"
QUIT "3 "_$PIECE(BDM1," ",1)_" "_X
+9 QUIT ""
TDAP(P,BDMSED,F) ;EP
+1 NEW BDMY,X,E,B,%DT,Y,TDD
+2 SET TDD=$$LASTTDAP(P,BDMSED)
+3 IF TDD
QUIT "1 Yes "_$SELECT($GET(F)="A":$$FMTE^XLFDT(TDD),1:$$DATE^BDMS9B1(TDD))
+4 SET R=""
SET G=""
FOR R=115
IF R=""!(G)
QUIT
Begin DoDot:1
+5 SET G=$$REFUSAL^BDMDC17(P,9999999.14,$ORDER(^AUTTIMM("C",R,0)),$$FMADD^XLFDT(DT,-365),DT,"R")
End DoDot:1
+6 IF G
QUIT "3 Refused "_$PIECE(G,U,3)
+7 ;; BI REFUSALS
+8 SET G=""
FOR Z=115
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
+9 SET R=$PIECE(^BIPC(X,0),U,3)
+10 IF R=""
QUIT
+11 IF '$DATA(^BICONT(R,0))
QUIT
+12 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+13 SET D=$PIECE(^BIPC(X,0),U,4)
+14 IF D=""
QUIT
+15 IF D<$$FMADD^XLFDT(DT,-365)
QUIT
+16 SET G=1_U_D
End DoDot:1
+17 IF G
QUIT "3 Refused "_$SELECT($GET(F)="A":$$FMTE^XLFDT($PIECE(G,U,2)),1:$$DATE^BDMS9B1($PIECE(G,U,2)))
+18 QUIT "2 No "_$SELECT($GET(F)="A":$$FMTE^XLFDT(TDD),1:$$DATE^BDMS9B1(TDD))
LASTTDAP(BDMPDFN,BDMED) ;PEP - date of last TD
+1 ;
+2 IF $GET(BDMPDFN)=""
QUIT ""
+3 SET BDMBD=$$DOB^AUPNPAT(BDMPDFN)
+4 IF $GET(BDMED)=""
SET BDMED=DT
+5 NEW BDMLAST,BDMVAL,BDMX,R,X,Y,V,E,T,G,BDMY,BDMF
+6 SET BDMLAST=""
+7 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"115","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+8 SET BDMF=$$LASTCPTI^BDMSMU2(BDMPDFN,90715,BDMBD,BDMED)
+9 IF BDMF
IF $PIECE(BDMF,U,3)>$PIECE(BDMVAL,U,1)
QUIT $PIECE(BDMF,U,3)
+10 QUIT $PIECE(BDMVAL,U,1)
PREG(P,BDATE,EDATE,NORXCHR,NORX) ;EP
+1 NEW BDMDX,B,CNT,BDMD,BDMG,Y,X,D,C,T,G,%
+2 ;if there is one before time frame set this to 1
SET B=0
SET CNT=0
SET BDMD=""
+3 SET NORXCHR=$GET(NORXCHR)
+4 SET NORX=$GET(NORX)
+5 KILL BDMG
+6 SET Y="BDMG("
+7 SET X=P_"^ALL DX [BGP PREGNANCY DIAGNOSES 2;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+8 ;now reorder by date of diagnosis and eliminate all chr and rx if necessary
+9 ;no diagnoses
IF '$DATA(BDMG)
GOTO PROB
+10 SET B=0
SET X=0
FOR
SET X=$ORDER(BDMG(X))
IF X'=+X
QUIT
Begin DoDot:1
+11 ;get date
+12 SET D=$PIECE(BDMG(X),U,1)
+13 SET C=$$CLINIC^APCLV($PIECE(BDMG(X),U,5),"C")
+14 IF NORXCHR
IF C=39
QUIT
+15 IF NORX
IF C=39
QUIT
+16 SET C=$$PRIMPROV^APCLV($PIECE(BDMG(X),U,5),"D")
+17 ;no chr as primary provider
IF NORXCHR
IF C=53
QUIT
+18 SET BDMDX(D)=""
SET CNT=CNT+1
IF CNT=2
SET BDMD=D
+19 IF D>$$FMADD^XLFDT(EDATE,-365)
SET B=1
+20 QUIT
End DoDot:1
+21 IF CNT>1
IF B
GOTO MA
PROB ;
+1 ;no pregnancy visit during time period ;-Lori fix in 09
IF '$GET(B)
QUIT ""
+2 SET T=$ORDER(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0))
+3 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+4 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+5 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+6 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+7 IF $PIECE(^AUPNPROB(X,0),U,8)<BDATE
QUIT
+8 SET Y=$PIECE(^AUPNPROB(X,0),U)
+9 IF '$$ICD^BDMUTL(Y,"BGP PREGNANCY DIAGNOSES 2",9)
QUIT
+10 SET G=$PIECE(^AUPNPROB(X,0),U,8)
+11 QUIT
End DoDot:1
+12 IF G=0
IF BDMD=""
QUIT 0
+13 SET BDMD=G
MA ;now check for abortion or miscarriage
+1 ;abortion first
+2 KILL BDMG
SET Y="BDMG("
SET X=P_"^LAST DX [BGP MISCARRIAGE/ABORTION DXS;DURING "_$$FMTE^XLFDT(BDMD)_"-"_$$FMTE^XLFDT(EDATE)
SET E=$$START1^APCLDF(X,Y)
+3 ;HAD MIS/AB
IF $DATA(BDMG(1))
QUIT 0
+4 SET BDMG=$$LASTPRCT^APCLAPIU(P,BDATE,EDATE,"BGP ABORTION PROCEDURES")
+5 IF BDMG
QUIT 0
+6 SET T=$ORDER(^ATXAX("B","BGP MISCARRIAGE/ABORTION DXS",0))
+7 SET (X,G)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+8 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+9 IF $PIECE(^AUPNPROB(X,0),U,12)="I"
QUIT
+10 IF $PIECE(^AUPNPROB(X,0),U,8)<BDMD
QUIT
+11 IF $PIECE(^AUPNPROB(X,0),U,8)>EDATE
QUIT
+12 SET Y=$PIECE(^AUPNPROB(X,0),U)
+13 IF '$$ICD^BDMUTL(Y,"BGP MISCARRIAGE/ABORTION DXS",9)
QUIT
+14 SET G=1
+15 QUIT
End DoDot:1
+16 IF G
QUIT 0
+17 ;now check CPTs for Abortion and Miscarriage
+18 SET T=$ORDER(^ATXAX("B","BGP CPT ABORTION",0))
+19 SET %=$$LASTCPTT^BDMAPIU(P,BDMD,EDATE,"BGP CPT ABORTION","E")
+20 IF %]""
QUIT 0
+21 SET T=$ORDER(^ATXAX("B","BGP CPT MISCARRIAGE",0))
+22 SET %=$$LASTCPTT^BDMAPIU(P,BDMD,EDATE,"BGP CPT MISCARRIAGE","E")
+23 IF %]""
QUIT 0
+24 QUIT 1
