BDPNODP.m

BDPNODP ;IHS/CMI/LAB - listing of patients with no desg prov

 ;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009

 ;

 ;

INFORM ;

 W !!,"This report will generate a list of patients who do not have a designated"

 W !,"provider assigned.  The user will be able to run this report on a selected"

 W !,"set of patients or on a search template of patients.  The user will also"

 W !,"be able to select which designated provider category to report on.  For"

 W !,"example you can run this report for all females over 18 with no designated"

 W !,"Women's Health Case Manager or run the report for all patients living in"

 W !,"a particular community with no designated primary care provider."

 W !!

ST ;

 W !,"Please note that you will get a chance later to further refine the set"

 W !,"of patients to include in this report.",!

 S BDPSEAT=""

 S DIR(0)="S^A:All Patients;S:Search template (cohort) of Patients",DIR("A")="Run the report for",DIR("B")="A"

 KILL DA D ^DIR KILL DIR

 I $D(DIRUT) D XIT Q

 I Y="A" G PGEN

ST1 ;

 S BDPSEAT=""

 W ! S DIC("S")="I $P(^(0),U,4)=2!($P(^(0),U,4)=9000001)" S DIC="^DIBT(",DIC("A")="Enter Patient SEARCH TEMPLATE name: ",DIC(0)="AEMQ"

 D ^DIC K DIC,DA,DR,DICR

 I Y=-1 G ST

 S BDPSEAT=+Y

PGEN ;

 S BDPSC=""

 W !!,"You will now be able to select criteria for which patients to "

 W !,"include in the report.  If you are running this report on a search"

 W !,"template of patients and do not want additional criteria applied"

 W !,"you can bypass the criteria selection."

 S DIR(0)="Y",DIR("A")="Do you want to apply search criteria for which subset of patients to include",DIR("B")="Y" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G ST

 S BDPSC=Y

 I BDPSC=0 G CAT

CONT ;

 S BDPNCAN=1 D ADD^APCLVL01 I $D(BDPQUIT) D DEL^APCLVL K BDPQUIT G ST

 S APCLTCW=0,APCLPTVS="P",APCLTYPE="P",APCLCTYP="T"

 K ^APCLVRPT(APCLRPT,11) S APCLCNTL="S" D ^APCLVL4 K APCLCNTL I $D(APCLQUIT) D DEL^APCLVL G ST

CAT ;which category

 W !!,"Enter the designated provider category for which you would like a list"

 W !,"of patients who do not have a provider assigned.",!

 S DIR(0)="90360.1,.01",DIR("A")="Enter the Designated Provider Category"

 KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G ST

 S BDPCAT=+Y

 S BDPCATN=$P(Y,U,2)

SORT ;

 S BDPSORT=""

 S DIR(0)="S^N:Patient Name;H:HRN;C:Current Community;A:Age of the Patient"

 S DIR("A")="How do you want the list of patients sorted",DIR("B")="N" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G CAT

 S BDPSORT=Y

ZIS ;

DEMO ;

 D DEMOCHK^APCLUTL(.BDPDEMO)

 I BDPDEMO=-1 G SORT

 S DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen",DIR("A")="Do you wish to ",DIR("B")="P" K DA D ^DIR K DIR

 I $D(DIRUT) G XIT

 S BDPBROW=Y

 I $G(Y)="B" D BROWSE,XIT Q

 W !! S XBRP="PRINT^BDPNODP",XBRC="PROC^BDPNODP",XBNS="BDP",XBRX="XIT^BDPNODP"

 D ^XBDBQUE

 D XIT

 Q

BROWSE ;

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

 S XBNS="BDP",XBRC="PROC^BDPNODP",XBRX="XIT^BDPNODP",XBIOP=0 D ^XBDBQUE

 Q

 ;

PAUSE ; 

 S DIR(0)="E",DIR("A")="Press return to continue or '^' to quit" D ^DIR K DIR,DA

 S:$D(DIRUT) BDPQUIT=1

 W:$D(IOF) @IOF

 Q

XIT ;

 D EN^XBVK("BDP")

 K L,M,S,T,X,X1,X2,Y,Z,B

 D KILL^AUPNPAT

 D ^XBFMK

 Q

PROC ;

 S BDPJOB=$J,BDPBTH=$H,BDPTOT=0,DFN=0,BDPBT=$H

 D XTMP^APCLOSUT("BDPNODP","BDP - NO DESIGNATED PROV REPORT")

 ;loop through either the template or the patient file and apply screens

 I $G(BDPSEAT) D STP Q

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

 .Q:$$DEMO^APCLUTL(DFN,$G(BDPDEMO))

 .I BDPSC D SCREENS

 .Q:$D(BDPSKIP)

 .;check to see if they have a desginated provider in the category selected.

 .K R

 .D ALLDP^BDPAPI(DFN,BDPCATN,.R)

 .I $D(R) Q  ;has the provider

 .S BDPSRTV=""

 .D @BDPSORT

 .S ^XTMP("BDPNODP",BDPJOB,BDPBTH,BDPSRTV,DFN)=""

 .Q

 Q

STP ;

 S DFN=0 F  S DFN=$O(^DIBT(BDPSEAT,1,DFN)) Q:DFN'=+DFN  D

 .Q:$$DEMO^APCLUTL(DFN,$G(BDPDEMO))

 .I BDPSC D SCREENS

 .;check to see if they have a desginated provider in the category selected.

 .K R

 .D ALLDP^BDPAPI(DFN,$P(^BDPTCAT(BDPCAT,0),U,1),.R)

 .I $D(R) Q  ;has the provider

 .S BDPSRTV=""

 .D @BDPSORT

 .S ^XTMP("BDPNODP",BDPJOB,BDPBTH,BDPSRTV,DFN)=""

 .Q

 Q

SCREENS ;

 K BDPSKIP

 S APCLI=0 F  S APCLI=$O(^APCLVRPT(APCLRPT,11,APCLI)) Q:APCLI'=+APCLI!($D(BDPSKIP))  D

 .I '$P(^APCLVSTS(APCLI,0),U,8) D SINGLE Q

 .D MULT

 .Q

 Q

SINGLE ;

 K X,APCLSPEC S X="",APCLX=0

 X:$D(^APCLVSTS(APCLI,1)) ^(1)

 I X="" S BDPSKIP="" Q

 I '$D(APCLSPEC),'$D(^APCLVRPT(APCLRPT,11,APCLI,11,"B",X)) S BDPSKIP="" Q

 I $D(APCLSPEC),X="" S BDPSKIP=1 Q

 Q

MULT ;

 K APCLFOUN,BDPSKIP,APCLSPEC,X S APCLX=0,X=""

 X:$D(^APCLVSTS(APCLI,1)) ^(1)

 I $O(X(""))="" S BDPSKIP="" Q

 I '$D(APCLSPEC) S Y="" F  S Y=$O(X(Y)) Q:Y=""  I $D(^APCLVRPT(APCLRPT,11,APCLI,11,"B",Y)) S APCLFOUN="" Q

 I $D(APCLSPEC),$D(X) S APCLFOUN=1 Q

 S:'$D(APCLFOUN) BDPSKIP=""

 Q

N ;

 S BDPSRTV=$P(^DPT(DFN,0),U,1)

 Q

H ;

 S BDPSRTV=$$HRN^AUPNPAT(DFN,DUZ(2))

 Q

C S BDPSRTV=$$COMMRES^AUPNPAT(DFN,"E") Q

A S BDPSRTV=$$AGE^AUPNPAT(DFN,DT) Q

 ;

PRINT ;

 S BDP80D="-------------------------------------------------------------------------------"

 S BDPPG=0

 I '$D(^XTMP("BDPNODP",BDPJOB,BDPBTH)) D HEAD W !!,"NO PATIENTS TO REPORT" G DONE

 D HEAD

 S BDPPROV=0 F  S BDPPROV=$O(^XTMP("BDPNODP",BDPJOB,BDPBTH,BDPPROV)) Q:BDPPROV=""!($D(BDPQ))  D

 .F  S DFN=$O(^XTMP("BDPNODP",BDPJOB,BDPBTH,BDPPROV,DFN)) Q:DFN=""!($D(BDPQ))  D DFN

DONE D DONE^APCLOSUT

 K ^XTMP("BDPNODP",BDPJOB,BDPBTH),BDPJOB,BDPBTH

 Q

DFN ;

 I $Y>(IOSL-3) D HEAD Q:$D(BDPQ)

 D LVST

 W $E($P(^DPT(DFN,0),U),1,20),?24,$$UP^XLFSTR($$DOB^AUPNPAT(DFN,"E")),?40,$$HRN^AUPNPAT(DFN,DUZ(2)),?50,$E($$COMMRES^AUPNPAT(DFN,"E"),1,15),?66,BDPDT,!

 Q

HEAD I 'BDPPG 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 BDPQ="" Q

HEAD1 ;

 I BDPPG W:$D(IOF) @IOF

 S BDPPG=BDPPG+1

 W $P(^VA(200,DUZ,0),U,2),?30,$$FMTE^XLFDT($$NOW^XLFDT),?70,"PAGE  "_BDPPG,!

 W ?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),!

 W $$CTR("PATIENTS WITH NO "_BDPCATN_" DESIGNATED PROVIDER",80),!

 I BDPSEAT W !,$$CTR("SEARCH TEMPLATE USED: "_$P(^DIBT(BDPSEAT,0),U,1),80),!

 W !?50,"CURRENT",!

 W "NAME",?24,"DOB",?40,"HRN",?50,"COMMUNITY",?66,"LAST VISIT",!,BDP80D,!

 Q

LVST ;ENTRY POINT from [BDP PRIM PROV LISTING print template

 S BDPAST=""

 S BDPVDFN=""

 S BDPAST=$O(^AUPNVSIT("AA",DFN,""))

 I BDPAST="" S BDPAST="NONE FOUND" Q

 S BDPVDFN=$O(^AUPNVSIT("AA",DFN,BDPAST,""))

 S Y=$P(^AUPNVSIT(BDPVDFN,0),U)

 D DD^%DT S BDPDT=$E(Y,1,12)

 Q

CTR(X,Y) ;EP - Center X in a field Y wide.

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

BDPNODP   ;IHS/CMI/LAB - listing of patients with no desg prov

 +1       ;;2.0;IHS PCC SUITE;**7**;MAY 14, 2009

 +2       ;

 +3       ;

INFORM    ;

 +1        WRITE !!,"This report will generate a list of patients who do not have a designated"

 +2        WRITE !,"provider assigned.  The user will be able to run this report on a selected"

 +3        WRITE !,"set of patients or on a search template of patients.  The user will also"

 +4        WRITE !,"be able to select which designated provider category to report on.  For"

 +5        WRITE !,"example you can run this report for all females over 18 with no designated"

 +6        WRITE !,"Women's Health Case Manager or run the report for all patients living in"

 +7        WRITE !,"a particular community with no designated primary care provider."

 +8        WRITE !!

ST        ;

 +1        WRITE !,"Please note that you will get a chance later to further refine the set"

 +2        WRITE !,"of patients to include in this report.",!

 +3        SET BDPSEAT=""

 +4        SET DIR(0)="S^A:All Patients;S:Search template (cohort) of Patients"

           SET DIR("A")="Run the report for"

           SET DIR("B")="A"

 +5        KILL DA

           DO ^DIR

           KILL DIR

 +6        IF $DATA(DIRUT)

               DO XIT

               QUIT 

 +7        IF Y="A"

               GOTO PGEN

ST1       ;

 +1        SET BDPSEAT=""

 +2        WRITE !

           SET DIC("S")="I $P(^(0),U,4)=2!($P(^(0),U,4)=9000001)"

           SET DIC="^DIBT("

           SET DIC("A")="Enter Patient SEARCH TEMPLATE name: "

           SET DIC(0)="AEMQ"

 +3        DO ^DIC

           KILL DIC,DA,DR,DICR

 +4        IF Y=-1

               GOTO ST

 +5        SET BDPSEAT=+Y

PGEN      ;

 +1        SET BDPSC=""

 +2        WRITE !!,"You will now be able to select criteria for which patients to "

 +3        WRITE !,"include in the report.  If you are running this report on a search"

 +4        WRITE !,"template of patients and do not want additional criteria applied"

 +5        WRITE !,"you can bypass the criteria selection."

 +6        SET DIR(0)="Y"

           SET DIR("A")="Do you want to apply search criteria for which subset of patients to include"

           SET DIR("B")="Y"

           KILL DA

           DO ^DIR

           KILL DIR

 +7        IF $DATA(DIRUT)

               GOTO ST

 +8        SET BDPSC=Y

 +9        IF BDPSC=0

               GOTO CAT

CONT      ;

 +1        SET BDPNCAN=1

           DO ADD^APCLVL01

           IF $DATA(BDPQUIT)

               DO DEL^APCLVL

               KILL BDPQUIT

               GOTO ST

 +2        SET APCLTCW=0

           SET APCLPTVS="P"

           SET APCLTYPE="P"

           SET APCLCTYP="T"

 +3        KILL ^APCLVRPT(APCLRPT,11)

           SET APCLCNTL="S"

           DO ^APCLVL4

           KILL APCLCNTL

           IF $DATA(APCLQUIT)

               DO DEL^APCLVL

               GOTO ST

CAT       ;which category

 +1        WRITE !!,"Enter the designated provider category for which you would like a list"

 +2        WRITE !,"of patients who do not have a provider assigned.",!

 +3        SET DIR(0)="90360.1,.01"

           SET DIR("A")="Enter the Designated Provider Category"

 +4        KILL DA

           DO ^DIR

           KILL DIR

 +5        IF $DATA(DIRUT)

               GOTO ST

 +6        SET BDPCAT=+Y

 +7        SET BDPCATN=$PIECE(Y,U,2)

SORT      ;

 +1        SET BDPSORT=""

 +2        SET DIR(0)="S^N:Patient Name;H:HRN;C:Current Community;A:Age of the Patient"

 +3        SET DIR("A")="How do you want the list of patients sorted"

           SET DIR("B")="N"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               GOTO CAT

 +5        SET BDPSORT=Y

ZIS       ;

DEMO      ;

 +1        DO DEMOCHK^APCLUTL(.BDPDEMO)

 +2        IF BDPDEMO=-1

               GOTO SORT

 +3        SET DIR(0)="S^P:PRINT Output;B:BROWSE Output on Screen"

           SET DIR("A")="Do you wish to "

           SET DIR("B")="P"

           KILL DA

           DO ^DIR

           KILL DIR

 +4        IF $DATA(DIRUT)

               GOTO XIT

 +5        SET BDPBROW=Y

 +6        IF $GET(Y)="B"

               DO BROWSE

               DO XIT

               QUIT 

 +7        WRITE !!

           SET XBRP="PRINT^BDPNODP"

           SET XBRC="PROC^BDPNODP"

           SET XBNS="BDP"

           SET XBRX="XIT^BDPNODP"

 +8        DO ^XBDBQUE

 +9        DO XIT

 +10       QUIT 

BROWSE    ;

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

 +2        SET XBNS="BDP"

           SET XBRC="PROC^BDPNODP"

           SET XBRX="XIT^BDPNODP"

           SET XBIOP=0

           DO ^XBDBQUE

 +3        QUIT 

 +4       ;

PAUSE     ; 

 +1        SET DIR(0)="E"

           SET DIR("A")="Press return to continue or '^' to quit"

           DO ^DIR

           KILL DIR,DA

 +2        IF $DATA(DIRUT)

               SET BDPQUIT=1

 +3        IF $DATA(IOF)

               WRITE @IOF

 +4        QUIT 

XIT       ;

 +1        DO EN^XBVK("BDP")

 +2        KILL L,M,S,T,X,X1,X2,Y,Z,B

 +3        DO KILL^AUPNPAT

 +4        DO ^XBFMK

 +5        QUIT 

PROC      ;

 +1        SET BDPJOB=$JOB

           SET BDPBTH=$HOROLOG

           SET BDPTOT=0

           SET DFN=0

           SET BDPBT=$HOROLOG

 +2        DO XTMP^APCLOSUT("BDPNODP","BDP - NO DESIGNATED PROV REPORT")

 +3       ;loop through either the template or the patient file and apply screens

 +4        IF $GET(BDPSEAT)

               DO STP

               QUIT 

 +5        SET DFN=0

           FOR 

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

               IF DFN'=+DFN

                   QUIT 

               Begin DoDot:1

 +6                IF $$DEMO^APCLUTL(DFN,$GET(BDPDEMO))

                       QUIT 

 +7                IF BDPSC

                       DO SCREENS

 +8                IF $DATA(BDPSKIP)

                       QUIT 

 +9       ;check to see if they have a desginated provider in the category selected.

 +10               KILL R

 +11               DO ALLDP^BDPAPI(DFN,BDPCATN,.R)

 +12      ;has the provider

                   IF $DATA(R)

                       QUIT 

 +13               SET BDPSRTV=""

 +14               DO @BDPSORT

 +15               SET ^XTMP("BDPNODP",BDPJOB,BDPBTH,BDPSRTV,DFN)=""

 +16               QUIT 

               End DoDot:1

 +17       QUIT 

STP       ;

 +1        SET DFN=0

           FOR 

               SET DFN=$ORDER(^DIBT(BDPSEAT,1,DFN))

               IF DFN'=+DFN

                   QUIT 

               Begin DoDot:1

 +2                IF $$DEMO^APCLUTL(DFN,$GET(BDPDEMO))

                       QUIT 

 +3                IF BDPSC

                       DO SCREENS

 +4       ;check to see if they have a desginated provider in the category selected.

 +5                KILL R

 +6                DO ALLDP^BDPAPI(DFN,$PIECE(^BDPTCAT(BDPCAT,0),U,1),.R)

 +7       ;has the provider

                   IF $DATA(R)

                       QUIT 

 +8                SET BDPSRTV=""

 +9                DO @BDPSORT

 +10               SET ^XTMP("BDPNODP",BDPJOB,BDPBTH,BDPSRTV,DFN)=""

 +11               QUIT 

               End DoDot:1

 +12       QUIT 

SCREENS   ;

 +1        KILL BDPSKIP

 +2        SET APCLI=0

           FOR 

               SET APCLI=$ORDER(^APCLVRPT(APCLRPT,11,APCLI))

               IF APCLI'=+APCLI!($DATA(BDPSKIP))

                   QUIT 

               Begin DoDot:1

 +3                IF '$PIECE(^APCLVSTS(APCLI,0),U,8)

                       DO SINGLE

                       QUIT 

 +4                DO MULT

 +5                QUIT 

               End DoDot:1

 +6        QUIT 

SINGLE    ;

 +1        KILL X,APCLSPEC

           SET X=""

           SET APCLX=0

 +2        IF $DATA(^APCLVSTS(APCLI,1))

               XECUTE ^(1)

 +3        IF X=""

               SET BDPSKIP=""

               QUIT 

 +4        IF '$DATA(APCLSPEC)

               IF '$DATA(^APCLVRPT(APCLRPT,11,APCLI,11,"B",X))

                   SET BDPSKIP=""

                   QUIT 

 +5        IF $DATA(APCLSPEC)

               IF X=""

                   SET BDPSKIP=1

                   QUIT 

 +6        QUIT 

MULT      ;

 +1        KILL APCLFOUN,BDPSKIP,APCLSPEC,X

           SET APCLX=0

           SET X=""

 +2        IF $DATA(^APCLVSTS(APCLI,1))

               XECUTE ^(1)

 +3        IF $ORDER(X(""))=""

               SET BDPSKIP=""

               QUIT 

 +4        IF '$DATA(APCLSPEC)

               SET Y=""

               FOR 

                   SET Y=$ORDER(X(Y))

                   IF Y=""

                       QUIT 

                   IF $DATA(^APCLVRPT(APCLRPT,11,APCLI,11,"B",Y))

                       SET APCLFOUN=""

                       QUIT 

 +5        IF $DATA(APCLSPEC)

               IF $DATA(X)

                   SET APCLFOUN=1

                   QUIT 

 +6        IF '$DATA(APCLFOUN)

               SET BDPSKIP=""

 +7        QUIT 

N         ;

 +1        SET BDPSRTV=$PIECE(^DPT(DFN,0),U,1)

 +2        QUIT 

H         ;

 +1        SET BDPSRTV=$$HRN^AUPNPAT(DFN,DUZ(2))

 +2        QUIT 

C          SET BDPSRTV=$$COMMRES^AUPNPAT(DFN,"E")

           QUIT 

A          SET BDPSRTV=$$AGE^AUPNPAT(DFN,DT)

           QUIT 

 +1       ;

PRINT     ;

 +1        SET BDP80D="-------------------------------------------------------------------------------"

 +2        SET BDPPG=0

 +3        IF '$DATA(^XTMP("BDPNODP",BDPJOB,BDPBTH))

               DO HEAD

               WRITE !!,"NO PATIENTS TO REPORT"

               GOTO DONE

 +4        DO HEAD

 +5        SET BDPPROV=0

           FOR 

               SET BDPPROV=$ORDER(^XTMP("BDPNODP",BDPJOB,BDPBTH,BDPPROV))

               IF BDPPROV=""!($DATA(BDPQ))

                   QUIT 

               Begin DoDot:1

 +6                FOR 

                       SET DFN=$ORDER(^XTMP("BDPNODP",BDPJOB,BDPBTH,BDPPROV,DFN))

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

                           QUIT 

                       DO DFN

               End DoDot:1

DONE       DO DONE^APCLOSUT

 +1        KILL ^XTMP("BDPNODP",BDPJOB,BDPBTH),BDPJOB,BDPBTH

 +2        QUIT 

DFN       ;

 +1        IF $Y>(IOSL-3)

               DO HEAD

               IF $DATA(BDPQ)

                   QUIT 

 +2        DO LVST

 +3        WRITE $EXTRACT($PIECE(^DPT(DFN,0),U),1,20),?24,$$UP^XLFSTR($$DOB^AUPNPAT(DFN,"E")),?40,$$HRN^AUPNPAT(DFN,DUZ(2)),?50,$EXTRACT($$COMMRES^AUPNPAT(DFN,"E"),1,15),?66,BDPDT,!

 +4        QUIT 

HEAD       IF 'BDPPG

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

                       QUIT 

HEAD1     ;

 +1        IF BDPPG

               IF $DATA(IOF)

                   WRITE @IOF

 +2        SET BDPPG=BDPPG+1

 +3        WRITE $PIECE(^VA(200,DUZ,0),U,2),?30,$$FMTE^XLFDT($$NOW^XLFDT),?70,"PAGE  "_BDPPG,!

 +4        WRITE ?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),!

 +5        WRITE $$CTR("PATIENTS WITH NO "_BDPCATN_" DESIGNATED PROVIDER",80),!

 +6        IF BDPSEAT

               WRITE !,$$CTR("SEARCH TEMPLATE USED: "_$PIECE(^DIBT(BDPSEAT,0),U,1),80),!

 +7        WRITE !?50,"CURRENT",!

 +8        WRITE "NAME",?24,"DOB",?40,"HRN",?50,"COMMUNITY",?66,"LAST VISIT",!,BDP80D,!

 +9        QUIT 

LVST      ;ENTRY POINT from [BDP PRIM PROV LISTING print template

 +1        SET BDPAST=""

 +2        SET BDPVDFN=""

 +3        SET BDPAST=$ORDER(^AUPNVSIT("AA",DFN,""))

 +4        IF BDPAST=""

               SET BDPAST="NONE FOUND"

               QUIT 

 +5        SET BDPVDFN=$ORDER(^AUPNVSIT("AA",DFN,BDPAST,""))

 +6        SET Y=$PIECE(^AUPNVSIT(BDPVDFN,0),U)

 +7        DO DD^%DT

           SET BDPDT=$EXTRACT(Y,1,12)

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