- APCLDM1A ; IHS/CMI/LAB -CONTINUATION OF APCLDM1 FOR DM AUDIT DATA FETCHING ;
- ;;2.0;IHS PCC SUITE;**4**;MAY 14, 2009
- ;
- EN ; - EP - from ^APCLDM1
- ;
- F APCLI=1:1 Q:$T(@APCLI)="" K APCLX S APCLY="APCL(" D @APCLI K APCL
- Q
- ;
- 1 ;
- WTTAKEN S APCLMEAS=$O(^AUTTMSR("B","WT","")) D TAKEN
- S ^TMP("APCL",$J,4)=APCLMEAS
- K APCLMEAS
- I APCLCUML S APCLGOT1=$S(^TMP("APCL",$J,4)["YES":1,1:0),APCLSUB=10 D CUML^APCLDM1
- Q
- 2 ;
- LASTWT S APCLW="" S APCLX=APCLPD_"^LAST 24 MEAS WT" S APCLER=$$START1^APCLDF(APCLX,APCLY)
- S APCLV221=$O(^ICD9("BA","V22.1 ",""))
- F APCLN=1:1 Q:'$D(APCL(APCLN))!$D(^TMP("APCL",$J,5)) S APCLZ=$P(APCL(APCLN),U,5) S APCLD=0 F S APCLD=$O(^AUPNVPOV("AD",APCLZ,APCLD)) Q:'APCLD!$D(^TMP("APCL",$J,5)) D
- . I $P(^AUPNVPOV(APCLD,0),U)'=APCLV221 S APCLW=$P(APCL(APCLN),U,2),^TMP("APCL",$J,5)=$P(APCL(APCLN),U,2)_" lbs",Y=$P(APCL(APCLN),U) D DD^%DT S ^TMP("APCL",$J,33)=Y
- .Q
- I '$D(^TMP("APCL",$J,5)) S ^(5)="NO WT AVAILABLE",^TMP("APCL",$J,33.1)="" I APCLCUML S APCLSUB=54,APCLGOT1=1 D CUML^APCLDM1 S APCLGOT1=0 S APCLSUB=48 D CUML^APCLDM1 S APCLSUB=49,APCLGOT1=0 D CUML^APCLDM1 G X2
- I '$G(APCLCUML) G X2
- S H=APCLHTKI I 'H S ^TMP("APCL",$J,33.1)="",APCLSUB=54,APCLGOT1=1 D CUML^APCLDM1 S APCLSUB=48,APCLGOT1=0 D CUML^APCLDM1 S APCLSUB=49,APCLGOT1=0 D CUML^APCLDM1 G X2
- S APCLW=APCLW*.4536,H=((H*.0254)*(H*.0254)),B=APCLW/H,^TMP("APCL",$J,33.1)=$J(B,4,1)
- I $$SEX^AUPNPAT(APCLPD)="M"&(B>31.0)!($$SEX^AUPNPAT(APCLPD)="F"&(B>32.2)) S APCLSUB=49,APCLGOT1=1 D CUML^APCLDM1 S APCLSUB=54,APCLGOT1=0 D CUML^APCLDM1 S APCLGOT1=1,APCLSUB=48 D CUML^APCLDM1 G X2
- I $$SEX^AUPNPAT(APCLPD)="M"&(B>27.7)!($$SEX^AUPNPAT(APCLPD)="F"&(B>27.2)) S APCLSUB=48,APCLGOT1=1 D CUML^APCLDM1 S APCLSUB=54,APCLGOT1=0 D CUML^APCLDM1 S APCLSUB=49,APCLGOT1=0 D CUML^APCLDM1 G X2
- ;I $E(APCLRWPT)="*" S APCLSUB=54,APCLGOT1=1 D CUML^APCLDM1 S APCLGOT1=0,APCLSUB=48 D CUML^APCLDM1 S APCLSUB=49 D CUML^APCLDM1 G X2
- ;I +APCLRWPT>154 S APCLSUB=49,APCLGOT1=1 D CUML^APCLDM1 S APCLGOT1=0,APCLSUB=48 D CUML^APCLDM1 S APCLSUB=54 D CUML^APCLDM1 G X2
- ;I +APCLRWPT>125 S APCLSUB=48,APCLGOT1=1 D CUML^APCLDM1 S APCLGOT1=0,APCLSUB=49 D CUML^APCLDM1 S APCLSUB=54 D CUML^APCLDM1 G X2
- F APCLSUB=48,49,54 S APCLGOT1=0 D CUML^APCLDM1
- X2 ;
- K APCLSUB,APCLGOT1,APCLRWPT,APCLZ,APCLN,APCLD,APCLV221,APCLX
- Q
- 3 ;
- BPTAKEN S APCLMEAS=$O(^AUTTMSR("B","BP","")) D TAKEN
- S ^TMP("APCL",$J,6)=APCLMEAS
- I APCLCUML S APCLGOT1=$S(^TMP("APCL",$J,6)["YES":1,1:0),APCLSUB=11 D CUML^APCLDM1
- K APCLMEAS
- Q
- ;
- TAKEN ; Is BP or WT taken 75% of time during the last year's diabetic visits
- S (APCLYES,APCLNTOT)=0 F APCLL=1:1:APCLTOT Q:'$D(^TMP("APCLDM DXVS",$J,APCLL)) D
- .S APCLVDFN=^TMP("APCLDM DXVS",$J,APCLL)
- .S APCLNTOT=APCLNTOT+1
- .S (APCLMDFN,APCLFOUN)=0 F S APCLMDFN=$O(^AUPNVMSR("AD",APCLVDFN,APCLMDFN)) Q:'APCLMDFN!(APCLFOUN) D
- ..Q:$P($G(^AUPNVMSR(APCLMDFN,2)),U,1) ;entered in error
- ..I APCLMDFN,+^AUPNVMSR(APCLMDFN,0)=APCLMEAS S APCLYES=APCLYES+1,APCLFOUN=1 Q
- ..Q
- ;***
- I 'APCLNTOT S APCLMEAS="No DM visits (01,06,28 clinics only)" G TAKENX
- NEW V
- S V=(APCLYES/APCLNTOT)*100,V=$J(V,2,0)
- S APCLMEAS=$S(V<75:"NO",1:"YES")_" - "_V_"%"
- K APCLNTOT
- TAKENX Q
- ;
- 4 ;
- HTNDX ;
- D HTNPLDX I $D(APCL(1)) G X
- S X=APCLEDT,%DT="" D ^%DT S X1=$S(Y>DT:DT,1:Y) S APCLHTNE=Y,X2=1 D C^%DTC S APCLHTNE=($E(X,1,3)-5)_$E(X,4,7) S Y=APCLHTNE D DD^%DT S APCLHTNE=Y
- S APCLX=APCLPD_"^LAST DX [SURVEILLANCE HYPERTENSION;DURING "_APCLHTNE_"-"_APCLEDT S APCLER=$$START1^APCLDF(APCLX,APCLY) G:APCLER X S ^TMP("APCL",$J,7)=$S($D(APCL(1)):"YES",1:"NO")
- X I APCLER S ^TMP("APCL",$J,7)="*** SCRIPT ERROR IN HTNDX^APCLDM1A. CONTACT SITE MANAGER"
- K APCL
- Q
- HTNPLDX ;see if htn on problem list
- S APCLX=APCLPD_"^PROBLEM [DM AUDIT PROBLEM HTN DIAGNOSES",APCLY="APCL(" S APCLER=$$START1^APCLDF(APCLX,APCLY) G:APCLER X I $D(APCL(1)) S ^TMP("APCL",$J,7)="YES"
- Q
- 5 ;
- BPS ;
- S APCLERCO=$O(^DIC(40.7,"C",30,"")),APCLLL=0
- S APCLX=APCLPD_"^LAST 50 MEAS BP"_APCLDATE S APCLER=$$START1^APCLDF(APCLX,APCLY) F APCLL=1:1:20 Q:'$D(APCL(APCLL)) S APCLBP=$P($G(APCL(APCLL)),U,2)_$S($P($G(APCL(APCLL)),U,2)]"":" mm HG",1:"") D
- .Q:$P(^AUPNVSIT($P(APCL(APCLL),U,5),0),U,8)=APCLERCO
- .S APCLLL=APCLLL+1,^TMP("APCL",$J,8_"."_APCLLL)=APCLBP S Y=$P(APCL(APCLL),U,1) D DD^%DT S ^TMP("APCL",$J,34_"."_APCLLL)=Y
- I APCLCUML,$G(^TMP("APCL",$J,8.1))]"" S (APCLSYS,APCLDIA,APCLBPS)=0 F APCLL=1:1:3 Q:'$D(^TMP("APCL",$J,8_"."_APCLL)) S APCLBPS=APCLBPS+1,APCLSYS=APCLSYS+^(8_"."_APCLL),APCLDIA=APCLDIA+$P(^(8_"."_APCLL),"/",2)
- CONTROL ;
- I '$G(APCLCUML) G X5
- I $G(^TMP("APCL",$J,8.3))="" S APCLGOT1=1,APCLSUB=61 D CUML^APCLDM1 D G X5 ;if not at least 3 bps - undocumented
- .S APCLGOT1=0 F APCLSUB=12,13,14,60 D CUML^APCLDM1
- S APCLSYS=$J((APCLSYS/APCLBPS),0,0),APCLDIA=$J((APCLDIA/APCLBPS),0,0)
- I ^TMP("APCL",$J,7)="NO",APCLSYS<140,APCLDIA<90 S APCLGOT1=1,APCLSUB=12 D CUML^APCLDM1 D G X5
- .S APCLGOT1=0 F APCLSUB=13,14,60,61 D CUML^APCLDM1
- I ^TMP("APCL",$J,7)="YES",APCLSYS<140,APCLDIA<90 S APCLGOT1=1,APCLSUB=13 D CUML^APCLDM1 D G X5
- .S APCLGOT1=0 F APCLSUB=12,14,60,61 D CUML^APCLDM1
- I APCLSYS>159!(APCLDIA>94) S APCLGOT1=1,APCLSUB=60 D CUML^APCLDM1 D G X5
- .S APCLGOT1=0 F APCLSUB=12,13,14,61 D CUML^APCLDM1
- I (APCLSYS>139&(APCLSYS<160))!(APCLDIA>89&(APCLDIA<95)) S APCLGOT1=1,APCLSUB=14 D CUML^APCLDM1 D G X5
- .S APCLGOT1=0 F APCLSUB=12,13,60,61 D CUML^APCLDM1
- X5 K APCLBP,APCLBPS,APCLSYS,APCLDIA,APCLHYP
- Q
- 6 ;
- BSTAKEN ;
- D BSTAKEN^APCLDM7
- Q
- ;
- APCLDM1A ; IHS/CMI/LAB -CONTINUATION OF APCLDM1 FOR DM AUDIT DATA FETCHING ;
- +1 ;;2.0;IHS PCC SUITE;**4**;MAY 14, 2009
- +2 ;
- EN ; - EP - from ^APCLDM1
- +1 ;
- +2 FOR APCLI=1:1
- IF $TEXT(@APCLI)=""
- QUIT
- KILL APCLX
- SET APCLY="APCL("
- DO @APCLI
- KILL APCL
- +3 QUIT
- +4 ;
- 1 ;
- WTTAKEN SET APCLMEAS=$ORDER(^AUTTMSR("B","WT",""))
- DO TAKEN
- +1 SET ^TMP("APCL",$JOB,4)=APCLMEAS
- +2 KILL APCLMEAS
- +3 IF APCLCUML
- SET APCLGOT1=$SELECT(^TMP("APCL",$JOB,4)["YES":1,1:0)
- SET APCLSUB=10
- DO CUML^APCLDM1
- +4 QUIT
- 2 ;
- LASTWT SET APCLW=""
- SET APCLX=APCLPD_"^LAST 24 MEAS WT"
- SET APCLER=$$START1^APCLDF(APCLX,APCLY)
- +1 SET APCLV221=$ORDER(^ICD9("BA","V22.1 ",""))
- +2 FOR APCLN=1:1
- IF '$DATA(APCL(APCLN))!$DATA(^TMP("APCL",$JOB,5))
- QUIT
- SET APCLZ=$PIECE(APCL(APCLN),U,5)
- SET APCLD=0
- FOR
- SET APCLD=$ORDER(^AUPNVPOV("AD",APCLZ,APCLD))
- IF 'APCLD!$DATA(^TMP("APCL",$JOB,5))
- QUIT
- Begin DoDot:1
- +3 IF $PIECE(^AUPNVPOV(APCLD,0),U)'=APCLV221
- SET APCLW=$PIECE(APCL(APCLN),U,2)
- SET ^TMP("APCL",$JOB,5)=$PIECE(APCL(APCLN),U,2)_" lbs"
- SET Y=$PIECE(APCL(APCLN),U)
- DO DD^%DT
- SET ^TMP("APCL",$JOB,33)=Y
- +4 QUIT
- End DoDot:1
- +5 IF '$DATA(^TMP("APCL",$JOB,5))
- SET ^(5)="NO WT AVAILABLE"
- SET ^TMP("APCL",$JOB,33.1)=""
- IF APCLCUML
- SET APCLSUB=54
- SET APCLGOT1=1
- DO CUML^APCLDM1
- SET APCLGOT1=0
- SET APCLSUB=48
- DO CUML^APCLDM1
- SET APCLSUB=49
- SET APCLGOT1=0
- DO CUML^APCLDM1
- GOTO X2
- +6 IF '$GET(APCLCUML)
- GOTO X2
- +7 SET H=APCLHTKI
- IF 'H
- SET ^TMP("APCL",$JOB,33.1)=""
- SET APCLSUB=54
- SET APCLGOT1=1
- DO CUML^APCLDM1
- SET APCLSUB=48
- SET APCLGOT1=0
- DO CUML^APCLDM1
- SET APCLSUB=49
- SET APCLGOT1=0
- DO CUML^APCLDM1
- GOTO X2
- +8 SET APCLW=APCLW*.4536
- SET H=((H*.0254)*(H*.0254))
- SET B=APCLW/H
- SET ^TMP("APCL",$JOB,33.1)=$JUSTIFY(B,4,1)
- +9 IF $$SEX^AUPNPAT(APCLPD)="M"&(B>31.0)!($$SEX^AUPNPAT(APCLPD)="F"&(B>32.2))
- SET APCLSUB=49
- SET APCLGOT1=1
- DO CUML^APCLDM1
- SET APCLSUB=54
- SET APCLGOT1=0
- DO CUML^APCLDM1
- SET APCLGOT1=1
- SET APCLSUB=48
- DO CUML^APCLDM1
- GOTO X2
- +10 IF $$SEX^AUPNPAT(APCLPD)="M"&(B>27.7)!($$SEX^AUPNPAT(APCLPD)="F"&(B>27.2))
- SET APCLSUB=48
- SET APCLGOT1=1
- DO CUML^APCLDM1
- SET APCLSUB=54
- SET APCLGOT1=0
- DO CUML^APCLDM1
- SET APCLSUB=49
- SET APCLGOT1=0
- DO CUML^APCLDM1
- GOTO X2
- +11 ;I $E(APCLRWPT)="*" S APCLSUB=54,APCLGOT1=1 D CUML^APCLDM1 S APCLGOT1=0,APCLSUB=48 D CUML^APCLDM1 S APCLSUB=49 D CUML^APCLDM1 G X2
- +12 ;I +APCLRWPT>154 S APCLSUB=49,APCLGOT1=1 D CUML^APCLDM1 S APCLGOT1=0,APCLSUB=48 D CUML^APCLDM1 S APCLSUB=54 D CUML^APCLDM1 G X2
- +13 ;I +APCLRWPT>125 S APCLSUB=48,APCLGOT1=1 D CUML^APCLDM1 S APCLGOT1=0,APCLSUB=49 D CUML^APCLDM1 S APCLSUB=54 D CUML^APCLDM1 G X2
- +14 FOR APCLSUB=48,49,54
- SET APCLGOT1=0
- DO CUML^APCLDM1
- X2 ;
- +1 KILL APCLSUB,APCLGOT1,APCLRWPT,APCLZ,APCLN,APCLD,APCLV221,APCLX
- +2 QUIT
- 3 ;
- BPTAKEN SET APCLMEAS=$ORDER(^AUTTMSR("B","BP",""))
- DO TAKEN
- +1 SET ^TMP("APCL",$JOB,6)=APCLMEAS
- +2 IF APCLCUML
- SET APCLGOT1=$SELECT(^TMP("APCL",$JOB,6)["YES":1,1:0)
- SET APCLSUB=11
- DO CUML^APCLDM1
- +3 KILL APCLMEAS
- +4 QUIT
- +5 ;
- TAKEN ; Is BP or WT taken 75% of time during the last year's diabetic visits
- +1 SET (APCLYES,APCLNTOT)=0
- FOR APCLL=1:1:APCLTOT
- IF '$DATA(^TMP("APCLDM DXVS",$JOB,APCLL))
- QUIT
- Begin DoDot:1
- +2 SET APCLVDFN=^TMP("APCLDM DXVS",$JOB,APCLL)
- +3 SET APCLNTOT=APCLNTOT+1
- +4 SET (APCLMDFN,APCLFOUN)=0
- FOR
- SET APCLMDFN=$ORDER(^AUPNVMSR("AD",APCLVDFN,APCLMDFN))
- IF 'APCLMDFN!(APCLFOUN)
- QUIT
- Begin DoDot:2
- +5 ;entered in error
- IF $PIECE($GET(^AUPNVMSR(APCLMDFN,2)),U,1)
- QUIT
- +6 IF APCLMDFN
- IF +^AUPNVMSR(APCLMDFN,0)=APCLMEAS
- SET APCLYES=APCLYES+1
- SET APCLFOUN=1
- QUIT
- +7 QUIT
- End DoDot:2
- End DoDot:1
- +8 ;***
- +9 IF 'APCLNTOT
- SET APCLMEAS="No DM visits (01,06,28 clinics only)"
- GOTO TAKENX
- +10 NEW V
- +11 SET V=(APCLYES/APCLNTOT)*100
- SET V=$JUSTIFY(V,2,0)
- +12 SET APCLMEAS=$SELECT(V<75:"NO",1:"YES")_" - "_V_"%"
- +13 KILL APCLNTOT
- TAKENX QUIT
- +1 ;
- 4 ;
- HTNDX ;
- +1 DO HTNPLDX
- IF $DATA(APCL(1))
- GOTO X
- +2 SET X=APCLEDT
- SET %DT=""
- DO ^%DT
- SET X1=$SELECT(Y>DT:DT,1:Y)
- SET APCLHTNE=Y
- SET X2=1
- DO C^%DTC
- SET APCLHTNE=($EXTRACT(X,1,3)-5)_$EXTRACT(X,4,7)
- SET Y=APCLHTNE
- DO DD^%DT
- SET APCLHTNE=Y
- +3 SET APCLX=APCLPD_"^LAST DX [SURVEILLANCE HYPERTENSION;DURING "_APCLHTNE_"-"_APCLEDT
- SET APCLER=$$START1^APCLDF(APCLX,APCLY)
- IF APCLER
- GOTO X
- SET ^TMP("APCL",$JOB,7)=$SELECT($DATA(APCL(1)):"YES",1:"NO")
- X IF APCLER
- SET ^TMP("APCL",$JOB,7)="*** SCRIPT ERROR IN HTNDX^APCLDM1A. CONTACT SITE MANAGER"
- +1 KILL APCL
- +2 QUIT
- HTNPLDX ;see if htn on problem list
- +1 SET APCLX=APCLPD_"^PROBLEM [DM AUDIT PROBLEM HTN DIAGNOSES"
- SET APCLY="APCL("
- SET APCLER=$$START1^APCLDF(APCLX,APCLY)
- IF APCLER
- GOTO X
- IF $DATA(APCL(1))
- SET ^TMP("APCL",$JOB,7)="YES"
- +2 QUIT
- 5 ;
- BPS ;
- +1 SET APCLERCO=$ORDER(^DIC(40.7,"C",30,""))
- SET APCLLL=0
- +2 SET APCLX=APCLPD_"^LAST 50 MEAS BP"_APCLDATE
- SET APCLER=$$START1^APCLDF(APCLX,APCLY)
- FOR APCLL=1:1:20
- IF '$DATA(APCL(APCLL))
- QUIT
- SET APCLBP=$PIECE($GET(APCL(APCLL)),U,2)_$SELECT($PIECE($GET(APCL(APCLL)),U,2)]"":" mm HG",1:"")
- Begin DoDot:1
- +3 IF $PIECE(^AUPNVSIT($PIECE(APCL(APCLL),U,5),0),U,8)=APCLERCO
- QUIT
- +4 SET APCLLL=APCLLL+1
- SET ^TMP("APCL",$JOB,8_"."_APCLLL)=APCLBP
- SET Y=$PIECE(APCL(APCLL),U,1)
- DO DD^%DT
- SET ^TMP("APCL",$JOB,34_"."_APCLLL)=Y
- End DoDot:1
- +5 IF APCLCUML
- IF $GET(^TMP("APCL",$JOB,8.1))]""
- SET (APCLSYS,APCLDIA,APCLBPS)=0
- FOR APCLL=1:1:3
- IF '$DATA(^TMP("APCL",$JOB,8_"."_APCLL))
- QUIT
- SET APCLBPS=APCLBPS+1
- SET APCLSYS=APCLSYS+^(8_"."_APCLL)
- SET APCLDIA=APCLDIA+$PIECE(^(8_"."_APCLL),"/",2)
- CONTROL ;
- +1 IF '$GET(APCLCUML)
- GOTO X5
- +2 ;if not at least 3 bps - undocumented
- IF $GET(^TMP("APCL",$JOB,8.3))=""
- SET APCLGOT1=1
- SET APCLSUB=61
- DO CUML^APCLDM1
- Begin DoDot:1
- +3 SET APCLGOT1=0
- FOR APCLSUB=12,13,14,60
- DO CUML^APCLDM1
- End DoDot:1
- GOTO X5
- +4 SET APCLSYS=$JUSTIFY((APCLSYS/APCLBPS),0,0)
- SET APCLDIA=$JUSTIFY((APCLDIA/APCLBPS),0,0)
- +5 IF ^TMP("APCL",$JOB,7)="NO"
- IF APCLSYS<140
- IF APCLDIA<90
- SET APCLGOT1=1
- SET APCLSUB=12
- DO CUML^APCLDM1
- Begin DoDot:1
- +6 SET APCLGOT1=0
- FOR APCLSUB=13,14,60,61
- DO CUML^APCLDM1
- End DoDot:1
- GOTO X5
- +7 IF ^TMP("APCL",$JOB,7)="YES"
- IF APCLSYS<140
- IF APCLDIA<90
- SET APCLGOT1=1
- SET APCLSUB=13
- DO CUML^APCLDM1
- Begin DoDot:1
- +8 SET APCLGOT1=0
- FOR APCLSUB=12,14,60,61
- DO CUML^APCLDM1
- End DoDot:1
- GOTO X5
- +9 IF APCLSYS>159!(APCLDIA>94)
- SET APCLGOT1=1
- SET APCLSUB=60
- DO CUML^APCLDM1
- Begin DoDot:1
- +10 SET APCLGOT1=0
- FOR APCLSUB=12,13,14,61
- DO CUML^APCLDM1
- End DoDot:1
- GOTO X5
- +11 IF (APCLSYS>139&(APCLSYS<160))!(APCLDIA>89&(APCLDIA<95))
- SET APCLGOT1=1
- SET APCLSUB=14
- DO CUML^APCLDM1
- Begin DoDot:1
- +12 SET APCLGOT1=0
- FOR APCLSUB=12,13,60,61
- DO CUML^APCLDM1
- End DoDot:1
- GOTO X5
- X5 KILL APCLBP,APCLBPS,APCLSYS,APCLDIA,APCLHYP
- +1 QUIT
- 6 ;
- BSTAKEN ;
- +1 DO BSTAKEN^APCLDM7
- +2 QUIT
- +3 ;
