Routine: BDMDF1J

BDMDF1J ; IHS/CMI/LAB -IHS -CUMULATIVE REPORT 10 Oct 2014 9:50 AM ;

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

CUML ;EP

COMORBID ;USE 400

 S:'$D(BDMCUML(400)) BDMCUML(400)="Comorbidities"

 S $P(BDMCUML(400),U,2)=$P(BDMCUML(400),U,2)+1  ;TOTAL # of patients

 ;active depression piece 3

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

 I $E(V)="1" S $P(BDMCUML(400),U,3)=$P(BDMCUML(400),U,3)+1,BDMCOMOR=BDMCOMOR+1

 ;tobacco use piece 4

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

 I +V=1 S $P(BDMCUML(400),U,4)=$P(BDMCUML(400),U,4)+1,BDMCOMOR=BDMCOMOR+1

 ;SEVERELY OBESE PIECE 5

 I BDMSEVOB S $P(BDMCUML(400),U,5)=$P(BDMCUML(400),U,5)+1,BDMCOMOR=BDMCOMOR+1

 ;HYPERTENSION DIAGNOSED PIECE 6

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

 I $E(H)=1 S $P(BDMCUML(400),U,6)=$P(BDMCUML(400),U,6)+1,BDMCOMOR=BDMCOMOR+1

 ;HTN AND MEAN BP <140/<90 PIECE 7

 I $E(H)=1,BDMBP140 S $P(BDMCUML(400),U,7)=$P(BDMCUML(400),U,7)+1

 ;cvd piece 8

 S V=$G(^XTMP("BDMDM18",BDMJOB,BDMBTH,"AUDIT",BDMPD,116))

 I $E(V)=1 S $P(BDMCUML(400),U,8)=$P(BDMCUML(400),U,8)+1,BDMCOMOR=BDMCOMOR+1

 ;CVD & BP <140/<90 PIECE 9

 I $E(V)=1,BDMBP140 S $P(BDMCUML(400),U,9)=$P(BDMCUML(400),U,9)+1

 ;CVD AND NOT A TOBACCO USER PIECE 10

 S T=$G(^XTMP("BDMDM18",BDMJOB,BDMBTH,"AUDIT",BDMPD,27))

 I $E(T)=2,$E(V)=1 S $P(BDMCUML(400),U,10)=$P(BDMCUML(400),U,10)+1

 ;CVD AND STATIN PRESCRIBED PIECE 11

 S T=+$G(^XTMP("BDMDM18",BDMJOB,BDMBTH,"AUDIT",BDMPD,300))

 I $E(V)=1,T=1 S $P(BDMCUML(400),U,11)=$P(BDMCUML(400),U,11)+1

 I $E(V)=1,T'=3 S $P(BDMCUML(400),U,34)=$P(BDMCUML(400),U,34)+1 ;DENOM W/O ALLERGY

 ;CVD AND ASPIRIN PIECE 12

 S T=$G(^XTMP("BDMDM18",BDMJOB,BDMBTH,"AUDIT",BDMPD,62))

 I $E(V)=1,$E(T)=1 S $P(BDMCUML(400),U,12)=$P(BDMCUML(400),U,12)+1

 ;CKD PIECE 13 & 14

 ;CKD IS EGFR <60 OR UACR >=30

 I $$AGE^AUPNPAT(BDMPD,BDMADAT)<18 G N

 S $P(BDMCUML(400),U,13)=$P(BDMCUML(400),U,13)+1  ;over 18 denom

 I BDMCKD S $P(BDMCUML(400),U,14)=$P(BDMCUML(400),U,14)+1,BDMCOMOR=BDMCOMOR+1  ;HAS CKD

 ;CKD AND BP <140/<90 PIECE 15

 I BDMCKD,BDMBP140 S $P(BDMCUML(400),U,15)=$P(BDMCUML(400),U,15)+1

 ;CKD AND ACE PIECE 16

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

 I A=1,BDMCKD S $P(BDMCUML(400),U,16)=$P(BDMCUML(400),U,16)+1

 ;EGFR AND UACR DONE PIECE 17

 S G=0

 I BDMEGFRU S $P(BDMCUML(400),U,17)=$P(BDMCUML(400),U,17)+1 D  I G G N

 .;NORMAL PIECE 18

 .I BDMEGFRV>59,BDMUACRV="<30" S $P(BDMCUML(400),U,18)=$P(BDMCUML(400),U,18)+1 S G=1

 .;STAGE 1/2 EGFR =>60, UACR =>30

 .I BDMEGFRV>59,BDMUACRV=">30" S $P(BDMCUML(400),U,19)=$P(BDMCUML(400),U,19)+1 S G=1

 ;STAGE 3 EGFR 30-59

 I BDMEGFRV]"",BDMEGFRV'<30,BDMEGFRV<60 S $P(BDMCUML(400),U,20)=$P(BDMCUML(400),U,20)+1 G N

 ;STAGE 4 EGFR 15-20 PIECE 21

 I BDMEGFRV]"",BDMEGFRV'<15,BDMEGFRV'>29 S $P(BDMCUML(400),U,21)=$P(BDMCUML(400),U,21)+1 G N

 ;STAGE 5 EGFR <15

 I BDMEGFRV]"",BDMEGFRV<15 S $P(BDMCUML(400),U,22)=$P(BDMCUML(400),U,22)+1 G N

 ;UACR AND EGFR NOT DONE

 S $P(BDMCUML(400),U,23)=$P(BDMCUML(400),U,23)+1

N ;p12 HEP C AND RETINOPATHY

 S V=$G(^XTMP("BDMDM18",BDMJOB,BDMBTH,"AUDIT",BDMPD,222))

 I $E(V)="1" S $P(BDMCUML(400),U,35)=$P(BDMCUML(400),U,35)+1,BDMCOMOR=BDMCOMOR+1 G R

 S V=$G(^XTMP("BDMDM18",BDMJOB,BDMBTH,"AUDIT",BDMPD,223))

 I $E(V)="1" S $P(BDMCUML(400),U,37)=$P(BDMCUML(400),U,37)+1

 I $E(V)'=3 S $P(BDMCUML(400),U,36)=$P(BDMCUML(400),U,36)+1 ;hep c screen denom

R ;RETINOPATHY

 S V=$G(^XTMP("BDMDM18",BDMJOB,BDMBTH,"AUDIT",BDMPD,224))

 I $E(V)="1" S $P(BDMCUML(400),U,38)=$P(BDMCUML(400),U,38)+1,BDMCOMOR=BDMCOMOR+1

V ;NONE PIECE 25

 I BDMCOMOR=0 S $P(BDMCUML(400),U,25)=$P(BDMCUML(400),U,25)+1

 I BDMCOMOR=1 S $P(BDMCUML(400),U,26)=$P(BDMCUML(400),U,26)+1

 I BDMCOMOR=2 S $P(BDMCUML(400),U,27)=$P(BDMCUML(400),U,27)+1

 I BDMCOMOR=3 S $P(BDMCUML(400),U,28)=$P(BDMCUML(400),U,28)+1

 I BDMCOMOR=4 S $P(BDMCUML(400),U,29)=$P(BDMCUML(400),U,29)+1

 I BDMCOMOR>4 S $P(BDMCUML(400),U,30)=$P(BDMCUML(400),U,30)+1  ;P11

 ;I BDMCOMOR=6 S $P(BDMCUML(400),U,31)=$P(BDMCUML(400),U,31)+1  ;P11

REC(DFN,BDMRTYP,BDMRBD,BDMRED,BDMED,BDMDMRG,BDMBDAT) ;EP - called to send back a visit record as

 NEW BDMX,BDMREC,BDMEPIX,BDMTTT,X,Y,Z

 S BDMREC=""

 S BDMRTYP("IEN")=$O(^BDMRECD("B",BDMRTYP,0))

 I 'BDMRTYP("IEN") Q BDMREC

PROC ;

 S BDMEPIX=0

 F  S BDMEPIX=$O(^BDMRECD(BDMRTYP("IEN"),11,"AC",BDMEPIX)) Q:BDMEPIX'=+BDMEPIX!(BDMREC=-1)  S BDMTTT=$O(^BDMRECD(BDMRTYP("IEN"),11,"AC",BDMEPIX,0))  D

 .S X="" X:$D(^BDMRECD(BDMRTYP("IEN"),11,BDMTTT,11)) ^BDMRECD(BDMRTYP("IEN"),11,BDMTTT,11)

 .;I X="" S X=" "

 .S $P(BDMREC,U,$P(^BDMRECD(BDMRTYP("IEN"),11,BDMTTT,0),U,2))=X

 Q BDMREC

EPICHK ;create epi info record in ^BDMDATA("BDMEPI",$J,n)

 ;skip this patient if dodx is greater than the audit date

 S X=$$DODX^BDMDF16(BDMPD,BDMDMRG,"I")

 I X>BDMADAT Q

 ;I DUZ=2881,BDMPD'=8932 Q

 NEW BDMECNT,BDMEPIR,BDMTHER

 S BDMEPIR="",BDMTHER="",BDMECNT=0

 S BDMEPIR=$$REC(BDMPD,"DM AUDIT 2018 EXPORT RECORD",BDMRBD,BDMRED,BDMADAT,BDMDMRG,BDMBDAT)

 ;CHECK ERRORS ON BDMEPIR

 S BDMRTYP("IEN")=$O(^BDMRECD("B","DM AUDIT 2018 EXPORT RECORD",0))

 S Z=0 F  S Z=$O(^BDMRECD(BDMRTYP("IEN"),21,Z)) Q:Z'=+Z  D

 .X:$D(^BDMRECD(BDMRTYP("IEN"),21,Z,1)) ^BDMRECD(BDMRTYP("IEN"),21,Z,1)

 .Q:'$T

 .S S=""

 .I BDMQSRT="P" S S=$P(^DPT(BDMPD,0),U,1)

 .I BDMQSRT="E" S S=$P(^BDMRECD(BDMRTYP("IEN"),21,Z,0),U,1)

 .S BDMECNT=BDMECNT+1

 .S $P(^XTMP("BDMDM18 ERRORS",BDMJOB,BDMBTH,"PATS",S,BDMPD,BDMECNT),U,1)=$P(^BDMRECD(BDMRTYP("IEN"),21,Z,0),U,1)

 .S J=$P(^BDMRECD(BDMRTYP("IEN"),21,Z,0),U,2)

 .S $P(^XTMP("BDMDM18 ERRORS",BDMJOB,BDMBTH,"PATS",S,BDMPD,BDMECNT),U,2)=$S(J="P":"POTENTIAL",J="D":"DEFINITE",1:"")

 .S $P(^XTMP("BDMDM18 ERRORS",BDMJOB,BDMBTH,"PATS",S,BDMPD,BDMECNT),U,3)=$P($G(^BDMRECD(BDMRTYP("IEN"),21,Z,11)),U,1)

 .S P=$P(^BDMRECD(BDMRTYP("IEN"),21,Z,0),U,4)

 .S A=""

 .I P="" D

 ..I $P(^BDMRECD(BDMRTYP("IEN"),21,Z,0),U,1)["BMI" S A=$$BMI^BDMDF18(BDMPD,BDMRBD,BDMRED)

 ..I $P(^BDMRECD(BDMRTYP("IEN"),21,Z,0),U,1)["HEIGHT TOTAL" S A="" I $P(BDMEPIR,U,18)]"" S A=$P(BDMEPIR,U,18)*12,A=A+$P(BDMEPIR,U,19)

 ..I $P(^BDMRECD(BDMRTYP("IEN"),21,Z,0),U,1)["DURATION" S A=$$DURDM^BDMDF16(BDMPD,BDMDMRG,BDMADAT)

 .I P S A=$P(BDMEPIR,U,P)

 .S $P(^XTMP("BDMDM18 ERRORS",BDMJOB,BDMBTH,"PATS",S,BDMPD,BDMECNT),U,4)=A

QUALCHK ;EP - addl questions for data quality report

 ;get sort value

 S BDMQSRT=""

 S DIR(0)="S^P:PATIENT NAME;E:ERROR FIELD NAME",DIR("A")="How should the report be sorted",DIR("B")="P" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) S BDMSTP=1 Q

 S BDMQSRT=Y

BDMDF1J   ; IHS/CMI/LAB -IHS -CUMULATIVE REPORT 10 Oct 2014 9:50 AM ;

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

 +2       ;

CUML      ;EP

 +1       ;

COMORBID  ;USE 400

 +1        IF '$DATA(BDMCUML(400))

               SET BDMCUML(400)="Comorbidities"

 +2       ;TOTAL # of patients

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

 +3       ;active depression piece 3

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

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

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

               SET BDMCOMOR=BDMCOMOR+1

 +6       ;tobacco use piece 4

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

 +8        IF +V=1

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

               SET BDMCOMOR=BDMCOMOR+1

 +9       ;SEVERELY OBESE PIECE 5

 +10       IF BDMSEVOB

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

               SET BDMCOMOR=BDMCOMOR+1

 +11      ;HYPERTENSION DIAGNOSED PIECE 6

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

 +13       IF $EXTRACT(H)=1

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

               SET BDMCOMOR=BDMCOMOR+1

 +14      ;HTN AND MEAN BP <140/<90 PIECE 7

 +15       IF $EXTRACT(H)=1

               IF BDMBP140

                   SET $PIECE(BDMCUML(400),U,7)=$PIECE(BDMCUML(400),U,7)+1

 +16      ;cvd piece 8

 +17       SET V=$GET(^XTMP("BDMDM18",BDMJOB,BDMBTH,"AUDIT",BDMPD,116))

 +18       IF $EXTRACT(V)=1

               SET $PIECE(BDMCUML(400),U,8)=$PIECE(BDMCUML(400),U,8)+1

               SET BDMCOMOR=BDMCOMOR+1

 +19      ;

 +20      ;CVD & BP <140/<90 PIECE 9

 +21       IF $EXTRACT(V)=1

               IF BDMBP140

                   SET $PIECE(BDMCUML(400),U,9)=$PIECE(BDMCUML(400),U,9)+1

 +22      ;CVD AND NOT A TOBACCO USER PIECE 10

 +23       SET T=$GET(^XTMP("BDMDM18",BDMJOB,BDMBTH,"AUDIT",BDMPD,27))

 +24       IF $EXTRACT(T)=2

               IF $EXTRACT(V)=1

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

 +25      ;CVD AND STATIN PRESCRIBED PIECE 11

 +26       SET T=+$GET(^XTMP("BDMDM18",BDMJOB,BDMBTH,"AUDIT",BDMPD,300))

 +27       IF $EXTRACT(V)=1

               IF T=1

                   SET $PIECE(BDMCUML(400),U,11)=$PIECE(BDMCUML(400),U,11)+1

 +28      ;DENOM W/O ALLERGY

           IF $EXTRACT(V)=1

               IF T'=3

                   SET $PIECE(BDMCUML(400),U,34)=$PIECE(BDMCUML(400),U,34)+1

 +29      ;CVD AND ASPIRIN PIECE 12

 +30       SET T=$GET(^XTMP("BDMDM18",BDMJOB,BDMBTH,"AUDIT",BDMPD,62))

 +31       IF $EXTRACT(V)=1

               IF $EXTRACT(T)=1

                   SET $PIECE(BDMCUML(400),U,12)=$PIECE(BDMCUML(400),U,12)+1

 +32      ;

 +33      ;CKD PIECE 13 & 14

 +34      ;CKD IS EGFR <60 OR UACR >=30

 +35       IF $$AGE^AUPNPAT(BDMPD,BDMADAT)<18

               GOTO N

 +36      ;over 18 denom

           SET $PIECE(BDMCUML(400),U,13)=$PIECE(BDMCUML(400),U,13)+1

 +37      ;HAS CKD

           IF BDMCKD

               SET $PIECE(BDMCUML(400),U,14)=$PIECE(BDMCUML(400),U,14)+1

               SET BDMCOMOR=BDMCOMOR+1

 +38      ;CKD AND BP <140/<90 PIECE 15

 +39       IF BDMCKD

               IF BDMBP140

                   SET $PIECE(BDMCUML(400),U,15)=$PIECE(BDMCUML(400),U,15)+1

 +40      ;CKD AND ACE PIECE 16

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

 +42       IF A=1

               IF BDMCKD

                   SET $PIECE(BDMCUML(400),U,16)=$PIECE(BDMCUML(400),U,16)+1

 +43      ;EGFR AND UACR DONE PIECE 17

 +44       SET G=0

 +45       IF BDMEGFRU

               SET $PIECE(BDMCUML(400),U,17)=$PIECE(BDMCUML(400),U,17)+1

               Begin DoDot:1

 +46      ;NORMAL PIECE 18

 +47               IF BDMEGFRV>59

                       IF BDMUACRV="<30"

                           SET $PIECE(BDMCUML(400),U,18)=$PIECE(BDMCUML(400),U,18)+1

                           SET G=1

 +48      ;STAGE 1/2 EGFR =>60, UACR =>30

 +49               IF BDMEGFRV>59

                       IF BDMUACRV=">30"

                           SET $PIECE(BDMCUML(400),U,19)=$PIECE(BDMCUML(400),U,19)+1

                           SET G=1

               End DoDot:1

               IF G

                   GOTO N

 +50      ;STAGE 3 EGFR 30-59

 +51       IF BDMEGFRV]""

               IF BDMEGFRV'<30

                   IF BDMEGFRV<60

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

                       GOTO N

 +52      ;STAGE 4 EGFR 15-20 PIECE 21

 +53       IF BDMEGFRV]""

               IF BDMEGFRV'<15

                   IF BDMEGFRV'>29

                       SET $PIECE(BDMCUML(400),U,21)=$PIECE(BDMCUML(400),U,21)+1

                       GOTO N

 +54      ;STAGE 5 EGFR <15

 +55       IF BDMEGFRV]""

               IF BDMEGFRV<15

                   SET $PIECE(BDMCUML(400),U,22)=$PIECE(BDMCUML(400),U,22)+1

                   GOTO N

 +56      ;UACR AND EGFR NOT DONE

 +57       SET $PIECE(BDMCUML(400),U,23)=$PIECE(BDMCUML(400),U,23)+1

N         ;p12 HEP C AND RETINOPATHY

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

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

               SET $PIECE(BDMCUML(400),U,35)=$PIECE(BDMCUML(400),U,35)+1

               SET BDMCOMOR=BDMCOMOR+1

               GOTO R

 +3       ;

 +4        SET V=$GET(^XTMP("BDMDM18",BDMJOB,BDMBTH,"AUDIT",BDMPD,223))

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

               SET $PIECE(BDMCUML(400),U,37)=$PIECE(BDMCUML(400),U,37)+1

 +6       ;hep c screen denom

           IF $EXTRACT(V)'=3

               SET $PIECE(BDMCUML(400),U,36)=$PIECE(BDMCUML(400),U,36)+1

R         ;RETINOPATHY

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

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

               SET $PIECE(BDMCUML(400),U,38)=$PIECE(BDMCUML(400),U,38)+1

               SET BDMCOMOR=BDMCOMOR+1

V         ;NONE PIECE 25

 +1        IF BDMCOMOR=0

               SET $PIECE(BDMCUML(400),U,25)=$PIECE(BDMCUML(400),U,25)+1

 +2        IF BDMCOMOR=1

               SET $PIECE(BDMCUML(400),U,26)=$PIECE(BDMCUML(400),U,26)+1

 +3        IF BDMCOMOR=2

               SET $PIECE(BDMCUML(400),U,27)=$PIECE(BDMCUML(400),U,27)+1

 +4        IF BDMCOMOR=3

               SET $PIECE(BDMCUML(400),U,28)=$PIECE(BDMCUML(400),U,28)+1

 +5        IF BDMCOMOR=4

               SET $PIECE(BDMCUML(400),U,29)=$PIECE(BDMCUML(400),U,29)+1

 +6       ;P11

           IF BDMCOMOR>4

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

 +7       ;I BDMCOMOR=6 S $P(BDMCUML(400),U,31)=$P(BDMCUML(400),U,31)+1  ;P11

 +8        QUIT

REC(DFN,BDMRTYP,BDMRBD,BDMRED,BDMED,BDMDMRG,BDMBDAT) ;EP - called to send back a visit record as

 +1        NEW BDMX,BDMREC,BDMEPIX,BDMTTT,X,Y,Z

 +2        SET BDMREC=""

 +3        SET BDMRTYP("IEN")=$ORDER(^BDMRECD("B",BDMRTYP,0))

 +4        IF 'BDMRTYP("IEN")

               QUIT BDMREC

PROC      ;

 +1        SET BDMEPIX=0

 +2        FOR

               SET BDMEPIX=$ORDER(^BDMRECD(BDMRTYP("IEN"),11,"AC",BDMEPIX))

               IF BDMEPIX'=+BDMEPIX!(BDMREC=-1)

                   QUIT

               SET BDMTTT=$ORDER(^BDMRECD(BDMRTYP("IEN"),11,"AC",BDMEPIX,0))

               Begin DoDot:1

 +3                SET X=""

                   IF $DATA(^BDMRECD(BDMRTYP("IEN"),11,BDMTTT,11))

                       XECUTE ^BDMRECD(BDMRTYP("IEN"),11,BDMTTT,11)

 +4       ;I X="" S X=" "

 +5                SET $PIECE(BDMREC,U,$PIECE(^BDMRECD(BDMRTYP("IEN"),11,BDMTTT,0),U,2))=X

               End DoDot:1

 +6        QUIT BDMREC

EPICHK    ;create epi info record in ^BDMDATA("BDMEPI",$J,n)

 +1       ;skip this patient if dodx is greater than the audit date

 +2        SET X=$$DODX^BDMDF16(BDMPD,BDMDMRG,"I")

 +3        IF X>BDMADAT

               QUIT

 +4       ;I DUZ=2881,BDMPD'=8932 Q

 +5        NEW BDMECNT,BDMEPIR,BDMTHER

 +6        SET BDMEPIR=""

           SET BDMTHER=""

           SET BDMECNT=0

 +7        SET BDMEPIR=$$REC(BDMPD,"DM AUDIT 2018 EXPORT RECORD",BDMRBD,BDMRED,BDMADAT,BDMDMRG,BDMBDAT)

 +8       ;CHECK ERRORS ON BDMEPIR

 +9        SET BDMRTYP("IEN")=$ORDER(^BDMRECD("B","DM AUDIT 2018 EXPORT RECORD",0))

 +10       SET Z=0

FOR

               SET Z=$ORDER(^BDMRECD(BDMRTYP("IEN"),21,Z))

               IF Z'=+Z

                   QUIT

               Begin DoDot:1

 +11               IF $DATA(^BDMRECD(BDMRTYP("IEN"),21,Z,1))

                       XECUTE ^BDMRECD(BDMRTYP("IEN"),21,Z,1)

 +12               IF '$TEST

                       QUIT

 +13               SET S=""

 +14               IF BDMQSRT="P"

                       SET S=$PIECE(^DPT(BDMPD,0),U,1)

 +15               IF BDMQSRT="E"

                       SET S=$PIECE(^BDMRECD(BDMRTYP("IEN"),21,Z,0),U,1)

 +16               SET BDMECNT=BDMECNT+1

 +17               SET $PIECE(^XTMP("BDMDM18 ERRORS",BDMJOB,BDMBTH,"PATS",S,BDMPD,BDMECNT),U,1)=$PIECE(^BDMRECD(BDMRTYP("IEN"),21,Z,0),U,1)

 +18               SET J=$PIECE(^BDMRECD(BDMRTYP("IEN"),21,Z,0),U,2)

 +19               SET $PIECE(^XTMP("BDMDM18 ERRORS",BDMJOB,BDMBTH,"PATS",S,BDMPD,BDMECNT),U,2)=$SELECT(J="P":"POTENTIAL",J="D":"DEFINITE",1:"")

 +20               SET $PIECE(^XTMP("BDMDM18 ERRORS",BDMJOB,BDMBTH,"PATS",S,BDMPD,BDMECNT),U,3)=$PIECE($GET(^BDMRECD(BDMRTYP("IEN"),21,Z,11)),U,1)

 +21               SET P=$PIECE(^BDMRECD(BDMRTYP("IEN"),21,Z,0),U,4)

 +22               SET A=""

 +23               IF P=""

                       Begin DoDot:2

 +24                       IF $PIECE(^BDMRECD(BDMRTYP("IEN"),21,Z,0),U,1)["BMI"

                               SET A=$$BMI^BDMDF18(BDMPD,BDMRBD,BDMRED)

 +25                       IF $PIECE(^BDMRECD(BDMRTYP("IEN"),21,Z,0),U,1)["HEIGHT TOTAL"

                               SET A=""

                               IF $PIECE(BDMEPIR,U,18)]""

                                   SET A=$PIECE(BDMEPIR,U,18)*12

                                   SET A=A+$PIECE(BDMEPIR,U,19)

 +26                       IF $PIECE(^BDMRECD(BDMRTYP("IEN"),21,Z,0),U,1)["DURATION"

                               SET A=$$DURDM^BDMDF16(BDMPD,BDMDMRG,BDMADAT)

                       End DoDot:2

 +27               IF P

                       SET A=$PIECE(BDMEPIR,U,P)

 +28               SET $PIECE(^XTMP("BDMDM18 ERRORS",BDMJOB,BDMBTH,"PATS",S,BDMPD,BDMECNT),U,4)=A

               End DoDot:1

 +29       QUIT

QUALCHK   ;EP - addl questions for data quality report

 +1       ;get sort value

 +2        SET BDMQSRT=""

 +3        SET DIR(0)="S^P:PATIENT NAME;E:ERROR FIELD NAME"

           SET DIR("A")="How should the report be sorted"

           SET DIR("B")="P"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               SET BDMSTP=1

               QUIT

 +5        SET BDMQSRT=Y

 +6        QUIT

BDMDF1J.m