BDMDR4.m

BDMDR4 ; IHS/CMI/LAB - patients w/o TB TX ; 05 Mar 2015  1:11 PM

 ;;2.0;DIABETES MANAGEMENT SYSTEM;**6,8,9,10**;JUN 14, 2007;Build 12

 ;

 ;

START ;

 D INFORM

 D EXIT

 D GETINFO

 I $D(BDMQUIT) D EXIT Q

 Q

INFORM ;

 W:$D(IOF) @IOF

 W !,$$CTR($$LOC)

 W !,$$CTR($$USR)

 W !!,"This report will list patients who have a positive PPD/TB who have",!,"no documentation of treatment being completed."

 W !,"Treatment Completed is defined as having Health Factor TB - TX COMPLETE",!,"documented.",!

 Q

 ;

GETINFO ;

 S (BDMTR,BDMREG,BDMSTAT,BDMND)=""

 S DIR(0)="S^R:Those who are members of a Register;A:All Patients",DIR("A")="List which subset of patients",DIR("B")="R" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) S BDMQUIT="" Q

 S BDMTR=Y

 D @Y

 I $D(BDMQUIT) D EXIT Q

 D ZIS

 Q

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="" Q

 S BDMREG=+Y

 ;get status

 S 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 S BDMSTAT="" Q

 ;which status

 S DIR(0)="9002241,1",DIR("A")="Which status",DIR("B")="A" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G R

 S BDMSTAT=Y

 Q

A ;

 Q

ZIS ;

 S BDMTEMP=""

 S DIR(0)="S^P:PRINT the List;B:BROWSE the List on the Screen",DIR("A")="Output Type",DIR("B")="P" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) D EXIT Q

 S BDMTEMP=Y

 ;call to XBDBQUE

DEMO ;

 D DEMOCHK^BDMUTL(.BDMDEMO)

 I BDMDEMO=-1 D EXIT Q

 I BDMTEMP="B" D BROWSE,EXIT Q

 S XBRP="PRINT^BDMDR4",XBRC="PROC^BDMDR4",XBRX="EXIT^BDMDR4",XBNS="BDM"

 D ^XBDBQUE

 D EXIT

 Q

BROWSE ;

 S XBRP="VIEWR^XBLM(""PRINT^BDMDR4"")"

 S XBRC="PROC^BDMDR4",XBRX="EXIT^BDMDR4",XBIOP=0 D ^XBDBQUE

 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

 K ^XTMP("BDMDR4",BDMJOB,BDMBTH)

 D XTMP^BDMOSUT("BDMDR4","DM NOT ON PROBLEM LIST")

 I BDMTR="R" D REGPROC Q

 I BDMTR="A" D ALLPROC Q

 Q

ALLPROC ;

 ;get last dm dx, if less than last date, Q

 ;if null Q

 ;get # of dxs, if less than BDMnd q

 S DFN=0 F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'=+DFN  D CHK1SET

 Q

CHK1SET ;

 Q:$$DEMO^BDMUTL(DFN,$G(BDMDEMO))

 Q:$$DOD^AUPNPAT(DFN)]""

 Q:$P($G(^AUPNPAT(DFN,41,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0)),U,5)]""  ;IHS/CMI/GRL

 Q:$P($G(^AUPNPAT(DFN,41,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0)),U,2)=""  ;IHS/CMI/GRL

 S BDMTB=$$HASTB(DFN)

 Q:$E(BDMTB)'=1

 Q:$$HASTBTX(DFN)

 S ^XTMP("BDMDR4",BDMJOB,BDMBTH,"PATIENTS",$P(^DPT(DFN,0),U),DFN)=$P(BDMTB,"  ",2,999)

 Q

HASTB(P) ;

 ;positive ppd

 NEW BDMS,E,X

 S BDMS=$P($$PPD^BDMDD18(DFN,DT),"||",2)

 Q BDMS

 ;

HASTBTX(P) ;

 I '$G(P) Q ""

 NEW X,E,BDM,Y

 S Y="BDM("

 S X=P_"^LAST HEALTH TX COMPLETE" S E=$$START1^APCLDF(X,Y)

 I $D(BDM(1)) Q $P(BDM(1),U)

 Q ""

 ;

NUMDXS(P) ;

 I '$G(P) Q ""

 NEW X,E,BDM,Y

 S Y="BDM("

 S X=P_"^ALL DX [SURVEILLANCE DIABETES" S E=$$START1^APCLDF(X,Y)

 S (X,Y)=0

 F  S X=$O(BDM(X)) Q:X'=+X  S Y=Y+1

 Q Y

 ;

REGPROC ;

 ;$o through register, check status, if no DM on problem list

 ;set xtmp

 ;gather up patients from register in ^XTMP

 S X=0 F  S X=$O(^ACM(41,"B",BDMREG,X)) Q:X'=+X  D

 .I BDMSTAT]"",$P($G(^ACM(41,X,"DT")),U,1)=BDMSTAT S DFN=$P(^ACM(41,X,0),U,2) D CHKSET Q

 .I BDMSTAT="" S DFN=$P(^ACM(41,X,0),U,2) D CHKSET Q

 .Q

 Q

CHKSET ;

 Q:$$DOD^AUPNPAT(DFN)]""

 Q:$P($G(^AUPNPAT(DFN,41,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0)),U,5)]""   ;IHS/CMI/GRL

 Q:$P($G(^AUPNPAT(DFN,41,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2)),0)),U,2)=""   ;IHS/CMI/GRL

 S BDMTB=$$HASTB(DFN)

 Q:$E(BDMTB)'=1

 Q:$$HASTBTX(DFN)

 S ^XTMP("BDMDR4",BDMJOB,BDMBTH,"PATIENTS",$P(^DPT(DFN,0),U),DFN)=$P(BDMTB,"  ",2,999)

 Q

PRINT ;EP - called from xbdbque

 S BDMIOSL=$S($G(BDMGUI):55,1:IOSL)

 S BDM80D="-------------------------------------------------------------------------------"

 S BDMPG=0 D HEAD

 I '$D(^XTMP("BDMDR4",BDMJOB,BDMBTH)) W !!,"NO PATIENTS TO REPORT" G EXIT

 S BDMNAME="" K BDMQ

 F  S BDMNAME=$O(^XTMP("BDMDR4",BDMJOB,BDMBTH,"PATIENTS",BDMNAME)) Q:BDMNAME=""!($D(BDMQ))  D

 .S DFN="" F  S DFN=$O(^XTMP("BDMDR4",BDMJOB,BDMBTH,"PATIENTS",BDMNAME,DFN)) Q:DFN=""!($D(BDMQ))  S BDMX=^XTMP("BDMDR4",BDMJOB,BDMBTH,"PATIENTS",BDMNAME,DFN) D

 ..I $Y>(BDMIOSL-4) D HEAD Q:$D(BDMQ)

 ..W !,$E(BDMNAME,1,20),?22,$$HRN^AUPNPAT(DFN,$S($G(BDMDUZ2):BDMDUZ2,1:DUZ(2))),?29,$$DOB^AUPNPAT(DFN,"E"),?43,$P(^DPT(DFN,0),U,2),?47,$$FMTE^XLFDT($$LASTVD^APCLV1(DFN))

 ..W !?5,"TB Status: ",^XTMP("BDMDR4",BDMJOB,BDMBTH,"PATIENTS",BDMNAME,DFN)

 ..W !?5,"Last Documented TB Health Factor: ",$$LASTHF^BDMSMU(DFN,"TB STATUS","B")

 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("BDMDR4",BDMJOB,BDMBTH),BDMJOB,BDMBTH

 Q

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("PATIENTS W/POSITIVE PPD/TB W/O DOCUMENTED TX COMPLETE",80),!

 I BDMTR="R" W $$CTR("Patients on the "_$P(^ACM(41.1,BDMREG,0),U)_" Register",80),!

PIH W !,"PATIENT NAME",?22,"HRN",?29,"DOB",?47,"LAST VISIT",!,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")

 ;----------

TEST ;

 D BDMG("R",1,"A")

 Q

BDMG(BDMTR,BDMREG,BDMSTAT,BDMDEMO) ;EP - GUI DMS Entry Point

 S BDMND=$G(BDMND)

 S BDMGUI=1

 S BDMLDAT=$G(BDMLDAT)

 NEW BDMNOW,BDMOPT,BDMIEN

 S BDMOPT="Patients w/POS PPD/TB w/o TX"

 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^BDMDR4",ZTDESC="GUI DM PTS TB" D ^%ZTLOAD

 D EXIT

 Q

GUIEP ;EP

 D PROC

 K ^TMP($J,"BDMDR4")

 S IOM=80

 D GUIR^XBLM("PRINT^BDMDR4","^TMP($J,""BDMDR4"",")

  S X=0,C=0 F  S X=$O(^TMP($J,"BDMDR4",X)) Q:X'=+X  D

 .S BDMDATA=^TMP($J,"BDMDR4",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,"BDMDR4")

 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

BDMDR4    ; IHS/CMI/LAB - patients w/o TB TX ; 05 Mar 2015  1:11 PM

 +1       ;;2.0;DIABETES MANAGEMENT SYSTEM;**6,8,9,10**;JUN 14, 2007;Build 12

 +2       ;

 +3       ;

START     ;

 +1        DO INFORM

 +2        DO EXIT

 +3        DO GETINFO

 +4        IF $DATA(BDMQUIT)

               DO EXIT

               QUIT 

 +5        QUIT 

INFORM    ;

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        WRITE !,$$CTR($$LOC)

 +3        WRITE !,$$CTR($$USR)

 +4        WRITE !!,"This report will list patients who have a positive PPD/TB who have",!,"no documentation of treatment being completed."

 +5        WRITE !,"Treatment Completed is defined as having Health Factor TB - TX COMPLETE",!,"documented.",!

 +6        QUIT 

 +7       ;

GETINFO   ;

 +1        SET (BDMTR,BDMREG,BDMSTAT,BDMND)=""

 +2        SET DIR(0)="S^R:Those who are members of a Register;A:All Patients"

           SET DIR("A")="List which subset of patients"

           SET DIR("B")="R"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               SET BDMQUIT=""

               QUIT 

 +4        SET BDMTR=Y

 +5        DO @Y

 +6        IF $DATA(BDMQUIT)

               DO EXIT

               QUIT 

 +7        DO ZIS

 +8        QUIT 

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=""

               QUIT 

 +4        SET BDMREG=+Y

 +5       ;get status

 +6        SET BDMSTAT=""

 +7        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

 +8        IF $DATA(DIRUT)

               GOTO R

 +9        IF Y=0

               SET BDMSTAT=""

               QUIT 

 +10      ;which status

 +11       SET DIR(0)="9002241,1"

           SET DIR("A")="Which status"

           SET DIR("B")="A"

           KILL DA

           DO ^DIR

           KILL DIR

 +12       IF $DATA(DIRUT)

               GOTO R

 +13       SET BDMSTAT=Y

 +14       QUIT 

A         ;

 +1        QUIT 

ZIS       ;

 +1        SET BDMTEMP=""

 +2        SET DIR(0)="S^P:PRINT the List;B:BROWSE the List on the Screen"

           SET DIR("A")="Output Type"

           SET DIR("B")="P"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               DO EXIT

               QUIT 

 +4        SET BDMTEMP=Y

 +5       ;call to XBDBQUE

DEMO      ;

 +1        DO DEMOCHK^BDMUTL(.BDMDEMO)

 +2        IF BDMDEMO=-1

               DO EXIT

               QUIT 

 +3        IF BDMTEMP="B"

               DO BROWSE

               DO EXIT

               QUIT 

 +4        SET XBRP="PRINT^BDMDR4"

           SET XBRC="PROC^BDMDR4"

           SET XBRX="EXIT^BDMDR4"

           SET XBNS="BDM"

 +5        DO ^XBDBQUE

 +6        DO EXIT

 +7        QUIT 

BROWSE    ;

 +1        SET XBRP="VIEWR^XBLM(""PRINT^BDMDR4"")"

 +2        SET XBRC="PROC^BDMDR4"

           SET XBRX="EXIT^BDMDR4"

           SET XBIOP=0

           DO ^XBDBQUE

 +3        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

 +2        KILL ^XTMP("BDMDR4",BDMJOB,BDMBTH)

 +3        DO XTMP^BDMOSUT("BDMDR4","DM NOT ON PROBLEM LIST")

 +4        IF BDMTR="R"

               DO REGPROC

               QUIT 

 +5        IF BDMTR="A"

               DO ALLPROC

               QUIT 

 +6        QUIT 

ALLPROC   ;

 +1       ;get last dm dx, if less than last date, Q

 +2       ;if null Q

 +3       ;get # of dxs, if less than BDMnd q

 +4        SET DFN=0

           FOR 

               SET DFN=$ORDER(^AUPNPAT(DFN))

               IF DFN'=+DFN

                   QUIT 

               DO CHK1SET

 +5        QUIT 

CHK1SET   ;

 +1        IF $$DEMO^BDMUTL(DFN,$GET(BDMDEMO))

               QUIT 

 +2        IF $$DOD^AUPNPAT(DFN)]""

               QUIT 

 +3       ;IHS/CMI/GRL

           IF $PIECE($GET(^AUPNPAT(DFN,41,$SELECT($GET(BDMDUZ2)

               QUIT 

 +4       ;IHS/CMI/GRL

           IF $PIECE($GET(^AUPNPAT(DFN,41,$SELECT($GET(BDMDUZ2)

               QUIT 

 +5        SET BDMTB=$$HASTB(DFN)

 +6        IF $EXTRACT(BDMTB)'=1

               QUIT 

 +7        IF $$HASTBTX(DFN)

               QUIT 

 +8        SET ^XTMP("BDMDR4",BDMJOB,BDMBTH,"PATIENTS",$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BDMTB,"  ",2,999)

 +9        QUIT 

HASTB(P)  ;

 +1       ;positive ppd

 +2        NEW BDMS,E,X

 +3        SET BDMS=$PIECE($$PPD^BDMDD18(DFN,DT),"||",2)

 +4        QUIT BDMS

 +5       ;

HASTBTX(P) ;

 +1        IF '$GET(P)

               QUIT ""

 +2        NEW X,E,BDM,Y

 +3        SET Y="BDM("

 +4        SET X=P_"^LAST HEALTH TX COMPLETE"

           SET E=$$START1^APCLDF(X,Y)

 +5        IF $DATA(BDM(1))

               QUIT $PIECE(BDM(1),U)

 +6        QUIT ""

 +7       ;

NUMDXS(P) ;

 +1        IF '$GET(P)

               QUIT ""

 +2        NEW X,E,BDM,Y

 +3        SET Y="BDM("

 +4        SET X=P_"^ALL DX [SURVEILLANCE DIABETES"

           SET E=$$START1^APCLDF(X,Y)

 +5        SET (X,Y)=0

 +6        FOR 

               SET X=$ORDER(BDM(X))

               IF X'=+X

                   QUIT 

               SET Y=Y+1

 +7        QUIT Y

 +8       ;

REGPROC   ;

 +1       ;$o through register, check status, if no DM on problem list

 +2       ;set xtmp

 +3       ;gather up patients from register in ^XTMP

 +4        SET X=0

           FOR 

               SET X=$ORDER(^ACM(41,"B",BDMREG,X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +5                IF BDMSTAT]""

                       IF $PIECE($GET(^ACM(41,X,"DT")),U,1)=BDMSTAT

                           SET DFN=$PIECE(^ACM(41,X,0),U,2)

                           DO CHKSET

                           QUIT 

 +6                IF BDMSTAT=""

                       SET DFN=$PIECE(^ACM(41,X,0),U,2)

                       DO CHKSET

                       QUIT 

 +7                QUIT 

               End DoDot:1

 +8        QUIT 

CHKSET    ;

 +1        IF $$DOD^AUPNPAT(DFN)]""

               QUIT 

 +2       ;IHS/CMI/GRL

           IF $PIECE($GET(^AUPNPAT(DFN,41,$SELECT($GET(BDMDUZ2)

               QUIT 

 +3       ;IHS/CMI/GRL

           IF $PIECE($GET(^AUPNPAT(DFN,41,$SELECT($GET(BDMDUZ2)

               QUIT 

 +4        SET BDMTB=$$HASTB(DFN)

 +5        IF $EXTRACT(BDMTB)'=1

               QUIT 

 +6        IF $$HASTBTX(DFN)

               QUIT 

 +7        SET ^XTMP("BDMDR4",BDMJOB,BDMBTH,"PATIENTS",$PIECE(^DPT(DFN,0),U),DFN)=$PIECE(BDMTB,"  ",2,999)

 +8        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("BDMDR4",BDMJOB,BDMBTH))

               WRITE !!,"NO PATIENTS TO REPORT"

               GOTO EXIT

 +5        SET BDMNAME=""

           KILL BDMQ

 +6        FOR 

               SET BDMNAME=$ORDER(^XTMP("BDMDR4",BDMJOB,BDMBTH,"PATIENTS",BDMNAME))

               IF BDMNAME=""!($DATA(BDMQ))

                   QUIT 

               Begin DoDot:1

 +7                SET DFN=""

                   FOR 

                       SET DFN=$ORDER(^XTMP("BDMDR4",BDMJOB,BDMBTH,"PATIENTS",BDMNAME,DFN))

                       IF DFN=""!($DATA(BDMQ))

                           QUIT 

                       SET BDMX=^XTMP("BDMDR4",BDMJOB,BDMBTH,"PATIENTS",BDMNAME,DFN)

                       Begin DoDot:2

 +8                        IF $Y>(BDMIOSL-4)

                               DO HEAD

                               IF $DATA(BDMQ)

                                   QUIT 

 +9                        WRITE !,$EXTRACT(BDMNAME,1,20),?22,$$HRN^AUPNPAT(DFN,$SELECT($GET(BDMDUZ2):BDMDUZ2,1:DUZ(2))),?29,$$DOB^AUPNPAT(DFN,"E"),?43,$PIECE(^DPT(DFN,0),U,2),?47,$$FMTE^XLFDT($$LASTVD^APCLV1(DFN))

 +10                       WRITE !?5,"TB Status: ",^XTMP("BDMDR4",BDMJOB,BDMBTH,"PATIENTS",BDMNAME,DFN)

 +11                       WRITE !?5,"Last Documented TB Health Factor: ",$$LASTHF^BDMSMU(DFN,"TB STATUS","B")

                       End DoDot:2

               End DoDot:1

 +12       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

 +13       IF $DATA(IOF)

               WRITE @IOF

 +14       KILL ^XTMP("BDMDR4",BDMJOB,BDMBTH),BDMJOB,BDMBTH

 +15       QUIT 

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("PATIENTS W/POSITIVE PPD/TB W/O DOCUMENTED TX COMPLETE",80),!

 +7        IF BDMTR="R"

               WRITE $$CTR("Patients on the "_$PIECE(^ACM(41.1,BDMREG,0),U)_" Register",80),!

PIH        WRITE !,"PATIENT NAME",?22,"HRN",?29,"DOB",?47,"LAST VISIT",!,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       ;----------

TEST      ;

 +1        DO BDMG("R",1,"A")

 +2        QUIT 

BDMG(BDMTR,BDMREG,BDMSTAT,BDMDEMO) ;EP - GUI DMS Entry Point

 +1        SET BDMND=$GET(BDMND)

 +2        SET BDMGUI=1

 +3        SET BDMLDAT=$GET(BDMLDAT)

 +4        NEW BDMNOW,BDMOPT,BDMIEN

 +5        SET BDMOPT="Patients w/POS PPD/TB w/o TX"

 +6        DO NOW^%DTC

 +7        SET BDMNOW=$GET(%)

 +8        KILL DD,DO,DIC

 +9        SET X=DUZ_BDMNOW

 +10       SET DIC("DR")=".02////"_DUZ_";.03////"_BDMNOW_";.06///"_$GET(BDMOPT)_";.07////R"

 +11       SET DIC="^BDMGUI("

           SET DIC(0)="L"

           SET DIADD=1

           SET DLAYGO=9003201.4

 +12       DO FILE^DICN

 +13       KILL DIADD,DLAYGO,DIC,DA

 +14       IF Y=-1

               SET BDMIEN=-1

               QUIT 

 +15       SET BDMIEN=+Y

 +16      ;cmi/maw added

           SET BDMGIEN=BDMIEN

 +17       DO ^XBFMK

 +18       KILL ZTSAVE

           SET ZTSAVE("*")=""

 +19      ;D GUIEP for interactive testing

 +20       SET ZTIO=""

           SET ZTDTH=$$NOW^XLFDT

           SET ZTRTN="GUIEP^BDMDR4"

           SET ZTDESC="GUI DM PTS TB"

           DO ^%ZTLOAD

 +21       DO EXIT

 +22       QUIT 

GUIEP     ;EP

 +1        DO PROC

 +2        KILL ^TMP($JOB,"BDMDR4")

 +3        SET IOM=80

 +4        DO GUIR^XBLM("PRINT^BDMDR4","^TMP($J,""BDMDR4"",")

 +5        SET X=0

           SET C=0

           FOR 

               SET X=$ORDER(^TMP($JOB,"BDMDR4",X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +6                SET BDMDATA=^TMP($JOB,"BDMDR4",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,"BDMDR4")

 +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