BDMDD1B ; IHS/CMI/LAB - get dm audit values ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**9**;JUN 14, 2007;Build 78
;
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=$$DATE^BDMS9B1(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":$$DATE^BDMS9B1(TDD),1:$$DATE^BDMS9B1(TDD))
S R="",G="" F R=115 Q:R=""!(G) D
.S G=$$REFUSAL^BDMDD17(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":$$DATE^BDMS9B1($P(G,U,2)),1:$$DATE^BDMS9B1($P(G,U,2)))
Q "2 No "_$S($G(F)="A":$$DATE^BDMS9B1(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,%
I $P(^DPT(P,0),U,2)'="F" Q ""
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 "_$$DATE^BDMS9B1(BDATE)_"-"_$$DATE^BDMS9B1(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
.Q
I CNT>1 Q 1
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 Q 1
Q 0
STATE(P) ;EP - STATE OF PATIENT1)
I '$G(P) Q ""
NEW X,C
S X=$$GET1^DIQ(2,P,.115,"I")
I 'X Q ""
I +$$GET1^DIQ(5,X,2)>69 Q ""
Q $$GET1^DIQ(5,X,1)
BDMDD1B ; IHS/CMI/LAB - get dm audit values ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**9**;JUN 14, 2007;Build 78
+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=$$DATE^BDMS9B1(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":$$DATE^BDMS9B1(TDD),1:$$DATE^BDMS9B1(TDD))
+4 SET R=""
SET G=""
FOR R=115
IF R=""!(G)
QUIT
Begin DoDot:1
+5 SET G=$$REFUSAL^BDMDD17(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":$$DATE^BDMS9B1($PIECE(G,U,2)),1:$$DATE^BDMS9B1($PIECE(G,U,2)))
+18 QUIT "2 No "_$SELECT($GET(F)="A":$$DATE^BDMS9B1(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 $PIECE(^DPT(P,0),U,2)'="F"
QUIT ""
+3 ;if there is one before time frame set this to 1
SET B=0
SET CNT=0
SET BDMD=""
+4 SET NORXCHR=$GET(NORXCHR)
+5 SET NORX=$GET(NORX)
+6 KILL BDMG
+7 SET Y="BDMG("
+8 SET X=P_"^ALL DX [BGP PREGNANCY DIAGNOSES 2;DURING "_$$DATE^BDMS9B1(BDATE)_"-"_$$DATE^BDMS9B1(EDATE)
SET E=$$START1^APCLDF(X,Y)
+9 ;now reorder by date of diagnosis and eliminate all chr and rx if necessary
+10 ;no diagnoses
IF '$DATA(BDMG)
GOTO PROB
+11 SET B=0
SET X=0
FOR
SET X=$ORDER(BDMG(X))
IF X'=+X
QUIT
Begin DoDot:1
+12 ;get date
+13 SET D=$PIECE(BDMG(X),U,1)
+14 SET C=$$CLINIC^APCLV($PIECE(BDMG(X),U,5),"C")
+15 IF NORXCHR
IF C=39
QUIT
+16 IF NORX
IF C=39
QUIT
+17 SET C=$$PRIMPROV^APCLV($PIECE(BDMG(X),U,5),"D")
+18 ;no chr as primary provider
IF NORXCHR
IF C=53
QUIT
+19 SET BDMDX(D)=""
SET CNT=CNT+1
IF CNT=2
SET BDMD=D
+20 QUIT
End DoDot:1
+21 IF CNT>1
QUIT 1
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
QUIT 1
+13 QUIT 0
STATE(P) ;EP - STATE OF PATIENT1)
+1 IF '$GET(P)
QUIT ""
+2 NEW X,C
+3 SET X=$$GET1^DIQ(2,P,.115,"I")
+4 IF 'X
QUIT ""
+5 IF +$$GET1^DIQ(5,X,2)>69
QUIT ""
+6 QUIT $$GET1^DIQ(5,X,1)
