BDMDM3 ; IHS/CMI/LAB -CONTINUATION OF DM AUDIT RETRIEVAL ROUTINE ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
;IHS/CMI/LAB - patch 4 new imm package
;
EN ; - EP - from ^BDMDM1
;
F BDMI=1:1 Q:$T(@BDMI)="" K BDMX S BDMY="BDM(" D @BDMI K BDM
Q
1 ;
EDUC S BDMX=BDMPD_"^EDUC [DM AUDIT DIABETES EDUC TOPICS"_BDMDATE S BDMER=$$START1^APCLDF(BDMX,BDMY)
I BDMER G X5
NEW %
I '$D(BDM(1)) F %=15.1,15.2,15.3 S ^TMP("BDM",$J,%)="NO"
I '$D(BDM(1)) G X5
S %=0 F S %=$O(BDM(%)) Q:'% S BDMDIET($P(BDM(%),U,3),%)=""
S %="" F S %=$O(BDMDIET(%)) Q:%=""!($D(^TMP("BDM",$J,15.3))) I %'="DM-DIET"&(%'="DM-NUTRITION")&(%'="DM-EXCERCISE") S ^TMP("BDM",$J,15.3)="YES"
I '$D(^TMP("BDM",$J,15.3)) S ^TMP("BDM",$J,15.3)="NO"
I $D(BDMDIET("DM-DIET"))!($D(BDMDIET("DM-NUTRITION"))) D I 1
. S BDMPCL=$O(^DIC(7,"D",29,""))
. S BDML=0 F S BDML=$O(^TMP("BDMDM VST",$J,BDML)) Q:'BDML!($G(^TMP("BDM",$J,15.1))="RD and OTHER") S BDMPRD=0 F S BDMPRD=$O(^AUPNVPRV("AD",BDML,BDMPRD)) Q:'BDMPRD!($G(^TMP("BDM",$J,15.1))="RD and OTHER") D
.. S BDMPRV=$P(^AUPNVPRV(BDMPRD,0),U)
.. I BDMPCL]"",$S($P(^DD(9000010.06,.01,0),U,2)[200:$$PROVCLS^XBFUNC1(BDMPRV,"I"),1:$P(^DIC(6,BDMPRV,0),U,4))=BDMPCL S ^TMP("BDM",$J,15.1)=$S($G(^TMP("BDM",$J,15.1))="OTHER":"RD and OTHER",1:"RD")
.. E S ^TMP("BDM",$J,15.1)="OTHER"
E S ^TMP("BDM",$J,15.1)="NO"
I $D(BDMDIET("DM-EXERCISE")) S ^TMP("BDM",$J,15.2)="YES"
E S ^TMP("BDM",$J,15.2)="NO"
X5 I BDMER S ^TMP("BDM",$J,15.1)="*** SCRIPT ERROR IN EDUC^BDMDM3. CONTACT SITE MANAGER" Q
I BDMCUML S BDMGOT1=$S(^TMP("BDM",$J,15.1)="NO":0,1:1),BDMSUB=25 D CUML^BDMDM1
I BDMCUML S BDMGOT1=$S(^TMP("BDM",$J,15.2)="NO":0,1:1),BDMSUB=26 D CUML^BDMDM1
I BDMCUML S BDMGOT1=$S(^TMP("BDM",$J,15.3)="NO":0,1:1),BDMSUB=27 D CUML^BDMDM1
K BDMDIET,BDM
Q
2 ;
THERAPY ;
S X=BDMEDT,%DT="" D ^%DT S X1=$S(Y>DT:DT,1:Y),X2=-122 D C^%DTC S Y=X D DD^%DT S BDMHTNE=Y
S BDMX=BDMPD_"^MEDS [DM AUDIT INSULIN DRUGS"_";DURING "_BDMHTNE_"-"_BDMEDT S BDMER=$$START1^APCLDF(BDMX,BDMY)
I BDMER G X10
S ^TMP("BDM",$J,30)=$S($D(BDM(1)):"Insulin",1:"") K BDM
S BDMX=BDMPD_"^MEDS [DM AUDIT ORAL HYPOGLYCEMICS"_";DURING "_BDMHTNE_"-"_BDMEDT S BDMER=$$START1^APCLDF(BDMX,BDMY)
I BDMER G X10
S ^(30)=$S($D(BDM(1))&(^TMP("BDM",$J,30)]""):"Oral Agent & Insulin",'$D(BDM(1))&(^(30)]""):^(30),$D(BDM(1))&(^(30)=""):"Oral Agent",1:"Diet Alone")
I BDMCUML S BDMTX=^TMP("BDM",$J,30) D
. I BDMTX="Oral Agent & Insulin" S BDMGOT1=1,BDMSUB=6 D CUML^BDMDM1 S BDMGOT1=0 F BDMSUB=3,4,5 D CUML^BDMDM1
. I BDMTX="Oral Agent" S BDMGOT1=1,BDMSUB=5 D CUML^BDMDM1 S BDMGOT1=0 F BDMSUB=3,4,6 D CUML^BDMDM1
. I BDMTX="Insulin" S BDMGOT1=1,BDMSUB=4 D CUML^BDMDM1 S BDMGOT1=0 F BDMSUB=3,5,6 D CUML^BDMDM1
. I BDMTX="Diet Alone" S BDMGOT1=1,BDMSUB=3 D CUML^BDMDM1 S BDMGOT1=0 F BDMSUB=4:1:6 D CUML^BDMDM1
. K BDMTX
X10 I BDMER S ^TMP("BDM",$J,30)="*** SCRIPT ERROR IN THERAPY^BDMDM3. CONTACT SITE MANAGER"
Q
;IHS/CMI/LAB - new sub routine for new imm package
BI() ; check to see if running new imm package
Q $S($O(^AUTTIMM(0))>100:1,1:0)
;end new subroutine IHS/CMI/LAB
3 ;
FLU S BDMX=BDMPD_"^LAST IMM "_$S($$BI:88,1:12)_BDMDATE S BDMER=$$START1^APCLDF(BDMX,BDMY) ;IHS/CMI/LAB - changed line for new imm package
I $D(BDM(1)) S Y=+BDM(1) D DD^%DT
S ^TMP("BDM",$J,29)=$S($D(BDM(1)):"YES - "_Y,1:"NO")
I BDMCUML S BDMGOT1=$S(^TMP("BDM",$J,29)="NO":0,1:1),BDMSUB=28 D CUML^BDMDM1
Q
4 ;
PNEUMOVX S BDMX=BDMPD_"^LAST IMM "_$S($$BI:33,1:19) S BDMER=$$START1^APCLDF(BDMX,BDMY) ;IHS/CMI/LAB - changed line for new imm package
S ^TMP("BDM",$J,18)=$S($D(BDM(1)):"YES",1:"NO")
I BDMCUML S BDMGOT1=$S(^TMP("BDM",$J,18)="NO":0,1:1),BDMSUB=29 D CUML^BDMDM1
Q
5 ;
TD S X=BDMTDTE D ^%DT S X1=Y,X2=-3652 D C^%DTC S Y=X D DD^%DT S BDMTD=";DURING "_Y_"-"_BDMTDTE
S BDMX=BDMPD_"^LAST IMM "_$S($$BI:9,1:"02")_BDMTD S BDMER=$$START1^APCLDF(BDMX,BDMY) ;IHS/CMI/LAB -changed line for new imm package
S ^TMP("BDM",$J,19)=$S($D(BDM(1)):"YES",1:"NO")
I BDMCUML S BDMGOT1=$S(^TMP("BDM",$J,19)="NO":0,1:1),BDMSUB=30 D CUML^BDMDM1
Q
6 ;
EKG ;
Q
7 ;ACE INHIBITOR
S BDMX=BDMPD_"^MEDS [DM AUDIT ACE INHIBITORS"_";DURING "_BDMHTNE_"-"_BDMEDT S BDMER=$$START1^APCLDF(BDMX,BDMY)
I BDMER G X7
S BDMGOT=0 D C7
S ^TMP("BDM",$J,41)=$S('BDMGOT:"Does not currently use/undetermined",1:"Currently uses (is prescribed)")
I BDMCUML D
.I BDMGOT S BDMGOT1=1,BDMSUB=80 D CUML^BDMDM1 S BDMGOT1=0,BDMSUB=82 D CUML^BDMDM1
.I 'BDMGOT S BDMGOT1=0,BDMSUB=80 D CUML^BDMDM1 S BDMGOT1=1,BDMSUB=82 D CUML^BDMDM1
.Q
X7 ;XIT ACE 7
I BDMER S ^TMP("BDM",$J,41)="ACE INHIBITOR TAXONOMY MISSING"
Q
C7 ;check for currently prescribed
S BDMX=0 F S BDMX=$O(BDM(BDMX)) Q:BDMX'=+BDMX!(BDMGOT) D
.S BDMVMED=+$P(BDM(BDMX),U,4),BDMDAYS=$P(^AUPNVMED(BDMVMED,0),U,7),BDMDP=$P(BDM(BDMX),U)
.Q:'BDMDAYS
.S B=$$FMADD^XLFDT(BDMDP,BDMDAYS)
.I B'<BDMUED S BDMGOT=1
.Q
Q
BDMDM3 ; IHS/CMI/LAB -CONTINUATION OF DM AUDIT RETRIEVAL ROUTINE ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**2**;JUN 14, 2007
+2 ;IHS/CMI/LAB - patch 4 new imm package
+3 ;
EN ; - EP - from ^BDMDM1
+1 ;
+2 FOR BDMI=1:1
IF $TEXT(@BDMI)=""
QUIT
KILL BDMX
SET BDMY="BDM("
DO @BDMI
KILL BDM
+3 QUIT
1 ;
EDUC SET BDMX=BDMPD_"^EDUC [DM AUDIT DIABETES EDUC TOPICS"_BDMDATE
SET BDMER=$$START1^APCLDF(BDMX,BDMY)
+1 IF BDMER
GOTO X5
+2 NEW %
+3 IF '$DATA(BDM(1))
FOR %=15.1,15.2,15.3
SET ^TMP("BDM",$JOB,%)="NO"
+4 IF '$DATA(BDM(1))
GOTO X5
+5 SET %=0
FOR
SET %=$ORDER(BDM(%))
IF '%
QUIT
SET BDMDIET($PIECE(BDM(%),U,3),%)=""
+6 SET %=""
FOR
SET %=$ORDER(BDMDIET(%))
IF %=""!($DATA(^TMP("BDM",$JOB,15.3)))
QUIT
IF %'="DM-DIET"&(%'="DM-NUTRITION")&(%'="DM-EXCERCISE")
SET ^TMP("BDM",$JOB,15.3)="YES"
+7 IF '$DATA(^TMP("BDM",$JOB,15.3))
SET ^TMP("BDM",$JOB,15.3)="NO"
+8 IF $DATA(BDMDIET("DM-DIET"))!($DATA(BDMDIET("DM-NUTRITION")))
Begin DoDot:1
+9 SET BDMPCL=$ORDER(^DIC(7,"D",29,""))
+10 SET BDML=0
FOR
SET BDML=$ORDER(^TMP("BDMDM VST",$JOB,BDML))
IF 'BDML!($GET(^TMP("BDM",$JOB,15.1))="RD and OTHER")
QUIT
SET BDMPRD=0
FOR
SET BDMPRD=$ORDER(^AUPNVPRV("AD",BDML,BDMPRD))
IF 'BDMPRD!($GET(^TMP("BDM",$JOB,15.1))="RD and OTHER")
QUIT
Begin DoDot:2
+11 SET BDMPRV=$PIECE(^AUPNVPRV(BDMPRD,0),U)
+12 IF BDMPCL]""
IF $SELECT($PIECE(^DD(9000010.06,.01,0),U,2)[200:$$PROVCLS^XBFUNC1(BDMPRV,"I"),1:$PIECE(^DIC(6,BDMPRV,0),U,4))=BDMPCL
SET ^TMP("BDM",$JOB,15.1)=$SELECT($GET(^TMP("BDM",$JOB,15.1))="OTHER":"RD and OTHER",1:"RD")
+13 IF '$TEST
SET ^TMP("BDM",$JOB,15.1)="OTHER"
End DoDot:2
End DoDot:1
IF 1
+14 IF '$TEST
SET ^TMP("BDM",$JOB,15.1)="NO"
+15 IF $DATA(BDMDIET("DM-EXERCISE"))
SET ^TMP("BDM",$JOB,15.2)="YES"
+16 IF '$TEST
SET ^TMP("BDM",$JOB,15.2)="NO"
X5 IF BDMER
SET ^TMP("BDM",$JOB,15.1)="*** SCRIPT ERROR IN EDUC^BDMDM3. CONTACT SITE MANAGER"
QUIT
+1 IF BDMCUML
SET BDMGOT1=$SELECT(^TMP("BDM",$JOB,15.1)="NO":0,1:1)
SET BDMSUB=25
DO CUML^BDMDM1
+2 IF BDMCUML
SET BDMGOT1=$SELECT(^TMP("BDM",$JOB,15.2)="NO":0,1:1)
SET BDMSUB=26
DO CUML^BDMDM1
+3 IF BDMCUML
SET BDMGOT1=$SELECT(^TMP("BDM",$JOB,15.3)="NO":0,1:1)
SET BDMSUB=27
DO CUML^BDMDM1
+4 KILL BDMDIET,BDM
+5 QUIT
2 ;
THERAPY ;
+1 SET X=BDMEDT
SET %DT=""
DO ^%DT
SET X1=$SELECT(Y>DT:DT,1:Y)
SET X2=-122
DO C^%DTC
SET Y=X
DO DD^%DT
SET BDMHTNE=Y
+2 SET BDMX=BDMPD_"^MEDS [DM AUDIT INSULIN DRUGS"_";DURING "_BDMHTNE_"-"_BDMEDT
SET BDMER=$$START1^APCLDF(BDMX,BDMY)
+3 IF BDMER
GOTO X10
+4 SET ^TMP("BDM",$JOB,30)=$SELECT($DATA(BDM(1)):"Insulin",1:"")
KILL BDM
+5 SET BDMX=BDMPD_"^MEDS [DM AUDIT ORAL HYPOGLYCEMICS"_";DURING "_BDMHTNE_"-"_BDMEDT
SET BDMER=$$START1^APCLDF(BDMX,BDMY)
+6 IF BDMER
GOTO X10
+7 SET ^(30)=$SELECT($DATA(BDM(1))&(^TMP("BDM",$JOB,30)]""):"Oral Agent & Insulin",'$DATA(BDM(1))&(^(30)]""):^(30),$DATA(BDM(1))&(^(30)=""):"Oral Agent",1:"Diet Alone")
+8 IF BDMCUML
SET BDMTX=^TMP("BDM",$JOB,30)
Begin DoDot:1
+9 IF BDMTX="Oral Agent & Insulin"
SET BDMGOT1=1
SET BDMSUB=6
DO CUML^BDMDM1
SET BDMGOT1=0
FOR BDMSUB=3,4,5
DO CUML^BDMDM1
+10 IF BDMTX="Oral Agent"
SET BDMGOT1=1
SET BDMSUB=5
DO CUML^BDMDM1
SET BDMGOT1=0
FOR BDMSUB=3,4,6
DO CUML^BDMDM1
+11 IF BDMTX="Insulin"
SET BDMGOT1=1
SET BDMSUB=4
DO CUML^BDMDM1
SET BDMGOT1=0
FOR BDMSUB=3,5,6
DO CUML^BDMDM1
+12 IF BDMTX="Diet Alone"
SET BDMGOT1=1
SET BDMSUB=3
DO CUML^BDMDM1
SET BDMGOT1=0
FOR BDMSUB=4:1:6
DO CUML^BDMDM1
+13 KILL BDMTX
End DoDot:1
X10 IF BDMER
SET ^TMP("BDM",$JOB,30)="*** SCRIPT ERROR IN THERAPY^BDMDM3. CONTACT SITE MANAGER"
+1 QUIT
+2 ;IHS/CMI/LAB - new sub routine for new imm package
BI() ; check to see if running new imm package
+1 QUIT $SELECT($ORDER(^AUTTIMM(0))>100:1,1:0)
+2 ;end new subroutine IHS/CMI/LAB
3 ;
FLU ;IHS/CMI/LAB - changed line for new imm package
SET BDMX=BDMPD_"^LAST IMM "_$SELECT($$BI:88,1:12)_BDMDATE
SET BDMER=$$START1^APCLDF(BDMX,BDMY)
+1 IF $DATA(BDM(1))
SET Y=+BDM(1)
DO DD^%DT
+2 SET ^TMP("BDM",$JOB,29)=$SELECT($DATA(BDM(1)):"YES - "_Y,1:"NO")
+3 IF BDMCUML
SET BDMGOT1=$SELECT(^TMP("BDM",$JOB,29)="NO":0,1:1)
SET BDMSUB=28
DO CUML^BDMDM1
+4 QUIT
4 ;
PNEUMOVX ;IHS/CMI/LAB - changed line for new imm package
SET BDMX=BDMPD_"^LAST IMM "_$SELECT($$BI:33,1:19)
SET BDMER=$$START1^APCLDF(BDMX,BDMY)
+1 SET ^TMP("BDM",$JOB,18)=$SELECT($DATA(BDM(1)):"YES",1:"NO")
+2 IF BDMCUML
SET BDMGOT1=$SELECT(^TMP("BDM",$JOB,18)="NO":0,1:1)
SET BDMSUB=29
DO CUML^BDMDM1
+3 QUIT
5 ;
TD SET X=BDMTDTE
DO ^%DT
SET X1=Y
SET X2=-3652
DO C^%DTC
SET Y=X
DO DD^%DT
SET BDMTD=";DURING "_Y_"-"_BDMTDTE
+1 ;IHS/CMI/LAB -changed line for new imm package
SET BDMX=BDMPD_"^LAST IMM "_$SELECT($$BI:9,1:"02")_BDMTD
SET BDMER=$$START1^APCLDF(BDMX,BDMY)
+2 SET ^TMP("BDM",$JOB,19)=$SELECT($DATA(BDM(1)):"YES",1:"NO")
+3 IF BDMCUML
SET BDMGOT1=$SELECT(^TMP("BDM",$JOB,19)="NO":0,1:1)
SET BDMSUB=30
DO CUML^BDMDM1
+4 QUIT
6 ;
EKG ;
+1 QUIT
7 ;ACE INHIBITOR
+1 SET BDMX=BDMPD_"^MEDS [DM AUDIT ACE INHIBITORS"_";DURING "_BDMHTNE_"-"_BDMEDT
SET BDMER=$$START1^APCLDF(BDMX,BDMY)
+2 IF BDMER
GOTO X7
+3 SET BDMGOT=0
DO C7
+4 SET ^TMP("BDM",$JOB,41)=$SELECT('BDMGOT:"Does not currently use/undetermined",1:"Currently uses (is prescribed)")
+5 IF BDMCUML
Begin DoDot:1
+6 IF BDMGOT
SET BDMGOT1=1
SET BDMSUB=80
DO CUML^BDMDM1
SET BDMGOT1=0
SET BDMSUB=82
DO CUML^BDMDM1
+7 IF 'BDMGOT
SET BDMGOT1=0
SET BDMSUB=80
DO CUML^BDMDM1
SET BDMGOT1=1
SET BDMSUB=82
DO CUML^BDMDM1
+8 QUIT
End DoDot:1
X7 ;XIT ACE 7
+1 IF BDMER
SET ^TMP("BDM",$JOB,41)="ACE INHIBITOR TAXONOMY MISSING"
+2 QUIT
C7 ;check for currently prescribed
+1 SET BDMX=0
FOR
SET BDMX=$ORDER(BDM(BDMX))
IF BDMX'=+BDMX!(BDMGOT)
QUIT
Begin DoDot:1
+2 SET BDMVMED=+$PIECE(BDM(BDMX),U,4)
SET BDMDAYS=$PIECE(^AUPNVMED(BDMVMED,0),U,7)
SET BDMDP=$PIECE(BDM(BDMX),U)
+3 IF 'BDMDAYS
QUIT
+4 SET B=$$FMADD^XLFDT(BDMDP,BDMDAYS)
+5 IF B'<BDMUED
SET BDMGOT=1
+6 QUIT
End DoDot:1
+7 QUIT
