BDMS9B5 ; IHS/CMI/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**3,8,9**;JUN 14, 2007;Build 78
;
;
MAM ;EP
K BDMSDAT,BDMSTEX
S BDMSDAT=""
;BDMsdat=date of last, BDMstex is display
Q:$P(^DPT(BDMSPAT,0),U,2)="M"
K BDMSEXD,BDMSDF1
S BDMSTXN=0
S BDMSDAT=$$LASTMAM^APCLAPI1(BDMSPAT)_"^"_$$MAMREF^BDMS9B4(BDMSPAT,BDMSDAT)
I $$VERSION^XPDUTL("BW")>2.9 G MAMA
S BDMSBWR=0 S:$D(X) BDMSAVX=X S X="BWUTL1" X ^%ZOSF("TEST") S:$D(BDMSAVX) X=BDMSAVX K BDMSAVX I $T S BDMSBWR=1
I BDMSBWR,$D(^BWP(BDMSPAT,0)) S BDMSTXN=BDMSTXN+1,BDMSTEX(BDMSTXN)=$$BNEED^BWUTL1(BDMSPAT) I BDMSTEX(1)="UNKNOWN" K BDMSTEX(1) S BDMSTXN=0
I $O(BDMSTEX("")) Q
MAMA ;
Q:$$AGE^AUPNPAT(BDMSPAT,DT,"Y")<50
Q:$$AGE^AUPNPAT(BDMSPAT,DT,"Y")>69
K BDMSTXN
S BDMSINT=365
I $P(BDMSDAT,U,2)]"" S BDMSTEX(1)=$P(BDMSDAT,U,2),BDMSDAT=$P(BDMSDAT,U) Q
I BDMSDAT="" S BDMSTEX(1)="MAY BE DUE NOW" Q
K BDMSBWR
S X1=BDMSDAT,X2=BDMSINT D C^%DTC S Y=X X BDMSCVD S BDMSTEX(1)="Next Due: "_Y,BDMSWD=Y
S X2=BDMSDAT,X1=DT D ^%DTC I X>BDMSINT S BDMSTEX(1)=$S('$D(BDMSDD):"MAY BE DUE NOW (WAS DUE "_BDMSWD_")",1:"MAY BE DUE NOW")
Q
;
;
PAP ;EP
K BDMSDAT,BDMSTEX,BDMSTP
S BDMSDAT=""
;BDMsdat=date of last, BDMstex is display
Q:$$AGE^AUPNPAT(BDMSPAT,DT,"Y")<18!($P(^DPT(BDMSPAT,0),U,2)="M")
K BDMSEXD,BDMSDF1
S BDMSTXN=0
I $$VERSION^XPDUTL("BW")>2.9 G PAPA
S BDMSBWR=0 S:$D(X) BDMSAVX=X S X="BWUTL1" X ^%ZOSF("TEST") S:$D(BDMSAVX) X=BDMSAVX K BDMSAVX I $T S BDMSBWR=1
I BDMSBWR,$D(^BWP(BDMSPAT,0)) S BDMSTXN=BDMSTXN+1,BDMSTEX(BDMSTXN)=$$CNEED^BWUTL1(BDMSPAT) I BDMSTEX(1)="UNKNOWN" K BDMSTEX(1) S BDMSTXN=0
PAPA ;
;S BDMSTP=$$HYSTER^BDMS9B4(BDMSPAT,DT)
S BDMSTP=$$HYSTER^BDMPB12(BDMSPAT,DT)
I BDMSTP]"" S BDMSTXN=BDMSTXN+1,BDMSTEX(BDMSTXN)="Pt had hysterectomy. Pap may be necessary",BDMSTXN=BDMSTXN+1,BDMSTEX(BDMSTXN)="based on individual followup."
I $O(BDMSTEX("")) S BDMSDAT="" Q
Q
;
;
ACE(P,D) ;EP - return date of last ACE iNHIBITOR
;IHS/CMI/LAB patch 3 - added this subroutine
;go through all v meds until 9999999-D and find all drugs with class CV800 or CV805
;if none found check taxonomy
G ACE^BDMS9B4
I '$G(P) Q ""
I '$G(D) S D=0 ;if don't pass date look at all time
NEW V,I,%
S %=""
S I=0 F S I=$O(^AUPNVMED("AA",P,I)) Q:I'=+I!(%)!(I>(9999999-D)) D
.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
I %]"" D Q %
.I $P(^AUPNVMED(%,0),U,8)="" S %="Yes - "_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),".")) Q
.I $P(^AUPNVMED(%,0),U,8)]"" S %="Discontinued - "_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),".")) Q
NEW T S T=$O(^ATXAX("B","DM AUDIT ACE INHIBITORS",0))
I 'T Q ""
S I=0 F S I=$O(^AUPNVMED("AA",P,I)) Q:I'=+I!(%)!(I>(9999999-D)) D
.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
I %]"" D Q %
.I $P(^AUPNVMED(%,0),U,8)="" S %="Yes - "_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),".")) Q
.I $P(^AUPNVMED(%,0),U,8)]"" S %="Discontinued - "_$$FMTE^XLFDT($P($P(^AUPNVSIT($P(^AUPNVMED(%,0),U,3),0),U),".")) 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 $$VAL^XBDIQ1(50,DRUG,.01)_" "_$$TYPEREF^BDMSMU(IEN)_" on "_$$FMTE^XLFDT(DATE)
BDMS9B5 ; IHS/CMI/LAB - DIABETIC CARE SUMMARY SUPPLEMENT ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**3,8,9**;JUN 14, 2007;Build 78
+2 ;
+3 ;
MAM ;EP
+1 KILL BDMSDAT,BDMSTEX
+2 SET BDMSDAT=""
+3 ;BDMsdat=date of last, BDMstex is display
+4 IF $PIECE(^DPT(BDMSPAT,0),U,2)="M"
QUIT
+5 KILL BDMSEXD,BDMSDF1
+6 SET BDMSTXN=0
+7 SET BDMSDAT=$$LASTMAM^APCLAPI1(BDMSPAT)_"^"_$$MAMREF^BDMS9B4(BDMSPAT,BDMSDAT)
+8 IF $$VERSION^XPDUTL("BW")>2.9
GOTO MAMA
+9 SET BDMSBWR=0
IF $DATA(X)
SET BDMSAVX=X
SET X="BWUTL1"
XECUTE ^%ZOSF("TEST")
IF $DATA(BDMSAVX)
SET X=BDMSAVX
KILL BDMSAVX
IF $TEST
SET BDMSBWR=1
+10 IF BDMSBWR
IF $DATA(^BWP(BDMSPAT,0))
SET BDMSTXN=BDMSTXN+1
SET BDMSTEX(BDMSTXN)=$$BNEED^BWUTL1(BDMSPAT)
IF BDMSTEX(1)="UNKNOWN"
KILL BDMSTEX(1)
SET BDMSTXN=0
+11 IF $ORDER(BDMSTEX(""))
QUIT
MAMA ;
+1 IF $$AGE^AUPNPAT(BDMSPAT,DT,"Y")<50
QUIT
+2 IF $$AGE^AUPNPAT(BDMSPAT,DT,"Y")>69
QUIT
+3 KILL BDMSTXN
+4 SET BDMSINT=365
+5 IF $PIECE(BDMSDAT,U,2)]""
SET BDMSTEX(1)=$PIECE(BDMSDAT,U,2)
SET BDMSDAT=$PIECE(BDMSDAT,U)
QUIT
+6 IF BDMSDAT=""
SET BDMSTEX(1)="MAY BE DUE NOW"
QUIT
+7 KILL BDMSBWR
+8 SET X1=BDMSDAT
SET X2=BDMSINT
DO C^%DTC
SET Y=X
XECUTE BDMSCVD
SET BDMSTEX(1)="Next Due: "_Y
SET BDMSWD=Y
+9 SET X2=BDMSDAT
SET X1=DT
DO ^%DTC
IF X>BDMSINT
SET BDMSTEX(1)=$SELECT('$DATA(BDMSDD):"MAY BE DUE NOW (WAS DUE "_BDMSWD_")",1:"MAY BE DUE NOW")
+10 QUIT
+11 ;
+12 ;
PAP ;EP
+1 KILL BDMSDAT,BDMSTEX,BDMSTP
+2 SET BDMSDAT=""
+3 ;BDMsdat=date of last, BDMstex is display
+4 IF $$AGE^AUPNPAT(BDMSPAT,DT,"Y")<18!($PIECE(^DPT(BDMSPAT,0),U,2)="M")
QUIT
+5 KILL BDMSEXD,BDMSDF1
+6 SET BDMSTXN=0
+7 IF $$VERSION^XPDUTL("BW")>2.9
GOTO PAPA
+8 SET BDMSBWR=0
IF $DATA(X)
SET BDMSAVX=X
SET X="BWUTL1"
XECUTE ^%ZOSF("TEST")
IF $DATA(BDMSAVX)
SET X=BDMSAVX
KILL BDMSAVX
IF $TEST
SET BDMSBWR=1
+9 IF BDMSBWR
IF $DATA(^BWP(BDMSPAT,0))
SET BDMSTXN=BDMSTXN+1
SET BDMSTEX(BDMSTXN)=$$CNEED^BWUTL1(BDMSPAT)
IF BDMSTEX(1)="UNKNOWN"
KILL BDMSTEX(1)
SET BDMSTXN=0
PAPA ;
+1 ;S BDMSTP=$$HYSTER^BDMS9B4(BDMSPAT,DT)
+2 SET BDMSTP=$$HYSTER^BDMPB12(BDMSPAT,DT)
+3 IF BDMSTP]""
SET BDMSTXN=BDMSTXN+1
SET BDMSTEX(BDMSTXN)="Pt had hysterectomy. Pap may be necessary"
SET BDMSTXN=BDMSTXN+1
SET BDMSTEX(BDMSTXN)="based on individual followup."
+4 IF $ORDER(BDMSTEX(""))
SET BDMSDAT=""
QUIT
+5 QUIT
+6 ;
+7 ;
ACE(P,D) ;EP - return date of last ACE iNHIBITOR
+1 ;IHS/CMI/LAB patch 3 - added this subroutine
+2 ;go through all v meds until 9999999-D and find all drugs with class CV800 or CV805
+3 ;if none found check taxonomy
+4 GOTO ACE^BDMS9B4
+5 IF '$GET(P)
QUIT ""
+6 ;if don't pass date look at all time
IF '$GET(D)
SET D=0
+7 NEW V,I,%
+8 SET %=""
+9 SET I=0
FOR
SET I=$ORDER(^AUPNVMED("AA",P,I))
IF I'=+I!(%)!(I>(9999999-D))
QUIT
Begin DoDot:1
+10 SET V=0
FOR
SET V=$ORDER(^AUPNVMED("AA",P,I,V))
IF V'=+V
QUIT
IF $DATA(^AUPNVMED(V,0))
SET G=$PIECE(^AUPNVMED(V,0),U)
IF $PIECE($GET(^PSDRUG(G,0)),U,2)="CV800"!($PIECE($GET(^PSDRUG(G,0)),U,2)="CV805")
SET %=V
End DoDot:1
+11 IF %]""
Begin DoDot:1
+12 IF $PIECE(^AUPNVMED(%,0),U,8)=""
SET %="Yes - "_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVMED(%,0),U,3),0),U),"."))
QUIT
+13 IF $PIECE(^AUPNVMED(%,0),U,8)]""
SET %="Discontinued - "_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVMED(%,0),U,3),0),U),"."))
QUIT
End DoDot:1
QUIT %
+14 NEW T
SET T=$ORDER(^ATXAX("B","DM AUDIT ACE INHIBITORS",0))
+15 IF 'T
QUIT ""
+16 SET I=0
FOR
SET I=$ORDER(^AUPNVMED("AA",P,I))
IF I'=+I!(%)!(I>(9999999-D))
QUIT
Begin DoDot:1
+17 SET V=0
FOR
SET V=$ORDER(^AUPNVMED("AA",P,I,V))
IF V'=+V
QUIT
IF $DATA(^AUPNVMED(V,0))
SET G=$PIECE(^AUPNVMED(V,0),U)
IF $DATA(^ATXAX(T,21,"B",G))
SET %=V
End DoDot:1
+18 IF %]""
Begin DoDot:1
+19 IF $PIECE(^AUPNVMED(%,0),U,8)=""
SET %="Yes - "_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVMED(%,0),U,3),0),U),"."))
QUIT
+20 IF $PIECE(^AUPNVMED(%,0),U,8)]""
SET %="Discontinued - "_$$FMTE^XLFDT($PIECE($PIECE(^AUPNVSIT($PIECE(^AUPNVMED(%,0),U,3),0),U),"."))
QUIT
End DoDot:1
QUIT %
+21 QUIT "No"
+22 ;
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 $$VAL^XBDIQ1(50,DRUG,.01)_" "_$$TYPEREF^BDMSMU(IEN)_" on "_$$FMTE^XLFDT(DATE)
