BMCRRNDA.m

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