BHSPMH2 ;IHS/MSC/MGH - Health Summary for Patient wellness handout ;17-Mar-2009 15:49;MGH
;;1.0;HEALTH SUMMARY COMPONENTS;**1,2**;March 17,2006
;=============================================================
;Taken from routine APCHSMPH2
; IHS/CMI/GRL Patient Health Summary - Post Visit ;
;;2.0;IHS RPMS/PCC Health Summary;**15**;JUN 24, 1997
;
;
;
Q
LAB(P,T,LT) ;EP
I '$G(LT) S LT=""
NEW D,V,G,X,J,R S (D,G)=0 F S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(G) D
.S X=0 F S X=$O(^AUPNVLAB("AE",P,D,X)) Q:X'=+X!(G) D
..S Y=0 F S Y=$O(^AUPNVLAB("AE",P,D,X,Y)) Q:Y'=+Y!(G) D
...I $D(^ATXLAB(T,21,"B",X)),$P(^AUPNVLAB(Y,0),U,4)]"" S G=Y Q
...Q:'LT
...S J=$P($G(^AUPNVLAB(Y,11)),U,13) Q:J=""
...Q:'$$LOINC(J,LT)
...S G=Y
...Q
..Q
.Q
I 'G S R=$$REF(P,T) Q "||||||"_R
Q $P(^AUPNVLAB(G,0),U,4)_"|||"_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVLAB(G,0),U,3),0),U),"."))_"|||"_$$REF(P,T,$P($P(^AUPNVSIT($P(^AUPNVLAB(G,0),U,3),0),U),"."))_"|||"_G
LOINC(A,B) ;
NEW %
S %=$P($G(^LAB(95.3,A,9999999)),U,2)
I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
I $D(^ATXAX(B,21,"B",%)) Q 1
Q ""
;
DATE(D) ;EP - convert to slashed date
I $G(D)="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
REF(P,T,D) ;return refusal string after date D for test is tax T
I '$G(P) Q ""
I '$G(T) Q ""
I '$G(D) S D=""
N BHSREF,BHST,V S BHST=0 F S BHST=$O(^ATXLAB(T,21,"B",BHST)) Q:BHST'=+BHST D
.S V=$$REF1(P,60,BHST,D) I V]"" S BHSREF(9999999-$P(V,U,3))=V
I $D(BHSREF) S %=0,%=$O(BHSREF(%)) I % S V=BHSREF(%) Q V
Q ""
REF1(P,F,I,D,T) ; ;
I '$G(P) Q ""
I '$G(F) Q ""
I '$G(I) Q ""
I $G(D)="" S D=""
I $G(T)="" S T="E"
NEW X,N S X=$O(^AUPNPREF("AA",P,F,I,0))
I 'X Q "" ;none of this item was refused
S N=$O(^AUPNPREF("AA",P,F,I,X,0))
NEW Y S Y=9999999-X
I D]"",Y>D Q $S(T="I":Y,1:$$TYPEREF(N)_"-"_$$DATE(Y))
I T="I" Q Y ;quit on internal form of date
Q $$TYPEREF(N)_"-"_$$DATE(Y)
;
TYPEREF(N) ;
NEW % S %=$P(^AUPNPREF(N,0),U,7)
I %="R"!(%="") Q "Refused"
I %="N" Q "Not Med Ind"
I %="F" Q "No Resp to F/U"
Q ""
;
;
GETLABSX ;get lab tests ordered today
;
N BHSLR,BHSTSTP,BHSLRO,BHSTEST,BHSTST,BHSVLAB,BHSTSTP,BHSSIVD,BHSTCTR,BHSCTR
S BHSLR=$G(^DPT(BHSDFN,"LR"))
I $G(BHSLR)]"" S BHSLRO=0,BHSTSTP=0 D
.F S BHSLRO=$O(^LRO(69,DT,1,"AA",BHSLR,BHSLRO)) Q:BHSLRO="" Q:BHSLRO'=+BHSLRO D
..F S BHSTSTP=$O(^LRO(69,DT,1,BHSLRO,2,"B",BHSTSTP)) Q:BHSTSTP'=+BHSTSTP D
...S BHSTCTR=$O(^LRO(69,DT,1,BHSLRO,2,"B",BHSTSTP,0))
...S BHSTEST=$P(^LAB(60,BHSTSTP,0),U)
...S BHSTST(BHSTEST)=""
...Q
;
;
GETLABS ;get todays labs from V Lab File
S BHSLR=$G(^DPT(BHSSDFN,"LR"))
I $D(^AUPNVLAB("AE",BHSSDFN,BHSSIVD)) S BHSTSTP=0,BHSVLAB=0 D
.F S BHSTSTP=$O(^AUPNVLAB("AE",BHSSDFN,BHSSIVD,BHSTSTP)) Q:BHSTSTP="" Q:BHSTSTP'=+BHSTSTP D
..S BHSTEST=$P(^LAB(60,BHSTSTP,0),U),BHSTST(BHSTEST)=""
..S BHSVLAB=$O(^AUPNVLAB("AE",BHSSDFN,BHSSIVD,BHSTSTP,BHSVLAB)) Q:BHSVLAB'=+BHSVLAB
..I $D(^AUPNVLAB(BHSVLAB,21)) S BHSCTR=0 F S BHSCTR=$O(^AUPNVLAB(BHSVLAB,21,BHSCTR)) Q:'BHSCTR D
...Q:BHSCTR'=+BHSCTR
...S BHSTST(BHSTEST,BHSCTR)=$P(^AUPNVLAB(BHSVLAB,21,BHSCTR,0),U)
..Q
Q
;
BHSLHD ;
;S X="Lab tests can help measure health and some check to make sure that your" D S(X,1)
;S X="medicines are working right." D S(X)
;
BHSPMH2 ;IHS/MSC/MGH - Health Summary for Patient wellness handout ;17-Mar-2009 15:49;MGH
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2**;March 17,2006
+2 ;=============================================================
+3 ;Taken from routine APCHSMPH2
+4 ; IHS/CMI/GRL Patient Health Summary - Post Visit ;
+5 ;;2.0;IHS RPMS/PCC Health Summary;**15**;JUN 24, 1997
+6 ;
+7 ;
+8 ;
+9 QUIT
LAB(P,T,LT) ;EP
+1 IF '$GET(LT)
SET LT=""
+2 NEW D,V,G,X,J,R
SET (D,G)=0
FOR
SET D=$ORDER(^AUPNVLAB("AE",P,D))
IF D'=+D!(G)
QUIT
Begin DoDot:1
+3 SET X=0
FOR
SET X=$ORDER(^AUPNVLAB("AE",P,D,X))
IF X'=+X!(G)
QUIT
Begin DoDot:2
+4 SET Y=0
FOR
SET Y=$ORDER(^AUPNVLAB("AE",P,D,X,Y))
IF Y'=+Y!(G)
QUIT
Begin DoDot:3
+5 IF $DATA(^ATXLAB(T,21,"B",X))
IF $PIECE(^AUPNVLAB(Y,0),U,4)]""
SET G=Y
QUIT
+6 IF 'LT
QUIT
+7 SET J=$PIECE($GET(^AUPNVLAB(Y,11)),U,13)
IF J=""
QUIT
+8 IF '$$LOINC(J,LT)
QUIT
+9 SET G=Y
+10 QUIT
End DoDot:3
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 IF 'G
SET R=$$REF(P,T)
QUIT "||||||"_R
+14 QUIT $PIECE(^AUPNVLAB(G,0),U,4)_"|||"_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVLAB(G,0),U,3),0),U),"."))_"|||"_$$REF(P,T,$PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVLAB(G,0),U,3),0),U),"."))_"|||"_G
LOINC(A,B) ;
+1 NEW %
+2 SET %=$PIECE($GET(^LAB(95.3,A,9999999)),U,2)
+3 IF %]""
IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+4 SET %=$PIECE($GET(^LAB(95.3,A,0)),U)_"-"_$PIECE($GET(^LAB(95.3,A,0)),U,15)
+5 IF $DATA(^ATXAX(B,21,"B",%))
QUIT 1
+6 QUIT ""
+7 ;
DATE(D) ;EP - convert to slashed date
+1 IF $GET(D)=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
REF(P,T,D) ;return refusal string after date D for test is tax T
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(T)
QUIT ""
+3 IF '$GET(D)
SET D=""
+4 NEW BHSREF,BHST,V
SET BHST=0
FOR
SET BHST=$ORDER(^ATXLAB(T,21,"B",BHST))
IF BHST'=+BHST
QUIT
Begin DoDot:1
+5 SET V=$$REF1(P,60,BHST,D)
IF V]""
SET BHSREF(9999999-$PIECE(V,U,3))=V
End DoDot:1
+6 IF $DATA(BHSREF)
SET %=0
SET %=$ORDER(BHSREF(%))
IF %
SET V=BHSREF(%)
QUIT V
+7 QUIT ""
REF1(P,F,I,D,T) ; ;
+1 IF '$GET(P)
QUIT ""
+2 IF '$GET(F)
QUIT ""
+3 IF '$GET(I)
QUIT ""
+4 IF $GET(D)=""
SET D=""
+5 IF $GET(T)=""
SET T="E"
+6 NEW X,N
SET X=$ORDER(^AUPNPREF("AA",P,F,I,0))
+7 ;none of this item was refused
IF 'X
QUIT ""
+8 SET N=$ORDER(^AUPNPREF("AA",P,F,I,X,0))
+9 NEW Y
SET Y=9999999-X
+10 IF D]""
IF Y>D
QUIT $SELECT(T="I":Y,1:$$TYPEREF(N)_"-"_$$DATE(Y))
+11 ;quit on internal form of date
IF T="I"
QUIT Y
+12 QUIT $$TYPEREF(N)_"-"_$$DATE(Y)
+13 ;
TYPEREF(N) ;
+1 NEW %
SET %=$PIECE(^AUPNPREF(N,0),U,7)
+2 IF %="R"!(%="")
QUIT "Refused"
+3 IF %="N"
QUIT "Not Med Ind"
+4 IF %="F"
QUIT "No Resp to F/U"
+5 QUIT ""
+6 ;
+7 ;
GETLABSX ;get lab tests ordered today
+1 ;
+2 NEW BHSLR,BHSTSTP,BHSLRO,BHSTEST,BHSTST,BHSVLAB,BHSTSTP,BHSSIVD,BHSTCTR,BHSCTR
+3 SET BHSLR=$GET(^DPT(BHSDFN,"LR"))
+4 IF $GET(BHSLR)]""
SET BHSLRO=0
SET BHSTSTP=0
Begin DoDot:1
+5 FOR
SET BHSLRO=$ORDER(^LRO(69,DT,1,"AA",BHSLR,BHSLRO))
IF BHSLRO=""
QUIT
IF BHSLRO'=+BHSLRO
QUIT
Begin DoDot:2
+6 FOR
SET BHSTSTP=$ORDER(^LRO(69,DT,1,BHSLRO,2,"B",BHSTSTP))
IF BHSTSTP'=+BHSTSTP
QUIT
Begin DoDot:3
+7 SET BHSTCTR=$ORDER(^LRO(69,DT,1,BHSLRO,2,"B",BHSTSTP,0))
+8 SET BHSTEST=$PIECE(^LAB(60,BHSTSTP,0),U)
+9 SET BHSTST(BHSTEST)=""
+10 QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+11 ;
+12 ;
GETLABS ;get todays labs from V Lab File
+1 SET BHSLR=$GET(^DPT(BHSSDFN,"LR"))
+2 IF $DATA(^AUPNVLAB("AE",BHSSDFN,BHSSIVD))
SET BHSTSTP=0
SET BHSVLAB=0
Begin DoDot:1
+3 FOR
SET BHSTSTP=$ORDER(^AUPNVLAB("AE",BHSSDFN,BHSSIVD,BHSTSTP))
IF BHSTSTP=""
QUIT
IF BHSTSTP'=+BHSTSTP
QUIT
Begin DoDot:2
+4 SET BHSTEST=$PIECE(^LAB(60,BHSTSTP,0),U)
SET BHSTST(BHSTEST)=""
+5 SET BHSVLAB=$ORDER(^AUPNVLAB("AE",BHSSDFN,BHSSIVD,BHSTSTP,BHSVLAB))
IF BHSVLAB'=+BHSVLAB
QUIT
+6 IF $DATA(^AUPNVLAB(BHSVLAB,21))
SET BHSCTR=0
FOR
SET BHSCTR=$ORDER(^AUPNVLAB(BHSVLAB,21,BHSCTR))
IF 'BHSCTR
QUIT
Begin DoDot:3
+7 IF BHSCTR'=+BHSCTR
QUIT
+8 SET BHSTST(BHSTEST,BHSCTR)=$PIECE(^AUPNVLAB(BHSVLAB,21,BHSCTR,0),U)
End DoDot:3
+9 QUIT
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
BHSLHD ;
+1 ;S X="Lab tests can help measure health and some check to make sure that your" D S(X,1)
+2 ;S X="medicines are working right." D S(X)
+3 ;
