BHSDM7 ;IHS/CIA/MGH - Health Summary for Diabetic Supplement ;30-Nov-2015 10:25;DU
;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,4,12**;March 17, 2006;Build 3
;===================================================================
;VA version of IHS components for supplemental summaries
;Taken from APCHS9B7
; IHS/TUCSON/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ; [ 02/19/03 7:23 AM ]
;;2.0;IHS RPMS/PCC Health Summary;**10**;JUN 24, 1997
;Patch 1 updates to patch 14 from IHS
;Patch 12 updated for new API for taxonomies
;====================================================================
;
EKG(P) ; EP
NEW APCHY,%,LEKG,E,TAXARR
S LEKG="",%=P_"^LAST DIAGNOSTIC ECG SUMMARY",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY) S LEKG=$P(APCHY(1),U)_U_$$VAL^XBDIQ1(9000010.21,+$P(APCHY(1),U,4),.04)
K APCHY S %=P_"^LAST PROCEDURE 89.51",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)) D
.Q:LEKG>$P(APCHY(1),U)
.S LEKG=$P(APCHY(1),U)
K APCHY S %=P_"^LAST PROCEDURE 89.52",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)) D
.Q:LEKG>$P(APCHY(1),U)
.S LEKG=$P(APCHY(1),U)
K APCHY S %=P_"^LAST PROCEDURE 89.53",E=$$START1^APCLDF(%,"APCHY(")
I $D(APCHY(1)) D
.Q:LEKG>$P(APCHY(1),U)
.S LEKG=$P(APCHY(1),U)
;check CPT codes in year prior to date range
S T=$O(^ATXAX("B","DM AUDIT EKG CPTS",0))
K APCHY I T S APCHY(1)=$$CPT(P,,,T,3) D
.I APCHY(1)="" K APCHY Q
.Q:LEKG>$P(APCHY(1),U)
.S LEKG=$P(APCHY(1),U)
K APCHY I T S APCHY(1)=$$RAD(P,,,T,3) D
.I APCHY(1)="" K APCHY Q
.Q:LEKG>$P(APCHY(1),U)
.S LEKG=$P(APCHY(1),U)
;
;
Q $$FMTE^XLFDT(LEKG)
;
CPT(P,BDATE,EDATE,T,F) ;
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
I $G(EDATE)="" S EDATE=DT
I $G(BDATE)="" S BDATE=$P(^DPT(P,0),U,3)
;go through visits in a date range for this patient, check cpts
NEW D,BD,ED,X,Y,D,G,V
S ED=9999999-EDATE,BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G) D
..Q:'$D(^AUPNVSIT(V,0))
..Q:'$D(^AUPNVCPT("AD",V))
..S X=0 F S X=$O(^AUPNVCPT("AD",V,X)) Q:X'=+X!(G) D
...I $$ICD^ATXAPI($P(^AUPNVCPT(X,0),U),T,1) S G=X
...Q
..Q
.Q
I 'G Q ""
I F=1 Q $S(G:1,1:"")
I F=2 Q G
I F=3 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
I F=4 S V=$P(^AUPNVCPT(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
Q ""
RAD(P,BDATE,EDATE,T,F) ;return if a v rad entry in date range
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(F) S F=1
I $G(EDATE)="" S EDATE=DT
I $G(BDATE)="" S BDATE=$P(^DPT(P,0),U,3)
;go through visits in a date range for this patient, check cpts
NEW D,BD,ED,X,Y,D,G,V
S ED=9999999-EDATE,BD=9999999-BDATE,G=0
F S ED=$O(^AUPNVSIT("AA",P,ED)) Q:ED=""!($P(ED,".")>BD)!(G) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,ED,V)) Q:V'=+V!(G) D
..Q:'$D(^AUPNVSIT(V,0))
..Q:'$D(^AUPNVRAD("AD",V))
..S X=0 F S X=$O(^AUPNVRAD("AD",V,X)) Q:X'=+X!(G) D
...Q:'$D(^AUPNVRAD(X,0))
...S Y=$P(^AUPNVRAD(X,0),U) Q:'Y Q:'$D(^RAMIS(71,Y,0))
...S Y=$P($G(^RAMIS(71,Y,0)),U,9) Q:'Y
...Q:'$$ICD^ATXCHK(Y,T,1)
...S G=X
...Q
..Q
.Q
I 'G Q ""
I F=1 Q $S(G:1,1:"")
I F=2 Q G
I F=3 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $P($P($G(^AUPNVSIT(V,0)),U),".")
I F=4 S V=$P(^AUPNVRAD(G,0),U,3) I V Q $$FMTE^XLFDT($P($P($G(^AUPNVSIT(V,0)),U),"."))
Q ""
BHSDM7 ;IHS/CIA/MGH - Health Summary for Diabetic Supplement ;30-Nov-2015 10:25;DU
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,4,12**;March 17, 2006;Build 3
+2 ;===================================================================
+3 ;VA version of IHS components for supplemental summaries
+4 ;Taken from APCHS9B7
+5 ; IHS/TUCSON/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ; [ 02/19/03 7:23 AM ]
+6 ;;2.0;IHS RPMS/PCC Health Summary;**10**;JUN 24, 1997
+7 ;Patch 1 updates to patch 14 from IHS
+8 ;Patch 12 updated for new API for taxonomies
+9 ;====================================================================
+10 ;
EKG(P) ; EP
+1 NEW APCHY,%,LEKG,E,TAXARR
+2 SET LEKG=""
SET %=P_"^LAST DIAGNOSTIC ECG SUMMARY"
SET E=$$START1^APCLDF(%,"APCHY(")
+3 IF $DATA(APCHY)
SET LEKG=$PIECE(APCHY(1),U)_U_$$VAL^XBDIQ1(9000010.21,+$PIECE(APCHY(1),U,4),.04)
+4 KILL APCHY
SET %=P_"^LAST PROCEDURE 89.51"
SET E=$$START1^APCLDF(%,"APCHY(")
+5 IF $DATA(APCHY(1))
Begin DoDot:1
+6 IF LEKG>$PIECE(APCHY(1),U)
QUIT
+7 SET LEKG=$PIECE(APCHY(1),U)
End DoDot:1
+8 KILL APCHY
SET %=P_"^LAST PROCEDURE 89.52"
SET E=$$START1^APCLDF(%,"APCHY(")
+9 IF $DATA(APCHY(1))
Begin DoDot:1
+10 IF LEKG>$PIECE(APCHY(1),U)
QUIT
+11 SET LEKG=$PIECE(APCHY(1),U)
End DoDot:1
+12 KILL APCHY
SET %=P_"^LAST PROCEDURE 89.53"
SET E=$$START1^APCLDF(%,"APCHY(")
+13 IF $DATA(APCHY(1))
Begin DoDot:1
+14 IF LEKG>$PIECE(APCHY(1),U)
QUIT
+15 SET LEKG=$PIECE(APCHY(1),U)
End DoDot:1
+16 ;check CPT codes in year prior to date range
+17 SET T=$ORDER(^ATXAX("B","DM AUDIT EKG CPTS",0))
+18 KILL APCHY
IF T
SET APCHY(1)=$$CPT(P,,,T,3)
Begin DoDot:1
+19 IF APCHY(1)=""
KILL APCHY
QUIT
+20 IF LEKG>$PIECE(APCHY(1),U)
QUIT
+21 SET LEKG=$PIECE(APCHY(1),U)
End DoDot:1
+22 KILL APCHY
IF T
SET APCHY(1)=$$RAD(P,,,T,3)
Begin DoDot:1
+23 IF APCHY(1)=""
KILL APCHY
QUIT
+24 IF LEKG>$PIECE(APCHY(1),U)
QUIT
+25 SET LEKG=$PIECE(APCHY(1),U)
End DoDot:1
+26 ;
+27 ;
+28 QUIT $$FMTE^XLFDT(LEKG)
+29 ;
CPT(P,BDATE,EDATE,T,F) ;
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 IF $GET(EDATE)=""
SET EDATE=DT
+5 IF $GET(BDATE)=""
SET BDATE=$PIECE(^DPT(P,0),U,3)
+6 ;go through visits in a date range for this patient, check cpts
+7 NEW D,BD,ED,X,Y,D,G,V
+8 SET ED=9999999-EDATE
SET BD=9999999-BDATE
SET G=0
+9 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
Begin DoDot:1
+10 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V!(G)
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 IF '$DATA(^AUPNVCPT("AD",V))
QUIT
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVCPT("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+14 IF $$ICD^ATXAPI($PIECE(^AUPNVCPT(X,0),U),T,1)
SET G=X
+15 QUIT
End DoDot:3
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 IF 'G
QUIT ""
+19 IF F=1
QUIT $SELECT(G:1,1:"")
+20 IF F=2
QUIT G
+21 IF F=3
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+22 IF F=4
SET V=$PIECE(^AUPNVCPT(G,0),U,3)
IF V
QUIT $$FMTE^XLFDT($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))
+23 QUIT ""
RAD(P,BDATE,EDATE,T,F) ;return if a v rad entry in date range
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(F)
SET F=1
+4 IF $GET(EDATE)=""
SET EDATE=DT
+5 IF $GET(BDATE)=""
SET BDATE=$PIECE(^DPT(P,0),U,3)
+6 ;go through visits in a date range for this patient, check cpts
+7 NEW D,BD,ED,X,Y,D,G,V
+8 SET ED=9999999-EDATE
SET BD=9999999-BDATE
SET G=0
+9 FOR
SET ED=$ORDER(^AUPNVSIT("AA",P,ED))
IF ED=""!($PIECE(ED,".")>BD)!(G)
QUIT
Begin DoDot:1
+10 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,ED,V))
IF V'=+V!(G)
QUIT
Begin DoDot:2
+11 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+12 IF '$DATA(^AUPNVRAD("AD",V))
QUIT
+13 SET X=0
FOR
SET X=$ORDER(^AUPNVRAD("AD",V,X))
IF X'=+X!(G)
QUIT
Begin DoDot:3
+14 IF '$DATA(^AUPNVRAD(X,0))
QUIT
+15 SET Y=$PIECE(^AUPNVRAD(X,0),U)
IF 'Y
QUIT
IF '$DATA(^RAMIS(71,Y,0))
QUIT
+16 SET Y=$PIECE($GET(^RAMIS(71,Y,0)),U,9)
IF 'Y
QUIT
+17 IF '$$ICD^ATXCHK(Y,T,1)
QUIT
+18 SET G=X
+19 QUIT
End DoDot:3
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
+22 IF 'G
QUIT ""
+23 IF F=1
QUIT $SELECT(G:1,1:"")
+24 IF F=2
QUIT G
+25 IF F=3
SET V=$PIECE(^AUPNVRAD(G,0),U,3)
IF V
QUIT $PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),".")
+26 IF F=4
SET V=$PIECE(^AUPNVRAD(G,0),U,3)
IF V
QUIT $$FMTE^XLFDT($PIECE($PIECE($GET(^AUPNVSIT(V,0)),U),"."))
+27 QUIT ""
