BMCRRNDA ; IHS/PHXAO/TMJ - NUMBER OF DAYS AUTHORIZED ;
;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
;
START ;
S BMCJOB=$J,BMCBTH=$H
W !!,"This report will tally all in-house referrals by provider of service.",!!
D ;DATE RANGE
BD ;get beginning date
W ! S DIR(0)="D^::EP",DIR("A")="Enter beginning Date of Modification" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G XIT
S BMCBD=Y
ED ;get ending date
W ! S DIR(0)="D^"_BMCBD_"::EP",DIR("A")="Enter ending Date of Modification" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G BD
S BMCED=Y
S X1=BMCBD,X2=-1 D C^%DTC S BMCSD=X
;
PAT ;Get Patient
S BMCPAT="" S DIR(0)="S^A:ALL Patients;O:ONE Patient",DIR("A")="Report should tally referrals for ",DIR("B")="A" K DA D ^DIR K DIR
G:$D(DIRUT) D
I Y="O" D GETPAT G:BMCPAT="" PAT
ZIS ;
S XBRP="PRINT^BMCRRNDA",XBRC="PROC^BMCRRNDA",XBRX="XIT^BMCRRNDA",XBNS="BMC" ;IHS/TUCSON/LAB - changed XBNX to XBNS - 05/30/97
D ^XBDBQUE
D XIT
Q
XIT ;EP
K BMCPAT,BMCREF,BMCODAT,BMCBD,BMCED,BMCSD,BMCQUIT,BMCPG,BMCCLIN,BMCBT,BMCBTH,BMCET,BMCRREC,C,D,DFN,DIC,DIRUT,P,X,X1,X2,BMCSTOT
D KILL^AUPNPAT
Q
GETPAT ;
PATIENT ; GET PATIENT
F D PATIENT2 I BMCQ!($G(BMCDFN)) Q
Q
;
PATIENT2 ; ASK FOR PATIENT UNTIL USER SELECTS OR QUITS
S BMCQ=1
S DIC="^AUPNPAT(",DIC(0)="AEMQ" D DIC^BMCFMC
Q:Y<1
S BMCDFN=+Y,BMCREC("PAT NAME")=$P(^DPT(+Y,0),U)
S BMCQ=0
I $$DOD^AUPNPAT(BMCDFN) D I 'Y K BMCDFN,BMCREC("PAT NAME") Q
. W !!,"This patient is deceased."
. S DIR(0)="YO",DIR("A")="Are you sure you want this patient",DIR("B")="NO" K DA D ^DIR K DIR
. W !
. Q
S BMCPAT=+Y
Q
;
PROC ;EP called from xbdbque
S BMCBT=$H
S BMCODAT=$O(^BMCREF("B",BMCSD)) I BMCODAT="" S BMCET=$H Q
S BMCODAT=BMCSD_".9999" F S BMCODAT=$O(^BMCREF("B",BMCODAT)) Q:BMCODAT=""!((BMCODAT\1)>BMCED) D R1
END ;
S BMCET=$H
Q
R1 ;
S BMCREF="" F S BMCREF=$O(^BMCREF("B",BMCODAT,BMCREF)) Q:BMCREF'=+BMCREF I $P(^BMCREF(BMCREF,0),U,4)'="N" S BMCRREC=^BMCREF(BMCREF,0),DFN=$P(BMCRREC,U,3) D PROCR
Q
PROCR ;
;I BMCPAT,$P(BMCRREC,U,3)'=BMCPAT Q
S P=$P(BMCRREC,U,3)
S BMCPAT=P
;S C=$S(C:$P(^DIC(40.7,C,0),U),1:"<UNKNOWN>")
S P=$S(P:$P(^DPT(P,0),U),1:"<UNKNOWN>")
;S ^(C)=$S($D(^XTMP("BMCRRNDA",BMCJOB,BMCBTH,"PAT",P)):^(C)+1,1:1)
Q:$P(BMCRREC,U,15)'="A" ; QUIT IF NOT ACTIVE
Q:$P($G(^BMCREF(BMCREF,11)),U,11)<2 ;QUIT IF NO ADDITIONAL VISITS AUTHORIZED
Q:$P($G(^BMCREF(BMCREF,11)),U,26)="" ; QUIT OF NO MODIFIED DT
S ^XTMP("BMCRRNDA",BMCJOB,BMCBTH,"PATIENT",P,BMCPAT,BMCREF)=""
Q
PRINT ;EP called from xbdbque
S BMCPG=0 D @("HEAD"_(2-($E(IOST,1,2)="C-")))
S BMCQUIT=0
I '$D(^XTMP("BMCRRNDA",BMCJOB,BMCBTH)) W !!,"No # DAYS AUHTORIZED FOR THIS RUN",! G DONE
S BMCPAT="" F S BMCPAT=$O(^XTMP("BMCRRNDA",BMCJOB,BMCBTH,"PAT",BMCPAT)) Q:BMCPAT=""!(BMCQUIT) D PATNAME
DONE ;
K ^XTMP("BMCRRNDA",BMCJOB,BMCBTH)
D DONE^BMCRLP2
Q
PATNAME ;
I $Y>(IOSL-5) D HEAD Q:BMCQUIT
W !!,BMCPAT S BMCSTOT=0
S BMCPATN="" F S BMCPATN=$O(^XTMP("BMCRRNDA",BMCJOB,BMCBTH,"PAT",BMCPAT,BMCPATN)) Q:BMCPATN=""!(BMCQUIT) D
.I $Y>(IOSL-5) D HEAD Q:BMCQUIT
.W !?25,BMCPATN,?55,$J(^XTMP("BMCRRNDA",BMCJOB,BMCBTH,"PAT",BMCPAT,BMCPATN),5) S BMCSTOT=BMCSTOT+^(BMCPATN)
.Q
I $Y>(IOSL-5) D HEAD Q:BMCQUIT
W !!,"Total for ",BMCPAT,?55,$J(BMCSTOT,5)
Q
HEAD ;
I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BMCQUIT=1 Q
HEAD1 ;
W:$D(IOF) @IOF
HEAD2 ;
S BMCPG=BMCPG+1
W !?55,$$FMTE^XLFDT(DT),?72,"Page ",BMCPG,!
W ?20,"IN-HOUSE REFERRALS BY PATIDER",!
W ?14,"REFERRAL DATE RANGE: ",$$FMTE^XLFDT(BMCBD)," to ",$$FMTE^XLFDT(BMCED)
W !!,"PATIDER",?25,"CLINIC REFERRED TO",?55,"NUMBER"
W !,$TR($J(" ",80)," ","-")
Q
BMCRRNDA ; IHS/PHXAO/TMJ - NUMBER OF DAYS AUTHORIZED ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
+2 ;
START ;
+1 SET BMCJOB=$JOB
SET BMCBTH=$HOROLOG
+2 WRITE !!,"This report will tally all in-house referrals by provider of service.",!!
D ;DATE RANGE
BD ;get beginning date
+1 WRITE !
SET DIR(0)="D^::EP"
SET DIR("A")="Enter beginning Date of Modification"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO XIT
+3 SET BMCBD=Y
ED ;get ending date
+1 WRITE !
SET DIR(0)="D^"_BMCBD_"::EP"
SET DIR("A")="Enter ending Date of Modification"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO BD
+3 SET BMCED=Y
+4 SET X1=BMCBD
SET X2=-1
DO C^%DTC
SET BMCSD=X
+5 ;
PAT ;Get Patient
+1 SET BMCPAT=""
SET DIR(0)="S^A:ALL Patients;O:ONE Patient"
SET DIR("A")="Report should tally referrals for "
SET DIR("B")="A"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
GOTO D
+3 IF Y="O"
DO GETPAT
IF BMCPAT=""
GOTO PAT
ZIS ;
+1 ;IHS/TUCSON/LAB - changed XBNX to XBNS - 05/30/97
SET XBRP="PRINT^BMCRRNDA"
SET XBRC="PROC^BMCRRNDA"
SET XBRX="XIT^BMCRRNDA"
SET XBNS="BMC"
+2 DO ^XBDBQUE
+3 DO XIT
+4 QUIT
XIT ;EP
+1 KILL BMCPAT,BMCREF,BMCODAT,BMCBD,BMCED,BMCSD,BMCQUIT,BMCPG,BMCCLIN,BMCBT,BMCBTH,BMCET,BMCRREC,C,D,DFN,DIC,DIRUT,P,X,X1,X2,BMCSTOT
+2 DO KILL^AUPNPAT
+3 QUIT
GETPAT ;
PATIENT ; GET PATIENT
+1 FOR
DO PATIENT2
IF BMCQ!($GET(BMCDFN))
QUIT
+2 QUIT
+3 ;
PATIENT2 ; ASK FOR PATIENT UNTIL USER SELECTS OR QUITS
+1 SET BMCQ=1
+2 SET DIC="^AUPNPAT("
SET DIC(0)="AEMQ"
DO DIC^BMCFMC
+3 IF Y<1
QUIT
+4 SET BMCDFN=+Y
SET BMCREC("PAT NAME")=$PIECE(^DPT(+Y,0),U)
+5 SET BMCQ=0
+6 IF $$DOD^AUPNPAT(BMCDFN)
Begin DoDot:1
+7 WRITE !!,"This patient is deceased."
+8 SET DIR(0)="YO"
SET DIR("A")="Are you sure you want this patient"
SET DIR("B")="NO"
KILL DA
DO ^DIR
KILL DIR
+9 WRITE !
+10 QUIT
End DoDot:1
IF 'Y
KILL BMCDFN,BMCREC("PAT NAME")
QUIT
+11 SET BMCPAT=+Y
+12 QUIT
+13 ;
PROC ;EP called from xbdbque
+1 SET BMCBT=$HOROLOG
+2 SET BMCODAT=$ORDER(^BMCREF("B",BMCSD))
IF BMCODAT=""
SET BMCET=$HOROLOG
QUIT
+3 SET BMCODAT=BMCSD_".9999"
FOR
SET BMCODAT=$ORDER(^BMCREF("B",BMCODAT))
IF BMCODAT=""!((BMCODAT\1)>BMCED)
QUIT
DO R1
END ;
+1 SET BMCET=$HOROLOG
+2 QUIT
R1 ;
+1 SET BMCREF=""
FOR
SET BMCREF=$ORDER(^BMCREF("B",BMCODAT,BMCREF))
IF BMCREF'=+BMCREF
QUIT
IF $PIECE(^BMCREF(BMCREF,0),U,4)'="N"
SET BMCRREC=^BMCREF(BMCREF,0)
SET DFN=$PIECE(BMCRREC,U,3)
DO PROCR
+2 QUIT
PROCR ;
+1 ;I BMCPAT,$P(BMCRREC,U,3)'=BMCPAT Q
+2 SET P=$PIECE(BMCRREC,U,3)
+3 SET BMCPAT=P
+4 ;S C=$S(C:$P(^DIC(40.7,C,0),U),1:"<UNKNOWN>")
+5 SET P=$SELECT(P:$PIECE(^DPT(P,0),U),1:"<UNKNOWN>")
+6 ;S ^(C)=$S($D(^XTMP("BMCRRNDA",BMCJOB,BMCBTH,"PAT",P)):^(C)+1,1:1)
+7 ; QUIT IF NOT ACTIVE
IF $PIECE(BMCRREC,U,15)'="A"
QUIT
+8 ;QUIT IF NO ADDITIONAL VISITS AUTHORIZED
IF $PIECE($GET(^BMCREF(BMCREF,11)),U,11)<2
QUIT
+9 ; QUIT OF NO MODIFIED DT
IF $PIECE($GET(^BMCREF(BMCREF,11)),U,26)=""
QUIT
+10 SET ^XTMP("BMCRRNDA",BMCJOB,BMCBTH,"PATIENT",P,BMCPAT,BMCREF)=""
+11 QUIT
PRINT ;EP called from xbdbque
+1 SET BMCPG=0
DO @("HEAD"_(2-($EXTRACT(IOST,1,2)="C-")))
+2 SET BMCQUIT=0
+3 IF '$DATA(^XTMP("BMCRRNDA",BMCJOB,BMCBTH))
WRITE !!,"No # DAYS AUHTORIZED FOR THIS RUN",!
GOTO DONE
+4 SET BMCPAT=""
FOR
SET BMCPAT=$ORDER(^XTMP("BMCRRNDA",BMCJOB,BMCBTH,"PAT",BMCPAT))
IF BMCPAT=""!(BMCQUIT)
QUIT
DO PATNAME
DONE ;
+1 KILL ^XTMP("BMCRRNDA",BMCJOB,BMCBTH)
+2 DO DONE^BMCRLP2
+3 QUIT
PATNAME ;
+1 IF $Y>(IOSL-5)
DO HEAD
IF BMCQUIT
QUIT
+2 WRITE !!,BMCPAT
SET BMCSTOT=0
+3 SET BMCPATN=""
FOR
SET BMCPATN=$ORDER(^XTMP("BMCRRNDA",BMCJOB,BMCBTH,"PAT",BMCPAT,BMCPATN))
IF BMCPATN=""!(BMCQUIT)
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-5)
DO HEAD
IF BMCQUIT
QUIT
+5 WRITE !?25,BMCPATN,?55,$JUSTIFY(^XTMP("BMCRRNDA",BMCJOB,BMCBTH,"PAT",BMCPAT,BMCPATN),5)
SET BMCSTOT=BMCSTOT+^(BMCPATN)
+6 QUIT
End DoDot:1
+7 IF $Y>(IOSL-5)
DO HEAD
IF BMCQUIT
QUIT
+8 WRITE !!,"Total for ",BMCPAT,?55,$JUSTIFY(BMCSTOT,5)
+9 QUIT
HEAD ;
+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 BMCQUIT=1
QUIT
HEAD1 ;
+1 IF $DATA(IOF)
WRITE @IOF
HEAD2 ;
+1 SET BMCPG=BMCPG+1
+2 WRITE !?55,$$FMTE^XLFDT(DT),?72,"Page ",BMCPG,!
+3 WRITE ?20,"IN-HOUSE REFERRALS BY PATIDER",!
+4 WRITE ?14,"REFERRAL DATE RANGE: ",$$FMTE^XLFDT(BMCBD)," to ",$$FMTE^XLFDT(BMCED)
+5 WRITE !!,"PATIDER",?25,"CLINIC REFERRED TO",?55,"NUMBER"
+6 WRITE !,$TRANSLATE($JUSTIFY(" ",80)," ","-")
+7 QUIT
