BDMDM6.m

BDMDM6 ; IHS/CMI/LAB - TOBACCO USE ;

 ;;2.0;DIABETES MANAGEMENT SYSTEM;**2,4,8**;JUN 14, 2007;Build 53

 ;

 ;cmi/anch/maw 9/10/2007 code set versioning in TOBACCO1

 ;

TOBACCO ;EP

 K BDMTOB

 D TOBACCO3

 I $D(^TMP("BDM",$J,1)) D TOBCUML G X1

 D TOBACCO0

 I $D(^TMP("BDM",$J,1)) D TOBCUML G X1

 D TOBACCO1 ;check Problem file for tobacco use

 I $D(^TMP("BDM",$J,1)) D TOBCUML G X1

 D TOBACCO2 ;check POVs for tobacco use

 I $D(^TMP("BDM",$J,1)) D TOBCUML G X1

 S BDMTOB(44)="UNDOCUMENTED",^TMP("BDM",$J,1)="UNDOCUMENTED"

 D TOBCUML

X1 S:BDMER ^TMP("BDM",$J,1)="*** SCRIPT ERROR IN TOBACCO^BDMDM1.  CONTACT SITE MANAGER"

 Q

TOBCUML ;

 I BDMCUML F BDMSUB=7,42,43,44 S BDMGOT1=$S('$D(BDMTOB(BDMSUB)):0,1:1) D CUML^BDMDM1

 K BDMTOB,BDMTOBN

 Q

TOBACCO0 ;check for tobacco documented in health factors

 K BDM S BDMX=BDMPD_"^LAST HEALTH [DM AUDIT TOBACCO HLTH FACTORS" S BDMER=$$START1^APCLDF(BDMX,BDMY) G:BDMER X1 I $D(BDM(1)) D  S BDMTOBN=$O(BDMTOB("")),^TMP("BDM",$J,1)=BDMTOB(BDMTOBN)

 . I $P(BDM(1),U,3)["NON" S BDMTOB(42)="NO, DOES NOT USE TOBACCO" Q

 . I $P(BDM(1),U,3)["PREVIOUS" S BDMTOB(43)="PAST USE OF TOBACCO" Q

 . S BDMTOB(7)="YES, USES TOBACCO"

 .Q

 Q

TOBACCO3 ;lookup in health status

 S %=$O(^ATXAX("B","DM AUDIT TOBACCO HLTH FACTORS",0))

 Q:'%

 S (X,Y)=0 F  S X=$O(^AUPNHF("AA",BDMPD,X)) Q:X'=+X!(Y)  I $D(^ATXAX(%,21,"B",X)) S Y=X

 Q:'Y

 S Y=$P(^AUTTHF(Y,0),U)

 S ^TMP("BDM",$J,1)=Y

 I Y["NON" S BDMTOB(42)="NO, DOES NOT USE TOBACCO" Q

 I Y["PREVIOUS" S BDMTOB(43)="PAST USE OF TOBACCO" Q

 S BDMTOB(7)="YES, USES TOBACCO"

 Q

TOBACCO1 ;check problem file for tobacco use

 K BDM S BDMX=BDMPD_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS" S BDMER=$$START1^APCLDF(BDMX,BDMY) G:BDMER X1 I $D(BDM(1)) D  S BDMTOBN=$O(BDMTOB("")),^TMP("BDM",$J,1)=BDMTOB(BDMTOBN)

 . ;I $P(^ICD9($P(BDM(1),U,2),0),U,1)=305.13 S BDMTOB(43)="PAST USE OF TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(BDM(1),U,4),0),U,5),0),U),1,30) Q  ;cmi/anch/maw 9/10/2007 orig line

 . I $P($$ICDDX^BDMUTL($P(BDM(1),U,2)),U,2)=305.13 S BDMTOB(43)="PAST USE OF TOBACCO"_" - "_$E($$VAL^XBDIQ1(9000011,+$P(BDM(1),U,4),.05),1,30) Q  ;cmi/anch/maw 9/10/2007 csv

 . S BDMTOB(7)="YES, USES TOBACCO - "_$E($$VAL^XBDIQ1(9000011,+$P(BDM(1),U,4),.05),1,30)

 .Q

 Q

TOBACCO2 ;check pov file for TOBACCO USE DOC

 K BDM S BDMX=BDMPD_"^LAST DX [DM AUDIT SMOKING RELATED DXS"_BDMDATE S BDMER=$$START1^APCLDF(BDMX,BDMY) G:BDMER X1 I $D(BDM(1)) D  S BDMTOBN=$O(BDMTOB("")),^TMP("BDM",$J,1)=BDMTOB(BDMTOBN)

 . I $P(BDM(1),U,2)=305.13 S BDMTOB(43)="PAST USE OF TOBACCO"_" - "_$E($$VAL^XBDIQ1(9000010.07,+$P(BDM(1),U,4),.05),1,30) Q

 . S BDMTOB(7)="YES, USES TOBACCO"_" - "_$E($$VAL^XBDIQ1(9000010.07,+$P(BDM(1),U,4),.05),1,30)

 .Q

 Q

 ;

RSTAT(R,S) ;EP - return # pts on register REG with status STAT

 I $G(R)="" Q ""

 I '$D(^ACM(41,"B",R)) Q ""

 I "AITUDN"'[S Q ""

 NEW %,C

 S (%,C)=0 F  S %=$O(^ACM(41,"B",R,%)) Q:%'=+%  I $P($G(^ACM(41,%,"DT")),U)=S S C=C+1

 Q C

LASTHT(P,F) ;PEP - return last ht

 I 'P Q -1

 I '$D(^AUPNVSIT("AC",P)) Q -1

 NEW %,BDMARRY,H,E

 S %=P_"^LAST MEAS HT" NEW X S E=$$START1^APCLDF(%,"BDMARRY(") S H=$P($G(BDMARRY(1)),U,2)

 I H="" Q H

 S H=$J(H,2,0)

 Q $S(F="I":H,1:(H\12)_" "_(H#12))

 ;F="I" - in inches, F="E" - feet and inches 5 5

LASTWT(P,F) ;PEP - return last wt

 I 'P Q ""

 NEW %,BDMARRY,E,W

 S %=P_"^LAST MEAS WT" NEW X S E=$$START1^APCLDF(%,"BDMARRY(") S W=$P($G(BDMARRY(1)),U,2)

 Q W

BMI(P) ;PEP - return BMI with last weight,last height

 I 'P Q -1

 NEW %,W,H,B

 S %=""

 S W=$$LASTWT(P) I W="" Q %

 S H=$$LASTHT(P,"I") I H="" Q %

 ;S W=(W/5)*2.3,H=(H*2.5),H=(H*H)/10000,%=(W/H),%=$J(%,4,1)

 S W=W*.45359,H=(H*.0254),H=(H*H),%=(W/H),%=$J(%,4,1)

 Q %

BDMDM6    ; IHS/CMI/LAB - TOBACCO USE ;

 +1       ;;2.0;DIABETES MANAGEMENT SYSTEM;**2,4,8**;JUN 14, 2007;Build 53

 +2       ;

 +3       ;cmi/anch/maw 9/10/2007 code set versioning in TOBACCO1

 +4       ;

TOBACCO   ;EP

 +1        KILL BDMTOB

 +2        DO TOBACCO3

 +3        IF $DATA(^TMP("BDM",$JOB,1))

               DO TOBCUML

               GOTO X1

 +4        DO TOBACCO0

 +5        IF $DATA(^TMP("BDM",$JOB,1))

               DO TOBCUML

               GOTO X1

 +6       ;check Problem file for tobacco use

           DO TOBACCO1

 +7        IF $DATA(^TMP("BDM",$JOB,1))

               DO TOBCUML

               GOTO X1

 +8       ;check POVs for tobacco use

           DO TOBACCO2

 +9        IF $DATA(^TMP("BDM",$JOB,1))

               DO TOBCUML

               GOTO X1

 +10       SET BDMTOB(44)="UNDOCUMENTED"

           SET ^TMP("BDM",$JOB,1)="UNDOCUMENTED"

 +11       DO TOBCUML

X1         IF BDMER

               SET ^TMP("BDM",$JOB,1)="*** SCRIPT ERROR IN TOBACCO^BDMDM1.  CONTACT SITE MANAGER"

 +1        QUIT 

TOBCUML   ;

 +1        IF BDMCUML

               FOR BDMSUB=7,42,43,44

                   SET BDMGOT1=$SELECT('$DATA(BDMTOB(BDMSUB)):0,1:1)

                   DO CUML^BDMDM1

 +2        KILL BDMTOB,BDMTOBN

 +3        QUIT 

TOBACCO0  ;check for tobacco documented in health factors

 +1        KILL BDM

           SET BDMX=BDMPD_"^LAST HEALTH [DM AUDIT TOBACCO HLTH FACTORS"

           SET BDMER=$$START1^APCLDF(BDMX,BDMY)

           IF BDMER

               GOTO X1

           IF $DATA(BDM(1))

               Begin DoDot:1

 +2                IF $PIECE(BDM(1),U,3)["NON"

                       SET BDMTOB(42)="NO, DOES NOT USE TOBACCO"

                       QUIT 

 +3                IF $PIECE(BDM(1),U,3)["PREVIOUS"

                       SET BDMTOB(43)="PAST USE OF TOBACCO"

                       QUIT 

 +4                SET BDMTOB(7)="YES, USES TOBACCO"

 +5                QUIT 

               End DoDot:1

               SET BDMTOBN=$ORDER(BDMTOB(""))

               SET ^TMP("BDM",$JOB,1)=BDMTOB(BDMTOBN)

 +6        QUIT 

TOBACCO3  ;lookup in health status

 +1        SET %=$ORDER(^ATXAX("B","DM AUDIT TOBACCO HLTH FACTORS",0))

 +2        IF '%

               QUIT 

 +3        SET (X,Y)=0

           FOR 

               SET X=$ORDER(^AUPNHF("AA",BDMPD,X))

               IF X'=+X!(Y)

                   QUIT 

               IF $DATA(^ATXAX(%,21,"B",X))

                   SET Y=X

 +4        IF 'Y

               QUIT 

 +5        SET Y=$PIECE(^AUTTHF(Y,0),U)

 +6        SET ^TMP("BDM",$JOB,1)=Y

 +7        IF Y["NON"

               SET BDMTOB(42)="NO, DOES NOT USE TOBACCO"

               QUIT 

 +8        IF Y["PREVIOUS"

               SET BDMTOB(43)="PAST USE OF TOBACCO"

               QUIT 

 +9        SET BDMTOB(7)="YES, USES TOBACCO"

 +10       QUIT 

TOBACCO1  ;check problem file for tobacco use

 +1        KILL BDM

           SET BDMX=BDMPD_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS"

           SET BDMER=$$START1^APCLDF(BDMX,BDMY)

           IF BDMER

               GOTO X1

           IF $DATA(BDM(1))

               Begin DoDot:1

 +2       ;I $P(^ICD9($P(BDM(1),U,2),0),U,1)=305.13 S BDMTOB(43)="PAST USE OF TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(BDM(1),U,4),0),U,5),0),U),1,30) Q  ;cmi/anch/maw 9/10/2007 orig line

 +3       ;cmi/anch/maw 9/10/2007 csv

                   IF $PIECE($$ICDDX^BDMUTL($PIECE(BDM(1),U,2)),U,2)=305.13

                       SET BDMTOB(43)="PAST USE OF TOBACCO"_" - "_$EXTRACT($$VAL^XBDIQ1(9000011,+$PIECE(BDM(1),U,4),.05),1,30)

                       QUIT 

 +4                SET BDMTOB(7)="YES, USES TOBACCO - "_$EXTRACT($$VAL^XBDIQ1(9000011,+$PIECE(BDM(1),U,4),.05),1,30)

 +5                QUIT 

               End DoDot:1

               SET BDMTOBN=$ORDER(BDMTOB(""))

               SET ^TMP("BDM",$JOB,1)=BDMTOB(BDMTOBN)

 +6        QUIT 

TOBACCO2  ;check pov file for TOBACCO USE DOC

 +1        KILL BDM

           SET BDMX=BDMPD_"^LAST DX [DM AUDIT SMOKING RELATED DXS"_BDMDATE

           SET BDMER=$$START1^APCLDF(BDMX,BDMY)

           IF BDMER

               GOTO X1

           IF $DATA(BDM(1))

               Begin DoDot:1

 +2                IF $PIECE(BDM(1),U,2)=305.13

                       SET BDMTOB(43)="PAST USE OF TOBACCO"_" - "_$EXTRACT($$VAL^XBDIQ1(9000010.07,+$PIECE(BDM(1),U,4),.05),1,30)

                       QUIT 

 +3                SET BDMTOB(7)="YES, USES TOBACCO"_" - "_$EXTRACT($$VAL^XBDIQ1(9000010.07,+$PIECE(BDM(1),U,4),.05),1,30)

 +4                QUIT 

               End DoDot:1

               SET BDMTOBN=$ORDER(BDMTOB(""))

               SET ^TMP("BDM",$JOB,1)=BDMTOB(BDMTOBN)

 +5        QUIT 

 +6       ;

RSTAT(R,S) ;EP - return # pts on register REG with status STAT

 +1        IF $GET(R)=""

               QUIT ""

 +2        IF '$DATA(^ACM(41,"B",R))

               QUIT ""

 +3        IF "AITUDN"'[S

               QUIT ""

 +4        NEW %,C

 +5        SET (%,C)=0

           FOR 

               SET %=$ORDER(^ACM(41,"B",R,%))

               IF %'=+%

                   QUIT 

               IF $PIECE($GET(^ACM(41,%,"DT")),U)=S

                   SET C=C+1

 +6        QUIT C

LASTHT(P,F) ;PEP - return last ht

 +1        IF 'P

               QUIT -1

 +2        IF '$DATA(^AUPNVSIT("AC",P))

               QUIT -1

 +3        NEW %,BDMARRY,H,E

 +4        SET %=P_"^LAST MEAS HT"

           NEW X

           SET E=$$START1^APCLDF(%,"BDMARRY(")

           SET H=$PIECE($GET(BDMARRY(1)),U,2)

 +5        IF H=""

               QUIT H

 +6        SET H=$JUSTIFY(H,2,0)

 +7        QUIT $SELECT(F="I":H,1:(H\12)_" "_(H#12))

 +8       ;F="I" - in inches, F="E" - feet and inches 5 5

LASTWT(P,F) ;PEP - return last wt

 +1        IF 'P

               QUIT ""

 +2        NEW %,BDMARRY,E,W

 +3        SET %=P_"^LAST MEAS WT"

           NEW X

           SET E=$$START1^APCLDF(%,"BDMARRY(")

           SET W=$PIECE($GET(BDMARRY(1)),U,2)

 +4        QUIT W

BMI(P)    ;PEP - return BMI with last weight,last height

 +1        IF 'P

               QUIT -1

 +2        NEW %,W,H,B

 +3        SET %=""

 +4        SET W=$$LASTWT(P)

           IF W=""

               QUIT %

 +5        SET H=$$LASTHT(P,"I")

           IF H=""

               QUIT %

 +6       ;S W=(W/5)*2.3,H=(H*2.5),H=(H*H)/10000,%=(W/H),%=$J(%,4,1)

 +7        SET W=W*.45359

           SET H=(H*.0254)

           SET H=(H*H)

           SET %=(W/H)

           SET %=$JUSTIFY(%,4,1)

 +8        QUIT %