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 %
