- APCLDM6 ; IHS/CMI/LAB - TOBACCO USE ;
- ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- ;
- ;cmi/anch/maw 9/10/2007 code set versioning in TOBACCO1
- ;
- TOBACCO ;EP
- K APCLTOB
- D TOBACCO3
- I $D(^TMP("APCL",$J,1)) D TOBCUML G X1
- D TOBACCO0
- I $D(^TMP("APCL",$J,1)) D TOBCUML G X1
- D TOBACCO1 ;check Problem file for tobacco use
- I $D(^TMP("APCL",$J,1)) D TOBCUML G X1
- D TOBACCO2 ;check POVs for tobacco use
- I $D(^TMP("APCL",$J,1)) D TOBCUML G X1
- S APCLTOB(44)="UNDOCUMENTED",^TMP("APCL",$J,1)="UNDOCUMENTED"
- D TOBCUML
- X1 S:APCLER ^TMP("APCL",$J,1)="*** SCRIPT ERROR IN TOBACCO^APCLDM1. CONTACT SITE MANAGER"
- Q
- TOBCUML ;
- I APCLCUML F APCLSUB=7,42,43,44 S APCLGOT1=$S('$D(APCLTOB(APCLSUB)):0,1:1) D CUML^APCLDM1
- K APCLTOB,APCLTOBN
- Q
- TOBACCO0 ;check for tobacco documented in health factors
- K APCL S APCLX=APCLPD_"^LAST HEALTH [DM AUDIT TOBACCO HLTH FACTORS" S APCLER=$$START1^APCLDF(APCLX,APCLY) G:APCLER X1 I $D(APCL(1)) D S APCLTOBN=$O(APCLTOB("")),^TMP("APCL",$J,1)=APCLTOB(APCLTOBN)
- . I $P(APCL(1),U,3)["NON" S APCLTOB(42)="NO, DOES NOT USE TOBACCO" Q
- . I $P(APCL(1),U,3)["PREVIOUS" S APCLTOB(43)="PAST USE OF TOBACCO" Q
- . S APCLTOB(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",APCLPD,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("APCL",$J,1)=Y
- I Y["NON" S APCLTOB(42)="NO, DOES NOT USE TOBACCO" Q
- I Y["PREVIOUS" S APCLTOB(43)="PAST USE OF TOBACCO" Q
- S APCLTOB(7)="YES, USES TOBACCO"
- Q
- TOBACCO1 ;check problem file for tobacco use
- K APCL S APCLX=APCLPD_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS" S APCLER=$$START1^APCLDF(APCLX,APCLY) G:APCLER X1 I $D(APCL(1)) D S APCLTOBN=$O(APCLTOB("")),^TMP("APCL",$J,1)=APCLTOB(APCLTOBN)
- . ;I $P(^ICD9($P(APCL(1),U,2),0),U,1)=305.13 S APCLTOB(43)="PAST USE OF TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCL(1),U,4),0),U,5),0),U),1,30) Q ;cmi/anch/maw 9/10/2007 orig line
- . I $P($$ICDDX^ICDCODE($P(APCL(1),U,2)),U,2)=305.13 S APCLTOB(43)="PAST USE OF TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCL(1),U,4),0),U,5),0),U),1,30) Q ;cmi/anch/maw 9/10/2007 csv
- . S APCLTOB(7)="YES, USES TOBACCO - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCL(1),U,4),0),U,5),0),U),1,30)
- .Q
- Q
- TOBACCO2 ;check pov file for TOBACCO USE DOC
- K APCL S APCLX=APCLPD_"^LAST DX [DM AUDIT SMOKING RELATED DXS"_APCLDATE S APCLER=$$START1^APCLDF(APCLX,APCLY) G:APCLER X1 I $D(APCL(1)) D S APCLTOBN=$O(APCLTOB("")),^TMP("APCL",$J,1)=APCLTOB(APCLTOBN)
- . I $P(APCL(1),U,2)=305.13 S APCLTOB(43)="PAST USE OF TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNVPOV(+$P(APCL(1),U,4),0),U,4),0),U),1,30) Q
- . S APCLTOB(7)="YES, USES TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNVPOV(+$P(APCL(1),U,4),0),U,4),0),U),1,30)
- .Q
- Q
- ;
- RSTAT(R,S) ;EP - return # pts on register REG with status STAT
- 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 %,APCLARRY,H,E
- S %=P_"^LAST MEAS HT" NEW X S E=$$START1^APCLDF(%,"APCLARRY(") S H=$P($G(APCLARRY(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 %,APCLARRY,E,W
- S %=P_"^LAST MEAS WT" NEW X S E=$$START1^APCLDF(%,"APCLARRY(") S W=$P($G(APCLARRY(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 %
- APCLDM6 ; IHS/CMI/LAB - TOBACCO USE ;
- +1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- +2 ;
- +3 ;cmi/anch/maw 9/10/2007 code set versioning in TOBACCO1
- +4 ;
- TOBACCO ;EP
- +1 KILL APCLTOB
- +2 DO TOBACCO3
- +3 IF $DATA(^TMP("APCL",$JOB,1))
- DO TOBCUML
- GOTO X1
- +4 DO TOBACCO0
- +5 IF $DATA(^TMP("APCL",$JOB,1))
- DO TOBCUML
- GOTO X1
- +6 ;check Problem file for tobacco use
- DO TOBACCO1
- +7 IF $DATA(^TMP("APCL",$JOB,1))
- DO TOBCUML
- GOTO X1
- +8 ;check POVs for tobacco use
- DO TOBACCO2
- +9 IF $DATA(^TMP("APCL",$JOB,1))
- DO TOBCUML
- GOTO X1
- +10 SET APCLTOB(44)="UNDOCUMENTED"
- SET ^TMP("APCL",$JOB,1)="UNDOCUMENTED"
- +11 DO TOBCUML
- X1 IF APCLER
- SET ^TMP("APCL",$JOB,1)="*** SCRIPT ERROR IN TOBACCO^APCLDM1. CONTACT SITE MANAGER"
- +1 QUIT
- TOBCUML ;
- +1 IF APCLCUML
- FOR APCLSUB=7,42,43,44
- SET APCLGOT1=$SELECT('$DATA(APCLTOB(APCLSUB)):0,1:1)
- DO CUML^APCLDM1
- +2 KILL APCLTOB,APCLTOBN
- +3 QUIT
- TOBACCO0 ;check for tobacco documented in health factors
- +1 KILL APCL
- SET APCLX=APCLPD_"^LAST HEALTH [DM AUDIT TOBACCO HLTH FACTORS"
- SET APCLER=$$START1^APCLDF(APCLX,APCLY)
- IF APCLER
- GOTO X1
- IF $DATA(APCL(1))
- Begin DoDot:1
- +2 IF $PIECE(APCL(1),U,3)["NON"
- SET APCLTOB(42)="NO, DOES NOT USE TOBACCO"
- QUIT
- +3 IF $PIECE(APCL(1),U,3)["PREVIOUS"
- SET APCLTOB(43)="PAST USE OF TOBACCO"
- QUIT
- +4 SET APCLTOB(7)="YES, USES TOBACCO"
- +5 QUIT
- End DoDot:1
- SET APCLTOBN=$ORDER(APCLTOB(""))
- SET ^TMP("APCL",$JOB,1)=APCLTOB(APCLTOBN)
- +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",APCLPD,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("APCL",$JOB,1)=Y
- +7 IF Y["NON"
- SET APCLTOB(42)="NO, DOES NOT USE TOBACCO"
- QUIT
- +8 IF Y["PREVIOUS"
- SET APCLTOB(43)="PAST USE OF TOBACCO"
- QUIT
- +9 SET APCLTOB(7)="YES, USES TOBACCO"
- +10 QUIT
- TOBACCO1 ;check problem file for tobacco use
- +1 KILL APCL
- SET APCLX=APCLPD_"^PROBLEMS [DM AUDIT PROBLEM SMOKING DXS"
- SET APCLER=$$START1^APCLDF(APCLX,APCLY)
- IF APCLER
- GOTO X1
- IF $DATA(APCL(1))
- Begin DoDot:1
- +2 ;I $P(^ICD9($P(APCL(1),U,2),0),U,1)=305.13 S APCLTOB(43)="PAST USE OF TOBACCO"_" - "_$E($P(^AUTNPOV($P(^AUPNPROB(+$P(APCL(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^ICDCODE($PIECE(APCL(1),U,2)),U,2)=305.13
- SET APCLTOB(43)="PAST USE OF TOBACCO"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNPROB(+$PIECE(APCL(1),U,4),0),U,5),0),U),1,30)
- QUIT
- +4 SET APCLTOB(7)="YES, USES TOBACCO - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNPROB(+$PIECE(APCL(1),U,4),0),U,5),0),U),1,30)
- +5 QUIT
- End DoDot:1
- SET APCLTOBN=$ORDER(APCLTOB(""))
- SET ^TMP("APCL",$JOB,1)=APCLTOB(APCLTOBN)
- +6 QUIT
- TOBACCO2 ;check pov file for TOBACCO USE DOC
- +1 KILL APCL
- SET APCLX=APCLPD_"^LAST DX [DM AUDIT SMOKING RELATED DXS"_APCLDATE
- SET APCLER=$$START1^APCLDF(APCLX,APCLY)
- IF APCLER
- GOTO X1
- IF $DATA(APCL(1))
- Begin DoDot:1
- +2 IF $PIECE(APCL(1),U,2)=305.13
- SET APCLTOB(43)="PAST USE OF TOBACCO"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNVPOV(+$PIECE(APCL(1),U,4),0),U,4),0),U),1,30)
- QUIT
- +3 SET APCLTOB(7)="YES, USES TOBACCO"_" - "_$EXTRACT($PIECE(^AUTNPOV($PIECE(^AUPNVPOV(+$PIECE(APCL(1),U,4),0),U,4),0),U),1,30)
- +4 QUIT
- End DoDot:1
- SET APCLTOBN=$ORDER(APCLTOB(""))
- SET ^TMP("APCL",$JOB,1)=APCLTOB(APCLTOBN)
- +5 QUIT
- +6 ;
- RSTAT(R,S) ;EP - return # pts on register REG with status STAT
- +1 IF '$DATA(^ACM(41,"B",R))
- QUIT ""
- +2 IF "AITUDN"'[S
- QUIT ""
- +3 NEW %,C
- +4 SET (%,C)=0
- FOR
- SET %=$ORDER(^ACM(41,"B",R,%))
- IF %'=+%
- QUIT
- IF $PIECE($GET(^ACM(41,%,"DT")),U)=S
- SET C=C+1
- +5 QUIT C
- LASTHT(P,F) ;PEP - return last ht
- +1 IF 'P
- QUIT -1
- +2 IF '$DATA(^AUPNVSIT("AC",P))
- QUIT -1
- +3 NEW %,APCLARRY,H,E
- +4 SET %=P_"^LAST MEAS HT"
- NEW X
- SET E=$$START1^APCLDF(%,"APCLARRY(")
- SET H=$PIECE($GET(APCLARRY(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 %,APCLARRY,E,W
- +3 SET %=P_"^LAST MEAS WT"
- NEW X
- SET E=$$START1^APCLDF(%,"APCLARRY(")
- SET W=$PIECE($GET(APCLARRY(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 %
