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

BGP8D6.m

Go to the documentation of this file. 
  1. BGP8D6 ; IHS/CMI/LAB - measure 31 ;
  1.  ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66
  1.  ;
  1. I031 ;EP
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
  1.  I BGPAGEB<2 S BGPSTOP=1 Q
  1.  I BGPAGEB>74 S BGPSTOP=1 Q
  1.  I BGPAGEB>1 S BGPD1=1
  1.  I BGPAGEB>1,BGPAGEB<6 S BGPD2=1
  1.  I BGPAGEB>5,BGPAGEB<12 S BGPD3=1
  1.  I BGPAGEB>11,BGPAGEB<20 S BGPD4=1
  1.  I BGPAGEB>19,BGPAGEB<25 S BGPD5=1
  1.  I BGPAGEB>24,BGPAGEB<35 S BGPD6=1
  1.  I BGPAGEB>34,BGPAGEB<45 S BGPD7=1
  1.  I BGPAGEB>44,BGPAGEB<55 S BGPD8=1
  1.  I BGPAGEB>54,BGPAGEB<75 S BGPD9=1
  1.  I '(BGPD1+BGPD2+BGPD3+BGPD4+BGPD5+BGPD6+BGPD7+BGPD8+BGPD9) S BGPSTOP=1 Q
  1.  S BGPBMI=$$BMI(DFN,BGPEDATE,BGPAGEE),BGPN1=$S(BGPBMI]"":1,1:0)
  1.  S BGPXPHV=$$SB^BGP8PDL1($J($P(BGPBMI,U),6,2)) S:BGPXPHV="0.00" BGPXPHV=""
  1.  S BGPN2=$$OW(DFN,BGPBMI,BGPAGEE)
  1.  S BGPN3=$$OB(DFN,BGPBMI,BGPAGEE)
  1.  I BGPN2!(BGPN3) S BGPN4=1
  1.  I 'BGPN1 S BGPREF=$$REF(DFN,BGP365,BGPEDATE,BGPAGEB) I $P(BGPREF,U)=1 S BGPN5=1
  1.  ;I BGPN5 S BGPN1=1
  1.  S BGPVALUE=$S(BGPD1:"UP",1:"") I BGPD1,BGPACTCL S BGPVALUE=BGPVALUE_",AC"
  1.  S BGPVALUE=BGPVALUE_"|||"_$S(BGPBMI]"":$$SB^BGP8PDL1($J($P(BGPBMI,U),6,2)),1:"")_$S(BGPN2:" [OVERWEIGHT]",1:"")_$S(BGPN3:" [OBESE]",1:"")
  1.  I BGPRTYPE'=1,BGPN5 S BGPVALUE=BGPVALUE_"Refused " ;_$P(BGPREF,U,2)_" "_$$DATE^BGP8UTL($P(BGPREF,U,3))_" "_$P(BGPREF,U,5)_" "_$$DATE^BGP8UTL($P(BGPREF,U,6))
  1.  K BGPL,BGPLWTS,BGPLHTS,%,X,BGPLWTS1,BGPLHTS1,Y
  1.  Q
  1. I031A ;
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9)=0
  1.  I BGPAGEB<2 S BGPSTOP=1 Q
  1.  I BGPAGEB>5 S BGPSTOP=1 Q
  1.  I BGPAGEE>5 S BGPSTOP=1 Q
  1.  ;I 'BGPACTCL S BGPSTOP=1 Q
  1.  I BGPACTCL=1 S BGPD1=1
  1.  S BGPD6=1 ;USER POP
  1.  S BGPBMI=$$BMIOR(DFN,BGPBDATE,BGPEDATE,BGPAGEE)
  1.  I $P(BGPBMI,U)="" S BGPSTOP=1 Q  ;no bmi
  1.  S BGPOW=$$OW(DFN,$P(BGPBMI,U),$$AGE^AUPNPAT(DFN,$P(BGPBMI,U,2))) I BGPOW S BGPN1=1
  1.  S BGPOB=$$OB(DFN,$P(BGPBMI,U),$$AGE^AUPNPAT(DFN,$P(BGPBMI,U,2))) I BGPOB S BGPN2=1
  1.  I BGPN1!(BGPN2) S BGPN3=1
  1.  S A=$$AGE^AUPNPAT(DFN,$P(BGPBMI,U,2))
  1.  I BGPACTCL,A=2 S BGPD2=1
  1.  I BGPACTCL,A=3 S BGPD3=1
  1.  I BGPACTCL,A=4 S BGPD4=1
  1.  I BGPACTCL,A=5 S BGPD5=1
  1.  ; '(BGPD2+BGPD3+BGPD4+BGPD5+BGPD6) W !,BGPBOMB
  1.  S BGPVALUE="UP"_$S(BGPD1:",AC",1:"")
  1.  I $P(BGPBMI,U)]"" S BGPVALUE=BGPVALUE_"|||"_" Age at BMI: "_A_"; "_$$DATE^BGP8UTL($P(BGPBMI,U,2))_" "_$P(BGPBMI,U)
  1.  I $P(BGPOW,U,2)]""!($P(BGPOB,U,2)]"") S BGPVALUE=BGPVALUE_" [Outside Data Check Limits]"
  1.  I BGPN1 S BGPVALUE=BGPVALUE_" [OVERWEIGHT] "
  1.  I BGPN2 S BGPVALUE=BGPVALUE_" [OBESE] "
  1.  K BGPBMIH,BGPBMI,BGPOW,BGPOB
  1.  Q
  1. BMIOR(P,BDATE,EDATE,AGE) ;EP
  1.  KILL %,W,H,B,D,%DT
  1.  S BGPBMIH=""
  1.  D  Q BGPBMIH
  1.  .S BDATE=$$FMTE^XLFDT(BDATE),EDATE=$$FMTE^XLFDT(EDATE)
  1.  .S X=$$HTWTSDOR(P,BDATE,EDATE)
  1.  .I '$P(X,"^") Q
  1.  .S W=$P(X,"^",2),H=$P(X,"^",3)
  1.  .S W=W*.45359,H=(H*.0254),H=(H*H),BGPBMIH=$$SB^BGP8PDL1($J((W/H),6,2))_U_$P(X,U,1)
  1.  .;S W=$P(X,"^",5),H=$P(X,"^",6)
  1.  .;S W=W*.45359,H=(H*.0254),H=(H*H),$P(BGPBMIH,U,3)=$$SB^BGP8PDL1($J((W/H),6,2))_U_$P(X,U,4)
  1.  .Q
  1.  Q ""
  1. HTWTSDOR(P,BDATE,EDATE) ;get last ht / wt on same day
  1.  I '$G(P) Q ""
  1.  KILL BGPLWTS,BGPLHTS,%,X,BGPLWTS1,BGPLHTS1,Y
  1.  ;get all hts during time frame
  1.  S %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BGPLHTS(")
  1.  S Y=0 F  S Y=$O(BGPLHTS(Y)) Q:Y'=+Y  I $P(BGPLHTS(Y),U,2)="?"!($P(BGPLHTS(Y),U,2)="") K BGPLHTS(Y)
  1.  ;set the array up by date
  1.  K BGPLHTS1 S X=0 F  S X=$O(BGPLHTS(X)) Q:X'=+X  S BGPLHTS1($P(BGPLHTS(X),U))=X
  1.  ;get all wts during time frame
  1.  S %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BGPLWTS(")
  1.  S Y=0 F  S Y=$O(BGPLWTS(Y)) Q:Y'=+Y  I $P(BGPLWTS(Y),U,2)="?"!($P(BGPLWTS(Y),U,2)="") K BGPLWTS(Y)
  1.  ;set the array up by date
  1.  K BGPLWTS1 S X=0 F  S X=$O(BGPLWTS(X)) Q:X'=+X  S BGPLWTS1($P(BGPLWTS(X),U))=X
  1.  S BGPLCHT="",X=9999999 F  S X=$O(BGPLWTS1(X),-1) Q:X=""!(BGPLCHT]"")  I $D(BGPLHTS1(X)) S BGPLCHT=$P(BGPLWTS(BGPLWTS1(X)),U)_U_$P(BGPLWTS(BGPLWTS1(X)),U,2)_U_$P(BGPLHTS(BGPLHTS1(X)),U,2)
  1.  Q BGPLCHT
  1. OB(P,BMI,A) ;EP obese
  1.  I $G(BMI)="" Q ""
  1.  S S=$P(^DPT(P,0),U,2)
  1.  I S="" Q ""
  1.  S R=0,R=$O(^APCLBMI("H",S,A,R))
  1.  I 'R S R=$O(^APCLBMI("H",S,A)) I R S R=$O(^APCLBMI("H",S,R,""))
  1.  I 'R Q ""
  1.  I BMI>$P(^APCLBMI(R,0),U,7)!(BMI<$P(^APCLBMI(R,0),U,6)) Q "0^Outside Data Check Limits"
  1.  I BMI'<$P(^APCLBMI(R,0),U,5) Q 1
  1.  Q ""
  1. OW(P,BMI,A) ;EP overweight
  1.  I $G(BMI)="" Q ""
  1.  S S=$P(^DPT(P,0),U,2)
  1.  I S="" Q ""
  1.  S R=0,R=$O(^APCLBMI("H",S,A,R))
  1.  I 'R S R=$O(^APCLBMI("H",S,A)) I R S R=$O(^APCLBMI("H",S,R,""))
  1.  I 'R Q ""
  1.  I BMI>$P(^APCLBMI(R,0),U,7)!(BMI<$P(^APCLBMI(R,0),U,6)) Q "0^Outside Data Check Limits"
  1.  I BMI'<$P(^APCLBMI(R,0),U,4),BMI<$P(^APCLBMI(R,0),U,5) Q 1
  1.  Q ""
  1. HT(P,BDATE,EDATE) ;EP
  1.  I 'P Q ""
  1.  NEW %,BGPARRY,H,E
  1.  S %=P_"^LAST MEAS HT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BGPARRY(") S H=$P($G(BGPARRY(1)),U,2)
  1.  I H="" Q H
  1.  I H["?" Q ""
  1.  S H=$J(H,2,0)
  1.  Q H
  1. WT(P,BDATE,EDATE) ;EP
  1.  I 'P Q ""
  1.  NEW %,E,BGPLW,X,BGPLN,BGPL,BGPLD,BGPLZ,BGPLX,ICD,T
  1.  K BGPL S BGPLW="" S BGPLX=P_"^LAST 24 MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(BGPLX,"BGPL(")
  1.  S BGPLN=0 F  S BGPLN=$O(BGPL(BGPLN)) Q:BGPLN'=+BGPLN!(BGPLW]"")  D
  1.  .S BGPLZ=$P(BGPL(BGPLN),U,5)
  1.  .I '$D(^AUPNVPOV("AD",BGPLZ)) S BGPLW=$P(BGPL(BGPLN),U,2) Q
  1.  . S BGPLD=0 F  S BGPLD=$O(^AUPNVPOV("AD",BGPLZ,BGPLD)) Q:'BGPLD!(BGPLW]"")  D
  1.  .. S D=$P(BGPL(BGPLN),U)
  1.  .. S ICD=$P($$ICDDX^BGP8UTL2($P(^AUPNVPOV(BGPLD,0),U),D),U,2) D
  1.  ...I $$ICD^BGP8UTL2($P(^AUPNVPOV(BGPLD,0),U,1),$O(^ATXAX("B","BGP PREGNANCY DIAGNOSES 2",0)),9) Q
  1.  ...;I $E(ICD,1,3)="V22" Q
  1.  ...;I $E(ICD,1,3)="V23" Q
  1.  ...;I $E(ICD,1,3)="V27" Q
  1.  ...;I $E(ICD,1,3)="V28" Q
  1.  ...;I ICD>629.9999&(ICD<676.95) Q
  1.  ...S BGPLW=$P(BGPL(BGPLN),U,2)
  1.  ..Q
  1.  Q BGPLW
  1.  ;
  1. BMI(P,EDATE,AGE) ;EP
  1.  NEW %,W,H,B,D,%DT,BDATE
  1.  ;S BDATE=$$FMADD^XLFDT(EDATE,-365),BDATE=$$FMTE^XLFDT(BDATE),EDATE=$$FMTE^XLFDT(EDATE)
  1.  S BGPBMIH=""
  1.  I AGE>18,AGE<51 D  Q BGPBMIH
  1.  .S BDATE=$$FMADD^XLFDT(EDATE,-(5*365)),BDATE=$$FMTE^XLFDT(BDATE),EDATE=$$FMTE^XLFDT(EDATE)
  1.  .S W=$$WT(P,BDATE,EDATE) I W=""!(W="?") Q
  1.  .;S HDATE=$$FMTE^XLFDT($$FMADD^XLFDT($P(^DPT(P,0),U,3),(19*365)))
  1.  .S HDATE=BDATE
  1.  .S H=$$HT(P,HDATE,EDATE) I H="" Q
  1.  .S W=W*.45359,H=(H*.0254),H=(H*H),BGPBMIH=(W/H)
  1.  I AGE>50 D  Q BGPBMIH
  1.  .S BDATE=$$FMADD^XLFDT(EDATE,-(2*365)),BDATE=$$FMTE^XLFDT(BDATE),EDATE=$$FMTE^XLFDT(EDATE)
  1.  .S W=$$WT(P,BDATE,EDATE) I W=""!(W="?") Q
  1.  .;S HDATE=$$FMTE^XLFDT($$FMADD^XLFDT($P(^DPT(P,0),U,3),(19*365)))
  1.  .S HDATE=BDATE
  1.  .S H=$$HT(P,HDATE,EDATE) I H="" Q
  1.  .S W=W*.45359,H=(H*.0254),H=(H*H),BGPBMIH=(W/H)
  1.  I AGE<19 D  Q BGPBMIH
  1.  .S BDATE=$$FMADD^XLFDT(EDATE,-365),BDATE=$$FMTE^XLFDT(BDATE),EDATE=$$FMTE^XLFDT(EDATE)
  1.  .S X=$$HTWTSD(P,BDATE,EDATE)
  1.  .I '$P(X,"^") Q
  1.  .I '$P(X,"^",2) Q
  1.  .S W=$P(X,"^"),H=$P(X,"^",2)
  1.  .S W=W*.45359,H=(H*.0254),H=(H*H),BGPBMIH=(W/H)
  1.  .Q
  1.  Q
  1. HTWTSD(P,BDATE,EDATE) ;get last ht / wt on same day
  1.  I '$G(P) Q ""
  1.  NEW BGPLWTS,BGPLHTS,%,X,BGPLWTS1,BGPLHTS1,Y
  1.  ;get all hts during time frame
  1.  S %=P_"^ALL MEAS HT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BGPLHTS(")
  1.  S Y=0 F  S Y=$O(BGPLHTS(Y)) Q:Y'=+Y  I $P(BGPLHTS(Y),U,2)="?"!($P(BGPLHTS(Y),U,2)="") K BGPLHTS(Y)
  1.  ;set the array up by date
  1.  K BGPLHTS1 S X=0 F  S X=$O(BGPLHTS(X)) Q:X'=+X  S BGPLHTS1($P(BGPLHTS(X),U))=X
  1.  ;get all wts during time frame
  1.  S %=P_"^ALL MEAS WT;DURING "_BDATE_"-"_EDATE S E=$$START1^APCLDF(%,"BGPLWTS(")
  1.  S Y=0 F  S Y=$O(BGPLWTS(Y)) Q:Y'=+Y  I $P(BGPLWTS(Y),U,2)="?"!($P(BGPLWTS(Y),U,2)="") K BGPLWTS(Y)
  1.  ;set the array up by date
  1.  K BGPLWTS1 S X=0 F  S X=$O(BGPLWTS(X)) Q:X'=+X  S BGPLWTS1($P(BGPLWTS(X),U))=X
  1.  S BGPLCHT="",X=9999999 F  S X=$O(BGPLWTS1(X),-1) Q:X=""!(BGPLCHT]"")  I $D(BGPLHTS1(X)) S BGPLCHT=$P(BGPLWTS(BGPLWTS1(X)),U,2)_U_$P(BGPLHTS(BGPLHTS1(X)),U,2)
  1.  Q BGPLCHT
  1.  ;
  1. REF(P,BDATE,EDATE,AGE) ;EP - get ht/wt Refusal in past year, same date for 18 and under
  1.  NEW R,X,Y
  1.  S R=""
  1.  I AGE<19 G AGE18R
  1.  S X=$$REFUSAL^BGP8UTL1(P,9999999.07,$O(^AUTTMSR("B","HT",0)),BDATE,EDATE) I X S R=1_U_"HT"_U_$P(X,U,2)
  1.  S Y=$$REFUSAL^BGP8UTL1(P,9999999.07,$O(^AUTTMSR("B","WT",0)),BDATE,EDATE) I Y S $P(R,U,4)=1,$P(R,U,5)="WT",$P(R,U,6)=$P(Y,U,2)
  1.  I X="",Y="" Q ""
  1.  Q R
  1. AGE18R ;
  1.  NEW H,W,Z,X,Y,R
  1.  K H,W
  1.  S H=$O(^AUTTMSR("B","HT",0))
  1.  S Z=0 F  S Z=$O(^AUPNPREF("AA",P,9999999.07,H,Z)) Q:Z'=+Z  D
  1.  .S V=0 F  S V=$O(^AUPNPREF("AA",P,9999999.07,H,Z,V)) Q:V'=+V  D
  1.  ..Q:'$D(^AUPNPREF(V,0))
  1.  ..S D=$P(^AUPNPREF(V,0),U,3)
  1.  ..Q:D>EDATE
  1.  ..Q:D<BDATE
  1.  ..S H(D)=""
  1.  ..Q
  1.  .Q
  1.  S W=$O(^AUTTMSR("B","WT",0))
  1.  S Z=0 F  S Z=$O(^AUPNPREF("AA",P,9999999.07,W,Z)) Q:Z'=+Z  D
  1.  .S V=0 F  S V=$O(^AUPNPREF("AA",P,9999999.07,W,Z,V)) Q:V'=+V  D
  1.  ..Q:'$D(^AUPNPREF(V,0))
  1.  ..S D=$P(^AUPNPREF(V,0),U,3)
  1.  ..Q:D>EDATE
  1.  ..Q:D<BDATE
  1.  ..Q:"NRU"'[$P(^AUPNPREF(V,0),U,7)
  1.  ..S W(D)=""
  1.  ..Q
  1.  .Q
  1.  ;is there an H and w on same day?
  1.  S R=""
  1.  S X=0 F  S X=$O(H(X)) Q:X'=+X!(R]"")  I $D(W(X)) S R=1_U_"HT/WT"_U_X
  1.  Q R