BDMRML ; IHS/CMI/LAB - patients w/o dm on problem list ; 28 Nov 2017 1:25 PM
;;2.0;DIABETES MANAGEMENT SYSTEM;**9,10,11**;JUN 14, 2007;Build 30
;
;
START ;
D INFORM
GETINFO ;
K BDMSTAT
R ;
S BDMREG=""
S DIC="^ACM(41.1,",DIC(0)="AEMQ",DIC("A")="Enter the Name of the Register: " D ^DIC
I Y=-1 W !,"No register selected." S BDMQUIT="" D EXIT Q
S BDMREG=+Y
RS ;get status
K BDMSTAT
S DIR(0)="Y",DIR("A")="Do you want to select register patients with a particular status",DIR("B")="Y" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G R
I Y=0 K BDMSTAT G AGE
R1 ;which status
S DIR(0)="9002241,1O",DIR("A")="Select "_$S($D(BDMSTAT):"another ",1:"")_"status" S:'$D(BDMSTAT) DIR("B")="A" KILL DA D ^DIR KILL DIR
I Y="",'$D(BDMSTAT) G RS
I $D(DIRUT),'$D(BDMSTAT) G RS
I $D(DIRUT) G AGE
I Y="" G AGE
S BDMSTAT(Y)=""
G R1
AGE ;Age Screening
K BDMAGE,BDMAGET
W ! S DIR(0)="YO",DIR("A")="Would you like to restrict the master list by Patient age range",DIR("B")="NO"
S DIR("?")="If you wish to include patients from ALL age ranges, anwser No. If you wish to list only patients within a particular age range, enter Yes."
D ^DIR K DIR
G:$D(DIRUT) RS
I 'Y G CMMNTS
;
AGER ;Age Screening
W !
S DIR(0)="FO^1:7",DIR("A")="Enter an Age Range (e.g. 5-12,1-1)" D ^DIR
I Y="" W !!,"No age range entered." G AGE
I Y'?1.3N1"-"1.3N W !!,$C(7),$C(7),"Enter a numeric range in the format nnn-nnn. e.g. 0-5, 0-99, 5-20." G AGER
S BDMAGET=Y
CMMNTS ;
K BDMCOMM S BDMCOMT=""
S DIR(0)="S^O:One particular Community;A:All Communities;S:Selected Set of Communities (Taxonomy)",DIR("A")="Include Patients",DIR("B")="A" K DA D ^DIR K DIR
I $D(DIRUT) G AGE
S BDMCOMT=Y
I BDMCOMT="A" G SEX
I BDMCOMT="O" D G:'$D(BDMCOMM) CMMNTS G SEX
.S DIC="^AUTTCOM(",DIC(0)="AEMQ",DIC("A")="Which COMMUNITY: " D ^DIC K DIC
.Q:Y=-1
.S BDMCOMM($P(^AUTTCOM(+Y,0),U))=""
S X="COMMUNITY",DIC="^AMQQ(5,",DIC(0)="FM",DIC("S")="I $P(^(0),U,14)" D ^DIC K DIC,DA I Y=-1 W "OOPS - QMAN NOT CURRENT - QUITTING" S BDMERR=1 Q
D PEP^AMQQGTX0(+Y,"BDMCOMM(")
I '$D(BDMCOMM) G CMMNTS
I $D(BDMCOMM("*")) W !,"* ISN'T ALLOWED, CHOOSE ALL" K BDMCOMM G CMMNTS
SEX ;
S BDMSEX=""
S DIR(0)="S^M:MALES;F:FEMALES;U:UNKNOWN;A:ALL Genders",DIR("A")="Include which Gender(s)",DIR("B")="A" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G CMMNTS
S BDMSEX=Y
CM ;
K BDMCM
S DIR(0)="Y",DIR("A")="Do you want to select register patients with a particular CASE MANAGER",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G SEX
I Y=0 K BDMCM G WF
CM1 ;which status
K DIC S DIC(0)="AEMQ",DIC=200,DIC("A")="Select "_$S($D(BDMCM):"another ",1:"")_"Case Manager: " D ^DIC K DIC
I Y=-1,'$D(BDMCM) G CM
I $D(DIRUT),'$D(BDMCM) G CM
I $D(DIRUT) G WF
I Y=-1 G WF
S BDMCM(+Y)=""
G CM1
WF ;
K BDMWF
S DIR(0)="Y",DIR("A")="Do you want to select patients with a particular facility WHERE FOLLOWED",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G CM
I Y=0 K BDMWF G SORT
WF1 ;which status
;ihs/cmi/maw 03/12/2014 2.0 patch 8 added DIC(0) call
K DIC S DIC=9999999.06,DIC(0)="AEMQZ",DIC("A")="Select "_$S($D(BDMWF):"another ",1:"")_"WHERE FOLLOWED facility: " D ^DIC K DIC
I Y=-1,'$D(BDMWF) G WF
I $D(DIRUT),'$D(BDMWF) G WF
I $D(DIRUT) G SORT
I Y=-1 G SORT
S BDMWF(+Y)=""
G WF1
SORT ;
S BDMSORT1="",BDMSORT2=""
W !!,"This list can be sorted by a primary and optionally a secondary sort value.",!
S DIR(0)="S^P:Patient Name;S:Register Status;A:Age;C:Community;G:Gender;M:Case Manager;W:Where Followed",DIR("A")="Select Primary Sort Value" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G WF
S BDMSORT1=Y,BDMSOR1T=Y(0)
SSORT ;
W !,"You can optionally sort by a second sort value. If you do not pick a",!,"secondary sort value it will default to patient name.",!
S BDMSORT2=""
K DIR
S DIR(0)="SO^"_$S(BDMSORT1'="P":"P:Patient Name",1:"")
S DIR(0)=DIR(0)_$S(BDMSORT1'="S":";S:Register Status",1:"")
S DIR(0)=DIR(0)_$S(BDMSORT1'="A":";A:Age",1:"")
S DIR(0)=DIR(0)_$S(BDMSORT1'="C":";C:Community",1:"")
S DIR(0)=DIR(0)_$S(BDMSORT1'="G":";G:Gender",1:"")
S DIR(0)=DIR(0)_$S(BDMSORT1'="M":";M:Case Manager",1:"")
S DIR(0)=DIR(0)_$S(BDMSORT1'="W":";W:Where Followed",1:"")
S DIR("A")="Select Secondary Sort Value" KILL DA D ^DIR KILL DIR
I X="" S BDMSORT2="P",BDMSOR2T="Patient Name" G TEMP
I $D(DIRUT) G SORT
S BDMSORT2=Y,BDMSOR2T=Y(0)
;I BDMSORT2="" S BDMSORT2="P",BDMSOR2T="Patient Name"
TEMP ;
S BDMTEMP=""
S DIR(0)="S^P:Print the List;B:Browse the List on the Screen;S:Save as a Search Template",DIR("A")="Output Type",DIR("B")="P" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G SORT
S BDMTEMP=Y
I BDMTEMP="P" G ZIS
I BDMTEMP="B" G ZIS
D EN2
I BDMSTMP="" G TEMP
ZIS ;call to XBDBQUE
DEMO ;
D DEMOCHK^BDMUTL(.BDMDEMO)
I BDMDEMO=-1 G R
I BDMTEMP="B" D BROWSE,EXIT Q
S XBRP="PRINT^BDMRML",XBRC="PROC^BDMRML",XBRX="EXIT^BDMRML",XBNS="BDM"
D ^XBDBQUE
D EXIT
Q
BROWSE ;
S XBRP="VIEWR^XBLM(""PRINT^BDMRML"")"
S XBRC="PROC^BDMRML",XBRX="EXIT^BDMRML",XBIOP=0 D ^XBDBQUE
Q
INFORM ;
W:$D(IOF) @IOF
W !,$$CTR($$LOC)
W !,$$CTR($$USR)
W !!,$$CTR("DIABETES REGISTER MASTER LIST",80)
W !!,"This report will list all patients on the Diabetes Register.",!
W "You will be able to select which patients will be included on the list",!
W "based on any of the following:",!
W ?5,"- Register Status",!
W ?5,"- Age",!
W ?5,"- Community of Residence",!
W ?5,"- Gender",!
W ?5,"- Case Manager",!
W ?5,"- Where Followed",!
W !
Q
EXIT ;clean up and exit
I '$D(BDMGUI) D EN^XBVK("BDM")
D ^XBFMK
D KILL^AUPNPAT
Q
PROC ;EP - called from XBDBQUE
S BDMJOB=$J,BDMBTH=$H,BDMTOT=0
K BDMSORT
K ^XTMP("BDMRML",BDMJOB,BDMBTH)
D XTMP^BDMOSUT("BDMRML","DM MASTER LIST")
S BDMX=0 F S BDMX=$O(^ACM(41,"B",BDMREG,BDMX)) Q:BDMX'=+BDMX D
.S DFN=$P(^ACM(41,BDMX,0),U,2)
.Q:$$DEMO^BDMUTL(DFN,$G(BDMDEMO))
.Q:$$DOD^AUPNPAT(DFN)]""
.I $D(BDMSTAT) S X=$P($G(^ACM(41,BDMX,"DT")),U,1) Q:X="" Q:'$D(BDMSTAT(X))
.I $D(BDMAGET) Q:$$AGE^AUPNPAT(DFN)>$P(BDMAGET,"-",2)
.I $D(BDMAGET) Q:$$AGE^AUPNPAT(DFN)<$P(BDMAGET,"-",1)
.I $D(BDMCOMM) S X=$P($G(^AUPNPAT(DFN,11)),U,18) Q:X="" I X]"",'$D(BDMCOMM(X)) Q
.I BDMSEX'="A" S X=$$GET1^DIQ(2,DFN,.02,"I") I BDMSEX'=X Q
.I $D(BDMCM) S X=$$VALI^XBDIQ1(9002241,BDMX,6) Q:'X I X Q:'$D(BDMCM(X))
.I $D(BDMWF) S X=$$VALI^XBDIQ1(9002241,BDMX,10) Q:'X I X Q:'$D(BDMWF(X))
.D @BDMSORT1
.S BDMS1=X
.D @BDMSORT2
.S BDMS2=X
.S ^XTMP("BDMRML",BDMJOB,BDMBTH,"PATIENTS",BDMS1,BDMS2,BDMX)=DFN
.I BDMSORT1'="P" S BDMSORT(BDMS1)=$G(BDMSORT(BDMS1))+1 ;SUBOTOTAL
.S BDMTOT=BDMTOT+1
Q
PRINT ;EP - called from xbdbque
S BDMIOSL=$S($G(BDMGUI):55,1:IOSL)
S BDM80D="-------------------------------------------------------------------------------"
S BDMPG=0 D HEAD
I '$D(^XTMP("BDMRML",BDMJOB,BDMBTH)) W !!,"NO PATIENTS TO REPORT" G DONE
S BDMS1="",BDMS2="" K BDMQ
F S BDMS1=$O(^XTMP("BDMRML",BDMJOB,BDMBTH,"PATIENTS",BDMS1)) Q:BDMS1=""!($D(BDMQ)) D
.I $Y>(IOSL-3) D HEAD Q:$D(BDMQ)
.I BDMTEMP'="S",BDMSORT1'="P" W !!?5,BDMSOR1T,": ",BDMS1," (Subtotal: ",BDMSORT(BDMS1),")"
.S BDMS2="" F S BDMS2=$O(^XTMP("BDMRML",BDMJOB,BDMBTH,"PATIENTS",BDMS1,BDMS2)) Q:BDMS2=""!($D(BDMQ)) D
..S BDMX="" F S BDMX=$O(^XTMP("BDMRML",BDMJOB,BDMBTH,"PATIENTS",BDMS1,BDMS2,BDMX)) Q:BDMX=""!($D(BDMQ)) D
...S DFN=^XTMP("BDMRML",BDMJOB,BDMBTH,"PATIENTS",BDMS1,BDMS2,BDMX)
...I BDMTEMP="S" S ^DIBT(BDMSTMP,1,DFN)="" Q
...I $Y>(BDMIOSL-4) D HEAD Q:$D(BDMQ)
...W !,$$HRN^AUPNPAT(DFN,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2))),?8,$E($P(^DPT(DFN,0),U,1),1,20),?30,$E($$GET1^DIQ(9002241,BDMX,6),1,15)
...W ?48,$$LASTVD(DFN),?59,$$DATE($$GET1^DIQ(9002241,BDMX,8,"I")),?70,$$DATE($$GET1^DIQ(9002241,BDMX,9,"I"))
DONE ;
I BDMTEMP="S" D HDR
I $E(IOST)="C",IO=IO(0) S DIR(0)="EO",DIR("A")="End of report. HIT RETURN" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
W:$D(IOF) @IOF
K ^XTMP("BDMRML",BDMJOB,BDMBTH),BDMJOB,BDMBTH
Q
DATE(D) ;
I D="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
LASTVD(P) ;
NEW X,Y,Z,V,D
S V=""
S D=0 F S D=$O(^AUPNVSIT("AA",P,D)) Q:D'=+D!(V) D
.S X=0 F S X=$O(^AUPNVSIT("AA",P,D,X)) Q:X'=+X!(V) D
..Q:'$D(^AUPNVSIT(X,0))
..Q:$P(^AUPNVSIT(X,0),U,11) ;deleted
..Q:'$P(^AUPNVSIT(X,0),U,9) ;ZERO DEP
..Q:"CTNEDX"[$P(^AUPNVSIT(X,0),U,7)
..S V=X
I V="" Q ""
S D=$$VD^APCLV(V)
Q $$DATE($$VD^APCLV(V))
HEAD I 'BDMPG G HEAD1
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BDMQ="" Q
HEAD1 ;
W:$D(IOF) @IOF S BDMPG=BDMPG+1
I $G(BDMGUI),BDMPG'=1 W !,"ZZZZZZZ"
W !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
W !,$P(^VA(200,DUZ,0),U,2),?72,"Page ",BDMPG,!
W ?(80-$L($P(^DIC(4,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0),U))/2),$P(^DIC(4,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0),U),!
W $$CTR("DIABETES REGISTER MASTER LIST",80),!
W $$CTR("Total number of patient selected for this report: "_BDMTOT),!
W !?48,"LAST",?60,"LAST",?70,"NEXT"
PIH W !,"HRN",?8,"PATIENT",?30,"CASE MANAGER",?48,"VISIT",?60,"REVIEW",?70,"REVIEW",!,BDM80D,!
Q
CTR(X,Y) ;EP - Center X in a field Y wide.
Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
;----------
EOP ;EP - End of page.
Q:$E(IOST)'="C"
Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
NEW DIR
K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR(0)="E" D ^DIR
Q
;----------
USR() ;EP - Return name of current user from ^VA(200.
Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
;----------
P ;
S X=$P(^DPT(DFN,0),U,1)
Q
S ;
S X=$$GET1^DIQ(9002241,BDMX,1)
I X="" S X="<NONE>"
Q
A ;
S X=$$AGE^AUPNPAT(DFN,DT)
Q
C ;
S X=$P($G(^AUPNPAT(DFN,11)),U,18)
I X="" S X="<NONE>"
Q
G ;
S X=$$GET1^DIQ(2,DFN,.02)
I X="" S X="UNKNOWN"
Q
M ;
S X=$$GET1^DIQ(9002241,BDMX,6)
I X="" S X="<NONE>"
Q
W ;
S X=$$GET1^DIQ(9002241,BDMX,10)
I X="" S X="<NONE>"
Q
TEST ;
D BDMG("R",1,"A")
Q
BDMG(BDMIEN,BDMREG,BDMAGET,BDMSTAT,BDMCOMT,BDMCOMM,BDMSEX,BDMCM,BDMWF,BDMSORT1,BDMSORT2,BDMTEMP,BDMDEMO,BDMSTMP) ;EP - GUI DMS Entry Point
S BDMND=$G(BDMND)
S BDMGUI=1
S BDMLDAT=$G(BDMLDAT)
I BDMAGET="" K BDMAGET
I BDMSTMP]"" S BDMSNAM=$P(^DIBT(BDMSTMP,0),U)
S BDMSOR1T=$S(BDMSORT1="P":"Patient Name",BDMSORT1="S":"Register Status",BDMSORT1="A":"Age",BDMSORT1="C":"Community",BDMSORT1="G":"Gender",BDMSORT1="M":"Case Manager",BDMSORT1="W":"Where Followed",1:"")
S BDMSOR2T=$S(BDMSORT2="P":"Patient Name",BDMSORT2="S":"Register Status",BDMSORT2="A":"Age",BDMSORT2="C":"Community",BDMSORT2="G":"Gender",BDMSORT2="M":"Case Manager",BDMSORT2="W":"Where Followed",1:"Patient Name")
I BDMSORT2="" S BDMSORT2="P"
NEW BDMNOW,BDMOPT,BDMIEN
S BDMOPT="Master List"
D NOW^%DTC
S BDMNOW=$G(%)
K DD,DO,DIC
S X=DUZ_BDMNOW
S DIC("DR")=".02////"_DUZ_";.03////"_BDMNOW_";.06///"_$G(BDMOPT)_";.07////R"
S DIC="^BDMGUI(",DIC(0)="L",DIADD=1,DLAYGO=9003201.4
D FILE^DICN
K DIADD,DLAYGO,DIC,DA
I Y=-1 S BDMIEN=-1 Q
S BDMIEN=+Y
S BDMGIEN=BDMIEN ;cmi/maw added
D ^XBFMK
K ZTSAVE S ZTSAVE("*")=""
;D GUIEP ;for interactive testing
S ZTIO="",ZTDTH=$$NOW^XLFDT,ZTRTN="GUIEP^BDMRML",ZTDESC="GUI MASTER LIST" D ^%ZTLOAD
D EXIT
Q
GUIEP ;EP
D PROC
K ^TMP($J,"BDMRML")
S IOM=80
D GUIR^XBLM("PRINT^BDMRML","^TMP($J,""BDMRML"",")
S X=0,C=0 F S X=$O(^TMP($J,"BDMRML",X)) Q:X'=+X D
.S BDMDATA=^TMP($J,"BDMRML",X)
.;I BDMDATA="ZZZZZZZ" ;S BDMDATA=$C(12)
.S ^BDMGUI(BDMIEN,11,X,0)=BDMDATA,C=C+1
S ^BDMGUI(BDMIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
S DA=BDMIEN,DIK="^BDMGUI(" D IX1^DIK
D ENDLOG
K ^TMP($J,"BDMRML")
D EXIT
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
EN2 ;EP
S BDMSTMP="",BDMSNAM=""
S DIC="^DIBT(",DIC(0)="AELMQZ",DIC("A")="Search Template: ",DIC("S")="I $P(^(0),U,4)=9000001&($P(^(0),U,5)=DUZ)"
W !
D ^DIC
I +Y<1 W !!,"No Search Template selected." H 2 Q
S BDMDIC=DIC ;ihs/cmi/maw 03/11/2014 patch 8
S BDMSTMP=+Y,BDMSNAM=$P(^DIBT(BDMSTMP,0),U)
DUP I '$P(Y,U,3) D I Q K BDMSTMP,Y G EN2
.S Q=""
.W !!,$C(7),$C(7)
.S DIR(0)="Y",DIR("A")="That template already exists!! Do you want to overwrite it",DIR("B")="N" K DA D ^DIR K DIR
.I $D(DIRUT) S Q=1 Q
.I 'Y S Q=1 Q
.L +^DIBT(BDMSTMP):10
.S BDMSTN=$P(^DIBT(BDMSTMP,0),U) S DA=BDMSTMP,DIK="^DIBT(" D ^DIK
.S ^DIBT(BDMSTMP,0)=BDMSNAM,DA=BDMSTMP,DIK="^DIBT(" D IX1^DIK
.L -^DIBT(BDMSTMP)
.Q
I BDMSTMP,$D(^DIBT(BDMSTMP)) D
.W !!,?5,"An unduplicated patient list resulting from this report",!,?5,"will be stored in the.........>",!!?18,"** ",BDMSNAM," ** Search Template."
.K ^DIBT(BDMSTMP,1)
.S DHIT="S ^DIBT("_BDMSTMP_",1,$P("_BDMDIC_"D0,0),U,2))="""""
.S DIE="^DIBT(",DA=BDMSTMP,DR="2////"_DT_";3////M;4////9000001;5////"_DUZ_";6////M"
.D ^DIE
.K DIE,DA,DR
Q
;Run Template in Background Mode
;
BACK ;
S DHD="W ?0 D HDR^BDMSTMP",FLDS="!.01"
W !!,"A brief report will be printed after the search template is complete.",!,"You must enter a device for this report OR you may queue at this time.",!
Q
HDR ;
W !!,?15,"***SEARCH TEMPLATE CREATION***"
W !!,?1,"Template Created: ",$P(^DIBT(BDMSTMP,0),U)
W !,?1,"Created by: ",$P(^VA(200,DUZ,0),U)
W !,"------------------------------------------------------------------------------",!
Q
BDMRML ; IHS/CMI/LAB - patients w/o dm on problem list ; 28 Nov 2017 1:25 PM
+1 ;;2.0;DIABETES MANAGEMENT SYSTEM;**9,10,11**;JUN 14, 2007;Build 30
+2 ;
+3 ;
START ;
+1 DO INFORM
GETINFO ;
+1 KILL BDMSTAT
R ;
+1 SET BDMREG=""
+2 SET DIC="^ACM(41.1,"
SET DIC(0)="AEMQ"
SET DIC("A")="Enter the Name of the Register: "
DO ^DIC
+3 IF Y=-1
WRITE !,"No register selected."
SET BDMQUIT=""
DO EXIT
QUIT
+4 SET BDMREG=+Y
RS ;get status
+1 KILL BDMSTAT
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want to select register patients with a particular status"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO R
+4 IF Y=0
KILL BDMSTAT
GOTO AGE
R1 ;which status
+1 SET DIR(0)="9002241,1O"
SET DIR("A")="Select "_$SELECT($DATA(BDMSTAT):"another ",1:"")_"status"
IF '$DATA(BDMSTAT)
SET DIR("B")="A"
KILL DA
DO ^DIR
KILL DIR
+2 IF Y=""
IF '$DATA(BDMSTAT)
GOTO RS
+3 IF $DATA(DIRUT)
IF '$DATA(BDMSTAT)
GOTO RS
+4 IF $DATA(DIRUT)
GOTO AGE
+5 IF Y=""
GOTO AGE
+6 SET BDMSTAT(Y)=""
+7 GOTO R1
AGE ;Age Screening
+1 KILL BDMAGE,BDMAGET
+2 WRITE !
SET DIR(0)="YO"
SET DIR("A")="Would you like to restrict the master list by Patient age range"
SET DIR("B")="NO"
+3 SET DIR("?")="If you wish to include patients from ALL age ranges, anwser No. If you wish to list only patients within a particular age range, enter Yes."
+4 DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
GOTO RS
+6 IF 'Y
GOTO CMMNTS
+7 ;
AGER ;Age Screening
+1 WRITE !
+2 SET DIR(0)="FO^1:7"
SET DIR("A")="Enter an Age Range (e.g. 5-12,1-1)"
DO ^DIR
+3 IF Y=""
WRITE !!,"No age range entered."
GOTO AGE
+4 IF Y'?1.3N1"-"1.3N
WRITE !!,$CHAR(7),$CHAR(7),"Enter a numeric range in the format nnn-nnn. e.g. 0-5, 0-99, 5-20."
GOTO AGER
+5 SET BDMAGET=Y
CMMNTS ;
+1 KILL BDMCOMM
SET BDMCOMT=""
+2 SET DIR(0)="S^O:One particular Community;A:All Communities;S:Selected Set of Communities (Taxonomy)"
SET DIR("A")="Include Patients"
SET DIR("B")="A"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO AGE
+4 SET BDMCOMT=Y
+5 IF BDMCOMT="A"
GOTO SEX
+6 IF BDMCOMT="O"
Begin DoDot:1
+7 SET DIC="^AUTTCOM("
SET DIC(0)="AEMQ"
SET DIC("A")="Which COMMUNITY: "
DO ^DIC
KILL DIC
+8 IF Y=-1
QUIT
+9 SET BDMCOMM($PIECE(^AUTTCOM(+Y,0),U))=""
End DoDot:1
IF '$DATA(BDMCOMM)
GOTO CMMNTS
GOTO SEX
+10 SET X="COMMUNITY"
SET DIC="^AMQQ(5,"
SET DIC(0)="FM"
SET DIC("S")="I $P(^(0),U,14)"
DO ^DIC
KILL DIC,DA
IF Y=-1
WRITE "OOPS - QMAN NOT CURRENT - QUITTING"
SET BDMERR=1
QUIT
+11 DO PEP^AMQQGTX0(+Y,"BDMCOMM(")
+12 IF '$DATA(BDMCOMM)
GOTO CMMNTS
+13 IF $DATA(BDMCOMM("*"))
WRITE !,"* ISN'T ALLOWED, CHOOSE ALL"
KILL BDMCOMM
GOTO CMMNTS
SEX ;
+1 SET BDMSEX=""
+2 SET DIR(0)="S^M:MALES;F:FEMALES;U:UNKNOWN;A:ALL Genders"
SET DIR("A")="Include which Gender(s)"
SET DIR("B")="A"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO CMMNTS
+4 SET BDMSEX=Y
CM ;
+1 KILL BDMCM
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want to select register patients with a particular CASE MANAGER"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO SEX
+4 IF Y=0
KILL BDMCM
GOTO WF
CM1 ;which status
+1 KILL DIC
SET DIC(0)="AEMQ"
SET DIC=200
SET DIC("A")="Select "_$SELECT($DATA(BDMCM):"another ",1:"")_"Case Manager: "
DO ^DIC
KILL DIC
+2 IF Y=-1
IF '$DATA(BDMCM)
GOTO CM
+3 IF $DATA(DIRUT)
IF '$DATA(BDMCM)
GOTO CM
+4 IF $DATA(DIRUT)
GOTO WF
+5 IF Y=-1
GOTO WF
+6 SET BDMCM(+Y)=""
+7 GOTO CM1
WF ;
+1 KILL BDMWF
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want to select patients with a particular facility WHERE FOLLOWED"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO CM
+4 IF Y=0
KILL BDMWF
GOTO SORT
WF1 ;which status
+1 ;ihs/cmi/maw 03/12/2014 2.0 patch 8 added DIC(0) call
+2 KILL DIC
SET DIC=9999999.06
SET DIC(0)="AEMQZ"
SET DIC("A")="Select "_$SELECT($DATA(BDMWF):"another ",1:"")_"WHERE FOLLOWED facility: "
DO ^DIC
KILL DIC
+3 IF Y=-1
IF '$DATA(BDMWF)
GOTO WF
+4 IF $DATA(DIRUT)
IF '$DATA(BDMWF)
GOTO WF
+5 IF $DATA(DIRUT)
GOTO SORT
+6 IF Y=-1
GOTO SORT
+7 SET BDMWF(+Y)=""
+8 GOTO WF1
SORT ;
+1 SET BDMSORT1=""
SET BDMSORT2=""
+2 WRITE !!,"This list can be sorted by a primary and optionally a secondary sort value.",!
+3 SET DIR(0)="S^P:Patient Name;S:Register Status;A:Age;C:Community;G:Gender;M:Case Manager;W:Where Followed"
SET DIR("A")="Select Primary Sort Value"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
GOTO WF
+5 SET BDMSORT1=Y
SET BDMSOR1T=Y(0)
SSORT ;
+1 WRITE !,"You can optionally sort by a second sort value. If you do not pick a",!,"secondary sort value it will default to patient name.",!
+2 SET BDMSORT2=""
+3 KILL DIR
+4 SET DIR(0)="SO^"_$SELECT(BDMSORT1'="P":"P:Patient Name",1:"")
+5 SET DIR(0)=DIR(0)_$SELECT(BDMSORT1'="S":";S:Register Status",1:"")
+6 SET DIR(0)=DIR(0)_$SELECT(BDMSORT1'="A":";A:Age",1:"")
+7 SET DIR(0)=DIR(0)_$SELECT(BDMSORT1'="C":";C:Community",1:"")
+8 SET DIR(0)=DIR(0)_$SELECT(BDMSORT1'="G":";G:Gender",1:"")
+9 SET DIR(0)=DIR(0)_$SELECT(BDMSORT1'="M":";M:Case Manager",1:"")
+10 SET DIR(0)=DIR(0)_$SELECT(BDMSORT1'="W":";W:Where Followed",1:"")
+11 SET DIR("A")="Select Secondary Sort Value"
KILL DA
DO ^DIR
KILL DIR
+12 IF X=""
SET BDMSORT2="P"
SET BDMSOR2T="Patient Name"
GOTO TEMP
+13 IF $DATA(DIRUT)
GOTO SORT
+14 SET BDMSORT2=Y
SET BDMSOR2T=Y(0)
+15 ;I BDMSORT2="" S BDMSORT2="P",BDMSOR2T="Patient Name"
TEMP ;
+1 SET BDMTEMP=""
+2 SET DIR(0)="S^P:Print the List;B:Browse the List on the Screen;S:Save as a Search Template"
SET DIR("A")="Output Type"
SET DIR("B")="P"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO SORT
+4 SET BDMTEMP=Y
+5 IF BDMTEMP="P"
GOTO ZIS
+6 IF BDMTEMP="B"
GOTO ZIS
+7 DO EN2
+8 IF BDMSTMP=""
GOTO TEMP
ZIS ;call to XBDBQUE
DEMO ;
+1 DO DEMOCHK^BDMUTL(.BDMDEMO)
+2 IF BDMDEMO=-1
GOTO R
+3 IF BDMTEMP="B"
DO BROWSE
DO EXIT
QUIT
+4 SET XBRP="PRINT^BDMRML"
SET XBRC="PROC^BDMRML"
SET XBRX="EXIT^BDMRML"
SET XBNS="BDM"
+5 DO ^XBDBQUE
+6 DO EXIT
+7 QUIT
BROWSE ;
+1 SET XBRP="VIEWR^XBLM(""PRINT^BDMRML"")"
+2 SET XBRC="PROC^BDMRML"
SET XBRX="EXIT^BDMRML"
SET XBIOP=0
DO ^XBDBQUE
+3 QUIT
INFORM ;
+1 IF $DATA(IOF)
WRITE @IOF
+2 WRITE !,$$CTR($$LOC)
+3 WRITE !,$$CTR($$USR)
+4 WRITE !!,$$CTR("DIABETES REGISTER MASTER LIST",80)
+5 WRITE !!,"This report will list all patients on the Diabetes Register.",!
+6 WRITE "You will be able to select which patients will be included on the list",!
+7 WRITE "based on any of the following:",!
+8 WRITE ?5,"- Register Status",!
+9 WRITE ?5,"- Age",!
+10 WRITE ?5,"- Community of Residence",!
+11 WRITE ?5,"- Gender",!
+12 WRITE ?5,"- Case Manager",!
+13 WRITE ?5,"- Where Followed",!
+14 WRITE !
+15 QUIT
EXIT ;clean up and exit
+1 IF '$DATA(BDMGUI)
DO EN^XBVK("BDM")
+2 DO ^XBFMK
+3 DO KILL^AUPNPAT
+4 QUIT
PROC ;EP - called from XBDBQUE
+1 SET BDMJOB=$JOB
SET BDMBTH=$HOROLOG
SET BDMTOT=0
+2 KILL BDMSORT
+3 KILL ^XTMP("BDMRML",BDMJOB,BDMBTH)
+4 DO XTMP^BDMOSUT("BDMRML","DM MASTER LIST")
+5 SET BDMX=0
FOR
SET BDMX=$ORDER(^ACM(41,"B",BDMREG,BDMX))
IF BDMX'=+BDMX
QUIT
Begin DoDot:1
+6 SET DFN=$PIECE(^ACM(41,BDMX,0),U,2)
+7 IF $$DEMO^BDMUTL(DFN,$GET(BDMDEMO))
QUIT
+8 IF $$DOD^AUPNPAT(DFN)]""
QUIT
+9 IF $DATA(BDMSTAT)
SET X=$PIECE($GET(^ACM(41,BDMX,"DT")),U,1)
IF X=""
QUIT
IF '$DATA(BDMSTAT(X))
QUIT
+10 IF $DATA(BDMAGET)
IF $$AGE^AUPNPAT(DFN)>$PIECE(BDMAGET,"-",2)
QUIT
+11 IF $DATA(BDMAGET)
IF $$AGE^AUPNPAT(DFN)<$PIECE(BDMAGET,"-",1)
QUIT
+12 IF $DATA(BDMCOMM)
SET X=$PIECE($GET(^AUPNPAT(DFN,11)),U,18)
IF X=""
QUIT
IF X]""
IF '$DATA(BDMCOMM(X))
QUIT
+13 IF BDMSEX'="A"
SET X=$$GET1^DIQ(2,DFN,.02,"I")
IF BDMSEX'=X
QUIT
+14 IF $DATA(BDMCM)
SET X=$$VALI^XBDIQ1(9002241,BDMX,6)
IF 'X
QUIT
IF X
IF '$DATA(BDMCM(X))
QUIT
+15 IF $DATA(BDMWF)
SET X=$$VALI^XBDIQ1(9002241,BDMX,10)
IF 'X
QUIT
IF X
IF '$DATA(BDMWF(X))
QUIT
+16 DO @BDMSORT1
+17 SET BDMS1=X
+18 DO @BDMSORT2
+19 SET BDMS2=X
+20 SET ^XTMP("BDMRML",BDMJOB,BDMBTH,"PATIENTS",BDMS1,BDMS2,BDMX)=DFN
+21 ;SUBOTOTAL
IF BDMSORT1'="P"
SET BDMSORT(BDMS1)=$GET(BDMSORT(BDMS1))+1
+22 SET BDMTOT=BDMTOT+1
End DoDot:1
+23 QUIT
PRINT ;EP - called from xbdbque
+1 SET BDMIOSL=$SELECT($GET(BDMGUI):55,1:IOSL)
+2 SET BDM80D="-------------------------------------------------------------------------------"
+3 SET BDMPG=0
DO HEAD
+4 IF '$DATA(^XTMP("BDMRML",BDMJOB,BDMBTH))
WRITE !!,"NO PATIENTS TO REPORT"
GOTO DONE
+5 SET BDMS1=""
SET BDMS2=""
KILL BDMQ
+6 FOR
SET BDMS1=$ORDER(^XTMP("BDMRML",BDMJOB,BDMBTH,"PATIENTS",BDMS1))
IF BDMS1=""!($DATA(BDMQ))
QUIT
Begin DoDot:1
+7 IF $Y>(IOSL-3)
DO HEAD
IF $DATA(BDMQ)
QUIT
+8 IF BDMTEMP'="S"
IF BDMSORT1'="P"
WRITE !!?5,BDMSOR1T,": ",BDMS1," (Subtotal: ",BDMSORT(BDMS1),")"
+9 SET BDMS2=""
FOR
SET BDMS2=$ORDER(^XTMP("BDMRML",BDMJOB,BDMBTH,"PATIENTS",BDMS1,BDMS2))
IF BDMS2=""!($DATA(BDMQ))
QUIT
Begin DoDot:2
+10 SET BDMX=""
FOR
SET BDMX=$ORDER(^XTMP("BDMRML",BDMJOB,BDMBTH,"PATIENTS",BDMS1,BDMS2,BDMX))
IF BDMX=""!($DATA(BDMQ))
QUIT
Begin DoDot:3
+11 SET DFN=^XTMP("BDMRML",BDMJOB,BDMBTH,"PATIENTS",BDMS1,BDMS2,BDMX)
+12 IF BDMTEMP="S"
SET ^DIBT(BDMSTMP,1,DFN)=""
QUIT
+13 IF $Y>(BDMIOSL-4)
DO HEAD
IF $DATA(BDMQ)
QUIT
+14 WRITE !,$$HRN^AUPNPAT(DFN,$SELECT($GET(BDMDUZ2):BDMDUZ2,1:DUZ(2))),?8,$EXTRACT($PIECE(^DPT(DFN,0),U,1),1,20),?30,$EXTRACT($$GET1^DIQ(9002241,BDMX,6),1,15)
+15 WRITE ?48,$$LASTVD(DFN),?59,$$DATE($$GET1^DIQ(9002241,BDMX,8,"I")),?70,$$DATE($$GET1^DIQ(9002241,BDMX,9,"I"))
End DoDot:3
End DoDot:2
End DoDot:1
DONE ;
+1 IF BDMTEMP="S"
DO HDR
+2 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
SET DIR(0)="EO"
SET DIR("A")="End of report. HIT RETURN"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF $DATA(IOF)
WRITE @IOF
+4 KILL ^XTMP("BDMRML",BDMJOB,BDMBTH),BDMJOB,BDMBTH
+5 QUIT
DATE(D) ;
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
LASTVD(P) ;
+1 NEW X,Y,Z,V,D
+2 SET V=""
+3 SET D=0
FOR
SET D=$ORDER(^AUPNVSIT("AA",P,D))
IF D'=+D!(V)
QUIT
Begin DoDot:1
+4 SET X=0
FOR
SET X=$ORDER(^AUPNVSIT("AA",P,D,X))
IF X'=+X!(V)
QUIT
Begin DoDot:2
+5 IF '$DATA(^AUPNVSIT(X,0))
QUIT
+6 ;deleted
IF $PIECE(^AUPNVSIT(X,0),U,11)
QUIT
+7 ;ZERO DEP
IF '$PIECE(^AUPNVSIT(X,0),U,9)
QUIT
+8 IF "CTNEDX"[$PIECE(^AUPNVSIT(X,0),U,7)
QUIT
+9 SET V=X
End DoDot:2
End DoDot:1
+10 IF V=""
QUIT ""
+11 SET D=$$VD^APCLV(V)
+12 QUIT $$DATE($$VD^APCLV(V))
HEAD IF 'BDMPG
GOTO HEAD1
+1 IF $EXTRACT(IOST)="C"
IF IO=IO(0)
WRITE !
SET DIR(0)="EO"
DO ^DIR
KILL DIR
IF Y=0!(Y="^")!($DATA(DTOUT))
SET BDMQ=""
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
SET BDMPG=BDMPG+1
+2 IF $GET(BDMGUI)
IF BDMPG'=1
WRITE !,"ZZZZZZZ"
+3 WRITE !?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
+4 WRITE !,$PIECE(^VA(200,DUZ,0),U,2),?72,"Page ",BDMPG,!
+5 WRITE ?(80-$LENGTH($PIECE(^DIC(4,$SELECT($GET(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0),U))/2),$PIECE(^DIC(4,$SELECT($GET(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0),U),!
+6 WRITE $$CTR("DIABETES REGISTER MASTER LIST",80),!
+7 WRITE $$CTR("Total number of patient selected for this report: "_BDMTOT),!
+8 WRITE !?48,"LAST",?60,"LAST",?70,"NEXT"
PIH WRITE !,"HRN",?8,"PATIENT",?30,"CASE MANAGER",?48,"VISIT",?60,"REVIEW",?70,"REVIEW",!,BDM80D,!
+1 QUIT
CTR(X,Y) ;EP - Center X in a field Y wide.
+1 QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X
+2 ;----------
EOP ;EP - End of page.
+1 IF $EXTRACT(IOST)'="C"
QUIT
+2 IF $DATA(ZTQUEUED)!'(IOT="TRM")!$DATA(IO("S"))
QUIT
+3 NEW DIR
+4 KILL DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+5 SET DIR(0)="E"
DO ^DIR
+6 QUIT
+7 ;----------
USR() ;EP - Return name of current user from ^VA(200.
+1 QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
+2 ;----------
LOC() ;EP - Return location name from file 4 based on DUZ(2).
+1 QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
+2 ;----------
P ;
+1 SET X=$PIECE(^DPT(DFN,0),U,1)
+2 QUIT
S ;
+1 SET X=$$GET1^DIQ(9002241,BDMX,1)
+2 IF X=""
SET X="<NONE>"
+3 QUIT
A ;
+1 SET X=$$AGE^AUPNPAT(DFN,DT)
+2 QUIT
C ;
+1 SET X=$PIECE($GET(^AUPNPAT(DFN,11)),U,18)
+2 IF X=""
SET X="<NONE>"
+3 QUIT
G ;
+1 SET X=$$GET1^DIQ(2,DFN,.02)
+2 IF X=""
SET X="UNKNOWN"
+3 QUIT
M ;
+1 SET X=$$GET1^DIQ(9002241,BDMX,6)
+2 IF X=""
SET X="<NONE>"
+3 QUIT
W ;
+1 SET X=$$GET1^DIQ(9002241,BDMX,10)
+2 IF X=""
SET X="<NONE>"
+3 QUIT
TEST ;
+1 DO BDMG("R",1,"A")
+2 QUIT
BDMG(BDMIEN,BDMREG,BDMAGET,BDMSTAT,BDMCOMT,BDMCOMM,BDMSEX,BDMCM,BDMWF,BDMSORT1,BDMSORT2,BDMTEMP,BDMDEMO,BDMSTMP) ;EP - GUI DMS Entry Point
+1 SET BDMND=$GET(BDMND)
+2 SET BDMGUI=1
+3 SET BDMLDAT=$GET(BDMLDAT)
+4 IF BDMAGET=""
KILL BDMAGET
+5 IF BDMSTMP]""
SET BDMSNAM=$PIECE(^DIBT(BDMSTMP,0),U)
+6 SET BDMSOR1T=$SELECT(BDMSORT1="P":"Patient Name",BDMSORT1="S":"Register Status",BDMSORT1="A":"Age",BDMSORT1="C":"Community",BDMSORT1="G":"Gender",BDMSORT1="M":"Case Manager",BDMSORT1="W":"Where Followed",1:"")
+7 SET BDMSOR2T=$SELECT(BDMSORT2="P":"Patient Name",BDMSORT2="S":"Register Status",BDMSORT2="A":"Age",BDMSORT2="C":"Community",BDMSORT2="G":"Gender",BDMSORT2="M":"Case Manager",BDMSORT2="W":"Where Followed",1:"Patient Name")
+8 IF BDMSORT2=""
SET BDMSORT2="P"
+9 NEW BDMNOW,BDMOPT,BDMIEN
+10 SET BDMOPT="Master List"
+11 DO NOW^%DTC
+12 SET BDMNOW=$GET(%)
+13 KILL DD,DO,DIC
+14 SET X=DUZ_BDMNOW
+15 SET DIC("DR")=".02////"_DUZ_";.03////"_BDMNOW_";.06///"_$GET(BDMOPT)_";.07////R"
+16 SET DIC="^BDMGUI("
SET DIC(0)="L"
SET DIADD=1
SET DLAYGO=9003201.4
+17 DO FILE^DICN
+18 KILL DIADD,DLAYGO,DIC,DA
+19 IF Y=-1
SET BDMIEN=-1
QUIT
+20 SET BDMIEN=+Y
+21 ;cmi/maw added
SET BDMGIEN=BDMIEN
+22 DO ^XBFMK
+23 KILL ZTSAVE
SET ZTSAVE("*")=""
+24 ;D GUIEP ;for interactive testing
+25 SET ZTIO=""
SET ZTDTH=$$NOW^XLFDT
SET ZTRTN="GUIEP^BDMRML"
SET ZTDESC="GUI MASTER LIST"
DO ^%ZTLOAD
+26 DO EXIT
+27 QUIT
GUIEP ;EP
+1 DO PROC
+2 KILL ^TMP($JOB,"BDMRML")
+3 SET IOM=80
+4 DO GUIR^XBLM("PRINT^BDMRML","^TMP($J,""BDMRML"",")
+5 SET X=0
SET C=0
FOR
SET X=$ORDER(^TMP($JOB,"BDMRML",X))
IF X'=+X
QUIT
Begin DoDot:1
+6 SET BDMDATA=^TMP($JOB,"BDMRML",X)
+7 ;I BDMDATA="ZZZZZZZ" ;S BDMDATA=$C(12)
+8 SET ^BDMGUI(BDMIEN,11,X,0)=BDMDATA
SET C=C+1
End DoDot:1
+9 SET ^BDMGUI(BDMIEN,11,0)="^^"_C_"^"_C_"^"_DT_"^"
+10 SET DA=BDMIEN
SET DIK="^BDMGUI("
DO IX1^DIK
+11 DO ENDLOG
+12 KILL ^TMP($JOB,"BDMRML")
+13 DO EXIT
+14 SET ZTREQ="@"
+15 QUIT
+16 ;
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
EN2 ;EP
+1 SET BDMSTMP=""
SET BDMSNAM=""
+2 SET DIC="^DIBT("
SET DIC(0)="AELMQZ"
SET DIC("A")="Search Template: "
SET DIC("S")="I $P(^(0),U,4)=9000001&($P(^(0),U,5)=DUZ)"
+3 WRITE !
+4 DO ^DIC
+5 IF +Y<1
WRITE !!,"No Search Template selected."
HANG 2
QUIT
+6 ;ihs/cmi/maw 03/11/2014 patch 8
SET BDMDIC=DIC
+7 SET BDMSTMP=+Y
SET BDMSNAM=$PIECE(^DIBT(BDMSTMP,0),U)
DUP IF '$PIECE(Y,U,3)
Begin DoDot:1
+1 SET Q=""
+2 WRITE !!,$CHAR(7),$CHAR(7)
+3 SET DIR(0)="Y"
SET DIR("A")="That template already exists!! Do you want to overwrite it"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+4 IF $DATA(DIRUT)
SET Q=1
QUIT
+5 IF 'Y
SET Q=1
QUIT
+6 LOCK +^DIBT(BDMSTMP):10
+7 SET BDMSTN=$PIECE(^DIBT(BDMSTMP,0),U)
SET DA=BDMSTMP
SET DIK="^DIBT("
DO ^DIK
+8 SET ^DIBT(BDMSTMP,0)=BDMSNAM
SET DA=BDMSTMP
SET DIK="^DIBT("
DO IX1^DIK
+9 LOCK -^DIBT(BDMSTMP)
+10 QUIT
End DoDot:1
IF Q
KILL BDMSTMP,Y
GOTO EN2
+11 IF BDMSTMP
IF $DATA(^DIBT(BDMSTMP))
Begin DoDot:1
+12 WRITE !!,?5,"An unduplicated patient list resulting from this report",!,?5,"will be stored in the.........>",!!?18,"** ",BDMSNAM," ** Search Template."
+13 KILL ^DIBT(BDMSTMP,1)
+14 SET DHIT="S ^DIBT("_BDMSTMP_",1,$P("_BDMDIC_"D0,0),U,2))="""""
+15 SET DIE="^DIBT("
SET DA=BDMSTMP
SET DR="2////"_DT_";3////M;4////9000001;5////"_DUZ_";6////M"
+16 DO ^DIE
+17 KILL DIE,DA,DR
End DoDot:1
+18 QUIT
+19 ;Run Template in Background Mode
+20 ;
BACK ;
+1 SET DHD="W ?0 D HDR^BDMSTMP"
SET FLDS="!.01"
+2 WRITE !!,"A brief report will be printed after the search template is complete.",!,"You must enter a device for this report OR you may queue at this time.",!
+3 QUIT
HDR ;
+1 WRITE !!,?15,"***SEARCH TEMPLATE CREATION***"
+2 WRITE !!,?1,"Template Created: ",$PIECE(^DIBT(BDMSTMP,0),U)
+3 WRITE !,?1,"Created by: ",$PIECE(^VA(200,DUZ,0),U)
+4 WRITE !,"------------------------------------------------------------------------------",!
+5 QUIT
