BDMS9B4 ; IHS/CMI/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ; 27 Jan 2011 6:58 AM
;;2.0;DIABETES MANAGEMENT SYSTEM;**3,4,8,9,10,11,12**;JUN 14, 2007;Build 51
;
;
GETALLLE(P,RETURN) ;
Q
FRSTDMDX(P,F) ;EP return date of first dm dx
I $G(F)="" S F="E"
I '$G(P) Q ""
NEW X,E,BDMS,Y
S Y="BDMS("
S X=P_"^FIRST DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,Y) S Y=$P($G(BDMS(1)),U)
Q $S(F="E":$$DATE^BDMS9B1(Y),1:Y)
CMSFDX(P,F) ;EP - return date/dx of dm in register
I $G(F)="" S F="E"
I '$G(P) Q ""
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
.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
..S D=$P($G(^ACM(44,X,"SV")),U,2) I D]"" S D(D)=""
S D=$O(D(0)) I D]"" S D=$S(F="E":$$DATE^BDMS9B1(D),1:D)
Q $G(D)
;
CMSFDXR(P,F) ;EP - return date/dx of dm in register
I $G(F)="" S F="E"
I '$G(P) Q ""
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
.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
..S D=$P($G(^ACM(44,X,"SV")),U,2) I D]"" S D(D)=N
S D=$O(D(0)) I D]"" S D=D(D)
Q $G(D)
PLDMDOO(P,F) ;EP get first dm dx from case management
I '$G(P) Q ""
I $G(F)="" S F="E"
NEW T S T=$O(^ATXAX("B","SURVEILLANCE DIABETES",0))
I 'T Q ""
NEW D,X,I S D="",X=0 F S X=$O(^AUPNPROB("AC",P,X)) Q:X'=+X D
.Q:$P(^AUPNPROB(X,0),U,12)="D"
.S I=$P(^AUPNPROB(X,0),U)
.I $$ICD^BDMUTL(I,"SURVEILLANCE DIABETES",9) D Q
..I $P(^AUPNPROB(X,0),U,13)]"" S D($P(^AUPNPROB(X,0),U,13))=""
.I $P($G(^AUPNPROB(X,800)),U,1)]"",$$SNOMED^BDMUTL($$LE^BDMS9B2(),"PXRM DIABETES",$P(^AUPNPROB(X,800),U,1)) D
..I $P(^AUPNPROB(X,0),U,13)]"" S D($P(^AUPNPROB(X,0),U,13))=""
S D=$O(D(0))
I D="" Q D
Q $S(F="E":$$DATE^BDMS9B1(D),1:D)
DNKA(V) ;EP is this a DNKA visit?
I '$G(V) Q ""
NEW D,N S D=$$PRIMPOV^APCLV(V,"C")
I D=".0860" Q 1
S N=$$PRIMPOV^APCLV(V,"N")
I $E(D)="V",N["DNKA" Q 1
I $E(D)="V",N["DID NOT KEEP APPOINTMENT" Q 1
I $E(D)="V",N["DID NOT KEEP APPT" Q 1
Q 0
;
ACE(P,D) ;EP - return date of last ACE iNHIBITOR
;go through all v meds until 9999999-D and find all drugs with class CV800 or CV805
;if none found check taxonomy
I '$G(P) Q ""
I '$G(D) S D="" ;if don't pass date look at all time
NEW BDMSMEDS
K BDMSMEDS
D GETMEDS^BDMSMU1(P,D,,"DM AUDIT ACE INHIBITORS",,"DM AUDIT ACE INHIB CLASS",,.BDMSMEDS)
;GET THE LAST ONE
NEW BDMSMED,X,%,Z,V,C
I '$D(BDMSMEDS) Q "No"
S X=0,C=0 F S X=$O(BDMSMEDS(X)) Q:X'=+X S C=X
S %=+$P(BDMSMEDS(C),U,4)
S V=$P(BDMSMEDS(C),U,5) ;last one
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 %
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 %
Q "No"
;
ASPREF(P) ;EP - CHECK FOR ASPIRIN NMI OR REFUSAL
I '$G(P) Q ""
NEW X,N,Z,D,IEN,DATE,DRUG
K X
S T=$O(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
I 'T Q ""
S (D,G)=0 F S D=$O(^AUPNPREF("AA",P,50,D)) Q:D'=+D!(G) D
.Q:'$D(^ATXAX(T,21,"B",D))
.S X=$O(^AUPNPREF("AA",P,50,D,0))
.S N=$O(^AUPNPREF("AA",P,50,D,X,0))
.S G=1,DATE=9999999-X,DRUG=D,IEN=N
I 'G Q ""
Q $E($$VAL^XBDIQ1(50,DRUG,.01),1,30)_" "_$$TYPEREF^BDMSMU(IEN)_" on "_$$DATE^BDMS9B1(DATE)
PNEU(P) ;EP
NEW BDMY,PNEU,X,G,Z,R,Y,%,PNEU1,PNEU2
S PNEU1=$$LASTPNEU(P,,,"A")
S PNEU2=$$LASTPNEU(P,,$$FMADD^XLFDT($P(PNEU1,U),-1),"A")
I PNEU1]"" Q "Yes "_$$DATE^BDMS9B1($P(PNEU1,U))_" "_$$DATE^BDMS9B1($P(PNEU2,U))
S R="",G="" F R=33,109 Q:R=""!(G) D
.S G=$$REFUSAL^BDMDG17(P,9999999.14,$O(^AUTTIMM("C",R,0)),$$DOB^AUPNPAT(P),DT,"R")
I G Q "Refused "_$P(G,U,3)
;; BI REFUSALS
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
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.Q:$P(^BICONT(R,0),U,1)'["Refusal"
.S D=$P(^BIPC(X,0),U,4)
.Q:D=""
.S G=1_U_D
I G Q "Refused "_$$DATE^BDMS9B1($P(G,U,2))
S G="",Z="" F Z=33,109 Q:Z=""!(G]"") S G=$$PNEUCONT(P,Z,$$DOB^AUPNPAT(P),DT)
I G]"" Q G
Q "No"
PNEUCONT(P,C,BD,ED) ;EP
NEW X,G,Y,R,D
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
.S R=$P(^BIPC(X,0),U,3)
.Q:R=""
.Q:'$D(^BICONT(R,0))
.S D=$P(^BIPC(X,0),U,4)
.Q:$P(^BIPC(X,0),U,4)>ED
.I $P(^BICONT(R,0),U,1)="Anaphylaxis" S G="Contraindication: Anaphylaxis "_$$DATE^BDMS9B1(D)
Q G
PPD(P) ;EP
NEW BDMY,Y,X,%,E,BDMV
S BDMV=""
S %=P_"^LAST SKIN PPD",E=$$START1^APCLDF(%,"BDMY(")
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))
K BDMY
S X=P_"^LAST LAB [DM AUDIT TB LAB TESTS" S E=$$START1^APCLDF(X,"BDMY(")
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)
;K BDMY S X=P_"^LAST DX V74.1" S E=$$START1^APCLDF(X,"BDMY(")
;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)"
I BDMV]"" Q $P(BDMV,U,4)_" "_$P(BDMV,U,2)_" "_$P(BDMV,U,3)_" "_$$DATE^BDMS9B1($P(BDMV,U,1))
S G=$$REFUSAL^BDMDG17(P,9999999.28,$O(^AUTTSK("B","PPD",0)),$$DOB^AUPNPAT(P),DT,"R")
I G Q G
Q ""
PPDS(P) ;EP
;check for tb health factor, problem list, povs if and
;indication of pos ppd then return "Known Positive PPD"
NEW BDMS,E,X
K BDMS
S X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS" S E=$$START1^APCLDF(X,"BDMS(")
I $D(BDMS) Q "Known Positive PPD or Hx of TB (Health Factor)"
PPDSPL ;CHECK PL
N T S T="DM AUDIT TUBERCULOSIS DXS"
I 'T Q ""
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
I I Q "Known Positive PPD or Hx of TB (Problem List DX)"
;check povs
K BDMS S X=P_"^FIRST DX [DM AUDIT TUBERCULOSIS DXS" S E=$$START1^APCLDF(X,"BDMS(")
I $D(BDMS(1)) Q "Known Positive PPD or Hx of TB (POV/DX "_$$DATE^BDMS9B1($P(BDMS(1),U))_")"
Q ""
BI() ;EP- check to see if using new imm package or not 1/5/1999 IHS/CMI/LAB
Q $S($O(^AUTTIMM(0))<100:0,1:1)
LASTPNEU(BDMPDFN,BDMBD,BDMED,BDMFORM) ;PEP - date of last PNEUMOVAX
;
I $G(BDMPDFN)="" Q ""
I $G(BDMBD)="" S BDMBD=$$DOB^AUPNPAT(BDMPDFN)
I $G(BDMED)="" S BDMED=DT
I $G(BDMFORM)="" S BDMFORM="D"
NEW BDMLAST,BDMVAL,BDMX,R,X,Y,V,E,T,G,BDMY,BDMF
S BDMLAST=""
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"33","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"100","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"109","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"133","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"152","IMMUNIZATION",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"V03.82","DX",$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"A")
D E
S BDMVAL=$$LASTCPTT^APCLAPIU(BDMPDFN,$S($P(BDMLAST,U)]"":$P(BDMLAST,U),1:BDMBD),BDMED,"BGP PNEUMO IZ CPTS","A")
D E
I BDMFORM="D" Q $P(BDMLAST,U)
Q BDMLAST
;
E ;
I $P(BDMVAL,U,1)>$P(BDMLAST,U,1) S BDMLAST=BDMVAL
Q
;
;
MAMREF(P,LMAM) ;EP
NEW G,BDMY,I,D,X,C,LAST
S G="",LAST=""
S I=0 F S I=$O(^AUPNPREF("AA",P,71,I)) Q:I'=+I D
.S C=$P($G(^RAMIS(71,I,0)),U,9)
.Q:C=""
.Q:'$$ICD^BDMUTL(C,$O(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1)
.S D=$O(^AUPNPREF("AA",P,71,I,0)) ;last date
.S D=9999999-D
.I D>$P(LAST,U,1) S LAST=D_U_"Patient Refused a Mammogram ("_C_") on "_$$DATE^BDMS9B1(D)
;now check cpt refusals
S I=0 F S I=$O(^AUPNPREF("AA",P,81,I)) Q:I'=+I D
.S C=I
.Q:'$$ICD^BDMUTL(C,$O(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1)
.S D=$O(^AUPNPREF("AA",P,81,I,0)) ;last date
.S D=9999999-D
.I D>$P(LAST,U,1) S LAST=D_U_"Patient Refused a Mammogram ("_C_") on "_$$DATE^BDMS9B1(D)
;now check PROC refusals
S I=0 F S I=$O(^AUPNPREF("AA",P,80.1,I)) Q:I'=+I D
.S C=I
.S C=$P($G(^ICD0(C,0)),U,1)
.I C'=87.36,C'=87.37 Q
.S D=$O(^AUPNPREF("AA",P,80.1,I,0)) ;last date
.S D=9999999-D
.I D>$P(LAST,U,1) S LAST=D_U_"Patient Refused a Mammogram ("_C_") on "_$$DATE^BDMS9B1(D)
Q $G(LAST)
;
PAP(P) ;EP
Q $$LASTPAP^APCLAPI1(P,,,"A")
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
+2 ;
+3 ;
GETALLLE(P,RETURN) ;
+1 QUIT
FRSTDMDX(P,F) ;EP return date of first dm dx
+1 IF $GET(F)=""
SET F="E"
+2 IF '$GET(P)
QUIT ""
+3 NEW X,E,BDMS,Y
+4 SET Y="BDMS("
+5 SET X=P_"^FIRST DX [SURVEILLANCE DIABETES"
SET E=$$START1^APCLDF(X,Y)
SET Y=$PIECE($GET(BDMS(1)),U)
+6 QUIT $SELECT(F="E":$$DATE^BDMS9B1(Y),1:Y)
CMSFDX(P,F) ;EP - return date/dx of dm in register
+1 IF $GET(F)=""
SET F="E"
+2 IF '$GET(P)
QUIT ""
+3 NEW R,N,D,D1,Y,X,G
SET R=0
SET N=""
SET D=""
FOR
SET N=$ORDER(^ACM(41.1,"B",N))
IF N=""
QUIT
SET R=0
FOR
SET R=$ORDER(^ACM(41.1,"B",N,R))
IF R'=+R
QUIT
IF N["DIAB"
Begin DoDot:1
+4 SET (G,X)=0
SET (Y)=""
FOR
SET X=$ORDER(^ACM(44,"C",P,X))
IF X'=+X
QUIT
IF $PIECE(^ACM(44,X,0),U,4)=R
Begin DoDot:2
+5 SET D=$PIECE($GET(^ACM(44,X,"SV")),U,2)
IF D]""
SET D(D)=""
End DoDot:2
End DoDot:1
+6 SET D=$ORDER(D(0))
IF D]""
SET D=$SELECT(F="E":$$DATE^BDMS9B1(D),1:D)
+7 QUIT $GET(D)
+8 ;
CMSFDXR(P,F) ;EP - return date/dx of dm in register
+1 IF $GET(F)=""
SET F="E"
+2 IF '$GET(P)
QUIT ""
+3 NEW R,N,D,D1,Y,X,G
SET R=0
SET N=""
SET D=""
FOR
SET N=$ORDER(^ACM(41.1,"B",N))
IF N=""
QUIT
SET R=0
FOR
SET R=$ORDER(^ACM(41.1,"B",N,R))
IF R'=+R
QUIT
IF N["DIAB"
Begin DoDot:1
+4 SET (G,X)=0
SET (Y)=""
FOR
SET X=$ORDER(^ACM(44,"C",P,X))
IF X'=+X
QUIT
IF $PIECE(^ACM(44,X,0),U,4)=R
Begin DoDot:2
+5 SET D=$PIECE($GET(^ACM(44,X,"SV")),U,2)
IF D]""
SET D(D)=N
End DoDot:2
End DoDot:1
+6 SET D=$ORDER(D(0))
IF D]""
SET D=D(D)
+7 QUIT $GET(D)
PLDMDOO(P,F) ;EP get first dm dx from case management
+1 IF '$GET(P)
QUIT ""
+2 IF $GET(F)=""
SET F="E"
+3 NEW T
SET T=$ORDER(^ATXAX("B","SURVEILLANCE DIABETES",0))
+4 IF 'T
QUIT ""
+5 NEW D,X,I
SET D=""
SET X=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X
QUIT
Begin DoDot:1
+6 IF $PIECE(^AUPNPROB(X,0),U,12)="D"
QUIT
+7 SET I=$PIECE(^AUPNPROB(X,0),U)
+8 IF $$ICD^BDMUTL(I,"SURVEILLANCE DIABETES",9)
Begin DoDot:2
+9 IF $PIECE(^AUPNPROB(X,0),U,13)]""
SET D($PIECE(^AUPNPROB(X,0),U,13))=""
End DoDot:2
QUIT
+10 IF $PIECE($GET(^AUPNPROB(X,800)),U,1)]""
IF $$SNOMED^BDMUTL($$LE^BDMS9B2(),"PXRM DIABETES",$PIECE(^AUPNPROB(X,800),U,1))
Begin DoDot:2
+11 IF $PIECE(^AUPNPROB(X,0),U,13)]""
SET D($PIECE(^AUPNPROB(X,0),U,13))=""
End DoDot:2
End DoDot:1
+12 SET D=$ORDER(D(0))
+13 IF D=""
QUIT D
+14 QUIT $SELECT(F="E":$$DATE^BDMS9B1(D),1:D)
DNKA(V) ;EP is this a DNKA visit?
+1 IF '$GET(V)
QUIT ""
+2 NEW D,N
SET D=$$PRIMPOV^APCLV(V,"C")
+3 IF D=".0860"
QUIT 1
+4 SET N=$$PRIMPOV^APCLV(V,"N")
+5 IF $EXTRACT(D)="V"
IF N["DNKA"
QUIT 1
+6 IF $EXTRACT(D)="V"
IF N["DID NOT KEEP APPOINTMENT"
QUIT 1
+7 IF $EXTRACT(D)="V"
IF N["DID NOT KEEP APPT"
QUIT 1
+8 QUIT 0
+9 ;
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
+2 ;if none found check taxonomy
+3 IF '$GET(P)
QUIT ""
+4 ;if don't pass date look at all time
IF '$GET(D)
SET D=""
+5 NEW BDMSMEDS
+6 KILL BDMSMEDS
+7 DO GETMEDS^BDMSMU1(P,D,,"DM AUDIT ACE INHIBITORS",,"DM AUDIT ACE INHIB CLASS",,.BDMSMEDS)
+8 ;GET THE LAST ONE
+9 NEW BDMSMED,X,%,Z,V,C
+10 IF '$DATA(BDMSMEDS)
QUIT "No"
+11 SET X=0
SET C=0
FOR
SET X=$ORDER(BDMSMEDS(X))
IF X'=+X
QUIT
SET C=X
+12 SET %=+$PIECE(BDMSMEDS(C),U,4)
+13 ;last one
SET V=$PIECE(BDMSMEDS(C),U,5)
+14 IF $PIECE(^AUPNVMED(%,0),U,8)=""
SET %="Yes "_$$DATE^BDMS9B1($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVMED(%,0),U,3),0),U),"."))_" "_$$VAL^XBDIQ1(9000010.14,%,.01)
QUIT %
+15 IF $PIECE(^AUPNVMED(%,0),U,8)]""
SET %="Discontinued "_$$DATE^BDMS9B1($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVMED(%,0),U,3),0),U),"."))_" "_$$VAL^XBDIQ1(9000010.14,%,.01)
QUIT %
+16 QUIT "No"
+17 ;
ASPREF(P) ;EP - CHECK FOR ASPIRIN NMI OR REFUSAL
+1 IF '$GET(P)
QUIT ""
+2 NEW X,N,Z,D,IEN,DATE,DRUG
+3 KILL X
+4 SET T=$ORDER(^ATXAX("B","DM AUDIT ASPIRIN DRUGS",0))
+5 IF 'T
QUIT ""
+6 SET (D,G)=0
FOR
SET D=$ORDER(^AUPNPREF("AA",P,50,D))
IF D'=+D!(G)
QUIT
Begin DoDot:1
+7 IF '$DATA(^ATXAX(T,21,"B",D))
QUIT
+8 SET X=$ORDER(^AUPNPREF("AA",P,50,D,0))
+9 SET N=$ORDER(^AUPNPREF("AA",P,50,D,X,0))
+10 SET G=1
SET DATE=9999999-X
SET DRUG=D
SET IEN=N
End DoDot:1
+11 IF 'G
QUIT ""
+12 QUIT $EXTRACT($$VAL^XBDIQ1(50,DRUG,.01),1,30)_" "_$$TYPEREF^BDMSMU(IEN)_" on "_$$DATE^BDMS9B1(DATE)
PNEU(P) ;EP
+1 NEW BDMY,PNEU,X,G,Z,R,Y,%,PNEU1,PNEU2
+2 SET PNEU1=$$LASTPNEU(P,,,"A")
+3 SET PNEU2=$$LASTPNEU(P,,$$FMADD^XLFDT($PIECE(PNEU1,U),-1),"A")
+4 IF PNEU1]""
QUIT "Yes "_$$DATE^BDMS9B1($PIECE(PNEU1,U))_" "_$$DATE^BDMS9B1($PIECE(PNEU2,U))
+5 SET R=""
SET G=""
FOR R=33,109
IF R=""!(G)
QUIT
Begin DoDot:1
+6 SET G=$$REFUSAL^BDMDG17(P,9999999.14,$ORDER(^AUTTIMM("C",R,0)),$$DOB^AUPNPAT(P),DT,"R")
End DoDot:1
+7 IF G
QUIT "Refused "_$PIECE(G,U,3)
+8 ;; BI REFUSALS
+9 SET G=""
FOR Z=33,109
IF G
QUIT
SET X=0
SET Y=$ORDER(^AUTTIMM("C",Z,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+10 SET R=$PIECE(^BIPC(X,0),U,3)
+11 IF R=""
QUIT
+12 IF '$DATA(^BICONT(R,0))
QUIT
+13 IF $PIECE(^BICONT(R,0),U,1)'["Refusal"
QUIT
+14 SET D=$PIECE(^BIPC(X,0),U,4)
+15 IF D=""
QUIT
+16 SET G=1_U_D
End DoDot:1
+17 IF G
QUIT "Refused "_$$DATE^BDMS9B1($PIECE(G,U,2))
+18 SET G=""
SET Z=""
FOR Z=33,109
IF Z=""!(G]"")
QUIT
SET G=$$PNEUCONT(P,Z,$$DOB^AUPNPAT(P),DT)
+19 IF G]""
QUIT G
+20 QUIT "No"
PNEUCONT(P,C,BD,ED) ;EP
+1 NEW X,G,Y,R,D
+2 SET X=0
SET G=""
SET Y=$ORDER(^AUTTIMM("C",C,0))
IF Y
FOR
SET X=$ORDER(^BIPC("AC",P,Y,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+3 SET R=$PIECE(^BIPC(X,0),U,3)
+4 IF R=""
QUIT
+5 IF '$DATA(^BICONT(R,0))
QUIT
+6 SET D=$PIECE(^BIPC(X,0),U,4)
+7 IF $PIECE(^BIPC(X,0),U,4)>ED
QUIT
+8 IF $PIECE(^BICONT(R,0),U,1)="Anaphylaxis"
SET G="Contraindication: Anaphylaxis "_$$DATE^BDMS9B1(D)
End DoDot:1
+9 QUIT G
PPD(P) ;EP
+1 NEW BDMY,Y,X,%,E,BDMV
+2 SET BDMV=""
+3 SET %=P_"^LAST SKIN PPD"
SET E=$$START1^APCLDF(%,"BDMY(")
+4 ;$P(^AUPNVSK(+$P(BDMY(1),U,4),0),U,5)_" "_$$DATE^BDMS9B1($P(BDMY(1),U))
SET E=""
IF $DATA(BDMY(1))
SET BDMV=$PIECE(BDMY(1),U)_U_$PIECE(^AUPNVSK(+$PIECE(BDMY(1),U,4),0),U,5)_U_$$VAL^XBDIQ1(9000010.12,+$PIECE(BDMY(1),U,4),.04)_U_" PPD"
+5 KILL BDMY
+6 SET X=P_"^LAST LAB [DM AUDIT TB LAB TESTS"
SET E=$$START1^APCLDF(X,"BDMY(")
+7 IF $DATA(BDMY(1))
IF $PIECE(BDMY(1),U,1)>$PIECE(BDMV,U,1)
SET BDMV=$PIECE(BDMY(1),U)_U_U_$PIECE(^AUPNVLAB(+$PIECE(BDMY(1),U,4),0),U,4)_U_$$VAL^XBDIQ1(9000010.09,+$PIECE(BDMY(1),U,4),.01)
+8 ;K BDMY S X=P_"^LAST DX V74.1" S E=$$START1^APCLDF(X,"BDMY(")
+9 ;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)"
+10 IF BDMV]""
QUIT $PIECE(BDMV,U,4)_" "_$PIECE(BDMV,U,2)_" "_$PIECE(BDMV,U,3)_" "_$$DATE^BDMS9B1($PIECE(BDMV,U,1))
+11 SET G=$$REFUSAL^BDMDG17(P,9999999.28,$ORDER(^AUTTSK("B","PPD",0)),$$DOB^AUPNPAT(P),DT,"R")
+12 IF G
QUIT G
+13 QUIT ""
PPDS(P) ;EP
+1 ;check for tb health factor, problem list, povs if and
+2 ;indication of pos ppd then return "Known Positive PPD"
+3 NEW BDMS,E,X
+4 KILL BDMS
+5 SET X=P_"^LAST HEALTH [DM AUDIT TB HEALTH FACTORS"
SET E=$$START1^APCLDF(X,"BDMS(")
+6 IF $DATA(BDMS)
QUIT "Known Positive PPD or Hx of TB (Health Factor)"
PPDSPL ;CHECK PL
+1 NEW T
SET T="DM AUDIT TUBERCULOSIS DXS"
+2 IF 'T
QUIT ""
+3 NEW X,Y,I
SET (X,Y,I)=0
FOR
SET X=$ORDER(^AUPNPROB("AC",P,X))
IF X'=+X!(I)
QUIT
IF $DATA(^AUPNPROB(X,0))
IF $PIECE(^AUPNPROB(X,0),U,12)'="D"
SET Y=$PIECE(^AUPNPROB(X,0),U)
IF $$ICD^BDMUTL(Y,T,9)
SET I=1
+4 IF I
QUIT "Known Positive PPD or Hx of TB (Problem List DX)"
+5 ;check povs
+6 KILL BDMS
SET X=P_"^FIRST DX [DM AUDIT TUBERCULOSIS DXS"
SET E=$$START1^APCLDF(X,"BDMS(")
+7 IF $DATA(BDMS(1))
QUIT "Known Positive PPD or Hx of TB (POV/DX "_$$DATE^BDMS9B1($PIECE(BDMS(1),U))_")"
+8 QUIT ""
BI() ;EP- check to see if using new imm package or not 1/5/1999 IHS/CMI/LAB
+1 QUIT $SELECT($ORDER(^AUTTIMM(0))<100:0,1:1)
LASTPNEU(BDMPDFN,BDMBD,BDMED,BDMFORM) ;PEP - date of last PNEUMOVAX
+1 ;
+2 IF $GET(BDMPDFN)=""
QUIT ""
+3 IF $GET(BDMBD)=""
SET BDMBD=$$DOB^AUPNPAT(BDMPDFN)
+4 IF $GET(BDMED)=""
SET BDMED=DT
+5 IF $GET(BDMFORM)=""
SET BDMFORM="D"
+6 NEW BDMLAST,BDMVAL,BDMX,R,X,Y,V,E,T,G,BDMY,BDMF
+7 SET BDMLAST=""
+8 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"33","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+9 DO E
+10 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"100","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+11 DO E
+12 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"109","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+13 DO E
+14 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"133","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+15 DO E
+16 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"152","IMMUNIZATION",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+17 DO E
+18 SET BDMVAL=$$LASTITEM^APCLAPIU(BDMPDFN,"V03.82","DX",$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"A")
+19 DO E
+20 SET BDMVAL=$$LASTCPTT^APCLAPIU(BDMPDFN,$SELECT($PIECE(BDMLAST,U)]"":$PIECE(BDMLAST,U),1:BDMBD),BDMED,"BGP PNEUMO IZ CPTS","A")
+21 DO E
+22 IF BDMFORM="D"
QUIT $PIECE(BDMLAST,U)
+23 QUIT BDMLAST
+24 ;
E ;
+1 IF $PIECE(BDMVAL,U,1)>$PIECE(BDMLAST,U,1)
SET BDMLAST=BDMVAL
+2 QUIT
+3 ;
+4 ;
MAMREF(P,LMAM) ;EP
+1 NEW G,BDMY,I,D,X,C,LAST
+2 SET G=""
SET LAST=""
+3 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",P,71,I))
IF I'=+I
QUIT
Begin DoDot:1
+4 SET C=$PIECE($GET(^RAMIS(71,I,0)),U,9)
+5 IF C=""
QUIT
+6 IF '$$ICD^BDMUTL(C,$ORDER(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1)
QUIT
+7 ;last date
SET D=$ORDER(^AUPNPREF("AA",P,71,I,0))
+8 SET D=9999999-D
+9 IF D>$PIECE(LAST,U,1)
SET LAST=D_U_"Patient Refused a Mammogram ("_C_") on "_$$DATE^BDMS9B1(D)
End DoDot:1
+10 ;now check cpt refusals
+11 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",P,81,I))
IF I'=+I
QUIT
Begin DoDot:1
+12 SET C=I
+13 IF '$$ICD^BDMUTL(C,$ORDER(^ATXAX("B","BGP CPT MAMMOGRAM",0)),1)
QUIT
+14 ;last date
SET D=$ORDER(^AUPNPREF("AA",P,81,I,0))
+15 SET D=9999999-D
+16 IF D>$PIECE(LAST,U,1)
SET LAST=D_U_"Patient Refused a Mammogram ("_C_") on "_$$DATE^BDMS9B1(D)
End DoDot:1
+17 ;now check PROC refusals
+18 SET I=0
FOR
SET I=$ORDER(^AUPNPREF("AA",P,80.1,I))
IF I'=+I
QUIT
Begin DoDot:1
+19 SET C=I
+20 SET C=$PIECE($GET(^ICD0(C,0)),U,1)
+21 IF C'=87.36
IF C'=87.37
QUIT
+22 ;last date
SET D=$ORDER(^AUPNPREF("AA",P,80.1,I,0))
+23 SET D=9999999-D
+24 IF D>$PIECE(LAST,U,1)
SET LAST=D_U_"Patient Refused a Mammogram ("_C_") on "_$$DATE^BDMS9B1(D)
End DoDot:1
+25 QUIT $GET(LAST)
+26 ;
PAP(P) ;EP
+1 QUIT $$LASTPAP^APCLAPI1(P,,,"A")
