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