BMCRR23.m

BMCRR23 ; IHS/OIT/FCJ - REPORT FOR CALL IN REFERRALS (1/2)

 ;;4.0;REFERRED CARE INFO SYSTEM;**12**;JAN 09, 2006;Build 101

 ;4.0*12 NEW ROUTINE

 ;NEW REPORT FOR GAO REQUIREMENT TO TRACK CALL IN REFERRALS

 ;

START ;

 D PCCTST S BMCJOB=$J

 K ^XTMP(BMCJOB,"BMCRR23")

 W:$D(IOF) @IOF

 W !,?14,"************* CHS Paid Referral Report *************"

 W !!,"Report will capture CHS Primary referrals. Report will sort by Call-in"

 W !,"Referrals. The CHS PO's must be final paid without out any Third Party"

 W !,"Payment. If the call-in notification date is not available the referral"

 W !,"will be checked for a PCC Visit to identify Call-in referrals."

 W !!,"If the PCC link was not on during anytime within reporting time"

 W !,"frame, this report MAY NOT be accurate for identifying Call-in referrals."

 I BMCPDT'="" D

 .W !!,"Facility does not use the PCC link, the earliest beginning date for report"

 .W !,"can be ",BMCPDT1,"."

 W !,!

BD ;get beginning date and ending dates

 K DIR("B")

 I BMCPDT'="" D

 .W ! S DIR(0)="D^"_BMCPDT_":DT:EP",DIR("A")="Enter beginning Referral Date" D ^DIR S:$D(DUOUT) DIRUT=1 K DIR S:$D(DUOUT) DIRUT=1

 .I $D(DIRUT) G EXIT

 .S BMCBD=Y

 .D ED^BMCRUTL

 E  D BD^BMCRUTL

 G:$D(DIRUT) EXIT

SELRPT ;REPORT TYPE CALL-IN, NON CALL-IN OR BOTH

 K DIR,DIC

 S DIR("A")="Report Type",DIR(0)="S^C:Call-in Referrals;N:Non Call-in Referrals;B:Both" S DIR("B")="Both"

 W !

 D ^DIR

 G BD:$D(DUOUT),EXIT:$D(DTOUT),EXIT:$D(DIROUT)

 S BMCRPT=Y

TYPE ; TYPE OF REPORT SUMARRY OR DETAILED

 ; Enter Summary or Detail

 S DIR(0)="S^S:SUMMARY;D:DETAILED",DIR("A")="Report Type ",DIR("B")="SUMMARY"

 S DIR("?")="Detail will display indiviual Referrals, Summary will display only the totals"

 D ^DIR

 G SELRPT:$D(DUOUT),EXIT:$D(DTOUT),EXIT:$D(DIROUT)

 S BMCRTYP=Y

FILE ;CREATE A FILE

 S %=$$DIR^XBDIR("Y","Create a file","N","","","^D HELP^ACHS(""H2"",""ACHSVUR2"")",2)

 G TYPE:$D(DUOUT),EXIT:$D(DTOUT)

 S BMCFIL=$S(%:"Y",1:"N")

ZIS ;call to XBDBQUE

 K BMCOPT

 W ! 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) S BMCQUIT="" Q

 S BMCOPT=Y

 G:$G(BMCQUIT) FILE

 I $G(BMCOPT)="B" D BROWSE,EXIT Q

 S XBRP="^BMCRR23P",XBRC="STPROC^BMCRR23",XBRX="EXIT^BMCRR23",XBNS="BMC"

 D ^XBDBQUE

 Q

BROWSE ;

 S XBRP="VIEWR^XBLM(""^BMCRR23P"")"

 S XBRC="STPROC^BMCRR23",XBIOP=0 D ^XBDBQUE

 Q

FIL2 ;CREATE THE FILE

 D FILHDR^BMCRR23P

 D FILSUM^BMCRR23P

 D FILSAV^BMCRR23P

 Q

EXIT ;

 I $D(BMCFIL) D:BMCFIL="Y" FIL2

 D KILL^AUPNPAT

 K BMC80D,BMC80E,BMCBT,BMCBTH,BMCET,BMCOPT,BMCPG,BMCQUIT,BMCRCNT,BMCREF,BMCRREC,BMCSORT,BMCSTYPE

 K BMCBD,BMCED,BMCBDD,BMCEDD,BMCSD,BMCRTYP,BMCFIL,BMCRTH,BMCCHS,BMCHIT,BMCJOB,BMCODAT,BMCPDT,BMCRPT

 K BMCCFC,BMCCHS0,BMCCPO,BMCPOC,BMCR,BMCRCDAY,BMCRCTOT,BMCREC,BMCRPO,BMCRRDAY,BMCRRTOT,BMCRTOT,BMCSRTH,BMCTAVG

 K DA,DFN,DIR,X,Y

 K ^XTMP($J,"BMCRR23")

 Q

PCCTST ;IF SITE DOES NOT USE PCC LINK THE EARLIEST DATE FOR REPORT WILL BE WHEN V4 P12 WAS INSTALLED

 S BMCPDT="",BMCPDT=""

 I $P(^BMCPARM(DUZ(2),0),U,3)<1 S BMCPDT=$P(^BMCPARM(DUZ(2),4100),U,12),Y=BMCPDT D DD^%DT S BMCPDT1=Y

 Q

STPROC ;

 S (BMCBT,BMCBTH)=$H,BMCRCNT=0

 D PROCESS,END

 Q

 ;

PROCESS ;

 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

 Q

 ;

R1 ;

 S BMCREF=""

 F  S BMCREF=$O(^BMCREF("B",BMCODAT,BMCREF)) Q:BMCREF'=+BMCREF  S BMCRREC=^BMCREF(BMCREF,0) D PROCESS2

 Q

 ;

END ;

 S BMCET=$H

 Q

PROCESS2 ;

 S BMCRREC=^BMCREF(BMCREF,0),DFN=$P(BMCRREC,U,3),BMCSORT="R"

 ;TEST FOR CHS REFERRAL

 Q:$P(BMCRREC,U,4)'="C"

 ;TEST FOR PRIMARY REFERRAL

 Q:$P($G(^BMCREF(BMCREF,1)),U)'=""

 ;TEST FOR PO AND PAID

 Q:($P($G(^BMCREF(BMCREF,11)),U,15)<1)&($P($G(^BMCREF(BMCREF,11)),U,16)<0)

 ;TEST FOR 0 THIRD PARTY PAY, FINAL PAY AND FIRST PO ENTERED

 S L=0,BMCCHS="",BMCHIT=""

 S L=$O(^BMCREF(BMCREF,41,L)) Q:L'?1N.N  D

 .S BMCCHS=$P(^BMCREF(BMCREF,41,L,0),U)

 .Q:$P($G(^ACHSF(DUZ(2),"D",BMCCHS,"PA")),U,5)>0

 .S:$P($G(^ACHSF(DUZ(2),"D",BMCCHS,"PA")),U,4)="F" BMCHIT=1

 Q:BMCHIT<1

 ;NOTIFICATION or PCC VISIT - Will be considered a call in if PCC link is on

 I BMCPDT,$P($G(^BMCREF(BMCREF,1)),U,4)'="" S BMCSORT="C" G SET   ;PCC LINK AND CALL IN

 I ($P($G(^BMCREF(BMCREF,1)),U,4)'="")!($P($G(^BMCREF(BMCREF,13)),U,9)="") S BMCSORT="C"  ;CALLIN OR NO VISIT

SET ;

 Q:((BMCSORT="C")&(BMCRPT="N"))

 Q:((BMCSORT="R")&(BMCRPT="C"))

 Q:$P(^BMCREF(BMCREF,0),U,5)'=DUZ(2)

 S ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"DATA HITS",DUZ(2),BMCSORT,BMCREF)="",BMCRCNT=BMCRCNT+1

 Q

BMCRR23   ; IHS/OIT/FCJ - REPORT FOR CALL IN REFERRALS (1/2)

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;**12**;JAN 09, 2006;Build 101

 +2       ;4.0*12 NEW ROUTINE

 +3       ;NEW REPORT FOR GAO REQUIREMENT TO TRACK CALL IN REFERRALS

 +4       ;

START     ;

 +1        DO PCCTST

           SET BMCJOB=$JOB

 +2        KILL ^XTMP(BMCJOB,"BMCRR23")

 +3        IF $DATA(IOF)

               WRITE @IOF

 +4        WRITE !,?14,"************* CHS Paid Referral Report *************"

 +5        WRITE !!,"Report will capture CHS Primary referrals. Report will sort by Call-in"

 +6        WRITE !,"Referrals. The CHS PO's must be final paid without out any Third Party"

 +7        WRITE !,"Payment. If the call-in notification date is not available the referral"

 +8        WRITE !,"will be checked for a PCC Visit to identify Call-in referrals."

 +9        WRITE !!,"If the PCC link was not on during anytime within reporting time"

 +10       WRITE !,"frame, this report MAY NOT be accurate for identifying Call-in referrals."

 +11       IF BMCPDT'=""

               Begin DoDot:1

 +12               WRITE !!,"Facility does not use the PCC link, the earliest beginning date for report"

 +13               WRITE !,"can be ",BMCPDT1,"."

               End DoDot:1

 +14       WRITE !,!

BD        ;get beginning date and ending dates

 +1        KILL DIR("B")

 +2        IF BMCPDT'=""

               Begin DoDot:1

 +3                WRITE !

                   SET DIR(0)="D^"_BMCPDT_":DT:EP"

                   SET DIR("A")="Enter beginning Referral Date"

                   DO ^DIR

                   IF $DATA(DUOUT)

                       SET DIRUT=1

                   KILL DIR

                   IF $DATA(DUOUT)

                       SET DIRUT=1

 +4                IF $DATA(DIRUT)

                       GOTO EXIT

 +5                SET BMCBD=Y

 +6                DO ED^BMCRUTL

               End DoDot:1

 +7       IF '$TEST

               DO BD^BMCRUTL

 +8        IF $DATA(DIRUT)

               GOTO EXIT

SELRPT    ;REPORT TYPE CALL-IN, NON CALL-IN OR BOTH

 +1        KILL DIR,DIC

 +2        SET DIR("A")="Report Type"

           SET DIR(0)="S^C:Call-in Referrals;N:Non Call-in Referrals;B:Both"

           SET DIR("B")="Both"

 +3        WRITE !

 +4        DO ^DIR

 +5        IF $DATA(DUOUT)

               GOTO BD

           IF $DATA(DTOUT)

               GOTO EXIT

           IF $DATA(DIROUT)

               GOTO EXIT

 +6        SET BMCRPT=Y

TYPE      ; TYPE OF REPORT SUMARRY OR DETAILED

 +1       ; Enter Summary or Detail

 +2        SET DIR(0)="S^S:SUMMARY;D:DETAILED"

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

           SET DIR("B")="SUMMARY"

 +3        SET DIR("?")="Detail will display indiviual Referrals, Summary will display only the totals"

 +4        DO ^DIR

 +5        IF $DATA(DUOUT)

               GOTO SELRPT

           IF $DATA(DTOUT)

               GOTO EXIT

           IF $DATA(DIROUT)

               GOTO EXIT

 +6        SET BMCRTYP=Y

FILE      ;CREATE A FILE

 +1        SET %=$$DIR^XBDIR("Y","Create a file","N","","","^D HELP^ACHS(""H2"",""ACHSVUR2"")",2)

 +2        IF $DATA(DUOUT)

               GOTO TYPE

           IF $DATA(DTOUT)

               GOTO EXIT

 +3        SET BMCFIL=$SELECT(%:"Y",1:"N")

ZIS       ;call to XBDBQUE

 +1        KILL BMCOPT

 +2        WRITE !

           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

 +3        IF $DATA(DIRUT)

               SET BMCQUIT=""

               QUIT 

 +4        SET BMCOPT=Y

 +5        IF $GET(BMCQUIT)

               GOTO FILE

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

               DO BROWSE

               DO EXIT

               QUIT 

 +7        SET XBRP="^BMCRR23P"

           SET XBRC="STPROC^BMCRR23"

           SET XBRX="EXIT^BMCRR23"

           SET XBNS="BMC"

 +8        DO ^XBDBQUE

 +9        QUIT 

BROWSE    ;

 +1        SET XBRP="VIEWR^XBLM(""^BMCRR23P"")"

 +2        SET XBRC="STPROC^BMCRR23"

           SET XBIOP=0

           DO ^XBDBQUE

 +3        QUIT 

FIL2      ;CREATE THE FILE

 +1        DO FILHDR^BMCRR23P

 +2        DO FILSUM^BMCRR23P

 +3        DO FILSAV^BMCRR23P

 +4        QUIT 

EXIT      ;

 +1        IF $DATA(BMCFIL)

               IF BMCFIL="Y"

                   DO FIL2

 +2        DO KILL^AUPNPAT

 +3        KILL BMC80D,BMC80E,BMCBT,BMCBTH,BMCET,BMCOPT,BMCPG,BMCQUIT,BMCRCNT,BMCREF,BMCRREC,BMCSORT,BMCSTYPE

 +4        KILL BMCBD,BMCED,BMCBDD,BMCEDD,BMCSD,BMCRTYP,BMCFIL,BMCRTH,BMCCHS,BMCHIT,BMCJOB,BMCODAT,BMCPDT,BMCRPT

 +5        KILL BMCCFC,BMCCHS0,BMCCPO,BMCPOC,BMCR,BMCRCDAY,BMCRCTOT,BMCREC,BMCRPO,BMCRRDAY,BMCRRTOT,BMCRTOT,BMCSRTH,BMCTAVG

 +6        KILL DA,DFN,DIR,X,Y

 +7        KILL ^XTMP($JOB,"BMCRR23")

 +8        QUIT 

PCCTST    ;IF SITE DOES NOT USE PCC LINK THE EARLIEST DATE FOR REPORT WILL BE WHEN V4 P12 WAS INSTALLED

 +1        SET BMCPDT=""

           SET BMCPDT=""

 +2        IF $PIECE(^BMCPARM(DUZ(2),0),U,3)<1

               SET BMCPDT=$PIECE(^BMCPARM(DUZ(2),4100),U,12)

               SET Y=BMCPDT

               DO DD^%DT

               SET BMCPDT1=Y

 +3        QUIT 

STPROC    ;

 +1        SET (BMCBT,BMCBTH)=$HOROLOG

           SET BMCRCNT=0

 +2        DO PROCESS

           DO END

 +3        QUIT 

 +4       ;

PROCESS   ;

 +1        SET BMCODAT=$ORDER(^BMCREF("B",BMCSD))

           IF BMCODAT=""

               SET BMCET=$HOROLOG

               QUIT 

 +2        SET BMCODAT=BMCSD_".9999"

 +3        FOR 

               SET BMCODAT=$ORDER(^BMCREF("B",BMCODAT))

               IF BMCODAT=""!((BMCODAT\1)>BMCED)

                   QUIT 

               DO R1

 +4        QUIT 

 +5       ;

R1        ;

 +1        SET BMCREF=""

 +2        FOR 

               SET BMCREF=$ORDER(^BMCREF("B",BMCODAT,BMCREF))

               IF BMCREF'=+BMCREF

                   QUIT 

               SET BMCRREC=^BMCREF(BMCREF,0)

               DO PROCESS2

 +3        QUIT 

 +4       ;

END       ;

 +1        SET BMCET=$HOROLOG

 +2        QUIT 

PROCESS2  ;

 +1        SET BMCRREC=^BMCREF(BMCREF,0)

           SET DFN=$PIECE(BMCRREC,U,3)

           SET BMCSORT="R"

 +2       ;TEST FOR CHS REFERRAL

 +3        IF $PIECE(BMCRREC,U,4)'="C"

               QUIT 

 +4       ;TEST FOR PRIMARY REFERRAL

 +5        IF $PIECE($GET(^BMCREF(BMCREF,1)),U)'=""

               QUIT 

 +6       ;TEST FOR PO AND PAID

 +7        IF ($PIECE($GET(^BMCREF(BMCREF,11)),U,15)<1)&($PIECE($GET(^BMCREF(BMCREF,11)),U,16)<0)

               QUIT 

 +8       ;TEST FOR 0 THIRD PARTY PAY, FINAL PAY AND FIRST PO ENTERED

 +9        SET L=0

           SET BMCCHS=""

           SET BMCHIT=""

 +10       SET L=$ORDER(^BMCREF(BMCREF,41,L))

           IF L'?1N.N

               QUIT 

           Begin DoDot:1

 +11           SET BMCCHS=$PIECE(^BMCREF(BMCREF,41,L,0),U)

 +12           IF $PIECE($GET(^ACHSF(DUZ(2),"D",BMCCHS,"PA")),U,5)>0

                   QUIT 

 +13           IF $PIECE($GET(^ACHSF(DUZ(2),"D",BMCCHS,"PA")),U,4)="F"

                   SET BMCHIT=1

           End DoDot:1

 +14       IF BMCHIT<1

               QUIT 

 +15      ;NOTIFICATION or PCC VISIT - Will be considered a call in if PCC link is on

 +16      ;PCC LINK AND CALL IN

           IF BMCPDT

               IF $PIECE($GET(^BMCREF(BMCREF,1)),U,4)'=""

                   SET BMCSORT="C"

                   GOTO SET

 +17      ;CALLIN OR NO VISIT

           IF ($PIECE($GET(^BMCREF(BMCREF,1)),U,4)'="")!($PIECE($GET(^BMCREF(BMCREF,13)),U,9)="")

               SET BMCSORT="C"

SET       ;

 +1        IF ((BMCSORT="C")&(BMCRPT="N"))

               QUIT 

 +2        IF ((BMCSORT="R")&(BMCRPT="C"))

               QUIT 

 +3        IF $PIECE(^BMCREF(BMCREF,0),U,5)'=DUZ(2)

               QUIT 

 +4        SET ^XTMP(BMCJOB,"BMCRR23",BMCBTH,"DATA HITS",DUZ(2),BMCSORT,BMCREF)=""

           SET BMCRCNT=BMCRCNT+1

 +5        QUIT