BHSDM3 ;IHS/CIA/MGH - Health Summary for Diabetic Supplement ;19-Jan-2009 15:36;MGH
;;1.0;HEALTH SUMMARY COMPONENTS;**1,2**;March 17, 2006
;===================================================================
;VA version of IHS components for supplemental summaries
;Taken from APCHHS9B3
; IHS/TUCSON/LAB - ; [ 05/26/04 12:46 PM ]
;;2.0;IHS RPMS/PCC Health Summary;**3,5,8,9,10,11,12**;JUN 24, 1997
;Patch 1 to update to IHS patch 14
;Patch 2 for pt ed
;=====================================================================
; ;
BI() ;EP- check to see if using new imm package or not 1/5/1999 IHS/CMI/LAB
Q $S($O(^AUTTIMM(0))<100:0,1:1)
TD(P,BHSED) ;EP
NEW APCHY,X,E,B,%DT,Y,TDD
S TDD=$$LASTTD^BHSMU2(P)
S X=$$FMADD^XLFDT(DT,-(10*365))
I TDD>X Q "Yes "_$$FMTE^XLFDT(TDD)
S G=$$REFDF^BHSDM3(P,9999999.14,$O(^AUTTIMM("C",9,0)))
I G]"" Q G
S G=$$REFDF^BHSDM3(P,9999999.14,$O(^AUTTIMM("C",1,0)))
I G]"" Q G
S G=$$REFDF^BHSDM3(P,9999999.14,$O(^AUTTIMM("C",20,0)))
I G]"" Q G
S G=$$REFDF^BHSDM3(P,9999999.14,$O(^AUTTIMM("C",22,0)))
I G]"" Q G
S G=$$REFDF^BHSDM3(P,9999999.14,$O(^AUTTIMM("C",28,0)))
I G]"" Q G
S G=$$REFDF^BHSDM3(P,9999999.14,$O(^AUTTIMM("C",35,0)))
I G]"" Q G
S G=$$REFDF^BHSDM3(P,9999999.14,$O(^AUTTIMM("C",50,0)))
I G]"" Q G
S G=$$REFDF^BHSDM3(P,9999999.14,$O(^AUTTIMM("C",106,0)))
I G]"" Q G
S G=$$REFDF^BHSDM3(P,9999999.14,$O(^AUTTIMM("C",107,0)))
I G]"" Q G
S G=$$REFDF^BHSDM3(P,9999999.14,$O(^AUTTIMM("C",110,0)))
I G]"" Q G
;Next two added in patch 1
S G=$$REFDF^APCHS9B3(P,9999999.14,$O(^AUTTIMM("C",113,0)))
I G]"" Q G
S G=$$REFDF^APCHS9B3(P,9999999.14,$O(^AUTTIMM("C",115,0)))
I G]"" Q G
Q "No "_$$FMTE^XLFDT(TDD,U)
FLU(P) ;EP
NEW APCHY,%,LFLU,E,T,X
S LFLU=$$LASTFLU^BHSMU2(P)
I LFLU="" G FLUR
;K APCHY S %=0 F S %=$O(LFLU(%)) Q:%'=+% S APCHY(1)=%
FLU1 NEW D S D=$S($E(DT,4,5)>7:$E(DT,1,3)_"0801",1:$E(DT,1,3)-1_"0801")
I LFLU'<D Q "Yes "_$$FMTE^XLFDT($P(LFLU,U))
FLUR ;
S G=$$REFDF^BHSDM3(BHSPAT,9999999.14,$O(^AUTTIMM("C",$S($$BI:15,1:12),0)),LFLU)
I G]"" Q G
S G=$$REFDF^BHSDM3(BHSPAT,9999999.14,$O(^AUTTIMM("C",$S($$BI:16,1:12),0)),LFLU)
I G]"" Q G
S G=$$REFDF^BHSDM3(BHSPAT,9999999.14,$O(^AUTTIMM("C",$S($$BI:88,1:12),0)),LFLU)
I G]"" Q G
S G=$$REFDF^BHSDM3(BHSPAT,9999999.14,$O(^AUTTIMM("C",$S($$BI:111,1:12),0)),LFLU)
I G]"" Q G
Q "No "_$$FMTE^XLFDT(LFLU,U)
REFDF(P,F,I,D) ;EP - dm item refused?
I '$G(P) Q ""
I '$G(F) Q ""
I '$G(I) Q ""
I $G(D)="" S D=""
NEW X S X=$O(^AUPNPREF("AA",P,F,I,0))
I 'X Q "" ;none of this item was refused
NEW Y S Y=9999999-X
I D]"",Y>D Q "Patient Refused "_$$VAL^XBDIQ1(F,I,.01)_" on "_$$FMTE^XLFDT(Y)
Q "Patient Refused "_$$VAL^XBDIQ1(F,I,.01)_" on "_$$FMTE^XLFDT(Y)
DIETV(P) ;EP
I '$G(P) Q ""
;get all dietician visits
;go through all visits in AA and get last to Prov 29 or
NEW D,V,G,X S (D,V,G)="" F S D=$O(^AUPNVSIT("AA",P,D)) Q:D'=+D!(G) D
.S V=0 F S V=$O(^AUPNVSIT("AA",P,D,V)) Q:V'=+V!(G) D
..Q:'$D(^AUPNVSIT(V,0))
..Q:$P(^AUPNVSIT(V,0),U,11)
..Q:'$P(^AUPNVSIT(V,0),U,9)
..Q:'$D(^AUPNVPOV("AD",V))
..Q:'$D(^AUPNVPRV("AD",V))
..Q:$$DNKA^BHSDM4(V)
..Q:$$CLINIC^APCLV(V,"C")=52 ;chart review
..I $P(^AUPNVSIT(V,0),U,7)="C" Q ;chart review
..I $$CLINIC^APCLV(V,"C")=67 S G=V Q
..S X=$$DIETP(V) ; is there a prov 07 or 29
..I X S G=V Q
..Q
.Q
I 'G Q ""
Q $$FMTE^XLFDT($P($P(^AUPNVSIT(G,0),U),"."))_" "_$E($$PRIMPOV^APCLV(G,"N"),1,39)
DIETP(V) ;are any providers an 07 or 29
I '$G(V) Q ""
NEW X,Y,Z,H
S H="",Z=0 F S Z=$O(^AUPNVPRV("AD",V,Z)) Q:Z'=+Z!(H) D
.S Y=$P(^AUPNVPRV(Z,0),U) ;provider ien
.I $P(^DD(9000010.06,.01,0),U,2)[200 S Y=$$PROVCLSC^XBFUNC1(Y) I Y=29!(Y="07") S H=1 Q
.Q
Q H
SELF(P,D) ;EP
I '$G(P) Q ""
I '$G(D) S D=0 ;if don't pass date look at all time
NEW V,I,%
S %=""
NEW T S T=$O(^ATXAX("B","DM AUDIT SELF MONITOR DRUGS",0))
I 'T Q "<<Missing DM AUDIT SELF MONITOR DRUGS taxonomy>>"
S I=0 F S I=$O(^AUPNVMED("AA",P,I)) Q:I'=+I!(%)!(I>(9999999-D)) D
.S V=0 F S V=$O(^AUPNVMED("AA",P,I,V)) Q:V'=+V I $D(^AUPNVMED(V,0)) S G=$P(^AUPNVMED(V,0),U) I $D(^ATXAX(T,21,"B",G)) S %=V
I %]"" D Q %
.I $P(^AUPNVMED(%,0),U,8)="" S %="Yes, dispensed "_$$VAL^XBDIQ1(9000010.14,%,.01)_" on "_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),".")) Q
.I $P(^AUPNVMED(%,0),U,8)]"" S %="Discontinued - "_$$VAL^XBDIQ1(9000010.14,%,.01)_" on "_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),".")) Q
S V=$$LASTHF^BHSMU(BHSDFN,"DIABETES SELF MONITORING","B") I V]"" Q V
Q "No Evidence in the past year"
EDUCREF ;EP - gather up all education provided in past year in APCHX
K APCHX,APCHY
S APCHY=0 F S APCHY=$O(^AUPNPREF("AA",BHSPAT,9999999.09,APCHY)) Q:APCHY'=+APCHY I $$EDT(APCHY) S APCHD=$O(^AUPNPREF("AA",BHSPAT,9999999.09,APCHY,0)) I APCHD<(9999999-BHSBEG) D
.S APCHX($P(^AUTTEDT(APCHY,0),U))=$$FMTE^XLFDT(9999999-APCHD)
Q
EDT(E) ;
;is this ien in any taxonomy
NEW T
S T=$O(^ATXAX("B","DM AUDIT DIABETES EDUC TOPICS",0))
I T,$D(^ATXAX(T,21,"B",E)) Q 1
S T=$O(^ATXAX("B","DM AUDIT DIET EDUC TOPICS",0))
I T,$D(^ATXAX(T,21,"B",E)) Q 1
S T=$O(^ATXAX("B","DM AUDIT EXERCISE EDUC TOPICS",0))
I T,$D(^ATXAX(T,21,"B",E)) Q 1
S T=$O(^ATXAX("B","DM AUDIT OTHER EDUC TOPICS",0))
I T,$D(^ATXAX(T,21,"B",E)) Q 1
S T=$P($G(^AUTTEDT(T,0)),U,2)
I $P(T,"-")="DM" Q 1
I $P(T,"-")="DMC" Q 1
Q ""
BHSDM3 ;IHS/CIA/MGH - Health Summary for Diabetic Supplement ;19-Jan-2009 15:36;MGH
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2**;March 17, 2006
+2 ;===================================================================
+3 ;VA version of IHS components for supplemental summaries
+4 ;Taken from APCHHS9B3
+5 ; IHS/TUCSON/LAB - ; [ 05/26/04 12:46 PM ]
+6 ;;2.0;IHS RPMS/PCC Health Summary;**3,5,8,9,10,11,12**;JUN 24, 1997
+7 ;Patch 1 to update to IHS patch 14
+8 ;Patch 2 for pt ed
+9 ;=====================================================================
+10 ; ;
BI() ;EP- check to see if using new imm package or not 1/5/1999 IHS/CMI/LAB
+1 QUIT $SELECT($ORDER(^AUTTIMM(0))<100:0,1:1)
TD(P,BHSED) ;EP
+1 NEW APCHY,X,E,B,%DT,Y,TDD
+2 SET TDD=$$LASTTD^BHSMU2(P)
+3 SET X=$$FMADD^XLFDT(DT,-(10*365))
+4 IF TDD>X
QUIT "Yes "_$$FMTE^XLFDT(TDD)
+5 SET G=$$REFDF^BHSDM3(P,9999999.14,$ORDER(^AUTTIMM("C",9,0)))
+6 IF G]""
QUIT G
+7 SET G=$$REFDF^BHSDM3(P,9999999.14,$ORDER(^AUTTIMM("C",1,0)))
+8 IF G]""
QUIT G
+9 SET G=$$REFDF^BHSDM3(P,9999999.14,$ORDER(^AUTTIMM("C",20,0)))
+10 IF G]""
QUIT G
+11 SET G=$$REFDF^BHSDM3(P,9999999.14,$ORDER(^AUTTIMM("C",22,0)))
+12 IF G]""
QUIT G
+13 SET G=$$REFDF^BHSDM3(P,9999999.14,$ORDER(^AUTTIMM("C",28,0)))
+14 IF G]""
QUIT G
+15 SET G=$$REFDF^BHSDM3(P,9999999.14,$ORDER(^AUTTIMM("C",35,0)))
+16 IF G]""
QUIT G
+17 SET G=$$REFDF^BHSDM3(P,9999999.14,$ORDER(^AUTTIMM("C",50,0)))
+18 IF G]""
QUIT G
+19 SET G=$$REFDF^BHSDM3(P,9999999.14,$ORDER(^AUTTIMM("C",106,0)))
+20 IF G]""
QUIT G
+21 SET G=$$REFDF^BHSDM3(P,9999999.14,$ORDER(^AUTTIMM("C",107,0)))
+22 IF G]""
QUIT G
+23 SET G=$$REFDF^BHSDM3(P,9999999.14,$ORDER(^AUTTIMM("C",110,0)))
+24 IF G]""
QUIT G
+25 ;Next two added in patch 1
+26 SET G=$$REFDF^APCHS9B3(P,9999999.14,$ORDER(^AUTTIMM("C",113,0)))
+27 IF G]""
QUIT G
+28 SET G=$$REFDF^APCHS9B3(P,9999999.14,$ORDER(^AUTTIMM("C",115,0)))
+29 IF G]""
QUIT G
+30 QUIT "No "_$$FMTE^XLFDT(TDD,U)
FLU(P) ;EP
+1 NEW APCHY,%,LFLU,E,T,X
+2 SET LFLU=$$LASTFLU^BHSMU2(P)
+3 IF LFLU=""
GOTO FLUR
+4 ;K APCHY S %=0 F S %=$O(LFLU(%)) Q:%'=+% S APCHY(1)=%
FLU1 NEW D
SET D=$SELECT($EXTRACT(DT,4,5)>7:$EXTRACT(DT,1,3)_"0801",1:$EXTRACT(DT,1,3)-1_"0801")
+1 IF LFLU'<D
QUIT "Yes "_$$FMTE^XLFDT($PIECE(LFLU,U))
FLUR ;
+1 SET G=$$REFDF^BHSDM3(BHSPAT,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:15,1:12),0)),LFLU)
+2 IF G]""
QUIT G
+3 SET G=$$REFDF^BHSDM3(BHSPAT,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:16,1:12),0)),LFLU)
+4 IF G]""
QUIT G
+5 SET G=$$REFDF^BHSDM3(BHSPAT,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:88,1:12),0)),LFLU)
+6 IF G]""
QUIT G
+7 SET G=$$REFDF^BHSDM3(BHSPAT,9999999.14,$ORDER(^AUTTIMM("C",$SELECT($$BI:111,1:12),0)),LFLU)
+8 IF G]""
QUIT G
+9 QUIT "No "_$$FMTE^XLFDT(LFLU,U)
REFDF(P,F,I,D) ;EP - dm item refused?
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(F)
QUIT ""
+3 IF '$GET(I)
QUIT ""
+4 IF $GET(D)=""
SET D=""
+5 NEW X
SET X=$ORDER(^AUPNPREF("AA",P,F,I,0))
+6 ;none of this item was refused
IF 'X
QUIT ""
+7 NEW Y
SET Y=9999999-X
+8 IF D]""
IF Y>D
QUIT "Patient Refused "_$$VAL^XBDIQ1(F,I,.01)_" on "_$$FMTE^XLFDT(Y)
+9 QUIT "Patient Refused "_$$VAL^XBDIQ1(F,I,.01)_" on "_$$FMTE^XLFDT(Y)
DIETV(P) ;EP
+1 IF '$GET(P)
QUIT ""
+2 ;get all dietician visits
+3 ;go through all visits in AA and get last to Prov 29 or
+4 NEW D,V,G,X
SET (D,V,G)=""
FOR
SET D=$ORDER(^AUPNVSIT("AA",P,D))
IF D'=+D!(G)
QUIT
Begin DoDot:1
+5 SET V=0
FOR
SET V=$ORDER(^AUPNVSIT("AA",P,D,V))
IF V'=+V!(G)
QUIT
Begin DoDot:2
+6 IF '$DATA(^AUPNVSIT(V,0))
QUIT
+7 IF $PIECE(^AUPNVSIT(V,0),U,11)
QUIT
+8 IF '$PIECE(^AUPNVSIT(V,0),U,9)
QUIT
+9 IF '$DATA(^AUPNVPOV("AD",V))
QUIT
+10 IF '$DATA(^AUPNVPRV("AD",V))
QUIT
+11 IF $$DNKA^BHSDM4(V)
QUIT
+12 ;chart review
IF $$CLINIC^APCLV(V,"C")=52
QUIT
+13 ;chart review
IF $PIECE(^AUPNVSIT(V,0),U,7)="C"
QUIT
+14 IF $$CLINIC^APCLV(V,"C")=67
SET G=V
QUIT
+15 ; is there a prov 07 or 29
SET X=$$DIETP(V)
+16 IF X
SET G=V
QUIT
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
+19 IF 'G
QUIT ""
+20 QUIT $$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT(G,0),U),"."))_" "_$EXTRACT($$PRIMPOV^APCLV(G,"N"),1,39)
DIETP(V) ;are any providers an 07 or 29
+1 IF '$GET(V)
QUIT ""
+2 NEW X,Y,Z,H
+3 SET H=""
SET Z=0
FOR
SET Z=$ORDER(^AUPNVPRV("AD",V,Z))
IF Z'=+Z!(H)
QUIT
Begin DoDot:1
+4 ;provider ien
SET Y=$PIECE(^AUPNVPRV(Z,0),U)
+5 IF $PIECE(^DD(9000010.06,.01,0),U,2)[200
SET Y=$$PROVCLSC^XBFUNC1(Y)
IF Y=29!(Y="07")
SET H=1
QUIT
+6 QUIT
End DoDot:1
+7 QUIT H
SELF(P,D) ;EP
+1 IF '$GET(P)
QUIT ""
+2 ;if don't pass date look at all time
IF '$GET(D)
SET D=0
+3 NEW V,I,%
+4 SET %=""
+5 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT SELF MONITOR DRUGS",0))
+6 IF 'T
QUIT "<<Missing DM AUDIT SELF MONITOR DRUGS taxonomy>>"
+7 SET I=0
FOR
SET I=$ORDER(^AUPNVMED("AA",P,I))
IF I'=+I!(%)!(I>(9999999-D))
QUIT
Begin DoDot:1
+8 SET V=0
FOR
SET V=$ORDER(^AUPNVMED("AA",P,I,V))
IF V'=+V
QUIT
IF $DATA(^AUPNVMED(V,0))
SET G=$PIECE(^AUPNVMED(V,0),U)
IF $DATA(^ATXAX(T,21,"B",G))
SET %=V
End DoDot:1
+9 IF %]""
Begin DoDot:1
+10 IF $PIECE(^AUPNVMED(%,0),U,8)=""
SET %="Yes, dispensed "_$$VAL^XBDIQ1(9000010.14,%,.01)_" on "_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVMED(%,0),U,3),0),U),"."))
QUIT
+11 IF $PIECE(^AUPNVMED(%,0),U,8)]""
SET %="Discontinued - "_$$VAL^XBDIQ1(9000010.14,%,.01)_" on "_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVMED(%,0),U,3),0),U),"."))
QUIT
End DoDot:1
QUIT %
+12 SET V=$$LASTHF^BHSMU(BHSDFN,"DIABETES SELF MONITORING","B")
IF V]""
QUIT V
+13 QUIT "No Evidence in the past year"
EDUCREF ;EP - gather up all education provided in past year in APCHX
+1 KILL APCHX,APCHY
+2 SET APCHY=0
FOR
SET APCHY=$ORDER(^AUPNPREF("AA",BHSPAT,9999999.09,APCHY))
IF APCHY'=+APCHY
QUIT
IF $$EDT(APCHY)
SET APCHD=$ORDER(^AUPNPREF("AA",BHSPAT,9999999.09,APCHY,0))
IF APCHD<(9999999-BHSBEG)
Begin DoDot:1
+3 SET APCHX($PIECE(^AUTTEDT(APCHY,0),U))=$$FMTE^XLFDT(9999999-APCHD)
End DoDot:1
+4 QUIT
EDT(E) ;
+1 ;is this ien in any taxonomy
+2 NEW T
+3 SET T=$ORDER(^ATXAX("B","DM AUDIT DIABETES EDUC TOPICS",0))
+4 IF T
IF $DATA(^ATXAX(T,21,"B",E))
QUIT 1
+5 SET T=$ORDER(^ATXAX("B","DM AUDIT DIET EDUC TOPICS",0))
+6 IF T
IF $DATA(^ATXAX(T,21,"B",E))
QUIT 1
+7 SET T=$ORDER(^ATXAX("B","DM AUDIT EXERCISE EDUC TOPICS",0))
+8 IF T
IF $DATA(^ATXAX(T,21,"B",E))
QUIT 1
+9 SET T=$ORDER(^ATXAX("B","DM AUDIT OTHER EDUC TOPICS",0))
+10 IF T
IF $DATA(^ATXAX(T,21,"B",E))
QUIT 1
+11 SET T=$PIECE($GET(^AUTTEDT(T,0)),U,2)
+12 IF $PIECE(T,"-")="DM"
QUIT 1
+13 IF $PIECE(T,"-")="DMC"
QUIT 1
+14 QUIT ""
