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

BHSDM5.m

Go to the documentation of this file. 
  1. BHSDM5 ;IHS/CIA/MGH - Health Summary for Diabetic Supplement ;30-Nov-2015 10:24;DU
  1.  ;;1.0;HEALTH SUMMARY COMPONENTS;**4,12**;Mar 17, 2006;Build 3
  1.  ;===================================================================
  1.  ;VA version of IHS components for supplemental summaries
  1.  ;Taken from APCHS9B5
  1.  ; IHS/TUCSON/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ;  [ 02/19/03  7:44 AM ]
  1.  ;;2.0;IHS RPMS/PCC Health Summary;**3,5,6,8,10,12**;JUN 24, 1997
  1.  ;====================================================================
  1.  ;
  1. MAM ;EP
  1.  K BHSDAT,BHSTEX
  1.  N X1,X2
  1.  S BHSDAT=""
  1.  ;BHSdat=date of last, BHStex is display
  1.  Q:$P(^DPT(BHSPAT,0),U,2)="M"
  1.  K BHSEXD,BHSDF1
  1.  S BHSTXN=0
  1.  S BHSDAT=$$LASTMAM^APCLAPI1(BHSPAT)_"^"_$$MAMREF^APCHS9B4(BHSPAT,BHSDAT)
  1.  I $$VERSION^XPDUTL("BW")>2.9 G MAMA
  1.  S BHSBWR=0 S:$D(X) BHSAVX=X S X="BWUTL1" X ^%ZOSF("TEST") S:$D(BHSAVX) X=BHSAVX K BHSAVX I $T S BHSBWR=1
  1.  I BHSBWR,$D(^BWP(BHSPAT,0)) S BHSTXN=BHSTXN+1,BHSTEX(BHSTXN)=$$BNEED^BWUTL1(BHSPAT) I BHSTEX(1)="UNKNOWN" K BHSTEX(1) S BHSTXN=0
  1.  I $O(BHSTEX("")) Q
  1. MAMA ;
  1.  Q:$$AGE^AUPNPAT(BHSPAT,DT,"Y")<50
  1.  Q:$$AGE^AUPNPAT(BHSPAT,DT,"Y")>69
  1.  K BHSTXN
  1.  S BHSINT=365
  1.  I $P(BHSDAT,U,2)]"" S BHSTEX(1)=$P(BHSDAT,U,2),BHSDAT=$P(BHSDAT,U) Q
  1.  I BHSDAT="" S BHSTEX(1)="MAY BE DUE NOW" Q
  1.  K BHSBWR
  1.  S X1=BHSDAT,X2=BHSINT D C^%DTC  D REGDT4^GMTSU  S BHSTEX(1)="Next Due: "_X,BHSWD=X
  1.  S X2=BHSDAT,X1=DT D ^%DTC I X>BHSINT S BHSTEX(1)=$S('$D(BHSDD):"MAY BE DUE NOW (WAS DUE "_BHSWD_")",1:"MAY BE DUE NOW")
  1.  Q
  1.  ;
  1.  ;
  1. PAP ;EP
  1.  K BHSDAT,BHSTEX,BHSTP
  1.  S BHSDAT=""
  1.  ;BHSdat=date of last, BHStex is display
  1.  Q:$$AGE^AUPNPAT(BHSPAT,DT,"Y")<18!($P(^DPT(BHSPAT,0),U,2)="M")
  1.  K BHSEXD,BHSDF1
  1.  S BHSTXN=0
  1.  I $$VERSION^XPDUTL("BW")>2.9 G PAPA
  1.  S BHSBWR=0 S:$D(X) BHSAVX=X S X="BWUTL1" X ^%ZOSF("TEST") S:$D(BHSAVX) X=BHSAVX K BHSAVX I $T S BHSBWR=1
  1.  I BHSBWR,$D(^BWP(BHSPAT,0)) S BHSTXN=BHSTXN+1,BHSTEX(BHSTXN)=$$CNEED^BWUTL1(BHSPAT) I BHSTEX(1)="UNKNOWN" K BHSTEX(1) S BHSTXN=0
  1.  ;
  1. PAPA S BHSTP=$$HYSTER^BHSDM4(BHSPAT,DT)
  1.  I BHSTP]"" S BHSTXN=BHSTXN+1,BHSTEX(BHSTXN)="Pt had hysterectomy.  Pap may be necessary",BHSTXN=BHSTXN+1,BHSTEX(BHSTXN)="based on individual followup."
  1.  I $O(BHSTEX("")) S BHSDAT="" Q
  1.  Q
  1.  ;
  1.  ;
  1. ACE(P,D) ;EP - return date of last ACE iNHIBITOR
  1.  ;IHS/CMI/LAB patch 3 - added this subroutine
  1.  ;go through all v meds until 9999999-D and find all drugs with class CV800 or CV805
  1.  ;if none found check taxonomy
  1.  I '$G(P) Q ""
  1.  I '$G(D) S D=0 ;if don't pass date look at all time
  1.  NEW V,I,%
  1.  S %=""
  1.  S I=0 F  S I=$O(^AUPNVMED("AA",P,I)) Q:I'=+I!(%)!(I>(9999999-D))  D
  1.  .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 $P($G(^PSDRUG(G,0)),U,2)="CV800"!($P($G(^PSDRUG(G,0)),U,2)="CV805") S %=V
  1.  I %]"" D  Q %
  1.  .I $P(^AUPNVMED(%,0),U,8)="" S %="Yes - "_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),".")) Q
  1.  .I $P(^AUPNVMED(%,0),U,8)]"" S %="Discontinued - "_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),".")) Q
  1.  NEW T S T=$O(^ATXAX("B","DM AUDIT ACE INHIBITORS",0))
  1.  I 'T Q ""
  1.  S I=0 F  S I=$O(^AUPNVMED("AA",P,I)) Q:I'=+I!(%)!(I>(9999999-D))  D
  1.  .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
  1.  I %]"" D  Q %
  1.  .I $P(^AUPNVMED(%,0),U,8)="" S %="Yes - "_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),".")) Q
  1.  .I $P(^AUPNVMED(%,0),U,8)]"" S %="Discontinued - "_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),".")) Q
  1.  Q "No"
  1.  ;
  1. ASPREF(P) ;EP - CHECK FOR ASPIRIN NMI OR REFUSAL
  1.  I '$G(P) Q ""
  1.  NEW X,N,Z,D,IEN,DATE,DRUG
  1.  K X
  1.  S T=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
  1.  I 'T Q ""
  1.  S (D,G)=0 F  S D=$O(^AUPNPREF("AA",P,50,D)) Q:D'=+D!(G)  D
  1.  .Q:'$D(^ATXAX(T,21,"B",D))
  1.  .S X=$O(^AUPNPREF("AA",P,50,D,0))
  1.  .S N=$O(^AUPNPREF("AA",P,50,D,X,0))
  1.  .S G=1,DATE=9999999-X,DRUG=D,IEN=N
  1.  I 'G Q ""
  1.  Q $$VAL^XBDIQ1(50,DRUG,.01)_" "_$$TYPEREF^BHSMU(IEN)_" on "_$$FMTE^XLFDT(DATE)
  1. PNEU(P) ;EP
  1.  NEW APCHY,PNEU,X,C S %=P_"^LAST 2 IMMUNIZATION "_$S($$BI:33,1:19),E=$$START1^APCLDF(%,"APCHY(") ;IHS/CMI/LAB patch 3 - changed line to support new imm package
  1.  I $D(APCHY(1)) S PNEU(9999999-$P(APCHY(1),U))=""
  1.  I $D(APCHY(2)) S PNEU(9999999-$P(APCHY(2),U))=""
  1.  K APCHY S %=P_"^LAST 2 IMMUNIZATION 100",E=$$START1^APCLDF(%,"APCHY(")
  1.  I $D(APCHY(1)) S PNEU(9999999-$P(APCHY(1),U))=""
  1.  I $D(APCHY(2)) S PNEU(9999999-$P(APCHY(2),U))=""
  1.  K APCHY S %=P_"^LAST 2 IMMUNIZATION 109",E=$$START1^APCLDF(%,"APCHY(")
  1.  I $D(APCHY(1)) S PNEU(9999999-$P(APCHY(1),U))=""
  1.  I $D(APCHY(2)) S PNEU(9999999-$P(APCHY(2),U))=""
  1.  K APCHY S X=0,C=0 F  S X=$O(PNEU(X)) Q:X'=+X!(C>2)  S C=C+1,APCHY(C)=9999999-X
  1.  I $D(APCHY(1)) Q "Yes  "_$$FMTE^XLFDT($P(APCHY(1),U))_"   "_$$FMTE^XLFDT($P($G(APCHY(2)),U))
  1.  S G=$$REFDF^BHSDM3(BHSPAT,9999999.14,$O(^AUTTIMM("C",$S($$BI:33,1:19),0)),$P($G(APCHY(1)),U))
  1.  I G]"" Q G
  1.  S G=$$REFDF^BHSDM3(BHSPAT,9999999.14,$O(^AUTTIMM("C",$S($$BI:109,1:19),0)),$P($G(APCHY(1)),U))
  1.  I G]"" Q G
  1.  S G=$$REFDF^BHSDM3(BHSPAT,9999999.14,$O(^AUTTIMM("C",$S($$BI:100,1:19),0)),$P($G(APCHY(1)),U))
  1.  I G]"" Q G
  1.  Q "No"
  1. PPD(P) ;EP
  1.  NEW APCHY,Y,X,%,E S %=P_"^LAST SKIN PPD",E=$$START1^APCLDF(%,"APCHY(")
  1.  I $D(APCHY(1)) Q $P(^AUPNVSK(+$P(APCHY(1),U,4),0),U,5)_"     "_$$FMTE^XLFDT($P(APCHY(1),U))
  1.  K APCHY S X=P_"^LAST DX V74.1" S E=$$START1^APCLDF(X,"APCHY(")
  1.  I $D(APCHY(1)) Q $$FMTE^XLFDT($P(APCHY(1),U))_"  (by Diagnosis)"
  1.  S G=$$REFDF^BHSDM3(BHSPAT,9999999.28,$O(^AUTTSK("B","PPD",0)))
  1.  I G]"" Q G
  1.  Q ""
  1. PPDS(P) ;EP
  1.  ;check for tb health factor, problem list, povs if and
  1.  ;indication of pos ppd then return "Known Positive PPD"
  1.  NEW BHS,E,X
  1.  K BHS
  1.  S X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S E=$$START1^APCLDF(X,"BHS(")
  1.  I $D(BHS) Q "Known Positive PPD or Hx of TB (Health Factor recorded)"
  1.  N T S T=$O(^ATXAX("B","DM AUDIT TB HEALTH FACTORS",0))
  1.  I 'T G PPDSPL
  1.  N G S G=0,X=0 F  S X=$O(^AUPNHF("AA",P,X)) Q:X'=+X!(G)  I $D(^ATXAX(T,21,"B",X)) S G=1
  1.  I G Q "Known Positive PPD or Hx of TB (Health Factor recorded)"
  1. PPDSPL ;CHECK PL
  1.  N T,TAXARR
  1.  ;IHS/MSC/MGH Moved taxonomy lookup out of loop
  1.  S TAXARR=""
  1.  S T=$O(^ATXAX("B","SURVEILLANCE TUBERCULOSIS",0))
  1.  I 'T Q ""
  1.  N X,Y,I S (X,Y,I)=0
  1.  F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I)  D
  1.  .I $D(^AUPNPROB(X,0)) S Y=$P(^AUPNPROB(X,0),U) I $$ICD^ATXAPI(Y,T,9) S I=1
  1.  I I Q "Known Positive PPD or Hx of TB (Problem List DX)"
  1.  ;check povs
  1.  K BHS S X=P_"^FIRST DX [SURVEILLANCE TUBERCULOSIS" S E=$$START1^APCLDF(X,"BHS(")
  1.  I $D(BHS(1)) Q "Known Positive PPD or Hx of TB (POV/DX "_$$FMTE^XLFDT($P(BHS(1),U))_")"
  1.  Q ""
  1. BI() ;EP- check to see if using new imm package or not 1/5/1999 IHS/CMI/LAB
  1.  Q $S($O(^AUTTIMM(0))<100:0,1:1)
  1.  ;end new subrotuine CMI/TUCSON/LAB