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

BDMS9B4.m

Go to the documentation of this file. 
  1. BDMS9B4 ; IHS/CMI/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ; 27 Jan 2011  6:58 AM
  1.  ;;2.0;DIABETES MANAGEMENT SYSTEM;**3,4,8,9,10,11,12**;JUN 14, 2007;Build 51
  1.  ;
  1.  ;
  1. GETALLLE(P,RETURN) ;
  1.  Q
  1. FRSTDMDX(P,F) ;EP return date of first dm dx
  1.  I $G(F)="" S F="E"
  1.  I '$G(P) Q ""
  1.  NEW X,E,BDMS,Y
  1.  S Y="BDMS("
  1.  S X=P_"^FIRST DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,Y) S Y=$P($G(BDMS(1)),U)
  1.  Q $S(F="E":$$DATE^BDMS9B1(Y),1:Y)
  1. CMSFDX(P,F) ;EP - return date/dx of dm in register
  1.  I $G(F)="" S F="E"
  1.  I '$G(P) Q ""
  1.  NEW R,N,D,D1,Y,X,G S R=0,N="",D="" F  S N=$O(^ACM(41.1,"B",N)) Q:N=""  S R=0 F  S R=$O(^ACM(41.1,"B",N,R)) Q:R'=+R  I N["DIAB" D
  1.  .S (G,X)=0,(Y)="" F  S X=$O(^ACM(44,"C",P,X)) Q:X'=+X  I $P(^ACM(44,X,0),U,4)=R D
  1.  ..S D=$P($G(^ACM(44,X,"SV")),U,2) I D]"" S D(D)=""
  1.  S D=$O(D(0)) I D]"" S D=$S(F="E":$$DATE^BDMS9B1(D),1:D)
  1.  Q $G(D)
  1.  ;
  1. CMSFDXR(P,F) ;EP - return date/dx of dm in register
  1.  I $G(F)="" S F="E"
  1.  I '$G(P) Q ""
  1.  NEW R,N,D,D1,Y,X,G S R=0,N="",D="" F  S N=$O(^ACM(41.1,"B",N)) Q:N=""  S R=0 F  S R=$O(^ACM(41.1,"B",N,R)) Q:R'=+R  I N["DIAB" D
  1.  .S (G,X)=0,(Y)="" F  S X=$O(^ACM(44,"C",P,X)) Q:X'=+X  I $P(^ACM(44,X,0),U,4)=R D
  1.  ..S D=$P($G(^ACM(44,X,"SV")),U,2) I D]"" S D(D)=N
  1.  S D=$O(D(0)) I D]"" S D=D(D)
  1.  Q $G(D)
  1. PLDMDOO(P,F) ;EP get first dm dx from case management
  1.  I '$G(P) Q ""
  1.  I $G(F)="" S F="E"
  1.  NEW T S T=$O(^ATXAX("B","SURVEILLANCE DIABETES",0))
  1.  I 'T Q ""
  1.  NEW D,X,I S D="",X=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X  D
  1.  .Q:$P(^AUPNPROB(X,0),U,12)="D"
  1.  .S I=$P(^AUPNPROB(X,0),U)
  1.  .I $$ICD^BDMUTL(I,"SURVEILLANCE DIABETES",9) D  Q
  1.  ..I $P(^AUPNPROB(X,0),U,13)]"" S D($P(^AUPNPROB(X,0),U,13))=""
  1.  .I $P($G(^AUPNPROB(X,800)),U,1)]"",$$SNOMED^BDMUTL($$LE^BDMS9B2(),"PXRM DIABETES",$P(^AUPNPROB(X,800),U,1)) D
  1.  ..I $P(^AUPNPROB(X,0),U,13)]"" S D($P(^AUPNPROB(X,0),U,13))=""
  1.  S D=$O(D(0))
  1.  I D="" Q D
  1.  Q $S(F="E":$$DATE^BDMS9B1(D),1:D)
  1. DNKA(V) ;EP is this a DNKA visit?
  1.  I '$G(V) Q ""
  1.  NEW D,N S D=$$PRIMPOV^APCLV(V,"C")
  1.  I D=".0860" Q 1
  1.  S N=$$PRIMPOV^APCLV(V,"N")
  1.  I $E(D)="V",N["DNKA" Q 1
  1.  I $E(D)="V",N["DID NOT KEEP APPOINTMENT" Q 1
  1.  I $E(D)="V",N["DID NOT KEEP APPT" Q 1
  1.  Q 0
  1.  ;
  1. ACE(P,D) ;EP - return date of last ACE iNHIBITOR
  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="" ;if don't pass date look at all time
  1.  NEW BDMSMEDS
  1.  K BDMSMEDS
  1.  D GETMEDS^BDMSMU1(P,D,,"DM AUDIT ACE INHIBITORS",,"DM AUDIT ACE INHIB CLASS",,.BDMSMEDS)
  1.  ;GET THE LAST ONE
  1.  NEW BDMSMED,X,%,Z,V,C
  1.  I '$D(BDMSMEDS) Q "No"
  1.  S X=0,C=0 F  S X=$O(BDMSMEDS(X)) Q:X'=+X  S C=X
  1.  S %=+$P(BDMSMEDS(C),U,4)
  1.  S V=$P(BDMSMEDS(C),U,5)  ;last one
  1.  I $P(^AUPNVMED(%,0),U,8)="" S %="Yes  "_$$DATE^BDMS9B1($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),"."))_" "_$$VAL^XBDIQ1(9000010.14,%,.01) Q %
  1.  I $P(^AUPNVMED(%,0),U,8)]"" S %="Discontinued  "_$$DATE^BDMS9B1($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),"."))_" "_$$VAL^XBDIQ1(9000010.14,%,.01) 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 $E($$VAL^XBDIQ1(50,DRUG,.01),1,30)_" "_$$TYPEREF^BDMSMU(IEN)_" on "_$$DATE^BDMS9B1(DATE)
  1. PNEU(P) ;EP
  1.  NEW BDMY,PNEU,X,G,Z,R,Y,%,PNEU1,PNEU2
  1.  S PNEU1=$$LASTPNEU(P,,,"A")
  1.  S PNEU2=$$LASTPNEU(P,,$$FMADD^XLFDT($P(PNEU1,U),-1),"A")
  1.  I PNEU1]"" Q "Yes  "_$$DATE^BDMS9B1($P(PNEU1,U))_"   "_$$DATE^BDMS9B1($P(PNEU2,U))
  1.  S R="",G="" F R=33,109 Q:R=""!(G)  D
  1.  .S G=$$REFUSAL^BDMDG17(P,9999999.14,$O(^AUTTIMM("C",R,0)),$$DOB^AUPNPAT(P),DT,"R")
  1.  I G Q "Refused "_$P(G,U,3)
  1.  ;; BI REFUSALS
  1.  S G="" F Z=33,109 Q:G  S X=0,Y=$O(^AUTTIMM("C",Z,0)) I Y F  S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G)  D
  1.  .S R=$P(^BIPC(X,0),U,3)
  1.  .Q:R=""
  1.  .Q:'$D(^BICONT(R,0))
  1.  .Q:$P(^BICONT(R,0),U,1)'["Refusal"
  1.  .S D=$P(^BIPC(X,0),U,4)
  1.  .Q:D=""
  1.  .S G=1_U_D
  1.  I G Q "Refused "_$$DATE^BDMS9B1($P(G,U,2))
  1.  S G="",Z="" F Z=33,109 Q:Z=""!(G]"")  S G=$$PNEUCONT(P,Z,$$DOB^AUPNPAT(P),DT)
  1.  I G]"" Q G
  1.  Q "No"
  1. PNEUCONT(P,C,BD,ED) ;EP
  1.  NEW X,G,Y,R,D
  1.  S X=0,G="",Y=$O(^AUTTIMM("C",C,0)) I Y F  S X=$O(^BIPC("AC",P,Y,X)) Q:X'=+X!(G)  D
  1.  .S R=$P(^BIPC(X,0),U,3)
  1.  .Q:R=""
  1.  .Q:'$D(^BICONT(R,0))
  1.  .S D=$P(^BIPC(X,0),U,4)
  1.  .Q:$P(^BIPC(X,0),U,4)>ED
  1.  .I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G="Contraindication: Anaphylaxis "_$$DATE^BDMS9B1(D)
  1.  Q G
  1. PPD(P) ;EP
  1.  NEW BDMY,Y,X,%,E,BDMV
  1.  S BDMV=""
  1.  S %=P_"^LAST SKIN PPD",E=$$START1^APCLDF(%,"BDMY(")
  1.  S E="" I $D(BDMY(1)) S BDMV=$P(BDMY(1),U)_U_$P(^AUPNVSK(+$P(BDMY(1),U,4),0),U,5)_U_$$VAL^XBDIQ1(9000010.12,+$P(BDMY(1),U,4),.04)_U_" PPD"      ;$P(^AUPNVSK(+$P(BDMY(1),U,4),0),U,5)_"     "_$$DATE^BDMS9B1($P(BDMY(1),U))
  1.  K BDMY
  1.  S X=P_"^LAST LAB [DM AUDIT TB LAB TESTS" S E=$$START1^APCLDF(X,"BDMY(")
  1.  I $D(BDMY(1)),$P(BDMY(1),U,1)>$P(BDMV,U,1) S BDMV=$P(BDMY(1),U)_U_U_$P(^AUPNVLAB(+$P(BDMY(1),U,4),0),U,4)_U_$$VAL^XBDIQ1(9000010.09,+$P(BDMY(1),U,4),.01)
  1.  ;K BDMY S X=P_"^LAST DX V74.1" S E=$$START1^APCLDF(X,"BDMY(")
  1.  ;I $D(BDMY(1)),$P(BDMY(1),U,1)>$P(BDMV,U,1) S BDMV=$P(BDMY(1),U,1)_U_U_U_" (by Diagnosis) V74.1"  ; Q $$DATE^BDMS9B1($P(BDMY(1),U))_"  (by Diagnosis)"
  1.  I BDMV]"" Q $P(BDMV,U,4)_"  "_$P(BDMV,U,2)_"  "_$P(BDMV,U,3)_"  "_$$DATE^BDMS9B1($P(BDMV,U,1))
  1.  S G=$$REFUSAL^BDMDG17(P,9999999.28,$O(^AUTTSK("B","PPD",0)),$$DOB^AUPNPAT(P),DT,"R")
  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 BDMS,E,X
  1.  K BDMS
  1.  S X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S E=$$START1^APCLDF(X,"BDMS(")
  1.  I $D(BDMS) Q "Known Positive PPD or Hx of TB (Health Factor)"
  1. PPDSPL ;CHECK PL
  1.  N T S T="DM AUDIT TUBERCULOSIS DXS"
  1.  I 'T Q ""
  1.  N X,Y,I S (X,Y,I)=0 F  S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X!(I)  I $D(^AUPNPROB(X,0)),$P(^AUPNPROB(X,0),U,12)'="D" S Y=$P(^AUPNPROB(X,0),U) I $$ICD^BDMUTL(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 BDMS S X=P_"^FIRST DX [DM AUDIT TUBERCULOSIS DXS" S E=$$START1^APCLDF(X,"BDMS(")
  1.  I $D(BDMS(1)) Q "Known Positive PPD or Hx of TB (POV/DX "_$$DATE^BDMS9B1($P(BDMS(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. LASTPNEU(BDMPDFN,BDMBD,BDMED,BDMFORM) ;PEP - date of last PNEUMOVAX
  1.  ; 
  1.  I $G(BDMPDFN)="" Q ""
  1.  I $G(BDMBD)="" S BDMBD=$$DOB^AUPNPAT(BDMPDFN)
  1.  I $G(BDMED)="" S BDMED=DT
  1.  I $G(BDMFORM)="" S BDMFORM="D"
  1.  NEW BDMLAST,BDMVAL,BDMX,R,X,Y,V,E,T,G,BDMY,BDMF
  1.  S BDMLAST=""
  1.  S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"33","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
  1.  D E
  1.  S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"100","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
  1.  D E
  1.  S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"109","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
  1.  D E
  1.  S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"133","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
  1.  D E
  1.  S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"152","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
  1.  D E
  1.  S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"V03.82","DX",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
  1.  D E
  1.  S BDMVAL=$$LASTCPTT^APCLAPIU(BDMPDFN,$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"BGP PNEUMO IZ CPTS","A")
  1.  D E
  1.  I BDMFORM="D" Q $P(BDMLAST,U)
  1.  Q BDMLAST
  1.  ;
  1. E ;
  1.  I $P(BDMVAL,U,1)>$P(BDMLAST,U,1) S BDMLAST=BDMVAL
  1.  Q
  1.  ;
  1.  ;
  1. MAMREF(P,LMAM) ;EP
  1.  NEW G,BDMY,I,D,X,C,LAST
  1.  S G="",LAST=""
  1.  S I=0 F  S I=$O(^AUPNPREF("AA",P,71,I)) Q:I'=+I   D
  1.  .S C=$P($G(^RAMIS(71,I,0)),U,9)
  1.  .Q:C=""
  1.  .Q:'$$ICD^BDMUTL(C,$O(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1)
  1.  .S D=$O(^AUPNPREF("AA",P,71,I,0))  ;last date
  1.  .S D=9999999-D
  1.  .I D>$P(LAST,U,1) S LAST=D_U_"Patient Refused a Mammogram ("_C_") on "_$$DATE^BDMS9B1(D)
  1.  ;now check cpt refusals
  1.  S I=0 F  S I=$O(^AUPNPREF("AA",P,81,I)) Q:I'=+I   D
  1.  .S C=I
  1.  .Q:'$$ICD^BDMUTL(C,$O(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1)
  1.  .S D=$O(^AUPNPREF("AA",P,81,I,0))  ;last date
  1.  .S D=9999999-D
  1.  .I D>$P(LAST,U,1) S LAST=D_U_"Patient Refused a Mammogram ("_C_") on "_$$DATE^BDMS9B1(D)
  1.  ;now check PROC refusals
  1.  S I=0 F  S I=$O(^AUPNPREF("AA",P,80.1,I)) Q:I'=+I   D
  1.  .S C=I
  1.  .S C=$P($G(^ICD0(C,0)),U,1)
  1.  .I C'=87.36,C'=87.37 Q
  1.  .S D=$O(^AUPNPREF("AA",P,80.1,I,0))  ;last date
  1.  .S D=9999999-D
  1.  .I D>$P(LAST,U,1) S LAST=D_U_"Patient Refused a Mammogram ("_C_") on "_$$DATE^BDMS9B1(D)
  1.  Q $G(LAST)
  1.  ;
  1. PAP(P) ;EP
  1.  Q $$LASTPAP^APCLAPI1(P,,,"A")