BDMVRL43 ; IHS/CMI/LAB - DEMO/APPTS ACTION ; 09 Feb 2010 7:43 AM
;;2.0;DIABETES MANAGEMENT SYSTEM;**1,2,3,4,5,6,7,8,9,10,11,12**;JUN 14, 2007;Build 51
;
PROVIDER ;EP;PRINT FU REPORT/LETTER FOR SELECTED PROVIDERS
K BDMK
W !!,"Print the Follow-up Report/Letters by"
S DIR(0)="SO^1:Community;2:Primary Provider;3:Where Followed"
S DIR("A")="Which one"
S DIR("B")="Community"
W !
D DIR^BDMFDIC
I Y<1 S BDMQUIT="" Q
I Y=1 S BDMK="COMMUNITY"
I Y=2 S BDMK="PROVIDER"
I Y=3 S BDMK="WHERE"
D C1
W !!,$S(BDMK["PROV":"Providers",BDMK["COMM":"Communities",1:"Locations")," Selected:"
I '$O(BDMK(0)) W !!?10,"ALL " Q
S BDMX=0
F S BDMX=$O(BDMK(BDMX)) Q:BDMX="" W !?10,BDMK(BDMX)
K BDMQUIT
Q
C1 ;SELECT COMMUNITY(IES)
W !!,"(Press <ENTER> to select ALL "
W $S(BDMK["COMM":"Communities",BDMK["PROV":"Providers",1:"Locations Where Followed")
F D C11 Q:$D(BDMQUIT)
K BDMQUIT
Q
C11 S DIR(0)="FO^1:30"
S DIR("A")="Which "_$S(BDMK["COMM":"Community",BDMK["PROV":"Provider",1:"Location Where Followed")
S:$O(BDMK(0)) DIR("A")="Select another "_$S(BDMK["COMM":"Community",BDMK["PROV":"Provider",1:"Location Where Followed")
W !
D DIR^BDMFDIC
I X=""!(X[U) S BDMQUIT="" Q
S BDMX=X
I $E(X)="[" D Q
.D CT
.S BDMQUIT="" Q
D C12
Q
C12 S DIC=$S(BDMK["COMM":"^AUTTCOM(",BDMK["PROV":$S(^DD(9000001,.14,0)[200:"^VA(200,",1:"^DIC(6,"),1:"^AUTTLOC(")
S DIC(0)="EMQZ"
W !
S X=BDMX
D DIC^BDMFDIC
I Y<1 S BDMQUIT="" Q
S BDMK(+Y)=Y(0,0)
Q
CT ;SELECT COMMUNITY TAXONOMY
S DIC("S")="I $P(^(0),U,15)="_$S(BDMK["COMM":9999999.05,BDMK["PROV":9999999.06,1:6)_",$O(^ATXAX(+Y,21,""B"",""""))]"""""
S X=$E(BDMX,2,999)
S DIC="^ATXAX("
S DIC(0)="EMZ"
D DIC^BDMFDIC
I Y<1 D Q
.I BDMX["?" K BDMQUIT G C1
.W !,BDMX," Taxonomy not found"
.S BDMQUIT=""
.H 2
W !!," Members of the ",X," Taxonomy:",!
S X=+Y
S Y=""
F S Y=$O(^ATXAX(X,21,"B",Y)) Q:Y="" D
.W !,Y
.S Z=0
.F S Z=$O(^AUTTCOM("B",Y,Z)) Q:'Z D
..S BDMK(Z)=Y
Q
LAB ;EP;DETERMINE LAST LAB VIA LAB SYSTEM
I BDMFU'="LIVR" D APCLLAB Q
K BDMQUIT
N BDMLR,J,X,Y,Z
S BDMLR=$P($G(^DPT(DFN,"LR")),U)
Q:'$D(^LR(+BDMLR,"CH"))
S X=0
F S X=$O(^LR(BDMLR,"CH",X)) Q:'X!$D(BDMQUIT) D
.I BDMFU="CHOL" F J=12 Q:$D(BDMQUIT) D LAB1:$G(^LR(BDMLR,"CH",X,J))
.I BDMFU="LDL" F J=18,291 Q:$D(BDMQUIT) D LAB1:$G(^LR(BDMLR,"CH",X,J))
.I BDMFU="HDL" F J=80 Q:$D(BDMQUIT) D LAB1:$G(^LR(BDMLR,"CH",X,J))
.I BDMFU="CREA" F J=4 Q:$D(BDMQUIT) D LAB1:$G(^LR(BDMLR,"CH",X,J))
.I BDMFU="TRIG" F J=47 Q:$D(BDMQUIT) D LAB1:$G(^LR(BDMLR,"CH",X,J))
.I BDMFU="HGB" F J=462 Q:$D(BDMQUIT) D LAB1:$G(^LR(BDMLR,"CH",X,J))
.I BDMFU="LIVR" F J=19,20 Q:$D(BDMQUIT) D LAB1:$G(^LR(BDMLR,"CH",X,J))
.I BDMFU="URIN" D
..F JJ=38,122,123,249,256,257,303,305,619 Q:$D(BDMQUIT) D
...S J=1665000+JJ
...D LAB1:$D(^LR(BDMLR,"CH",X,J))
.I BDMFU="UPRO" D
..F JJ=38,249,256,257,303,305 Q:$D(BDMQUIT) D
...S J=1665000+JJ
...D LAB1:$D(^LR(BDMLR,"CH",X,J))
K BDMQUIT
Q
LAB1 S Y=$P(X,".")
S Z=$$LSTVST^BDMVRL4(Y)
I Z="" D Q
.K ^TMP("BDMTMP",$J,BDM("COMMUNITY"),BDM("PATIENT"),BDMP,BDM("FOLLOW-UP TYPE"))
.S BDMQUIT=""
S X=Z
D FUOUT^BDMVRL4
Q
TYPE ;EP;CHECK FOR TYPE 1/TYPE 2 DM
S DFN=$P($G(^ACM(41,BDMRPDA,0)),U,2)
Q:'DFN
K BDMQUIT
N X,Y,Z
S X=0
F S X=$O(^ACM(44,"AC",BDMRDA,DFN,X)) Q:'X!$D(BDMQUIT) D
.I $P($G(^ACM(44.1,X,0)),U)["TYPE" S BDMQUIT=""
Q
;
APCLLAB ;EP;TO USE DM AUDIT LOGIC
S X="BDMDG18"
S Z=""
I BDMFU="CHOL" S Y="S Z=$$CHOL^"_X_"(DFN,2900101,DT)" X Y
I BDMFU="LDL" S Y="S Z=$$LDL^"_X_"(DFN,2900101,DT)" X Y
I BDMFU="HDL" S Y="S Z=$$HDL^"_X_"(DFN,2900101,DT)" X Y
I BDMFU="CREA" S Y="S Z=$$CREAT^"_X_"(DFN,2900101,DT)" X Y
I BDMFU="TRIG" S Y="S Z=$$TRIG^"_X_"(DFN,2900101,DT)" X Y
;I BDMFU="UPT" S Y="S Z=$$URIN^"_X_"(DFN,2900101,DT)" X Y
;I BDMFU="UPRO" S Y="S Z=$$PROTEIN^"_X_"(DFN,2900101,DT)" X Y
I BDMFU="GFR" S Z=$$GFR^BDMDG1C(DFN,2900101,DT,1)
I BDMFU="UACR" S Z=$$UACR^BDMDG1C(DFN,2900101,DT)
I BDMFU="HEPC" S Z=$$HEPSCR^BDMDG1D(DFN,DT)
;I BDMFU="UPRO" S Y="S Z=$$MICRO^"_X_"(DFN,2900101,DT)" X Y
I BDMFU="GFR"!(BDMFU="UACR")!(BDMFU="UPT") D
.S:$P(Z,U,3)="" Z=""
.I $P(Z,U,3)]"" S Z=U_$P(Z,U,3)
I Z]"" S X=$P(Z,U,2),%DT="" D ^%DT S Z=Y
I BDMFU="HGB" D
.S Y="S Z=$$HGBA1C^"_X_"(DFN,2900101,DT)" X Y
.S:Z Z=$P(Z,U,1)
I 'Z D FUNO^BDMVRL4 Q
S X=9999999-Z
D LAB1
Q
IMMUN ;EP;TO USE DM TD LOGIC
F X="APCLD91B","APCLD81B","APCLD71B","APCLD61B","APCLD51B","APCLD41B","APCLD31B","APCLD313","APCLD216" X ^%ZOSF("TEST") Q:$T
S Z=""
I BDMFU="TD" S Y="S Z=$$TD^"_X_"(DFN,DT)" X Y
I Z]"" D
.S:$L(Z," ")>1 Z=$P(Z," ",3,5)
.S X=+$P(Z," ",2)
.S:$L(X)=1 X=0_X
.S Y=$P(Z," ",3)-1700
.S Z=$P(Z," ")
.S Z=$S(Z="Jan":"01",Z="Feb":"02",Z="Mar":"03",Z="Apr":"04",Z="May":"05",Z="Jun":"06",Z="Jul":"07",Z="Aug":"08",Z="Sep":"09",Z="Oct":10,Z="Nov":11,Z="Dec":12,1:"")
.I 'Z S Z="" Q
.S Z=Y_Z_X
I 'Z D FUNO^BDMVRL4 Q
S X=9999999-Z
D LAB1
Q
BDMVRL43 ; IHS/CMI/LAB - DEMO/APPTS ACTION ; 09 Feb 2010 7:43 AM
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**1,2,3,4,5,6,7,8,9,10,11,12**;JUN 14, 2007;Build 51
+2 ;
PROVIDER ;EP;PRINT FU REPORT/LETTER FOR SELECTED PROVIDERS
+1 KILL BDMK
+2 WRITE !!,"Print the Follow-up Report/Letters by"
+3 SET DIR(0)="SO^1:Community;2:Primary Provider;3:Where Followed"
+4 SET DIR("A")="Which one"
+5 SET DIR("B")="Community"
+6 WRITE !
+7 DO DIR^BDMFDIC
+8 IF Y<1
SET BDMQUIT=""
QUIT
+9 IF Y=1
SET BDMK="COMMUNITY"
+10 IF Y=2
SET BDMK="PROVIDER"
+11 IF Y=3
SET BDMK="WHERE"
+12 DO C1
+13 WRITE !!,$SELECT(BDMK["PROV":"Providers",BDMK["COMM":"Communities",1:"Locations")," Selected:"
+14 IF '$ORDER(BDMK(0))
WRITE !!?10,"ALL "
QUIT
+15 SET BDMX=0
+16 FOR
SET BDMX=$ORDER(BDMK(BDMX))
IF BDMX=""
QUIT
WRITE !?10,BDMK(BDMX)
+17 KILL BDMQUIT
+18 QUIT
C1 ;SELECT COMMUNITY(IES)
+1 WRITE !!,"(Press <ENTER> to select ALL "
+2 WRITE $SELECT(BDMK["COMM":"Communities",BDMK["PROV":"Providers",1:"Locations Where Followed")
+3 FOR
DO C11
IF $DATA(BDMQUIT)
QUIT
+4 KILL BDMQUIT
+5 QUIT
C11 SET DIR(0)="FO^1:30"
+1 SET DIR("A")="Which "_$SELECT(BDMK["COMM":"Community",BDMK["PROV":"Provider",1:"Location Where Followed")
+2 IF $ORDER(BDMK(0))
SET DIR("A")="Select another "_$SELECT(BDMK["COMM":"Community",BDMK["PROV":"Provider",1:"Location Where Followed")
+3 WRITE !
+4 DO DIR^BDMFDIC
+5 IF X=""!(X[U)
SET BDMQUIT=""
QUIT
+6 SET BDMX=X
+7 IF $EXTRACT(X)="["
Begin DoDot:1
+8 DO CT
+9 SET BDMQUIT=""
QUIT
End DoDot:1
QUIT
+10 DO C12
+11 QUIT
C12 SET DIC=$SELECT(BDMK["COMM":"^AUTTCOM(",BDMK["PROV":$SELECT(^DD(9000001,.14,0)[200:"^VA(200,",1:"^DIC(6,"),1:"^AUTTLOC(")
+1 SET DIC(0)="EMQZ"
+2 WRITE !
+3 SET X=BDMX
+4 DO DIC^BDMFDIC
+5 IF Y<1
SET BDMQUIT=""
QUIT
+6 SET BDMK(+Y)=Y(0,0)
+7 QUIT
CT ;SELECT COMMUNITY TAXONOMY
+1 SET DIC("S")="I $P(^(0),U,15)="_$SELECT(BDMK["COMM":9999999.05,BDMK["PROV":9999999.06,1:6)_",$O(^ATXAX(+Y,21,""B"",""""))]"""""
+2 SET X=$EXTRACT(BDMX,2,999)
+3 SET DIC="^ATXAX("
+4 SET DIC(0)="EMZ"
+5 DO DIC^BDMFDIC
+6 IF Y<1
Begin DoDot:1
+7 IF BDMX["?"
KILL BDMQUIT
GOTO C1
+8 WRITE !,BDMX," Taxonomy not found"
+9 SET BDMQUIT=""
+10 HANG 2
End DoDot:1
QUIT
+11 WRITE !!," Members of the ",X," Taxonomy:",!
+12 SET X=+Y
+13 SET Y=""
+14 FOR
SET Y=$ORDER(^ATXAX(X,21,"B",Y))
IF Y=""
QUIT
Begin DoDot:1
+15 WRITE !,Y
+16 SET Z=0
+17 FOR
SET Z=$ORDER(^AUTTCOM("B",Y,Z))
IF 'Z
QUIT
Begin DoDot:2
+18 SET BDMK(Z)=Y
End DoDot:2
End DoDot:1
+19 QUIT
LAB ;EP;DETERMINE LAST LAB VIA LAB SYSTEM
+1 IF BDMFU'="LIVR"
DO APCLLAB
QUIT
+2 KILL BDMQUIT
+3 NEW BDMLR,J,X,Y,Z
+4 SET BDMLR=$PIECE($GET(^DPT(DFN,"LR")),U)
+5 IF '$DATA(^LR(+BDMLR,"CH"))
QUIT
+6 SET X=0
+7 FOR
SET X=$ORDER(^LR(BDMLR,"CH",X))
IF 'X!$DATA(BDMQUIT)
QUIT
Begin DoDot:1
+8 IF BDMFU="CHOL"
FOR J=12
IF $DATA(BDMQUIT)
QUIT
IF $GET(^LR(BDMLR,"CH",X,J))
DO LAB1
+9 IF BDMFU="LDL"
FOR J=18,291
IF $DATA(BDMQUIT)
QUIT
IF $GET(^LR(BDMLR,"CH",X,J))
DO LAB1
+10 IF BDMFU="HDL"
FOR J=80
IF $DATA(BDMQUIT)
QUIT
IF $GET(^LR(BDMLR,"CH",X,J))
DO LAB1
+11 IF BDMFU="CREA"
FOR J=4
IF $DATA(BDMQUIT)
QUIT
IF $GET(^LR(BDMLR,"CH",X,J))
DO LAB1
+12 IF BDMFU="TRIG"
FOR J=47
IF $DATA(BDMQUIT)
QUIT
IF $GET(^LR(BDMLR,"CH",X,J))
DO LAB1
+13 IF BDMFU="HGB"
FOR J=462
IF $DATA(BDMQUIT)
QUIT
IF $GET(^LR(BDMLR,"CH",X,J))
DO LAB1
+14 IF BDMFU="LIVR"
FOR J=19,20
IF $DATA(BDMQUIT)
QUIT
IF $GET(^LR(BDMLR,"CH",X,J))
DO LAB1
+15 IF BDMFU="URIN"
Begin DoDot:2
+16 FOR JJ=38,122,123,249,256,257,303,305,619
IF $DATA(BDMQUIT)
QUIT
Begin DoDot:3
+17 SET J=1665000+JJ
+18 IF $DATA(^LR(BDMLR,"CH",X,J))
DO LAB1
End DoDot:3
End DoDot:2
+19 IF BDMFU="UPRO"
Begin DoDot:2
+20 FOR JJ=38,249,256,257,303,305
IF $DATA(BDMQUIT)
QUIT
Begin DoDot:3
+21 SET J=1665000+JJ
+22 IF $DATA(^LR(BDMLR,"CH",X,J))
DO LAB1
End DoDot:3
End DoDot:2
End DoDot:1
+23 KILL BDMQUIT
+24 QUIT
LAB1 SET Y=$PIECE(X,".")
+1 SET Z=$$LSTVST^BDMVRL4(Y)
+2 IF Z=""
Begin DoDot:1
+3 KILL ^TMP("BDMTMP",$JOB,BDM("COMMUNITY"),BDM("PATIENT"),BDMP,BDM("FOLLOW-UP TYPE"))
+4 SET BDMQUIT=""
End DoDot:1
QUIT
+5 SET X=Z
+6 DO FUOUT^BDMVRL4
+7 QUIT
TYPE ;EP;CHECK FOR TYPE 1/TYPE 2 DM
+1 SET DFN=$PIECE($GET(^ACM(41,BDMRPDA,0)),U,2)
+2 IF 'DFN
QUIT
+3 KILL BDMQUIT
+4 NEW X,Y,Z
+5 SET X=0
+6 FOR
SET X=$ORDER(^ACM(44,"AC",BDMRDA,DFN,X))
IF 'X!$DATA(BDMQUIT)
QUIT
Begin DoDot:1
+7 IF $PIECE($GET(^ACM(44.1,X,0)),U)["TYPE"
SET BDMQUIT=""
End DoDot:1
+8 QUIT
+9 ;
APCLLAB ;EP;TO USE DM AUDIT LOGIC
+1 SET X="BDMDG18"
+2 SET Z=""
+3 IF BDMFU="CHOL"
SET Y="S Z=$$CHOL^"_X_"(DFN,2900101,DT)"
XECUTE Y
+4 IF BDMFU="LDL"
SET Y="S Z=$$LDL^"_X_"(DFN,2900101,DT)"
XECUTE Y
+5 IF BDMFU="HDL"
SET Y="S Z=$$HDL^"_X_"(DFN,2900101,DT)"
XECUTE Y
+6 IF BDMFU="CREA"
SET Y="S Z=$$CREAT^"_X_"(DFN,2900101,DT)"
XECUTE Y
+7 IF BDMFU="TRIG"
SET Y="S Z=$$TRIG^"_X_"(DFN,2900101,DT)"
XECUTE Y
+8 ;I BDMFU="UPT" S Y="S Z=$$URIN^"_X_"(DFN,2900101,DT)" X Y
+9 ;I BDMFU="UPRO" S Y="S Z=$$PROTEIN^"_X_"(DFN,2900101,DT)" X Y
+10 IF BDMFU="GFR"
SET Z=$$GFR^BDMDG1C(DFN,2900101,DT,1)
+11 IF BDMFU="UACR"
SET Z=$$UACR^BDMDG1C(DFN,2900101,DT)
+12 IF BDMFU="HEPC"
SET Z=$$HEPSCR^BDMDG1D(DFN,DT)
+13 ;I BDMFU="UPRO" S Y="S Z=$$MICRO^"_X_"(DFN,2900101,DT)" X Y
+14 IF BDMFU="GFR"!(BDMFU="UACR")!(BDMFU="UPT")
Begin DoDot:1
+15 IF $PIECE(Z,U,3)=""
SET Z=""
+16 IF $PIECE(Z,U,3)]""
SET Z=U_$PIECE(Z,U,3)
End DoDot:1
+17 IF Z]""
SET X=$PIECE(Z,U,2)
SET %DT=""
DO ^%DT
SET Z=Y
+18 IF BDMFU="HGB"
Begin DoDot:1
+19 SET Y="S Z=$$HGBA1C^"_X_"(DFN,2900101,DT)"
XECUTE Y
+20 IF Z
SET Z=$PIECE(Z,U,1)
End DoDot:1
+21 IF 'Z
DO FUNO^BDMVRL4
QUIT
+22 SET X=9999999-Z
+23 DO LAB1
+24 QUIT
IMMUN ;EP;TO USE DM TD LOGIC
+1 FOR X="APCLD91B","APCLD81B","APCLD71B","APCLD61B","APCLD51B","APCLD41B","APCLD31B","APCLD313","APCLD216"
XECUTE ^%ZOSF("TEST")
IF $TEST
QUIT
+2 SET Z=""
+3 IF BDMFU="TD"
SET Y="S Z=$$TD^"_X_"(DFN,DT)"
XECUTE Y
+4 IF Z]""
Begin DoDot:1
+5 IF $LENGTH(Z," ")>1
SET Z=$PIECE(Z," ",3,5)
+6 SET X=+$PIECE(Z," ",2)
+7 IF $LENGTH(X)=1
SET X=0_X
+8 SET Y=$PIECE(Z," ",3)-1700
+9 SET Z=$PIECE(Z," ")
+10 SET Z=$SELECT(Z="Jan":"01",Z="Feb":"02",Z="Mar":"03",Z="Apr":"04",Z="May":"05",Z="Jun":"06",Z="Jul":"07",Z="Aug":"08",Z="Sep":"09",Z="Oct":10,Z="Nov":11,Z="Dec":12,1:"")
+11 IF 'Z
SET Z=""
QUIT
+12 SET Z=Y_Z_X
End DoDot:1
+13 IF 'Z
DO FUNO^BDMVRL4
QUIT
+14 SET X=9999999-Z
+15 DO LAB1
+16 QUIT
