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

BGP2D86.m

Go to the documentation of this file. 
  1. BGP2D86 ; IHS/CMI/LAB - measure C 06 Nov 2009 2:26 PM ;
  1.  ;;12.1;IHS CLINICAL REPORTING;;MAY 17, 2012;Build 66
  1.  ;
  1. IRAR ;EP
  1.  S (BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12)=0
  1.  I 'BGPACTCL S BGPSTOP=1 Q
  1.  I BGPAGEB<16 S BGPSTOP=1 Q  ;must be 16 or older
  1.  I '$$RHEUAR^BGP2D862(DFN,BGPBDATE,BGPEDATE) S BGPSTOP=1 Q  ;no OSTEOARTHRITIS
  1.  S BGPV=$$MEDSPRE^BGP2D863(DFN,BGPBDATE,BGPEDATE)
  1.  I '$P(BGPV,U) S BGPSTOP=1 K ^TMP($J,"A"),BGPMEDS1 Q  ;no meds prescribed per logic
  1.  S BGPN1=0
  1.  I BGPACTCL S BGPD1=1
  1.  I BGPACTUP S BGPD2=1
  1.  I 'BGPD1 S BGPSTOP=1 Q
  1.  K BGPIRZ,BGPIRV
  1.  I $P(BGPV,U,2) D
  1.  .S BGPCBC=$$CBC^BGP2D861(DFN,BGPBDATE,BGPEDATE)
  1.  .S BGPLFT=$$LFT^BGP2D861(DFN,BGPBDATE,BGPEDATE)
  1.  .S BGPCREAT=$$CREAT^BGP2D22(DFN,BGPBDATE,BGPEDATE)
  1.  .S BGPIRZ("A")=0,BGPIRV("A")="NSAID: "
  1.  .I BGPCBC,BGPLFT,BGPCREAT S BGPIRZ("A")=1 ;,BGPIRV("A")=BGPIRV("A")_$$DATE^BGP2UTL($P(BGPCREAT,U,2))_" CREAT, "_$$DATE^BGP2UTL($P(BGPCBC,U,2))_" CBC, "_$$DATE^BGP2UTL($P(BGPLFT,U,2))_" LFT"  ;NA MEDS AND HAS CBC,LFT
  1.  .I BGPCREAT S BGPIRV("A")=BGPIRV("A")_$$DATE^BGP2UTL($P(BGPCREAT,U,2))_" CREAT"
  1.  .I BGPCBC S BGPIRV("A")=BGPIRV("A")_$S(BGPIRV("A")]"":", ",1:"") S BGPIRV("A")=BGPIRV("A")_$$DATE^BGP2UTL($P(BGPCBC,U,2))_" CBC"
  1.  .I BGPLFT S BGPIRV("A")=BGPIRV("A")_$S(BGPIRV("A")]"":", ",1:"") S BGPIRV("A")=BGPIRV("A")_$$DATE^BGP2UTL($P(BGPLFT,U,2))_" LFT"
  1.  I $P(BGPV,U,3) D
  1.  .S BGPGOLD=$$GOLDLAB^BGP2D864(DFN,BGPBDATE,BGPEDATE)
  1.  .S BGPIRZ("B")=0,BGPIRV("B")="IM Gold: "
  1.  .I BGPGOLD S BGPIRZ("B")=1,BGPIRV("B")=BGPIRV("B")_" "_$P(BGPGOLD,U,2)
  1.  .I 'BGPGOLD S BGPIRV("B")=$P(BGPGOLD,U,2)
  1.  I $P(BGPV,U,4) D
  1.  .S BGPCBC=$$CBC4^BGP2D861(DFN,BGPBDATE,BGPEDATE)
  1.  .S BGPIRZ("C")=0,BGPIRV("C")="AZATHIOPRINE: "
  1.  .I BGPCBC S BGPIRZ("C")=1,BGPIRV("C")=BGPIRV("C")_"has 4 CBC's"
  1.  .I 'BGPCBC S BGPIRV("C")=BGPIRV("C")_" does not have 4 CBC's"
  1.  I $P(BGPV,U,5) D
  1.  .S BGPCBC=$$CBC6^BGP2D861(DFN,BGPBDATE,BGPEDATE)
  1.  .S BGPIRZ("D")=0,BGPIRV("D")="Leflunomide: "
  1.  .I BGPCBC S BGPIRV("D")=BGPIRV("D")_"has 6 CBC's"
  1.  .I 'BGPCBC S BGPIRV("D")=BGPIRV("D")_" does not have 6 CBC's"
  1.  .S BGPSERUM=$$SERUM6^BGP2D861(DFN,BGPBDATE,BGPEDATE)
  1.  .I BGPSERUM S BGPIRV("D")=BGPIRV("D")_" has 6 Serum Creatinine's"
  1.  .I 'BGPSERUM S BGPIRV("D")=BGPIRV("D")_" does not have 6 Serum Creatinine's"
  1.  .S BGPLFT=$$LFT6^BGP2D861(DFN,BGPBDATE,BGPEDATE)
  1.  .I BGPLFT S BGPIRV("D")=BGPIRV("D")_" has 6 LFT's"
  1.  .I 'BGPLFT S BGPIRV("D")=BGPIRV("D")_" does not have 6 LFT's"
  1.  .I BGPCBC,BGPSERUM,BGPLFT S BGPIRZ("D")=1
  1.  I $P(BGPV,U,6) D
  1.  .S BGPCBC=$$CBC6^BGP2D861(DFN,BGPBDATE,BGPEDATE)
  1.  .S BGPIRZ("E")=0,BGPIRV("E")="Methotrexate: "
  1.  .I BGPCBC S BGPIRV("E")=BGPIRV("E")_"has 6 CBC's"
  1.  .I 'BGPCBC S BGPIRV("E")=BGPIRV("E")_" does not have 6 CBC's"
  1.  .S BGPSERUM=$$SERUM6^BGP2D861(DFN,BGPBDATE,BGPEDATE)
  1.  .I BGPSERUM S BGPIRV("E")=BGPIRV("E")_" has 6 Serum Creatinine's"
  1.  .I 'BGPSERUM S BGPIRV("E")=BGPIRV("E")_" does not have 6 Serum Creatinine's"
  1.  .S BGPLFT=$$LFT6^BGP2D861(DFN,BGPBDATE,BGPEDATE)
  1.  .I BGPLFT S BGPIRV("E")=BGPIRV("E")_" has 6 LFT's"
  1.  .I 'BGPLFT S BGPIRV("E")=BGPIRV("E")_" does not have 6 LFT's"
  1.  .I BGPCBC,BGPSERUM,BGPLFT S BGPIRZ("E")=1
  1.  I $P(BGPV,U,7) D
  1.  .S BGPCBC=$$CBC^BGP2D861(DFN,$$FMADD^XLFDT(BGPEDATE,-180),BGPEDATE)
  1.  .S BGPIRZ("F")=0,BGPIRV("F")="Cycolsporin: "
  1.  .I BGPCBC S BGPIRV("F")=BGPIRV("F")_"has CBC Past 180 days"
  1.  .I 'BGPCBC S BGPIRV("F")=BGPIRV("F")_" does not have CBC past 180 days"
  1.  .S BGPLFT=$$LFT^BGP2D861(DFN,$$FMADD^XLFDT(BGPBDATE,-180),BGPEDATE)
  1.  .I BGPLFT S BGPIRV("F")=BGPIRV("F")_" has LFT past 180 days"
  1.  .I 'BGPLFT S BGPIRV("F")=BGPIRV("F")_" does not have LFT 180 days"
  1.  .S BGPPOT=$$POT^BGP2D861(DFN,$$FMADD^XLFDT(BGPBDATE,-180),BGPEDATE)
  1.  .I BGPPOT S BGPIRV("F")=BGPIRV("F")_" has Potassium in 180 days"
  1.  .I 'BGPPOT S BGPIRV("F")=BGPIRV("F")_" does not have Potassium"
  1.  .S BGPSERUM=$$SERUM12^BGP2D861(DFN,BGPBDATE,BGPEDATE)
  1.  .I BGPSERUM S BGPIRV("F")=BGPIRV("F")_" has 12 serum creatinine"
  1.  .I 'BGPSERUM S BGPIRV("F")=BGPIRV("F")_" does not have 12 serum creatinine"
  1.  .I BGPCBC,BGPSERUM,BGPLFT,BGPPOT S BGPIRZ("F")=1
  1.  I $P(BGPV,U,8) D
  1.  .S BGPCBC=$$CBC4^BGP2D861(DFN,BGPBDATE,BGPEDATE)
  1.  .S BGPIRZ("G")=0,BGPIRV("G")="Oral Gold: "
  1.  .I BGPCBC S BGPIRV("G")=BGPIRV("G")_"has 4 CBC's"
  1.  .I 'BGPCBC S BGPIRV("G")=BGPIRV("G")_" does not have 6 CBC's"
  1.  .S BGPUP=$$UP4^BGP2D861(DFN,BGPBDATE,BGPEDATE)
  1.  .I BGPUP S BGPIRV("G")=BGPIRV("G")_" has 4 Urine Proteins"
  1.  .I 'BGPUP S BGPIRV("G")=BGPIRV("G")_" does not have 4 Urine Protein's"
  1.  .I BGPCBC,BGPUP S BGPIRZ("G")=1
  1.  I $P(BGPV,U,9) D
  1.  .S BGPCBC=$$CBC^BGP2D861(DFN,$$FMADD^XLFDT(BGPEDATE,-180),BGPEDATE)
  1.  .S BGPIRZ("H")=0,BGPIRV("H")="Mycophenolate: "
  1.  .I BGPCBC S BGPIRV("H")=BGPIRV("H")_"has CBC Past 180 days"
  1.  .I 'BGPCBC S BGPIRV("H")=BGPIRV("H")_" does not have CBC past 180 days"
  1.  .I BGPCBC S BGPIRZ("H")=1
  1.  I $P(BGPV,U,10) D
  1.  .S BGPCBC=$$CBC4^BGP2D861(DFN,BGPBDATE,BGPEDATE)
  1.  .S BGPIRZ("I")=0,BGPIRV("I")="Penicillamine: "
  1.  .I BGPCBC S BGPIRV("I")=BGPIRV("I")_"has 4 CBC's"
  1.  .I 'BGPCBC S BGPIRV("I")=BGPIRV("I")_" does not have 6 CBC's"
  1.  .S BGPUP=$$UP4^BGP2D861(DFN,BGPBDATE,BGPEDATE)
  1.  .I BGPUP S BGPIRV("I")=BGPIRV("I")_" has 4 Urine Proteins"
  1.  .I 'BGPUP S BGPIRV("I")=BGPIRV("I")_" does not have 4 Urine Protein's"
  1.  .I BGPCBC,BGPUP S BGPIRZ("I")=1
  1.  I $P(BGPV,U,11) D
  1.  .S BGPCBC=$$CBC4^BGP2D861(DFN,BGPBDATE,BGPEDATE)
  1.  .S BGPIRZ("J")=0,BGPIRV("J")="Sulfasalazine: "
  1.  .I BGPCBC S BGPIRZ("J")=1,BGPIRV("J")=BGPIRV("J")_"has 4 CBC's"
  1.  .I 'BGPCBC S BGPIRV("J")=BGPIRV("J")_" does not have 4 CBC's"
  1.  I $P(BGPV,U,12) D
  1.  .S BGPGLU=$$GLUCOSE^BGP2D861(DFN,BGPBDATE,BGPEDATE)
  1.  .S BGPIRZ("K")=0,BGPIRV("K")="Glucocorticoids: "
  1.  .I BGPGLU S BGPIRZ("K")=1,BGPIRV("K")=BGPIRV("K")_$$DATE^BGP2UTL($P(BGPGLU,U,2))_" Glucose"
  1.  .I 'BGPGLU S BGPIRV("K")=BGPIRV("K")_" does not have Glucose"
  1.  S BGPN1=1 S X="" F  S X=$O(BGPIRZ(X)) Q:X=""  I BGPIRZ(X)=0 S BGPN1=0
  1.  S BGPVALUE=$S(BGPD1:"AC",1:"")_"|||"
  1.  S BGPVALUE=BGPVALUE_$S(BGPN1:"YES: ",1:"NO: ") S X="" F  S X=$O(BGPIRV(X)) Q:X=""  S BGPVALUE=BGPVALUE_$S($P(BGPVALUE,U,2)]"":"; ",1:""),BGPVALUE=BGPVALUE_BGPIRV(X)
  1.  K X,Y,Z,%,A,B,C,D,E,H,BDATE,EDATE,P,V,S,F,T
  1.  K ^TMP($J,"A")
  1.  Q
  1.  ;
  1. TDAP(P,EDATE) ;EP
  1.  K BGPC,BGPG,BGPX
  1.  ;gather up all immunizations, cpts, povs and check for 3 each ten days apart
  1.  K BGPVARI
  1.  ;get all immunizations
  1.  S C="115"
  1.  D GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
  1.  ;go through and set into array if 10 days apart
  1.  I $O(BGPX(0)) Q 1_U_"Tdap"
  1.  ;now get cpts
  1.  S ED=9999999-EDATE-1,BD=9999999-$$DOB^AUPNPAT(P),G=0
  1.  F  S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)  D
  1.  .S V=0 F  S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V  D
  1.  ..Q:'$D(^AUPNVSIT(V,0))
  1.  ..S X=0 F  S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X  D
  1.  ...S Y=$P(^AUPNVCPT(X,0),U),Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90715 S BGPVARI(9999999-$P(ED,"."))=""
  1.  ..S X=0 F  S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X  D
  1.  ...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y  S Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=90715 S BGPVARI(9999999-$P(ED,"."))=""
  1.  I $D(BGPVARI) Q 1_U_"Tdap"
  1.  F BGPZ=115 S X=$$ANCONT^BGP2D31(P,BGPZ,EDATE) Q:X]""
  1.  I X]"" Q 4_U_"Contra Tdap"
  1.  ;now go to Refusals
  1.  S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
  1.  F BGPIMM=115  D
  1.  .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
  1.  .S X=0 F  S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X  S Y=0 F  S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y  S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
  1.  I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI Tdap",1:"Ref Tdap")
  1.  F BGPIMM=90715  D
  1.  .S I=+$$CODEN^ICPTCOD(BGPIMM) Q:'I
  1.  .S X=0 F  S X=$O(^AUPNPREF("AA",P,81,I,X)) Q:X'=+X  S Y=0 F  S Y=$O(^AUPNPREF("AA",P,81,I,X,Y)) Q:Y'=+Y  S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
  1.  I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI Tdap",1:"Ref Tdap")
  1.  ;now check Refusals in imm pkg
  1.  F BGPIMM=115 S R=$$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
  1.  I R Q 3_U_"Ref imm pkg Tdap"
  1. TD ;
  1.  K BGPC,BGPG,BGPX
  1.  ;gather up all immunizations, cpts, povs and check for 3 each ten days apart
  1.  K BGPVARI
  1.  ;get all immunizations
  1.  S C="9^113"
  1.  D GETIMMS^BGP2D32(P,EDATE,C,.BGPX)
  1.  ;go through and set into array if 10 days apart
  1.  I $O(BGPX(0)) Q 1_U_"Td"
  1.  ;now get cpts
  1.  S ED=9999999-EDATE-1,BD=9999999-$$DOB^AUPNPAT(P),G=0
  1.  F  S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)  D
  1.  .S V=0 F  S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V  D
  1.  ..Q:'$D(^AUPNVSIT(V,0))
  1.  ..S X=0 F  S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X  D
  1.  ...S Y=$P(^AUPNVCPT(X,0),U),Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=Y=90714!(Y=90718) S BGPVARI(9999999-$P(ED,"."))=""
  1.  ..S X=0 F  S X=$O(^AUPNVTC("AD",V,X)) Q:X'=+X  D
  1.  ...S Y=$P(^AUPNVTC(X,0),U,7) Q:'Y  S Y=$P($$CPT^ICPTCOD(Y),U,2) I Y=Y=90714!(Y=90718) S BGPVARI(9999999-$P(ED,"."))=""
  1.  I $D(BGPVARI) Q 1_U_"Td"
  1.  K BGPG S %=P_"^ALL DX [BGP TD IZ DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE,E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)) Q 1_U_"Td"
  1.  F BGPZ=9,113 S X=$$ANCONT^BGP2D31(P,BGPZ,EDATE) Q:X]""
  1.  I X]"" Q 4_U_"Contra Td"
  1.  ;now go to Refusals
  1.  S B=$$DOB^AUPNPAT(P),E=EDATE,BGPNMI="",R=""
  1.  F BGPIMM=9,113  D
  1.  .S I=$O(^AUTTIMM("C",BGPIMM,0)) Q:'I
  1.  .S X=0 F  S X=$O(^AUPNPREF("AA",P,9999999.14,I,X)) Q:X'=+X  S Y=0 F  S Y=$O(^AUPNPREF("AA",P,9999999.14,I,X,Y)) Q:Y'=+Y  S D=$P(^AUPNPREF(Y,0),U,3) I D'<B&(D'>E) S:$P(^AUPNPREF(Y,0),U,7)="N" BGPNMI=1 S R=1
  1.  I R Q $S(BGPNMI:4,1:3)_U_$S(BGPNMI:"NMI Td",1:"Ref Td")
  1.  ;now check Refusals in imm pkg
  1.  F BGPIMM=9,113 S R=$$IMMREF^BGP2D32(P,BGPIMM,$$DOB^AUPNPAT(P),EDATE)+R
  1.  I R Q 3_U_"Ref imm pkg Td"
  1.  Q ""