Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCHPMH2

APCHPMH2.m

Go to the documentation of this file. 
  1. APCHPMH2 ; IHS/CMI/LAB - Patient Wellness Handout ;
  1.  ;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009
  1.  ;
  1.  ;
  1.  ;
  1.  Q
  1. LAB(P,T,LT) ;EP
  1.  I '$G(LT) S LT=""
  1.  NEW D,V,G,X,J S (D,G)=0 F  S D=$O(^AUPNVLAB("AE",P,D)) Q:D'=+D!(G)  D
  1.  .S X=0 F  S X=$O(^AUPNVLAB("AE",P,D,X)) Q:X'=+X!(G)  D
  1.  ..S Y=0 F  S Y=$O(^AUPNVLAB("AE",P,D,X,Y)) Q:Y'=+Y!(G)  D
  1.  ...I $D(^ATXLAB(T,21,"B",X)),$P(^AUPNVLAB(Y,0),U,4)]"" S G=Y Q
  1.  ...Q:'LT
  1.  ...S J=$P($G(^AUPNVLAB(Y,11)),U,13) Q:J=""
  1.  ...Q:'$$LOINC(J,LT)
  1.  ...S G=Y
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  I 'G S R=$$REF(P,T) Q "||||||"_R
  1.  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
  1. LOINC(A,B) ;
  1.  NEW %
  1.  S %=$P($G(^LAB(95.3,A,9999999)),U,2)
  1.  I %]"",$D(^ATXAX(B,21,"B",%)) Q 1
  1.  S %=$P($G(^LAB(95.3,A,0)),U)_"-"_$P($G(^LAB(95.3,A,0)),U,15)
  1.  I $D(^ATXAX(B,21,"B",%)) Q 1
  1.  Q ""
  1.  ;
  1. DATE(D) ;EP - convert to slashed date
  1.  I $G(D)="" Q ""
  1.  Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
  1. REF(P,T,D) ;return refusal string after date D for test is tax T
  1.  I '$G(P) Q ""
  1.  I '$G(T) Q ""
  1.  I '$G(D) S D=""
  1.  N APCHREF,APCHT,V S APCHT=0 F  S APCHT=$O(^ATXLAB(T,21,"B",APCHT)) Q:APCHT'=+APCHT  D
  1.  .S V=$$REF1(P,60,APCHT,D) I V]"" S APCHREF(9999999-$P(V,U,3))=V
  1.  I $D(APCHREF) S %=0,%=$O(APCHREF(%)) I % S V=APCHREF(%) Q V
  1.  Q ""
  1. REF1(P,F,I,D,T) ; ;
  1.  I '$G(P) Q ""
  1.  I '$G(F) Q ""
  1.  I '$G(I) Q ""
  1.  I $G(D)="" S D=""
  1.  I $G(T)="" S T="E"
  1.  NEW X,N S X=$O(^AUPNPREF("AA",P,F,I,0))
  1.  I 'X Q ""  ;none of this item was refused
  1.  S N=$O(^AUPNPREF("AA",P,F,I,X,0))
  1.  NEW Y S Y=9999999-X
  1.  I D]"",Y>D Q $S(T="I":Y,1:$$TYPEREF(N)_"-"_$$DATE(Y))
  1.  I T="I" Q Y  ;quit on internal form of date
  1.  Q $$TYPEREF(N)_"-"_$$DATE(Y)
  1.  ;
  1. TYPEREF(N) ;
  1.  NEW % S %=$P(^AUPNPREF(N,0),U,7)
  1.  I %="R"!(%="") Q "Declined"
  1.  I %="N" Q "Not Med Ind"
  1.  I %="F" Q "No Resp to F/U"
  1.  Q ""
  1.  ; 
  1.  ;
  1. GETLABSX ;get lab tests ordered today
  1.  ;
  1.  S APCHLR=$G(^DPT(APCHSDFN,"LR"))
  1.  I $G(APCHLR)]"" S APCHLRO=0,APCHTSTP=0 D
  1.  .F  S APCHLRO=$O(^LRO(69,DT,1,"AA",APCHLR,APCHLRO)) Q:APCHLRO=""  Q:APCHLRO'=+APCHLRO  D
  1.  ..F  S APCHTSTP=$O(^LRO(69,DT,1,APCHLRO,2,"B",APCHTSTP)) Q:APCHTSTP'=+APCHTSTP  D
  1.  ...S APCHTCTR=$O(^LRO(69,DT,1,APCHLRO,2,"B",APCHTSTP,0))
  1.  ...S APCHTEST=$P(^LAB(60,APCHTSTP,0),U)
  1.  ...S APCHTST(APCHTEST)=""
  1.  ...Q
  1.  ;
  1.  ;
  1. GETLABS ;get todays labs from V Lab File
  1.  S APCHSIVD=9999999-DT
  1.  I $D(^AUPNVLAB("AE",APCHSDFN,APCHSIVD)) S APCHTSTP=0,APCHVLAB=0 D
  1.  .F  S APCHTSTP=$O(^AUPNVLAB("AE",APCHSDFN,APCHSIVD,APCHTSTP)) Q:APCHTSTP=""  Q:APCHTSTP'=+APCHTSTP  D
  1.  ..S APCHTEST=$P(^LAB(60,APCHTSTP,0),U),APCHTST(APCHTEST)=""
  1.  ..S APCHVLAB=$O(^AUPNVLAB("AE",APCHSDFN,APCHSIVD,APCHTSTP,APCHVLAB)) Q:APCHVLAB'=+APCHVLAB
  1.  ..I $D(^AUPNVLAB(APCHVLAB,21)) S APCHCTR=0 F  S APCHCTR=$O(^AUPNVLAB(APCHVLAB,21,APCHCTR)) Q:'APCHCTR  D
  1.  ...Q:APCHCTR'=+APCHCTR
  1.  ...S APCHTST(APCHTEST,APCHCTR)=$P(^AUPNVLAB(APCHVLAB,21,APCHCTR,0),U)
  1.  ..Q
  1.  Q
  1.  ;
  1. APCHLHD ;
  1.  ;S X="Lab tests can help measure health and some check to make sure that your" D S(X,1)
  1.  ;S X="medicines are working right." D S(X)
  1.  ;