BDMS9B5.m

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)