- 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 ""
