Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BDMDC1B

BDMDC1B.m

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