- 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
