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
