BDMVRL4 ; IHS/CMI/LAB - VIEW PT RECORD CON'T ;
;;2.0;DIABETES MANAGEMENT SYSTEM;**1,3,5,6,7,8,9,10,11,12**;JUN 14, 2007;Build 51
;LIST OF FOLLOW-UP EXAMS
;MOVED 'FURESULT' TO BDMVRL42 TO CONTROL ROUTINE SIZE
;DMS GUI INTERFACE CODE
;
FU ;EP;TO PRINT FOLLOW-UP NEEDED REPORTS
D REG^BDMFUTIL
Q:$D(BDMQUIT)
F D FUEN Q:$D(BDMQUIT)!$D(BDMOUT)
EXIT ;EP
K BDM,BDMQUIT,BDMTAX,BDMFU,BDMRPDA,BDMOUT,BDMPROV,BDMFUAPP
K L,FR,TO,BY,FLDS ;cmi/anch/maw 8/15/2007 DIP vars that may hand around even though they aren't supposed to patch 1
K ^TMP("BDMVR",$J),^TMP("BDMTMP",$J)
Q
FUEN ;
D REG^BDMFUTIL
Q:$D(BDMQUIT)
D EXIT
S:'$G(VALMWD) VALMWD=80
D CLEAR^VALM1
W !?8,"DIABETES REGISTER - FOLLOW-UP NEEDED REPORTS"
W !?8,"(Patients due now or within the next 30 days.)"
W !
D SCREEN^BDMVRL42
S DIR(0)="FO^1:30"
S DIR("A",1)=" Type 'ALL' to include ALL Follow-up Needed"
S DIR("A")=" Which Report"
W !
D DIR^BDMFDIC
I X=""!$D(BDMQUIT) S BDMQUIT="" Q
;I X=99 D PROTO^BDMVRL42 Q
I $E(Y)?1A D I $D(BDMQUIT) K BDMQUIT Q
.S X=Y
.X ^%ZOSF("UPPERCASE")
.I Y'="ALL" S BDMQUIT="" Q
I Y="ALL" D ALL^BDMVRL42 S BDMY=Y
D PARSE^BDMVRL42
D ST
Q:$D(BDMQUIT)
D ACTIVE
Q:$D(BDMQUIT)
D DX
Q:$D(BDMQUIT)
D APPT^BDMVRL42
Q:$D(BDMQUIT)
D PROVIDER^BDMVRL43
Q:$D(BDMQUIT)
D REPLET
Q:$D(BDMQUIT)
D DEMOCHK^BDMUTL(.BDMDEMO)
I BDMDEMO=-1 Q
D ZIS
Q
ZIS ;DEVICE INTERFACE
S ZTSAVE("BDM*")=""
S (ZTRTN,BDMRTN)="FUPRINT^BDMVRL4"
D ^BDMFZIS
Q
BDMG(BDM) ;EP - Visual DMS Entry Point
;cmi/anch/maw added for GUI DMS
D FUPRINT
K ^XTMP("BDMTAX",BDMJOB,BDMBTH)
Q
;
FUPRINT ;EP;TO DISPLAY THE FOLLOW-UP REPORT
I $E(IOST,1,2)="C-" D
.W !!,"Please stand by. It could take me a while to figure this out."
S BDMJOB=$J,BDMBTH=$H
D BUILDSML^BDMUTL(2019)
D FUGET ;GET ALL DATA AND SET IM ^TMP ARRAY
D FUDISP ;DISPLAY FOLLOW-UP REPORT
Q
FUGET ;EP;GET DATA
S BDMP=0
F S BDMP=$O(BDM("PARSE",BDMP)) Q:'BDMP D FUGET1
Q
FUGET1 S BDMFU=$P(BDM("REPORT",BDMP),U)
S BDMRDA=$O(^ACM(41.1,"B",BDMREGNM,0))
I BDMRDA="" D Q
.S X="NO "_BDMREGNM_" ON FILE"
.D Z(X)
;INDEPENDENT LOOKUP FOR HTN, PAP, MAMM
;I BDMFU="HTN" S BDM("FOLLOW-UP TYPE")="HYPERTENSION"
;E I BDMFU="PAP" S BDM("FOLLOW-UP TYPE")="PAP SMEAR"
;E I BDMFU="MAM" S BDM("FOLLOW-UP TYPE")="MAMMOGRAPHY"
I BDMFU="DENT" S BDM("FOLLOW-UP TYPE")="DENTAL"
E D ;Q:'$D(BDM("IEN"))
.D IEN^BDMVRL41
.;Q:'$D(BDM("IEN"))
K X2
I BDMFU="EKG" S X2=-1795
D FULAST
I $G(BDMRPDA) D FUPAT Q
I $G(BDMIANL) D FUPAT Q
S BDMRPDA=0
F S BDMRPDA=$O(^ACM(41,"B",BDMRDA,BDMRPDA)) Q:'BDMRPDA D
.D FUPAT
.I $E(IOST,1,2)="C-" W "."
Q
FUPAT ;EP;TO GATHER FOLLOW-UP INFO ON A PATIENT
I '$G(BDMIANL) S DFN=$P($G(^ACM(41,BDMRPDA,0)),U,2)
Q:'DFN
;I DUZ=2881 Q:DFN'=1717
;S ^TMP("ALL DFN",$J,DFN)=""
Q:$$DEMO^BDMUTL(DFN,$G(BDMDEMO))
I $G(BDM("DM DIAGNOSIS"))]"" D PATDX I $D(BDMQUIT) K BDMQUIT Q
I $G(BDM("SEARCH TEMPLATE")) Q:'$D(^DIBT(BDM("SEARCH TEMPLATE"),1,DFN))
D PAT(DFN,BDMRPDA)
S BDMRECST=""
I BDMRPDA S BDMRECST=$P($G(^ACM(41,BDMRPDA,"DT")),U,1)
I BDM("STATUS")'="Z" Q:$G(BDMRECST)'=BDM("STATUS")
;I BDMFU="PAP"!(BDMFU="MAM")!(BDMFU="BRST"),$P($G(^DPT(DFN,0)),U,2)'="F" Q
K BDM("HRN")
S BDM=""
I BDMK["PROV" D
.S BDM=$P($G(^AUPNPAT(DFN,0)),U,14)
.I BDM,'$O(BDMK(0)) S BDM=$P($G(^VA(200,BDM,0)),U)
I BDMK["COMM" D
.D RES^BDMVRL5(DFN)
.I '$O(BDMK(0)) S BDM=$P($G(^AUTTCOM(+$G(BDM("RES")),0)),U)
I BDMK["WHER" D
.S BDM=$P($G(^ACM(41,BDMRPDA,"DT")),U,10)
.I BDM,'$O(BDMK(0)) D
..S BDM("HRN")=$P($G(^AUPNPAT(DFN,41,+BDM,0)),U,2)
..K:BDM("HRN")="" BDM("HRN")
..S BDM=$P($G(^DIC(4,BDM,0)),U)
S:BDM="" BDM="NOT LISTED"
K BDMQUIT
I $O(BDMK(0)),BDM]"" D
.I '$D(BDMK(BDM)) S BDMQUIT="" Q
.S BDM=BDMK(BDM)
I $D(BDMQUIT) K BDMQUIT Q
S BDM("COMMUNITY")=$E(BDM,1,15)
S:'$D(BDM("HRN")) BDM("HRN")=$P($G(^AUPNPAT(DFN,41,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0)),U,2)
S:BDM("HRN")="" BDM("HRN")="XXXXXX"
S BDM("PATIENT")=$E($P($G(^DPT(DFN,0)),U),1,25)
;INDEPENDENT LOOKUPS
I BDMFU="HTN" D HTN^BDMVRL41 I 1
E I BDMFU="PAP" D LPAP^BDMVRL41 I 1
E I BDMFU="MAM" D LMAM^BDMVRL41 I 1
E I "^FTEX^EYE^DENT^DEP^EKG^"[(U_BDMFU_U) D APCLEXAM^BDMVRL41 I 1
E I "^NTED^EXER^GENI^"[(U_BDMFU_U) D APCLED^BDMVRL41 I 1
E I BDMFU="FLU" D FLUC^BDMVRL41 I 1
E I BDMFU="PNEU" D PNEUMOC^BDMVRL41 I 1
E I BDMFU="TD" D TDC^BDMVRL41 I 1
E I BDMFU="HEPB" D HEPBC^BDMVRL41 I 1
E I BDMFU="HEPC" D HEPCC^BDMVRL41 I 1
E D FIND I 1
;INDEPENDENT LOOKUPS
K BDMQUIT
Q
FUDISP ;DISPLAY REPORT
I $G(BDMLET)<2!($G(BDMLET)=3) D FUD1
I $G(BDMLET)>1 D FUL1
Q
FUD1 D FUHEAD^BDMVRL42
I $E(IOST,1,2)="C-" D FUVALM Q
S X=0
F S X=$O(^TMP("BDMVR",$J,X)) Q:'X D
.S Y=$G(^TMP("BDMVR",$J,X,0))
.W !,Y
.D PAGE
Q
FUL1 ;PRINT FOLLOW-UP LETTER
K BDMQUIT
S DFN=0
F S DFN=$O(^TMP("BDMTMP",$J,"FUL",DFN)) Q:'DFN!$D(BDMQUIT) D
.S BDMRPDA=$G(^ACM(41,"AC",DFN,BDMRDA))
.Q:'BDMRPDA
.D PAT(DFN,BDMRPDA)
.D PRINT^BDMLET
Q
PAGE ;PAGE CONTROL
Q:IOSL-4>$Y
S:'$G(BDMPAGE) BDMPAGE=1
W @IOF
I $G(BDMGUI),BDMPAGE'=1 W !,"ZZZZZZZ"
W !?8,$S($G(BDMREGNM)]"":BDMREGNM,1:"DIABETES REGISTER")
W !?8,"FOLLOW-UP REPORT: ",BDM("FOLLOW-UP TYPE"),?60,"PAGE: ",BDMPAGE
W !!,"COMMUNITY",?16,"PATIENT",?42,"HRN",?49,"STATUS"
W !,"---------------",?16,"-------------------------",?42,"------",?49,"--------------------"
Q
FUVALM ;USE LIST MANAGER TO DISPLAY REPORT TO SCREEN
S BDMVALM="BDM FOLLOW-UP REPORT"
D VALM^BDMVRL(BDMVALM)
Q
FIND ;FIND PATIENTS WITHOUT SPECIFIED ITEM
N X,Y
S X=BDMFU
I BDMFU="CHOL"!(BDMFU="LDL")!(BDMFU="HDL")!(BDMFU="TRIG")!(BDMFU="CREA")!(BDMFU="HGB")!(BDMFU="LIVR")!(BDMFU="UPRO")!(BDMFU="URIN")!(BDMFU="GFR")!(BDMFU="UACR")!(BDMFU="HEPC") D LAB^BDMVRL43 Q
I BDMFU="TD" D IMMUN^BDMVRL43 Q
;USE V EXAM FOR DENTAL INSTEAD OF V DENTAL
I X="DENT" D DENT
I X="EKG" S Y="^AUPNVDPR("
I "^FTEX^RECT^BRST^EYE^DENT^DEP^"[(U_X_U) S Y="^AUPNVXAM"
I X="MAM" S Y="^AUPNVRAD"
I X="FLU"!(X="PNEU")!(X="TD") S Y="^AUPNVIMM"
I X="PPD" S Y="^AUPNVSK"
I X="NTED"!(X="COMP")!(X="EXER")!(X="GENI") S Y="^AUPNVPED"
I X=(X="DIET")!(X="DISE")!(X="FUP")!(X="FTED")!(X="LIFE")!(X="MEDS") S Y="^AUPNVPED"
I X="HGB"!(X="LIVR")!(X="UPRO")!(X="URIN")!(X="CHOL")!(X="LDL")!(X="HDL")!(X="MICR")!(X="CREA")!(X="TRIG")!(X="PAP")!(X="UPT") S Y="^AUPNVLAB"
F1 S BDMGBL=Y
I X="LIVR" D Q:'$D(BDMQUIT)
.D LMEDS
.;IF PATIENT NOT TAKING TARGET MEDS THEY DON'T NEED TO BE ON F/U LIST
K BDMQUIT
I BDMFU="CHOL"!(BDMFU="LDL")!(BDMFU="HDL")!(BDMFU="TRIG")!(BDMFU="CREA")!(BDMFU="HGB")!(BDMFU="LIVR")!(BDMFU="UPRO")!(BDMFU="URIN")!(BDMFU="UPT")!(BDMFU="GFR") D LAB^BDMVRL43 Q
D FURESULT^BDMVRL42
I $D(BDMQUIT) K BDMQUIT Q
D ENTRY
Q
LMEDS D LMEDS^BDMVRL2
Q
FUNO ;EP Followup Entry
S X="*NO* "_BDM("FOLLOW-UP TYPE")_" on record."
FUOUT ;EP;
I $G(BDMIANL) G FUOUT1
S ^TMP("BDMTMP",$J,BDM("COMMUNITY"),BDM("PATIENT"),BDMP,BDM("FOLLOW-UP TYPE"))=X_U_BDM("HRN")
S ^TMP("BDMTMP",$J,BDM("COMMUNITY"),BDM("PATIENT"))=DFN
Q:$G(BDMLET)<2
FUOUT1 S ^TMP("BDMTMP",$J,"FUL",DFN,BDMP,BDM("FOLLOW-UP TYPE"))=X
Q
FULAST ;EP;
S X1=DT
S:'$G(X2) X2=-330
D C^%DTC
S BDM("SHOULD HAVE FOLLOW-UP AFTER")=X
K X1,X2
Q
LSTVST(X) ;EP;LAST VISIT
N Y
S Y=9999999-X
I Y>BDM("SHOULD HAVE FOLLOW-UP AFTER") S X=""
E D
.X ^DD("DD")
.S X="last "_BDM("FOLLOW-UP TYPE")_" "_Y
Q X
ENTRY ;EP;FOR INDEPENDENT CALLS
I $G(Z)="" D FUNO Q
S Z=$$LSTVST(Z)
EDONE ;EP;FOLLOW-UP DONE
I Z="" D Q
.K ^TMP("BDMTMP",$J,BDM("COMMUNITY"),BDM("PATIENT"),BDMP,BDM("FOLLOW-UP TYPE"))
.S BDMQUIT=""
I BDMFU="PPD",$D(BDM("PPD")) D
.I $P(BDM("PPD"),U)]"" S Z=Z_" ("_$S($E(BDM("PPD"))="N":"NEG",$E(BDM("PPD"))="P":"POS",1:"")
.I $P(BDM("PPD"),U,2) S Z=Z_$S($P(BDM("PPD"),U)="":" (",1:"-")_$P(BDM("PPD"),U,2)_" MM)"
.E S:$P(BDM("PPD"),U)]""!$P(BDM("PPD"),U,2) Z=Z_")"
.K BDM("PPD")
S X=Z
D FUOUT
Q
ACTIVE ;EP;TO SELECT PATIENT STATUS
W !!,"Select the Patient Status for this report"
S DIR(0)="SO^A:Active;I:Inactive;T:Transient;U:Unreviewed;D:Deceased;N:Non-IHS;NON:Noncompliant;Z:All Register Patients"
S DIR("A")="Which patients"
S DIR("B")="Active"
D DIR^BDMFDIC
I Y]"","AITUDNONZ"[Y S BDM("STATUS")=Y Q
E S BDMQUIT=""
Q
REPLET ;PRINT REPORT OR LETTER
S DIR(0)="SO^1:Follow-up Report;2:Follow-up Letter;3:Both"
S DIR("A")="Which one"
S DIR("B")="Follow-up Report"
D DIR^BDMFDIC
I Y<1 S BDMQUIT="" Q
S BDMLET=+Y
Q:+Y=1
D SELECT^BDMLET
I '$G(BDMLDA) S BDMQUIT="" Q
Q
Z(X) ;SET TMP NODE
S VALMCNT=VALMCNT+1
S ^TMP("BDMVR",$J,VALMCNT,0)=X
Q
PAT(DFN,ACMRPDA) ;EP;TO CHECK PATIENT DOD STATUS
Q:'ACMRPDA
Q:'$G(^DPT(+DFN,.35))
S DA=ACMRPDA
S DIE="^ACM(41,"
S DR="1////D"
D DIE^BDMFDIC
Q
ST ;SELECT SEARCH TEMPLATE OR ENTIRE REGISTER
S DIR(0)="SO^1:Use Register Members;2:Use A Search Template"
S DIR("A")="Which Group"
S DIR("B")="Use Register Members"
D DIR^BDMFDIC
Q:Y<2
S DIC="^DIBT("
S DIC(0)="AEMQZ"
S DIC("A")="Which Search Template: "
S DIC("S")="I $D(^DIBT(+Y,1)),$P(^DIBT(+Y,0),U,4)=2!($P(^DIBT(+Y,0),U,4)=9000001)"
D DIC^BDMFDIC
I +Y>0 S BDM("SEARCH TEMPLATE")=+Y
E K BDM("SEARCH TEMPLATE")
Q
DX ;EP;TO SELECT DIABETES DIAGNOSIS
D DX^BDMVRL2
Q
PATDX ;INCLUDE PATIENTS WITH SPECIFIC DIAGNOSIS
D PATDX^BDMVRL2
Q
DENT K BDM("IEN")
S Y="^AUPNVDEN"
F X=9320,9321 I $O(^AUTTADA("B",X,0)) S BDM("IEN",$O(^(0)))=""
I '$D(BDM("IEN")) D D1 Q
D F1
D1 D DENT^BDMVRL41
Q
;
BDMGA(BDMRET,BDM,BDMFUAPP,BDMFL,BDMK,BDMRL,BDMFU,BDMLDA,BDMREG,BDMGUI,BDMDEMO) ;PEP - gui call
S BDMJ=$J
S BDMH=$H
F X="BDMJOB","BDMH","BDM","BDMRS","BDMFUAP","BDMBEG","BDGEND","BDMPBYV","BDMFL","BDMK","BDMRL","BDMFU","BDMLP","BDMLDA","BDMREG" S @X=$G(@X)
I $G(BDMJ)="" S BDMRET=-1 Q
I $G(BDMH)="" S BDMRET=-1 Q
;create entry in fileman file to hold output
N BDMOPT ;maw
S BDMOPT="Follow-Up Needed"
D NOW^%DTC
S BDMNOW=$G(%)
K DD,D0,DIC
S X=DUZ_"."_BDMH
S DIC("DR")=".02////"_DUZ_";.03////"_BDMNOW_";.05///1;.06///"_$G(BDMOPT)_";.07///R"
S DIC="^BDMGUI(",DIC(0)="L",DIADD=1,DLAYGO=9003002.4
D FILE^DICN
K DIADD,DLAYGO,DIC,DA
I Y=-1 S BDMRET=-1 Q
S BDMIEN=+Y
S BDMRET=BDMIEN
D ^XBFMK
K ZTSAVE S ZTSAVE("*")=""
;D GUIEP ;for interactive testing
S ZTIO="",ZTDTH=$$NOW^XLFDT,ZTRTN="GUIEP^BDMVRL4",ZTDESC="GUI DM FOLLOW UP REPORT" D ^%ZTLOAD
D XIT
Q
GUIEP ;EP - called from taskman
;D ^FUPRINT
K ^TMP($J,"BDMFUR")
S IOM=80 ;cmi/maw added
S IOSL=55
S IOST="P"
D GUIR^XBLM("BDMG^BDMVRL4(.BDM)","^TMP($J,""BDMFUR"",")
;Q:$G(BDMDSP) ;quit if to screen
S X=0,C=0 F S X=$O(^TMP($J,"BDMFUR",X)) Q:'X D
. N BDMGDATA
. S BDMGDATA=^TMP($J,"BDMFUR",X)
. ;I BDMGDATA="ZZZZZZZ" S BDMGDATA=$C(12)
. S ^BDMGUI(BDMIEN,11,X,0)=BDMGDATA
. S C=C+1
S ^BDMGUI(BDMIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
S DA=BDMIEN,DIK="^BDMGUI(" D IX1^DIK
D ENDLOG
S ZTREQ="@"
Q
;
ENDLOG ;-- write the end of the log
D NOW^%DTC
S BDMNOW=$G(%)
S DIE="^BDMGUI(",DA=BDMIEN,DR=".04////"_BDMNOW_";.07///C"
D ^DIE
K DIE,DR,DA
Q
;
XIT ;-- remove variables and quit
D EN^XBVK("AUPN")
D ^XBFMK,KILL^AUPNPAT
K ^TMP($J,"PATS")
Q
;
BDMVRL4 ; IHS/CMI/LAB - VIEW PT RECORD CON'T ;
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**1,3,5,6,7,8,9,10,11,12**;JUN 14, 2007;Build 51
+2 ;LIST OF FOLLOW-UP EXAMS
+3 ;MOVED 'FURESULT' TO BDMVRL42 TO CONTROL ROUTINE SIZE
+4 ;DMS GUI INTERFACE CODE
+5 ;
FU ;EP;TO PRINT FOLLOW-UP NEEDED REPORTS
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 FOR
DO FUEN
IF $DATA(BDMQUIT)!$DATA(BDMOUT)
QUIT
EXIT ;EP
+1 KILL BDM,BDMQUIT,BDMTAX,BDMFU,BDMRPDA,BDMOUT,BDMPROV,BDMFUAPP
+2 ;cmi/anch/maw 8/15/2007 DIP vars that may hand around even though they aren't supposed to patch 1
KILL L,FR,TO,BY,FLDS
+3 KILL ^TMP("BDMVR",$JOB),^TMP("BDMTMP",$JOB)
+4 QUIT
FUEN ;
+1 DO REG^BDMFUTIL
+2 IF $DATA(BDMQUIT)
QUIT
+3 DO EXIT
+4 IF '$GET(VALMWD)
SET VALMWD=80
+5 DO CLEAR^VALM1
+6 WRITE !?8,"DIABETES REGISTER - FOLLOW-UP NEEDED REPORTS"
+7 WRITE !?8,"(Patients due now or within the next 30 days.)"
+8 WRITE !
+9 DO SCREEN^BDMVRL42
+10 SET DIR(0)="FO^1:30"
+11 SET DIR("A",1)=" Type 'ALL' to include ALL Follow-up Needed"
+12 SET DIR("A")=" Which Report"
+13 WRITE !
+14 DO DIR^BDMFDIC
+15 IF X=""!$DATA(BDMQUIT)
SET BDMQUIT=""
QUIT
+16 ;I X=99 D PROTO^BDMVRL42 Q
+17 IF $EXTRACT(Y)?1A
Begin DoDot:1
+18 SET X=Y
+19 XECUTE ^%ZOSF("UPPERCASE")
+20 IF Y'="ALL"
SET BDMQUIT=""
QUIT
End DoDot:1
IF $DATA(BDMQUIT)
KILL BDMQUIT
QUIT
+21 IF Y="ALL"
DO ALL^BDMVRL42
SET BDMY=Y
+22 DO PARSE^BDMVRL42
+23 DO ST
+24 IF $DATA(BDMQUIT)
QUIT
+25 DO ACTIVE
+26 IF $DATA(BDMQUIT)
QUIT
+27 DO DX
+28 IF $DATA(BDMQUIT)
QUIT
+29 DO APPT^BDMVRL42
+30 IF $DATA(BDMQUIT)
QUIT
+31 DO PROVIDER^BDMVRL43
+32 IF $DATA(BDMQUIT)
QUIT
+33 DO REPLET
+34 IF $DATA(BDMQUIT)
QUIT
+35 DO DEMOCHK^BDMUTL(.BDMDEMO)
+36 IF BDMDEMO=-1
QUIT
+37 DO ZIS
+38 QUIT
ZIS ;DEVICE INTERFACE
+1 SET ZTSAVE("BDM*")=""
+2 SET (ZTRTN,BDMRTN)="FUPRINT^BDMVRL4"
+3 DO ^BDMFZIS
+4 QUIT
BDMG(BDM) ;EP - Visual DMS Entry Point
+1 ;cmi/anch/maw added for GUI DMS
+2 DO FUPRINT
+3 KILL ^XTMP("BDMTAX",BDMJOB,BDMBTH)
+4 QUIT
+5 ;
FUPRINT ;EP;TO DISPLAY THE FOLLOW-UP REPORT
+1 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+2 WRITE !!,"Please stand by. It could take me a while to figure this out."
End DoDot:1
+3 SET BDMJOB=$JOB
SET BDMBTH=$HOROLOG
+4 DO BUILDSML^BDMUTL(2019)
+5 ;GET ALL DATA AND SET IM ^TMP ARRAY
DO FUGET
+6 ;DISPLAY FOLLOW-UP REPORT
DO FUDISP
+7 QUIT
FUGET ;EP;GET DATA
+1 SET BDMP=0
+2 FOR
SET BDMP=$ORDER(BDM("PARSE",BDMP))
IF 'BDMP
QUIT
DO FUGET1
+3 QUIT
FUGET1 SET BDMFU=$PIECE(BDM("REPORT",BDMP),U)
+1 SET BDMRDA=$ORDER(^ACM(41.1,"B",BDMREGNM,0))
+2 IF BDMRDA=""
Begin DoDot:1
+3 SET X="NO "_BDMREGNM_" ON FILE"
+4 DO Z(X)
End DoDot:1
QUIT
+5 ;INDEPENDENT LOOKUP FOR HTN, PAP, MAMM
+6 ;I BDMFU="HTN" S BDM("FOLLOW-UP TYPE")="HYPERTENSION"
+7 ;E I BDMFU="PAP" S BDM("FOLLOW-UP TYPE")="PAP SMEAR"
+8 ;E I BDMFU="MAM" S BDM("FOLLOW-UP TYPE")="MAMMOGRAPHY"
+9 IF BDMFU="DENT"
SET BDM("FOLLOW-UP TYPE")="DENTAL"
+10 ;Q:'$D(BDM("IEN"))
IF '$TEST
Begin DoDot:1
+11 DO IEN^BDMVRL41
+12 ;Q:'$D(BDM("IEN"))
End DoDot:1
+13 KILL X2
+14 IF BDMFU="EKG"
SET X2=-1795
+15 DO FULAST
+16 IF $GET(BDMRPDA)
DO FUPAT
QUIT
+17 IF $GET(BDMIANL)
DO FUPAT
QUIT
+18 SET BDMRPDA=0
+19 FOR
SET BDMRPDA=$ORDER(^ACM(41,"B",BDMRDA,BDMRPDA))
IF 'BDMRPDA
QUIT
Begin DoDot:1
+20 DO FUPAT
+21 IF $EXTRACT(IOST,1,2)="C-"
WRITE "."
End DoDot:1
+22 QUIT
FUPAT ;EP;TO GATHER FOLLOW-UP INFO ON A PATIENT
+1 IF '$GET(BDMIANL)
SET DFN=$PIECE($GET(^ACM(41,BDMRPDA,0)),U,2)
+2 IF 'DFN
QUIT
+3 ;I DUZ=2881 Q:DFN'=1717
+4 ;S ^TMP("ALL DFN",$J,DFN)=""
+5 IF $$DEMO^BDMUTL(DFN,$GET(BDMDEMO))
QUIT
+6 IF $GET(BDM("DM DIAGNOSIS"))]""
DO PATDX
IF $DATA(BDMQUIT)
KILL BDMQUIT
QUIT
+7 IF $GET(BDM("SEARCH TEMPLATE"))
IF '$DATA(^DIBT(BDM("SEARCH TEMPLATE"),1,DFN))
QUIT
+8 DO PAT(DFN,BDMRPDA)
+9 SET BDMRECST=""
+10 IF BDMRPDA
SET BDMRECST=$PIECE($GET(^ACM(41,BDMRPDA,"DT")),U,1)
+11 IF BDM("STATUS")'="Z"
IF $GET(BDMRECST)'=BDM("STATUS")
QUIT
+12 ;I BDMFU="PAP"!(BDMFU="MAM")!(BDMFU="BRST"),$P($G(^DPT(DFN,0)),U,2)'="F" Q
+13 KILL BDM("HRN")
+14 SET BDM=""
+15 IF BDMK["PROV"
Begin DoDot:1
+16 SET BDM=$PIECE($GET(^AUPNPAT(DFN,0)),U,14)
+17 IF BDM
IF '$ORDER(BDMK(0))
SET BDM=$PIECE($GET(^VA(200,BDM,0)),U)
End DoDot:1
+18 IF BDMK["COMM"
Begin DoDot:1
+19 DO RES^BDMVRL5(DFN)
+20 IF '$ORDER(BDMK(0))
SET BDM=$PIECE($GET(^AUTTCOM(+$GET(BDM("RES")),0)),U)
End DoDot:1
+21 IF BDMK["WHER"
Begin DoDot:1
+22 SET BDM=$PIECE($GET(^ACM(41,BDMRPDA,"DT")),U,10)
+23 IF BDM
IF '$ORDER(BDMK(0))
Begin DoDot:2
+24 SET BDM("HRN")=$PIECE($GET(^AUPNPAT(DFN,41,+BDM,0)),U,2)
+25 IF BDM("HRN")=""
KILL BDM("HRN")
+26 SET BDM=$PIECE($GET(^DIC(4,BDM,0)),U)
End DoDot:2
End DoDot:1
+27 IF BDM=""
SET BDM="NOT LISTED"
+28 KILL BDMQUIT
+29 IF $ORDER(BDMK(0))
IF BDM]""
Begin DoDot:1
+30 IF '$DATA(BDMK(BDM))
SET BDMQUIT=""
QUIT
+31 SET BDM=BDMK(BDM)
End DoDot:1
+32 IF $DATA(BDMQUIT)
KILL BDMQUIT
QUIT
+33 SET BDM("COMMUNITY")=$EXTRACT(BDM,1,15)
+34 IF '$DATA(BDM("HRN"))
SET BDM("HRN")=$PIECE($GET(^AUPNPAT(DFN,41,$SELECT($GET(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0)),U,2)
+35 IF BDM("HRN")=""
SET BDM("HRN")="XXXXXX"
+36 SET BDM("PATIENT")=$EXTRACT($PIECE($GET(^DPT(DFN,0)),U),1,25)
+37 ;INDEPENDENT LOOKUPS
+38 IF BDMFU="HTN"
DO HTN^BDMVRL41
IF 1
+39 IF '$TEST
IF BDMFU="PAP"
DO LPAP^BDMVRL41
IF 1
+40 IF '$TEST
IF BDMFU="MAM"
DO LMAM^BDMVRL41
IF 1
+41 IF '$TEST
IF "^FTEX^EYE^DENT^DEP^EKG^"[(U_BDMFU_U)
DO APCLEXAM^BDMVRL41
IF 1
+42 IF '$TEST
IF "^NTED^EXER^GENI^"[(U_BDMFU_U)
DO APCLED^BDMVRL41
IF 1
+43 IF '$TEST
IF BDMFU="FLU"
DO FLUC^BDMVRL41
IF 1
+44 IF '$TEST
IF BDMFU="PNEU"
DO PNEUMOC^BDMVRL41
IF 1
+45 IF '$TEST
IF BDMFU="TD"
DO TDC^BDMVRL41
IF 1
+46 IF '$TEST
IF BDMFU="HEPB"
DO HEPBC^BDMVRL41
IF 1
+47 IF '$TEST
IF BDMFU="HEPC"
DO HEPCC^BDMVRL41
IF 1
+48 IF '$TEST
DO FIND
IF 1
+49 ;INDEPENDENT LOOKUPS
+50 KILL BDMQUIT
+51 QUIT
FUDISP ;DISPLAY REPORT
+1 IF $GET(BDMLET)<2!($GET(BDMLET)=3)
DO FUD1
+2 IF $GET(BDMLET)>1
DO FUL1
+3 QUIT
FUD1 DO FUHEAD^BDMVRL42
+1 IF $EXTRACT(IOST,1,2)="C-"
DO FUVALM
QUIT
+2 SET X=0
+3 FOR
SET X=$ORDER(^TMP("BDMVR",$JOB,X))
IF 'X
QUIT
Begin DoDot:1
+4 SET Y=$GET(^TMP("BDMVR",$JOB,X,0))
+5 WRITE !,Y
+6 DO PAGE
End DoDot:1
+7 QUIT
FUL1 ;PRINT FOLLOW-UP LETTER
+1 KILL BDMQUIT
+2 SET DFN=0
+3 FOR
SET DFN=$ORDER(^TMP("BDMTMP",$JOB,"FUL",DFN))
IF 'DFN!$DATA(BDMQUIT)
QUIT
Begin DoDot:1
+4 SET BDMRPDA=$GET(^ACM(41,"AC",DFN,BDMRDA))
+5 IF 'BDMRPDA
QUIT
+6 DO PAT(DFN,BDMRPDA)
+7 DO PRINT^BDMLET
End DoDot:1
+8 QUIT
PAGE ;PAGE CONTROL
+1 IF IOSL-4>$Y
QUIT
+2 IF '$GET(BDMPAGE)
SET BDMPAGE=1
+3 WRITE @IOF
+4 IF $GET(BDMGUI)
IF BDMPAGE'=1
WRITE !,"ZZZZZZZ"
+5 WRITE !?8,$SELECT($GET(BDMREGNM)]"":BDMREGNM,1:"DIABETES REGISTER")
+6 WRITE !?8,"FOLLOW-UP REPORT: ",BDM("FOLLOW-UP TYPE"),?60,"PAGE: ",BDMPAGE
+7 WRITE !!,"COMMUNITY",?16,"PATIENT",?42,"HRN",?49,"STATUS"
+8 WRITE !,"---------------",?16,"-------------------------",?42,"------",?49,"--------------------"
+9 QUIT
FUVALM ;USE LIST MANAGER TO DISPLAY REPORT TO SCREEN
+1 SET BDMVALM="BDM FOLLOW-UP REPORT"
+2 DO VALM^BDMVRL(BDMVALM)
+3 QUIT
FIND ;FIND PATIENTS WITHOUT SPECIFIED ITEM
+1 NEW X,Y
+2 SET X=BDMFU
+3 IF BDMFU="CHOL"!(BDMFU="LDL")!(BDMFU="HDL")!(BDMFU="TRIG")!(BDMFU="CREA")!(BDMFU="HGB")!(BDMFU="LIVR")!(BDMFU="UPRO")!(BDMFU="URIN")!(BDMFU="GFR")!(BDMFU="UACR")!(BDMFU="HEPC")
DO LAB^BDMVRL43
QUIT
+4 IF BDMFU="TD"
DO IMMUN^BDMVRL43
QUIT
+5 ;USE V EXAM FOR DENTAL INSTEAD OF V DENTAL
+6 IF X="DENT"
DO DENT
+7 IF X="EKG"
SET Y="^AUPNVDPR("
+8 IF "^FTEX^RECT^BRST^EYE^DENT^DEP^"[(U_X_U)
SET Y="^AUPNVXAM"
+9 IF X="MAM"
SET Y="^AUPNVRAD"
+10 IF X="FLU"!(X="PNEU")!(X="TD")
SET Y="^AUPNVIMM"
+11 IF X="PPD"
SET Y="^AUPNVSK"
+12 IF X="NTED"!(X="COMP")!(X="EXER")!(X="GENI")
SET Y="^AUPNVPED"
+13 IF X=(X="DIET")!(X="DISE")!(X="FUP")!(X="FTED")!(X="LIFE")!(X="MEDS")
SET Y="^AUPNVPED"
+14 IF X="HGB"!(X="LIVR")!(X="UPRO")!(X="URIN")!(X="CHOL")!(X="LDL")!(X="HDL")!(X="MICR")!(X="CREA")!(X="TRIG")!(X="PAP")!(X="UPT")
SET Y="^AUPNVLAB"
F1 SET BDMGBL=Y
+1 IF X="LIVR"
Begin DoDot:1
+2 DO LMEDS
+3 ;IF PATIENT NOT TAKING TARGET MEDS THEY DON'T NEED TO BE ON F/U LIST
End DoDot:1
IF '$DATA(BDMQUIT)
QUIT
+4 KILL BDMQUIT
+5 IF BDMFU="CHOL"!(BDMFU="LDL")!(BDMFU="HDL")!(BDMFU="TRIG")!(BDMFU="CREA")!(BDMFU="HGB")!(BDMFU="LIVR")!(BDMFU="UPRO")!(BDMFU="URIN")!(BDMFU="UPT")!(BDMFU="GFR")
DO LAB^BDMVRL43
QUIT
+6 DO FURESULT^BDMVRL42
+7 IF $DATA(BDMQUIT)
KILL BDMQUIT
QUIT
+8 DO ENTRY
+9 QUIT
LMEDS DO LMEDS^BDMVRL2
+1 QUIT
FUNO ;EP Followup Entry
+1 SET X="*NO* "_BDM("FOLLOW-UP TYPE")_" on record."
FUOUT ;EP;
+1 IF $GET(BDMIANL)
GOTO FUOUT1
+2 SET ^TMP("BDMTMP",$JOB,BDM("COMMUNITY"),BDM("PATIENT"),BDMP,BDM("FOLLOW-UP TYPE"))=X_U_BDM("HRN")
+3 SET ^TMP("BDMTMP",$JOB,BDM("COMMUNITY"),BDM("PATIENT"))=DFN
+4 IF $GET(BDMLET)<2
QUIT
FUOUT1 SET ^TMP("BDMTMP",$JOB,"FUL",DFN,BDMP,BDM("FOLLOW-UP TYPE"))=X
+1 QUIT
FULAST ;EP;
+1 SET X1=DT
+2 IF '$GET(X2)
SET X2=-330
+3 DO C^%DTC
+4 SET BDM("SHOULD HAVE FOLLOW-UP AFTER")=X
+5 KILL X1,X2
+6 QUIT
LSTVST(X) ;EP;LAST VISIT
+1 NEW Y
+2 SET Y=9999999-X
+3 IF Y>BDM("SHOULD HAVE FOLLOW-UP AFTER")
SET X=""
+4 IF '$TEST
Begin DoDot:1
+5 XECUTE ^DD("DD")
+6 SET X="last "_BDM("FOLLOW-UP TYPE")_" "_Y
End DoDot:1
+7 QUIT X
ENTRY ;EP;FOR INDEPENDENT CALLS
+1 IF $GET(Z)=""
DO FUNO
QUIT
+2 SET Z=$$LSTVST(Z)
EDONE ;EP;FOLLOW-UP DONE
+1 IF Z=""
Begin DoDot:1
+2 KILL ^TMP("BDMTMP",$JOB,BDM("COMMUNITY"),BDM("PATIENT"),BDMP,BDM("FOLLOW-UP TYPE"))
+3 SET BDMQUIT=""
End DoDot:1
QUIT
+4 IF BDMFU="PPD"
IF $DATA(BDM("PPD"))
Begin DoDot:1
+5 IF $PIECE(BDM("PPD"),U)]""
SET Z=Z_" ("_$SELECT($EXTRACT(BDM("PPD"))="N":"NEG",$EXTRACT(BDM("PPD"))="P":"POS",1:"")
+6 IF $PIECE(BDM("PPD"),U,2)
SET Z=Z_$SELECT($PIECE(BDM("PPD"),U)="":" (",1:"-")_$PIECE(BDM("PPD"),U,2)_" MM)"
+7 IF '$TEST
IF $PIECE(BDM("PPD"),U)]""!$PIECE(BDM("PPD"),U,2)
SET Z=Z_")"
+8 KILL BDM("PPD")
End DoDot:1
+9 SET X=Z
+10 DO FUOUT
+11 QUIT
ACTIVE ;EP;TO SELECT PATIENT STATUS
+1 WRITE !!,"Select the Patient Status for this report"
+2 SET DIR(0)="SO^A:Active;I:Inactive;T:Transient;U:Unreviewed;D:Deceased;N:Non-IHS;NON:Noncompliant;Z:All Register Patients"
+3 SET DIR("A")="Which patients"
+4 SET DIR("B")="Active"
+5 DO DIR^BDMFDIC
+6 IF Y]""
IF "AITUDNONZ"[Y
SET BDM("STATUS")=Y
QUIT
+7 IF '$TEST
SET BDMQUIT=""
+8 QUIT
REPLET ;PRINT REPORT OR LETTER
+1 SET DIR(0)="SO^1:Follow-up Report;2:Follow-up Letter;3:Both"
+2 SET DIR("A")="Which one"
+3 SET DIR("B")="Follow-up Report"
+4 DO DIR^BDMFDIC
+5 IF Y<1
SET BDMQUIT=""
QUIT
+6 SET BDMLET=+Y
+7 IF +Y=1
QUIT
+8 DO SELECT^BDMLET
+9 IF '$GET(BDMLDA)
SET BDMQUIT=""
QUIT
+10 QUIT
Z(X) ;SET TMP NODE
+1 SET VALMCNT=VALMCNT+1
+2 SET ^TMP("BDMVR",$JOB,VALMCNT,0)=X
+3 QUIT
PAT(DFN,ACMRPDA) ;EP;TO CHECK PATIENT DOD STATUS
+1 IF 'ACMRPDA
QUIT
+2 IF '$GET(^DPT(+DFN,.35))
QUIT
+3 SET DA=ACMRPDA
+4 SET DIE="^ACM(41,"
+5 SET DR="1////D"
+6 DO DIE^BDMFDIC
+7 QUIT
ST ;SELECT SEARCH TEMPLATE OR ENTIRE REGISTER
+1 SET DIR(0)="SO^1:Use Register Members;2:Use A Search Template"
+2 SET DIR("A")="Which Group"
+3 SET DIR("B")="Use Register Members"
+4 DO DIR^BDMFDIC
+5 IF Y<2
QUIT
+6 SET DIC="^DIBT("
+7 SET DIC(0)="AEMQZ"
+8 SET DIC("A")="Which Search Template: "
+9 SET DIC("S")="I $D(^DIBT(+Y,1)),$P(^DIBT(+Y,0),U,4)=2!($P(^DIBT(+Y,0),U,4)=9000001)"
+10 DO DIC^BDMFDIC
+11 IF +Y>0
SET BDM("SEARCH TEMPLATE")=+Y
+12 IF '$TEST
KILL BDM("SEARCH TEMPLATE")
+13 QUIT
DX ;EP;TO SELECT DIABETES DIAGNOSIS
+1 DO DX^BDMVRL2
+2 QUIT
PATDX ;INCLUDE PATIENTS WITH SPECIFIC DIAGNOSIS
+1 DO PATDX^BDMVRL2
+2 QUIT
DENT KILL BDM("IEN")
+1 SET Y="^AUPNVDEN"
+2 FOR X=9320,9321
IF $ORDER(^AUTTADA("B",X,0))
SET BDM("IEN",$ORDER(^(0)))=""
+3 IF '$DATA(BDM("IEN"))
DO D1
QUIT
+4 DO F1
D1 DO DENT^BDMVRL41
+1 QUIT
+2 ;
BDMGA(BDMRET,BDM,BDMFUAPP,BDMFL,BDMK,BDMRL,BDMFU,BDMLDA,BDMREG,BDMGUI,BDMDEMO) ;PEP - gui call
+1 SET BDMJ=$JOB
+2 SET BDMH=$HOROLOG
+3 FOR X="BDMJOB","BDMH","BDM","BDMRS","BDMFUAP","BDMBEG","BDGEND","BDMPBYV","BDMFL","BDMK","BDMRL","BDMFU","BDMLP","BDMLDA","BDMREG"
SET @X=$GET(@X)
+4 IF $GET(BDMJ)=""
SET BDMRET=-1
QUIT
+5 IF $GET(BDMH)=""
SET BDMRET=-1
QUIT
+6 ;create entry in fileman file to hold output
+7 ;maw
NEW BDMOPT
+8 SET BDMOPT="Follow-Up Needed"
+9 DO NOW^%DTC
+10 SET BDMNOW=$GET(%)
+11 KILL DD,D0,DIC
+12 SET X=DUZ_"."_BDMH
+13 SET DIC("DR")=".02////"_DUZ_";.03////"_BDMNOW_";.05///1;.06///"_$GET(BDMOPT)_";.07///R"
+14 SET DIC="^BDMGUI("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9003002.4
+15 DO FILE^DICN
+16 KILL DIADD,DLAYGO,DIC,DA
+17 IF Y=-1
SET BDMRET=-1
QUIT
+18 SET BDMIEN=+Y
+19 SET BDMRET=BDMIEN
+20 DO ^XBFMK
+21 KILL ZTSAVE
SET ZTSAVE("*")=""
+22 ;D GUIEP ;for interactive testing
+23 SET ZTIO=""
SET ZTDTH=$$NOW^XLFDT
SET ZTRTN="GUIEP^BDMVRL4"
SET ZTDESC="GUI DM FOLLOW UP REPORT"
DO ^%ZTLOAD
+24 DO XIT
+25 QUIT
GUIEP ;EP - called from taskman
+1 ;D ^FUPRINT
+2 KILL ^TMP($JOB,"BDMFUR")
+3 ;cmi/maw added
SET IOM=80
+4 SET IOSL=55
+5 SET IOST="P"
+6 DO GUIR^XBLM("BDMG^BDMVRL4(.BDM)","^TMP($J,""BDMFUR"",")
+7 ;Q:$G(BDMDSP) ;quit if to screen
+8 SET X=0
SET C=0
FOR
SET X=$ORDER(^TMP($JOB,"BDMFUR",X))
IF 'X
QUIT
Begin DoDot:1
+9 NEW BDMGDATA
+10 SET BDMGDATA=^TMP($JOB,"BDMFUR",X)
+11 ;I BDMGDATA="ZZZZZZZ" S BDMGDATA=$C(12)
+12 SET ^BDMGUI(BDMIEN,11,X,0)=BDMGDATA
+13 SET C=C+1
End DoDot:1
+14 SET ^BDMGUI(BDMIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
+15 SET DA=BDMIEN
SET DIK="^BDMGUI("
DO IX1^DIK
+16 DO ENDLOG
+17 SET ZTREQ="@"
+18 QUIT
+19 ;
ENDLOG ;-- write the end of the log
+1 DO NOW^%DTC
+2 SET BDMNOW=$GET(%)
+3 SET DIE="^BDMGUI("
SET DA=BDMIEN
SET DR=".04////"_BDMNOW_";.07///C"
+4 DO ^DIE
+5 KILL DIE,DR,DA
+6 QUIT
+7 ;
XIT ;-- remove variables and quit
+1 DO EN^XBVK("AUPN")
+2 DO ^XBFMK
DO KILL^AUPNPAT
+3 KILL ^TMP($JOB,"PATS")
+4 QUIT
+5 ;
