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

APCHS9B7.m

Go to the documentation of this file.
  1. APCHS9B7 ; IHS/CMI/LAB - DIABETIC CARE SUMMARY SUPPLEMENT 06 Jan 2005 5:09 PM ;
  1. ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1. ;
  1. ;
  1. EKG(P) ;EP
  1. NEW APCHY,%,LEKG S LEKG="",%=P_"^LAST DIAGNOSTIC ECG SUMMARY",E=$$START1^APCLDF(%,"APCHY(")
  1. I $D(APCHY) S LEKG=$P(APCHY(1),U)_U_$$VAL^XBDIQ1(9000010.21,+$P(APCHY(1),U,4),.04)
  1. K APCHY S %=P_"^LAST PROCEDURE 89.51",E=$$START1^APCLDF(%,"APCHY(")
  1. I $D(APCHY(1)) D
  1. .Q:LEKG>$P(APCHY(1),U)
  1. .S LEKG=$P(APCHY(1),U)
  1. K APCHY S %=P_"^LAST PROCEDURE 89.52",E=$$START1^APCLDF(%,"APCHY(")
  1. I $D(APCHY(1)) D
  1. .Q:LEKG>$P(APCHY(1),U)
  1. .S LEKG=$P(APCHY(1),U)
  1. K APCHY S %=P_"^LAST PROCEDURE 89.53",E=$$START1^APCLDF(%,"APCHY(")
  1. I $D(APCHY(1)) D
  1. .Q:LEKG>$P(APCHY(1),U)
  1. .S LEKG=$P(APCHY(1),U)
  1. ;check CPT
  1. S T=$O(^ATXAX("B","DM AUDIT EKG CPTS",0))
  1. K APCHY I T S APCHY(1)=$$CPT(P,,,T,3) D
  1. .I APCHY(1)="" K APCHY Q
  1. .Q:LEKG>$P(APCHY(1),U)
  1. .S LEKG=$P(APCHY(1),U)
  1. K APCHY I T S APCHY(1)=$$RAD(P,,,T,3) D
  1. .I APCHY(1)="" K APCHY Q
  1. .Q:LEKG>$P(APCHY(1),U)
  1. .S LEKG=$P(APCHY(1),U)
  1. ;
  1. ;
  1. Q $$FMTE^XLFDT(LEKG)_U_$P(LEKG,U,2)
  1. ;
  1. CPT(P,BDATE,EDATE,T,F) ;
  1. I '$G(P) Q ""
  1. I '$G(T) Q ""
  1. I '$G(F) S F=1
  1. I $G(EDATE)="" S EDATE=DT
  1. I $G(BDATE)="" S BDATE=$P(^DPT(P,0),U,3)
  1. ;go through visits in a date range for this patient, check cpts
  1. NEW D,BD,ED,X,Y,D,G,V
  1. S ED=9999999-EDATE,BD=9999999-BDATE,G=0
  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 X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!(G) D
  1. ...I $$ICD^ATXCHK($P(^AUPNVCPT(X,0),U),T,1) S G=X
  1. ...Q
  1. ..Q
  1. .Q
  1. I 'G Q ""
  1. I F=1 Q $S(G:1,1:"")
  1. I F=2 Q G
  1. I F=3 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
  1. I F=4 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
  1. Q ""
  1. RAD(P,BDATE,EDATE,T,F) ;return if a v rad entry in date range
  1. I '$G(P) Q ""
  1. I '$G(T) Q ""
  1. I '$G(F) S F=1
  1. I $G(EDATE)="" S EDATE=DT
  1. I $G(BDATE)="" S BDATE=$P(^DPT(P,0),U,3)
  1. ;go through visits in a date range for this patient, check cpts
  1. NEW D,BD,ED,X,Y,D,G,V
  1. S ED=9999999-EDATE,BD=9999999-BDATE,G=0
  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(^AUPNVRAD("AD",V))
  1. ..S X=0 F S X=$O(^AUPNVRAD("AD",V,X)) Q:X'=+X!(G) D
  1. ...Q:'$D(^AUPNVRAD(X,0))
  1. ...S Y=$P(^AUPNVRAD(X,0),U) Q:'Y Q:'$D(^RAMIS(71,Y,0))
  1. ...S Y=$P($G(^RAMIS(71,Y,0)),U,9) Q:'Y
  1. ...Q:'$$ICD^ATXCHK(Y,T,1)
  1. ...S G=X
  1. ...Q
  1. ..Q
  1. .Q
  1. I 'G Q ""
  1. I F=1 Q $S(G:1,1:"")
  1. I F=2 Q G
  1. I F=3 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
  1. I F=4 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
  1. Q ""