Routine: BDMDE1S

BDMDE1S ; IHS/CMI/LAB -IHS -CUMULATIVE REPORT 03 Feb 2014 5:38 PM ;

 ;;2.0;DIABETES MANAGEMENT SYSTEM;**10,11**;JUN 14, 2007;Build 30

SDPI ;EP

 K BDMCUML

 S BDMCUML(10)="Adult Weight and Cardiometabolic Risk Management and Diabetes Guidelines"

 S BDMCUML(10,1)="Documented assessment for"

 S BDMCUML(10,2)="overweight or obesity (height"

 S BDMCUML(10,3)="and weight reported)"

 S BDMCUML(10,4)="Documented nutrition and physical"

 S BDMCUML(10,5)="activity education"

 S BDMCUML(20)="Cardiovascular Health and Diabetes"

 S BDMCUML(20,1)="Documented smoking status"

 S BDMCUML(20,2)="In current tobacco users, counseled"

 S BDMCUML(20,3)="Mean blood pressure (BP) <140/<90"

 S BDMCUML(30)="Depression Care"

 S BDMCUML(30,1)="In patients without active depression,"

 S BDMCUML(30,2)="screened for depression**"

 S BDMCUML(40)="Eye Care"

 S BDMCUML(40,1)="Eye exam - dilated or retinal imaging"

 S BDMCUML(50)="Foot Care"

 S BDMCUML(50,1)="Foot exam - Complete"

 S BDMCUML(60)="Nutrition for Diabetes Prevention and Care"

 S BDMCUML(60,1)="Documented nutrition education"

 S BDMCUML(60,2)="Documented nutrition education by an RD"

 S BDMCUML(70)="Oral Health Care"

 S BDMCUML(70,1)="Dental exam"

 S BDMCUML(80)="Screening for Chronic Kidney Disease"

 S BDMCUML(80,1)="In patients age 18 and above,"

 S BDMCUML(80,2)="eGFR and UACR"

 S BDMCUML(80,3)="Mean blood pressure (BP) <140/<90"

 S BDMCUML(80,4)="In patients with known hypertension, ACE"

 S BDMCUML(80,5)="inhibitor or ARB prescribed"

 S BDMCUML(90)="Systems of Care"

 S BDMCUML(90,1)="A1C <8.0"

 S BDMCUML(90,2)="A1C >=9.0"

 S BDMCUML(90,3)="Mean blood pressure (BP) <140/<90"

 S BDMCUML(90,4)="LDL <100"

 S BDMCUML(90,5)="Combined Audit Outcomes Measure: A1C<8.0,"

 S BDMCUML(90,6)="LDL <100, and mean BP <140/<90"

PROCESS ;

 S BDMNOGO=0

 S BDMPD=0 F  S BDMPD=$O(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD)) Q:BDMPD'=+BDMPD  D CUML1

CUML1 ;

BMI ;

 I $$DODX^BDMDE16(BDMPD,BDMDMRG,"I")>BDMADAT S BDMNOGO=BDMNOGO+1 Q

 S H=$G(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,30))

 S W=$G(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,32))

 S $P(BDMCUML(10,3),U,3)=$P($G(BDMCUML(10,3)),U,3)+1  ;DENOM

 I H]"",W]"" S $P(BDMCUML(10,3),U,2)=$P(BDMCUML(10,3),U,2)+1 ;NUMER

PA ;

 S N=$E($G(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,44)))

 S P=$E($G(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,46)))

 S $P(BDMCUML(10,5),U,3)=$P($G(BDMCUML(10,5)),U,3)+1  ;DENOM

 I P=1,(N=1!(N=2)!(N=3)) S $P(BDMCUML(10,5),U,2)=$P(BDMCUML(10,5),U,2)+1  ;NUME

CHD ;

 S $P(BDMCUML(20,1),U,3)=$P(BDMCUML(20,1),U,3)+1  ;DENOM

 S V=$G(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,27))

 I $E(V)=1!($E(V)=2) S $P(BDMCUML(20,1),U,2)=$P(BDMCUML(20,1),U,2)+1

 S C=$G(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,28))

 I $E(V)=1 S $P(BDMCUML(20,2),U,3)=$P(BDMCUML(20,2),U,3)+1 I $E(C)=1 S $P(BDMCUML(20,2),U,2)=$P(BDMCUML(20,2),U,2)+1

BPC ;blood pressure control

 ;take last 3 bp's and get mean systolic and mean diastolic

 S $P(BDMCUML(20,3),U,3)=$P(BDMCUML(20,3),U,3)+1

 S S=$$SYSMEAN^BDMDE15(BDMPD,BDMRBD,BDMRED)

 S D=$$DIAMEAN^BDMDE15(BDMPD,BDMRBD,BDMRED)

 .I S=""!(D="") Q

 .I S<140&(D<90) S $P(BDMCUML(20,3),U,2)=$P(BDMCUML(20,3),U,2)+1 Q

DEP ;

 S V=$G(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,200))

 I $E(V)'="1" S $P(BDMCUML(30,2),U,3)=$P(BDMCUML(30,2),U,3)+1 D

 .S V=$G(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,210))

 .I $E(V)="1" S $P(BDMCUML(30,2),U,2)=$P(BDMCUML(30,2),U,2)+1

EYE ;

 S $P(BDMCUML(40,1),U,3)=$P(BDMCUML(40,1),U,3)+1

 S V=$G(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,40))

 I $E(V)="1" S $P(BDMCUML(40,1),U,2)=$P(BDMCUML(40,1),U,2)+1

FOOT ;

 S $P(BDMCUML(50,1),U,3)=$P(BDMCUML(50,1),U,3)+1

 S V=$G(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,38))

 I $E(V)="1" S $P(BDMCUML(50,1),U,2)=$P(BDMCUML(50,1),U,2)+1

NUTR ;

 S $P(BDMCUML(60,1),U,3)=$P(BDMCUML(60,1),U,3)+1

 S $P(BDMCUML(60,2),U,3)=$P(BDMCUML(60,2),U,3)+1

 S N=$E($G(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,44)))

 I N=1!(N=2)!(N=3) S $P(BDMCUML(60,1),U,2)=$P(BDMCUML(60,1),U,2)+1  ;NUME

 I N=1!(N=3) S $P(BDMCUML(60,2),U,2)=$P(BDMCUML(60,2),U,2)+1

DENT ;

 S $P(BDMCUML(70,1),U,3)=$P(BDMCUML(70,1),U,3)+1

 S V=$G(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,42))

 I $E(V)="1" S $P(BDMCUML(70,1),U,2)=$P(BDMCUML(70,1),U,2)+1

EGFR ;

 I $$AGE^AUPNPAT(BDMPD,BDMADAT)>17 D

 .S $P(BDMCUML(80,2),U,3)=$P(BDMCUML(80,2),U,3)+1

 .S V=$G(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,79))

 .S Q=$G(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,92))

 .I $E(V)=1,$E(Q)=1 S $P(BDMCUML(80,2),U,2)=$P(BDMCUML(80,2),U,2)+1

BPS ;

 S $P(BDMCUML(80,3),U,3)=$P(BDMCUML(80,3),U,3)+1

 S S=$$SYSMEAN^BDMDE15(BDMPD,BDMRBD,BDMRED)

 S D=$$DIAMEAN^BDMDE15(BDMPD,BDMRBD,BDMRED)

 .I S=""!(D="") Q

 .I S<140&(D<90) S $P(BDMCUML(80,3),U,2)=$P(BDMCUML(80,3),U,2)+1 Q

ACE ;

 S H=$E($G(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,34)))

 I H=1 D

 .S $P(BDMCUML(80,5),U,3)=$P(BDMCUML(80,5),U,3)+1

 .S A=$E($G(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,60)))

 .I A=1 S $P(BDMCUML(80,5),U,2)=$P(BDMCUML(80,5),U,2)+1

SC ;

 S $P(BDMCUML(90,1),U,3)=$P(BDMCUML(90,1),U,3)+1

 S $P(BDMCUML(90,2),U,3)=$P(BDMCUML(90,2),U,3)+1

 S V=$P($G(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,78)),U,2)

 S P="",BDMA18=0

 I V=""!(V="?") G N

 I V["<" S P=1

 I V[">" S P=2

 S V=$$STV^BDMDE18(V,5)

 I V="" G N

 S V=+V

 I 'P S P=$S(V="":0,V<8.0:1,V>8.9:2,1:"")

 I P=1 S $P(BDMCUML(90,1),U,2)=$P(BDMCUML(90,1),U,2)+1,BDMA18=1

 I P=2 S $P(BDMCUML(90,2),U,2)=$P(BDMCUML(90,2),U,2)+1

N ;

 S $P(BDMCUML(90,3),U,3)=$P(BDMCUML(90,3),U,3)+1

 S S=$$SYSMEAN^BDMDE15(BDMPD,BDMRBD,BDMRED)

 S D=$$DIAMEAN^BDMDE15(BDMPD,BDMRBD,BDMRED)

 .S BDMMBP=0

 .I S=""!(D="") Q

 .I S<140&(D<90) S BDMMBP=1 S $P(BDMCUML(90,3),U,2)=$P(BDMCUML(90,3),U,2)+1 Q

LDL ;

 S BDMLDL=0

 S $P(BDMCUML(90,4),U,3)=$P(BDMCUML(90,4),U,3)+1

 S V=$$LDL^BDMDE18(BDMPD,BDMBDAT,BDMADAT,"I")

 I V="" G N1

 S V=$P(V,U)

 S V=$$STV^BDMDE18(V,5,1) I $E(V)'=+$E(V)!(+V=0) G N1

 I V<100 S $P(BDMCUML(90,4),U,2)=$P(BDMCUML(90,4),U,2)+1 S BDMLDL=1

N1 ;

 S $P(BDMCUML(90,6),U,3)=$P(BDMCUML(90,6),U,3)+1

 I BDMA18,BDMLDL,BDMMBP S $P(BDMCUML(90,6),U,2)=$P(BDMCUML(90,6),U,2)+1

BDMDE1S   ; IHS/CMI/LAB -IHS -CUMULATIVE REPORT 03 Feb 2014 5:38 PM ;

 +1       ;;2.0;DIABETES MANAGEMENT SYSTEM;**10,11**;JUN 14, 2007;Build 30

 +2       ;

 +3       ;

SDPI      ;EP

 +1        KILL BDMCUML

 +2        SET BDMCUML(10)="Adult Weight and Cardiometabolic Risk Management and Diabetes Guidelines"

 +3        SET BDMCUML(10,1)="Documented assessment for"

 +4        SET BDMCUML(10,2)="overweight or obesity (height"

 +5        SET BDMCUML(10,3)="and weight reported)"

 +6        SET BDMCUML(10,4)="Documented nutrition and physical"

 +7        SET BDMCUML(10,5)="activity education"

 +8        SET BDMCUML(20)="Cardiovascular Health and Diabetes"

 +9        SET BDMCUML(20,1)="Documented smoking status"

 +10       SET BDMCUML(20,2)="In current tobacco users, counseled"

 +11       SET BDMCUML(20,3)="Mean blood pressure (BP) <140/<90"

 +12       SET BDMCUML(30)="Depression Care"

 +13       SET BDMCUML(30,1)="In patients without active depression,"

 +14       SET BDMCUML(30,2)="screened for depression**"

 +15       SET BDMCUML(40)="Eye Care"

 +16       SET BDMCUML(40,1)="Eye exam - dilated or retinal imaging"

 +17       SET BDMCUML(50)="Foot Care"

 +18       SET BDMCUML(50,1)="Foot exam - Complete"

 +19       SET BDMCUML(60)="Nutrition for Diabetes Prevention and Care"

 +20       SET BDMCUML(60,1)="Documented nutrition education"

 +21       SET BDMCUML(60,2)="Documented nutrition education by an RD"

 +22       SET BDMCUML(70)="Oral Health Care"

 +23       SET BDMCUML(70,1)="Dental exam"

 +24       SET BDMCUML(80)="Screening for Chronic Kidney Disease"

 +25       SET BDMCUML(80,1)="In patients age 18 and above,"

 +26       SET BDMCUML(80,2)="eGFR and UACR"

 +27       SET BDMCUML(80,3)="Mean blood pressure (BP) <140/<90"

 +28       SET BDMCUML(80,4)="In patients with known hypertension, ACE"

 +29       SET BDMCUML(80,5)="inhibitor or ARB prescribed"

 +30       SET BDMCUML(90)="Systems of Care"

 +31       SET BDMCUML(90,1)="A1C <8.0"

 +32       SET BDMCUML(90,2)="A1C >=9.0"

 +33       SET BDMCUML(90,3)="Mean blood pressure (BP) <140/<90"

 +34       SET BDMCUML(90,4)="LDL <100"

 +35       SET BDMCUML(90,5)="Combined Audit Outcomes Measure: A1C<8.0,"

 +36       SET BDMCUML(90,6)="LDL <100, and mean BP <140/<90"

 +37      ;

PROCESS   ;

 +1        SET BDMNOGO=0

 +2        SET BDMPD=0

FOR

               SET BDMPD=$ORDER(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD))

               IF BDMPD'=+BDMPD

                   QUIT

               DO CUML1

 +3        QUIT

 +4       ;

CUML1     ;

BMI       ;

 +1        IF $$DODX^BDMDE16(BDMPD,BDMDMRG,"I")>BDMADAT

               SET BDMNOGO=BDMNOGO+1

               QUIT

 +2        SET H=$GET(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,30))

 +3        SET W=$GET(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,32))

 +4       ;DENOM

           SET $PIECE(BDMCUML(10,3),U,3)=$PIECE($GET(BDMCUML(10,3)),U,3)+1

 +5       ;NUMER

           IF H]""

               IF W]""

                   SET $PIECE(BDMCUML(10,3),U,2)=$PIECE(BDMCUML(10,3),U,2)+1

PA        ;

 +1        SET N=$EXTRACT($GET(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,44)))

 +2        SET P=$EXTRACT($GET(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,46)))

 +3       ;DENOM

           SET $PIECE(BDMCUML(10,5),U,3)=$PIECE($GET(BDMCUML(10,5)),U,3)+1

 +4       ;NUME

           IF P=1

               IF (N=1!(N=2)!(N=3))

                   SET $PIECE(BDMCUML(10,5),U,2)=$PIECE(BDMCUML(10,5),U,2)+1

CHD       ;

 +1       ;DENOM

           SET $PIECE(BDMCUML(20,1),U,3)=$PIECE(BDMCUML(20,1),U,3)+1

 +2        SET V=$GET(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,27))

 +3        IF $EXTRACT(V)=1!($EXTRACT(V)=2)

               SET $PIECE(BDMCUML(20,1),U,2)=$PIECE(BDMCUML(20,1),U,2)+1

 +4        SET C=$GET(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,28))

 +5        IF $EXTRACT(V)=1

               SET $PIECE(BDMCUML(20,2),U,3)=$PIECE(BDMCUML(20,2),U,3)+1

               IF $EXTRACT(C)=1

                   SET $PIECE(BDMCUML(20,2),U,2)=$PIECE(BDMCUML(20,2),U,2)+1

BPC       ;blood pressure control

 +1       ;take last 3 bp's and get mean systolic and mean diastolic

 +2        SET $PIECE(BDMCUML(20,3),U,3)=$PIECE(BDMCUML(20,3),U,3)+1

 +3        SET S=$$SYSMEAN^BDMDE15(BDMPD,BDMRBD,BDMRED)

 +4        SET D=$$DIAMEAN^BDMDE15(BDMPD,BDMRBD,BDMRED)

 +5        Begin DoDot:1

 +6            IF S=""!(D="")

                   QUIT

 +7            IF S<140&(D<90)

                   SET $PIECE(BDMCUML(20,3),U,2)=$PIECE(BDMCUML(20,3),U,2)+1

                   QUIT

           End DoDot:1

DEP       ;

 +1        SET V=$GET(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,200))

 +2        IF $EXTRACT(V)'="1"

               SET $PIECE(BDMCUML(30,2),U,3)=$PIECE(BDMCUML(30,2),U,3)+1

               Begin DoDot:1

 +3                SET V=$GET(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,210))

 +4                IF $EXTRACT(V)="1"

                       SET $PIECE(BDMCUML(30,2),U,2)=$PIECE(BDMCUML(30,2),U,2)+1

               End DoDot:1

EYE       ;

 +1        SET $PIECE(BDMCUML(40,1),U,3)=$PIECE(BDMCUML(40,1),U,3)+1

 +2        SET V=$GET(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,40))

 +3        IF $EXTRACT(V)="1"

               SET $PIECE(BDMCUML(40,1),U,2)=$PIECE(BDMCUML(40,1),U,2)+1

FOOT      ;

 +1        SET $PIECE(BDMCUML(50,1),U,3)=$PIECE(BDMCUML(50,1),U,3)+1

 +2        SET V=$GET(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,38))

 +3        IF $EXTRACT(V)="1"

               SET $PIECE(BDMCUML(50,1),U,2)=$PIECE(BDMCUML(50,1),U,2)+1

NUTR      ;

 +1        SET $PIECE(BDMCUML(60,1),U,3)=$PIECE(BDMCUML(60,1),U,3)+1

 +2        SET $PIECE(BDMCUML(60,2),U,3)=$PIECE(BDMCUML(60,2),U,3)+1

 +3        SET N=$EXTRACT($GET(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,44)))

 +4       ;NUME

           IF N=1!(N=2)!(N=3)

               SET $PIECE(BDMCUML(60,1),U,2)=$PIECE(BDMCUML(60,1),U,2)+1

 +5        IF N=1!(N=3)

               SET $PIECE(BDMCUML(60,2),U,2)=$PIECE(BDMCUML(60,2),U,2)+1

DENT      ;

 +1        SET $PIECE(BDMCUML(70,1),U,3)=$PIECE(BDMCUML(70,1),U,3)+1

 +2        SET V=$GET(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,42))

 +3        IF $EXTRACT(V)="1"

               SET $PIECE(BDMCUML(70,1),U,2)=$PIECE(BDMCUML(70,1),U,2)+1

EGFR      ;

 +1        IF $$AGE^AUPNPAT(BDMPD,BDMADAT)>17

               Begin DoDot:1

 +2                SET $PIECE(BDMCUML(80,2),U,3)=$PIECE(BDMCUML(80,2),U,3)+1

 +3                SET V=$GET(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,79))

 +4                SET Q=$GET(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,92))

 +5                IF $EXTRACT(V)=1

                       IF $EXTRACT(Q)=1

                           SET $PIECE(BDMCUML(80,2),U,2)=$PIECE(BDMCUML(80,2),U,2)+1

               End DoDot:1

BPS       ;

 +1        SET $PIECE(BDMCUML(80,3),U,3)=$PIECE(BDMCUML(80,3),U,3)+1

 +2        SET S=$$SYSMEAN^BDMDE15(BDMPD,BDMRBD,BDMRED)

 +3        SET D=$$DIAMEAN^BDMDE15(BDMPD,BDMRBD,BDMRED)

 +4        Begin DoDot:1

 +5            IF S=""!(D="")

                   QUIT

 +6            IF S<140&(D<90)

                   SET $PIECE(BDMCUML(80,3),U,2)=$PIECE(BDMCUML(80,3),U,2)+1

                   QUIT

           End DoDot:1

ACE       ;

 +1        SET H=$EXTRACT($GET(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,34)))

 +2        IF H=1

               Begin DoDot:1

 +3                SET $PIECE(BDMCUML(80,5),U,3)=$PIECE(BDMCUML(80,5),U,3)+1

 +4                SET A=$EXTRACT($GET(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,60)))

 +5                IF A=1

                       SET $PIECE(BDMCUML(80,5),U,2)=$PIECE(BDMCUML(80,5),U,2)+1

               End DoDot:1

SC        ;

 +1        SET $PIECE(BDMCUML(90,1),U,3)=$PIECE(BDMCUML(90,1),U,3)+1

 +2        SET $PIECE(BDMCUML(90,2),U,3)=$PIECE(BDMCUML(90,2),U,3)+1

 +3        SET V=$PIECE($GET(^XTMP("BDMDM17",BDMJOB,BDMBTH,"AUDIT",BDMPD,78)),U,2)

 +4        SET P=""

           SET BDMA18=0

 +5        IF V=""!(V="?")

               GOTO N

 +6        IF V["<"

               SET P=1

 +7        IF V[">"

               SET P=2

 +8        SET V=$$STV^BDMDE18(V,5)

 +9        IF V=""

               GOTO N

 +10       SET V=+V

 +11       IF 'P

               SET P=$SELECT(V="":0,V<8.0:1,V>8.9:2,1:"")

 +12       IF P=1

               SET $PIECE(BDMCUML(90,1),U,2)=$PIECE(BDMCUML(90,1),U,2)+1

               SET BDMA18=1

 +13       IF P=2

               SET $PIECE(BDMCUML(90,2),U,2)=$PIECE(BDMCUML(90,2),U,2)+1

N         ;

 +1        SET $PIECE(BDMCUML(90,3),U,3)=$PIECE(BDMCUML(90,3),U,3)+1

 +2        SET S=$$SYSMEAN^BDMDE15(BDMPD,BDMRBD,BDMRED)

 +3        SET D=$$DIAMEAN^BDMDE15(BDMPD,BDMRBD,BDMRED)

 +4        Begin DoDot:1

 +5            SET BDMMBP=0

 +6            IF S=""!(D="")

                   QUIT

 +7            IF S<140&(D<90)

                   SET BDMMBP=1

                   SET $PIECE(BDMCUML(90,3),U,2)=$PIECE(BDMCUML(90,3),U,2)+1

                   QUIT

           End DoDot:1

LDL       ;

 +1        SET BDMLDL=0

 +2        SET $PIECE(BDMCUML(90,4),U,3)=$PIECE(BDMCUML(90,4),U,3)+1

 +3        SET V=$$LDL^BDMDE18(BDMPD,BDMBDAT,BDMADAT,"I")

 +4        IF V=""

               GOTO N1

 +5        SET V=$PIECE(V,U)

 +6        SET V=$$STV^BDMDE18(V,5,1)

           IF $EXTRACT(V)'=+$EXTRACT(V)!(+V=0)

               GOTO N1

 +7        IF V<100

               SET $PIECE(BDMCUML(90,4),U,2)=$PIECE(BDMCUML(90,4),U,2)+1

               SET BDMLDL=1

N1        ;

 +1        SET $PIECE(BDMCUML(90,6),U,3)=$PIECE(BDMCUML(90,6),U,3)+1

 +2        IF BDMA18

               IF BDMLDL

                   IF BDMMBP

                       SET $PIECE(BDMCUML(90,6),U,2)=$PIECE(BDMCUML(90,6),U,2)+1

 +3        QUIT

BDMDE1S.m