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

BGP6D27.m

Go to the documentation of this file. 
  1. BGP6D27 ; IHS/CMI/LAB - measure I2 ;
  1.  ;;16.1;IHS CLINICAL REPORTING;;MAR 22, 2016;Build 170
  1.  ;
  1.  ;
  1. AMP(P,EDATE) ;EP - DID PATIENT HAVE AMPUTATION
  1.  ;
  1.  NEW X,Y,Z,G,T,Y,D,%,E,BGPX,C,BGPG
  1.  ;CHECK DX 15.1
  1.  S BGPG=$$LASTPRC^BGP6UTL1(P,"BGP BILAT FOOT AMP PROCEDURES",$$DOB^AUPNPAT(P),EDATE)
  1.  I BGPG Q 1
  1.  S BGPG=$$CPT^BGP6DU(P,$$DOB^AUPNPAT(P),EDATE,$O(^ATXAX("B","BGP CPT BILAT FOOT AMP",0)))
  1.  I BGPG Q 1
  1.  ;check cpt codes for bilateral
  1.  ;loop through all cpt codes up to Edate and if any match quit
  1.  S (X,Y,Z,G)=0 K BGPX
  1.  S T=$O(^ATXAX("B","BGP FOOT AMP CPTS",0))
  1.  I T S %="" D  I %]"" Q %
  1.  .S Y=0 F  S Y=$O(^AUPNVCPT("AC",P,Y)) Q:Y'=+Y!(%]"")  D
  1.  ..S D=$P($G(^AUPNVCPT(Y,0)),U,3)
  1.  ..Q:D=""
  1.  ..S D=$P($P($G(^AUPNVSIT(D,0)),U),".") ;date done
  1.  ..Q:D=""
  1.  ..I D>EDATE Q
  1.  ..S X=$P(^AUPNVCPT(Y,0),U)
  1.  ..Q:'$$ICD^BGP6UTL2(X,T,1)
  1.  ..S BGPX(D)=""
  1.  ..;
  1.  ..S M=$P(^AUPNVCPT(Y,0),U,8) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1_U_$$DATE^BGP6UTL(D)_" FOOT AMP "_$P(^ICPT(X,0),U,1)
  1.  ..S M=$P(^AUPNVCPT(Y,0),U,9) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1_U_$$DATE^BGP6UTL(D)_" FOOT AMP "_$P(^ICPT(X,0),U,1)
  1.  ..Q
  1.  .Q
  1.  ; now check tran codes
  1.  I T,$D(^AUPNVTC("AC",P)) S %="" D  I %]"" Q %
  1.  .S E=0 F  S E=$O(^AUPNVTC("AC",P,E)) Q:E'=+E!(%]"")  D
  1.  ..S D=$P($G(^AUPNVTC(E,0)),U,3) Q:'D  S D=$P($P($G(^AUPNVSIT(D,0)),U),".")
  1.  ..Q:'$$ICD^BGP6UTL2($P(^AUPNVTC(E,0),U,7),T,1)
  1.  ..S Y=$P(^AUPNVTC(E,0),U,7)
  1.  ..I D>EDATE Q
  1.  ..S BGPX(D)=""
  1.  ..S M=$P(^AUPNVTC(E,0),U,12) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1_U_$$DATE^BGP6UTL(D)_" FOOT AMP "_$P(^ICPT(Y,0),U,1)
  1.  ..S M=$P(^AUPNVTC(E,0),U,15) I M S M=$P($G(^AUTTCMOD(M,0)),U) I M=50 S %=1_U_$$DATE^BGP6UTL(D)_" FOOT AMP "_$P(^ICPT(Y,0),U,1)
  1.  ..Q
  1.  .Q
  1.  ;see if 2 on different dates
  1.  S %=0,X=0,C=0 F  S X=$O(BGPX(X)) Q:X'=+X  S C=C+1
  1.  I C>1 Q 1
  1.  S T=$O(^ATXAX("B","BGP FOOT AMP PROCEDURES",0))
  1.  S (F,S)=0 F  S F=$O(^AUPNVPRC("AC",P,F)) Q:F'=+F  S C=$P(^AUPNVPRC(F,0),U) D
  1.  .S G=0 S:$$ICD^BGP6UTL2(C,T,0) G=1
  1.  .Q:G=0
  1.  .S D=$P(^AUPNVPRC(F,0),U,6) I D="" S D=$P($P(^AUPNVSIT($P(^AUPNVPRC(F,0),U,3),0),U),".")
  1.  .I D>EDATE Q
  1.  .S BGPX(D)=""
  1.  S %=0,X=0,C=0 F  S X=$O(BGPX(X)) Q:X'=+X  S C=C+1
  1.  I C>1 Q 1
  1.  ;NOW ADD IN DX CODES
  1.  K BGPG
  1.  S Y="BGPG("
  1.  S X=P_"^ALL DX [BGP UNILATERAL FOOT AMP DXS;DURING "_$$DOB^AUPNPAT(P)_"-"_EDATE S E=$$START1^APCLDF(X,Y)
  1.  S %=0 F  S %=$O(BGPG(%)) Q:%'=+%  S D=$P(BGPG(%),U,1),BGPX(D)=""
  1.  S %=0,X=0,C=0 F  S X=$O(BGPX(X)) Q:X'=+X  S C=C+1
  1.  I C>1 Q 1
  1.  Q 0
  1. DEPSCRBH(P,BDATE,EDATE) ;EP
  1.  NEW BGPDEPS,BGPG,%,E,Y,X,BGPC,D,V,BGPP,BGPTC
  1.  S BGPDEPS=""
  1.  I $G(P)="" Q ""
  1.  S BGPTC=$O(^BGPCTRL("B",2016,0))
  1. BH S D=0,BGPC="",E=9999999-BDATE,D=9999999-EDATE-1_".99" F  S D=$O(^AMHREC("AE",P,D)) Q:D'=+D!($P(D,".")>E)!(BGPC)  S V=0 F  S V=$O(^AMHREC("AE",P,D,V)) Q:V'=+V!(BGPC)  D
  1.  .Q:'$D(^AMHREC(V,0))
  1.  .S C=$P(^AMHREC(V,0),U,25)
  1.  .Q:'C
  1.  .S C=$P($G(^DIC(40.7,C,0)),U,2)
  1.  .Q:C=""
  1.  .Q:'$D(^BGPCTRL(BGPTC,50,"B",C))  ;not BH clinic
  1.  .I $P($G(^AMHREC(V,14)),U,5)="P"!($P($G(^AMHREC(V,14)),U,5)="N") S BGPC=1_U_C_U_$$DATE^BGP6UTL(9999999-D)_U_(9999999-D)_U_C
  1.  .Q:BGPC
  1.  .S X=0 F  S X=$O(^AMHRPRO("AD",V,X)) Q:X'=+X!(BGPC)  S BGPP=$P($G(^AMHRPRO(X,0)),U) D
  1.  ..Q:'BGPP
  1.  ..S BGPP=$P($G(^AMHPROB(BGPP,0)),U)
  1.  ..I BGPP=14.1 S BGPC=1_U_C_U_$$DATE^BGP6UTL(9999999-D)_U_(9999999-D)_U_C Q
  1.  .Q:BGPC
  1.  .S X=0 F  S X=$O(^AMHRMSR("AD",V,X)) Q:X'=+X!(BGPC)  S BGPP=$P($G(^AMHRMSR(X,0)),U) D
  1.  ..Q:'BGPP
  1.  ..S BGPP=$P($G(^AUTTMSR(BGPP,0)),U)
  1.  ..I BGPP="PHQ2"!(BGPP="PHQ9") S BGPC=1_U_C_U_$$DATE^BGP6UTL(9999999-D)_U_(9999999-D)_U_C
  1.  .Q:BGPC
  1.  .S X=0 F  S X=$O(^AMHRPROC("AD",V,X)) Q:X'=+X!(BGPC)  S BGPP=$P($G(^AMHRPROC(X,0)),U) D
  1.  ..Q:'BGPP
  1.  ..Q:'$$ICD^BGP6UTL2(BGPP,$O(^ATXAX("B","BGP DEPRESSION SCREEN CPTS",0)),1)
  1.  ..S BGPC=1_U_C_U_$$DATE^BGP6UTL(9999999-D)_U_(9999999-D)_U_C
  1.  I BGPC]"",$P(BGPDEPS,U,4)<$P(BGPC,U,4) S BGPDEPS=BGPC
  1.  K BGPG S %=P_"^ALL EXAM 36;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE),E=$$START1^APCLDF(%,"BGPG(")
  1.  I $D(BGPG(1)) D
  1.  .S E=0 F  S E=$O(BGPG(E)) Q:E'=+E  S V=$P(BGPG(E),U,5),C=$$CLINIC^APCLV(V,"C") D
  1.  ..Q:C=""
  1.  ..Q:'$D(^BGPCTRL(BGPTC,50,"B",C))  ;not BH clinic
  1.  ..I $P(BGPDEPS,U,4)<$P(BGPG(E),U) S BGPDEPS=1_"^"_C_U_$$DATE^BGP6UTL($P(BGPG(E),U))_U_$P(BGPG(E),U)_U_C
  1.  K BGPG
  1.  S Y="BGPG("
  1.  S X=P_"^ALL DX [BGP DEPRESSION SCRN DXS;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  I $D(BGPG(1)) D
  1.  .S E=0 F  S E=$O(BGPG(E)) Q:E'=+E  S V=$P(BGPG(E),U,5),C=$$CLINIC^APCLV(V,"C") D
  1.  ..Q:C=""
  1.  ..Q:'$D(^BGPCTRL(BGPTC,50,"B",C))  ;not BH clinic
  1.  ..I $P(BGPDEPS,U,4)<$P(BGPG(E),U) S BGPDEPS=1_"^"_C_U_$$DATE^BGP6UTL($P(BGPG(E),U))_U_$P(BGPG(E),U)_U_C
  1.  ;now add in v measurements
  1.  K BGPG
  1.  S Y="BGPG("
  1.  S X=P_"^ALL MEAS PHQ2;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  I $D(BGPG(1)) D
  1.  .S E=0 F  S E=$O(BGPG(E)) Q:E'=+E  S V=$P(BGPG(E),U,5),C=$$CLINIC^APCLV(V,"C") D
  1.  ..Q:C=""
  1.  ..Q:'$D(^BGPCTRL(BGPTC,50,"B",C))  ;not BH clinic
  1.  ..I $P(BGPDEPS,U,4)<$P(BGPG(E),U) S BGPDEPS=1_C_U_$$DATE^BGP6UTL($P(BGPG(E),U))_U_$P(BGPG(E),U)_U_C
  1.  K BGPG
  1.  S Y="BGPG("
  1.  S X=P_"^ALL MEAS PHQ9;DURING "_$$FMTE^XLFDT(BDATE)_"-"_$$FMTE^XLFDT(EDATE) S E=$$START1^APCLDF(X,Y)
  1.  I $D(BGPG(1)) D
  1.  .S E=0 F  S E=$O(BGPG(E)) Q:E'=+E  S V=$P(BGPG(E),U,5),C=$$CLINIC^APCLV(V,"C") D
  1.  ..Q:C=""
  1.  ..Q:'$D(^BGPCTRL(BGPTC,50,"B",C))  ;not BH clinic
  1.  ..I $P(BGPDEPS,U,4)<$P(BGPG(E),U) S BGPDEPS=1_C_U_$$DATE^BGP6UTL($P(BGPG(E),U))_U_$P(BGPG(E),U)_U_C
  1. BHSCRC ;
  1.  ;go through visits in a date range for this patient, check cpts
  1.  NEW BD,ED
  1.  S ED=(9999999-EDATE),BD=9999999-BDATE,G=""
  1.  F  S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G)  D
  1.  .S V=0 F  S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G)  D
  1.  ..Q:'$D(^AUPNVSIT(V,0))
  1.  ..Q:'$D(^AUPNVCPT("AD",V))
  1.  ..S C=$$CLINIC^APCLV(V,"C")
  1.  ..Q:C=""
  1.  ..Q:'$D(^BGPCTRL(BGPTC,50,"B",C))
  1.  ..S X=0 F  S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!(G)  D
  1.  ...I $$ICD^BGP6UTL2($P(^AUPNVCPT(X,0),U),$O(^ATXAX("B","BGP DEPRESSION SCREEN CPTS",0)),1) S G=1_U_C_U_$$DATE^BGP6UTL($$VD^APCLV(V))_U_$$VD^APCLV(V)_U_C
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  I G,$P(BGPDEPS,U,4)<$P(G,U,1) S BGPDEPS=G
  1.  Q BGPDEPS