BCHRC8.m

BCHRC8 ; IHS/CMI/LAB - CHR Report 2 ; 

 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27

 ;IHS/CMI/LAB - tmp to xtmp

 ;

 I '$G(DUZ(2)) W $C(7),$C(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER!!",!! Q

 S BCHJOB=$J,BCHBTH=$H

 D INFORM

GETDATES ;

BD ;get beginning date

 W ! S DIR(0)="D^:DT:EP",DIR("A")="Enter BEGINNING Date of Service for Report" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G XIT

 S BCHBD=Y

ED ;get ending date

 W ! S DIR(0)="D^"_BCHBD_":DT:EP",DIR("A")="Enter ENDING Date of Service for Report" S Y=BCHBD D DD^%DT S DIR("B")=Y,Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) G BD

 S BCHED=Y

 S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X

 ;

TYPE ;

 S BCHRPT=""

 S DIR(0)="S^PG:By PROGRAM (Report 8);PR:By PROVIDER (Report 8.2)",DIR("A")="Which report do you wish to run",DIR("B")="PG" K DA D ^DIR K DIR

 I $D(DIRUT) G GETDATES

 S BCHRPT=Y

 D @Y

PROG ;IHS/CMI/LAB - added program screen

 S BCHPRG=""

 S DIR(0)="Y",DIR("A")="Include data from ALL CHR Programs",DIR("B")="N",DIR("?")="If you wish to include visits from ALL programs answer Yes.  If you wish to tabulate for only one program enter NO." D ^DIR K DIR

 G:$D(DIRUT) TYPE

 I Y=1 S BCHPRG="" G REG

PROG1 ;enter program

 K X,DIC,DA,DD,DR,Y S DIC("A")="Which CHR Program: ",DIC="^BCHTPROG(",DIC(0)="AEMQ" D ^DIC K DIC,DA G:Y<0 PROG

 S BCHPRG=+Y

REG ;

 S BCHREG="",BCHREGN=""

 S DIR(0)="S^R:Registered Patients;N:Non-Registered Patients;B:Both Registered and Non-Registered Patients",DIR("A")="Include which Patients",DIR("B")="B" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G PROG

 S BCHREG=Y,BCHREGN=Y(0)

ZIS ;CALL TO XBDBQUE

 S XBRP="^BCHRC8P",XBRC="PROC^BCHRC8",XBRX="XIT^BCHRC8",XBNS="BCH"

 D ^XBDBQUE

 D XIT

 Q

ERR W $C(7),$C(7),!,"Must be a valid date and be Today or earlier. Time not allowed!" Q

XIT ;

 K BCHPRG,BCHNONE,BCHFT,BCHF,BCHT,BCHREF,BCHQUIT,BCHJOB,BCHBTH,BCHBT,BCHET,BCHBD,BCHED,BCHBDD,BCHEDD,BCHSD,BCHODAT,BCHPROG,BCHX,BCHR,BCHR0,BCHPG,BCHDT,BCHIDAT,BCHMON,BCHTOT,BCHCH,BCHITEM,BCHNAME,BCHRN,BCHRPT,BCHBRK,BCHEOJ

 K M,R,V,X,Y,I

 K X,Y

 Q

 ;

INFORM ;

 W:$D(IOF) @IOF

 W !?20,"**********  CHR REPORT NO. 8  **********"

 W !!?20,"HOURS (SERVICE+TRAVEL) BY MONTH",!!,"You must enter the time frame and the program for which the report",!,"will be run.",!!

 Q

 ;

 ;

PROC ;EP - PROCESS REFERRAL REPORT

 D XTMP^BCHUTIL("BCHRC8","CHR CHR REPORT")

 S (BCHBT,BCHBTH)=$H,BCHJOB=$J

 D D,EOJ

 Q

 ;

EOJ ;

 S BCHET=$H

 Q

D ; Run by date of service

 S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X

 S BCHODAT=BCHSD_".9999" F  S BCHODAT=$O(^BCHR("B",BCHODAT)) Q:BCHODAT=""!((BCHODAT\1)>BCHED)  D D1

 Q

 ;

D1 ;

 S (BCHR,BCHRCNT)=0 F  S BCHR=$O(^BCHR("B",BCHODAT,BCHR)) Q:BCHR'=+BCHR  I $D(^BCHR(BCHR,0)),$P(^(0),U,2)]"",$P(^(0),U,3)]"" S BCHR0=^(0) D PROCESS

 Q

PROCESS ;

 S BCHPAT=$P(BCHR0,U,4)

 S BCHNRPAT=$P($G(^BCHR(BCHR,11)),U,12)

 ;BI 'BCHPAT,'BCHNRPAT Q   ;no patient

 I BCHREG="R",BCHPAT="" Q

 I BCHREG="N",BCHNRPAT="" Q

 I BCHPAT,BCHNRPAT S BCHNRPAT=""

 I BCHPAT Q:'$D(^DPT(BCHPAT,0))

 S BCHPROG=$P(BCHR0,U,2)

 I BCHPRG,BCHPRG'=BCHPROG Q

 I BCHRPT="PR" S BCHITEM=$P(BCHR0,U,3)

 I BCHRPT="PG" S BCHITEM=BCHPROG

 S BCHDATE=$P(BCHR0,U) S Y=BCHDATE D DD^%DT S BCHMON=$P(Y," ")_$P(Y,",",2),X=BCHMON,%DT="" D ^%DT S BCHIDAT=Y

 S BCHTOT=$P(BCHR0,U,27)+$P(BCHR0,U,11),BCHS=$P(BCHR0,U,27),BCHT=$P(BCHR0,U,11)

 S $P(^(BCHMON),U)=$S($D(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"MONTHS",BCHIDAT,BCHMON)):$P(^(BCHMON),U)+BCHTOT,1:BCHTOT)

 S $P(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"MONTHS",BCHIDAT,BCHMON),U,2)=$P(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"MONTHS",BCHIDAT,BCHMON),U,2)+BCHS

 S $P(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"MONTHS",BCHIDAT,BCHMON),U,3)=$P(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"MONTHS",BCHIDAT,BCHMON),U,3)+BCHT

 S $P(^("TOTAL"),U)=$S($D(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"TOTAL")):$P(^("TOTAL"),U)+BCHTOT,1:BCHTOT)

 S $P(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"TOTAL"),U,2)=$P(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"TOTAL"),U,2)+BCHS

 S $P(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"TOTAL"),U,3)=$P(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"TOTAL"),U,3)+BCHT

 Q

PG ;

 S BCHRN=8,BCHCH="PROGRAM"

 Q

PR ;

 S BCHRN=8.2,BCHCH="PROVIDER"

 Q

BCHRC8    ; IHS/CMI/LAB - CHR Report 2 ; 

 +1       ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27

 +2       ;IHS/CMI/LAB - tmp to xtmp

 +3       ;

 +4        IF '$GET(DUZ(2))

               WRITE $CHAR(7),$CHAR(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER!!",!!

               QUIT 

 +5        SET BCHJOB=$JOB

           SET BCHBTH=$HOROLOG

 +6        DO INFORM

GETDATES  ;

BD        ;get beginning date

 +1        WRITE !

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

           SET DIR("A")="Enter BEGINNING Date of Service for Report"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO XIT

 +3        SET BCHBD=Y

ED        ;get ending date

 +1        WRITE !

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

           SET DIR("A")="Enter ENDING Date of Service for Report"

           SET Y=BCHBD

           DO DD^%DT

           SET DIR("B")=Y

           SET Y=""

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +2        IF $DATA(DIRUT)

               GOTO BD

 +3        SET BCHED=Y

 +4        SET X1=BCHBD

           SET X2=-1

           DO C^%DTC

           SET BCHSD=X

 +5       ;

TYPE      ;

 +1        SET BCHRPT=""

 +2        SET DIR(0)="S^PG:By PROGRAM (Report 8);PR:By PROVIDER (Report 8.2)"

           SET DIR("A")="Which report do you wish to run"

           SET DIR("B")="PG"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO GETDATES

 +4        SET BCHRPT=Y

 +5        DO @Y

PROG      ;IHS/CMI/LAB - added program screen

 +1        SET BCHPRG=""

 +2        SET DIR(0)="Y"

           SET DIR("A")="Include data from ALL CHR Programs"

           SET DIR("B")="N"

           SET DIR("?")="If you wish to include visits from ALL programs answer Yes.  If you wish to tabulate for only one program enter NO."

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO TYPE

 +4        IF Y=1

               SET BCHPRG=""

               GOTO REG

PROG1     ;enter program

 +1        KILL X,DIC,DA,DD,DR,Y

           SET DIC("A")="Which CHR Program: "

           SET DIC="^BCHTPROG("

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC,DA

           IF Y<0

               GOTO PROG

 +2        SET BCHPRG=+Y

REG       ;

 +1        SET BCHREG=""

           SET BCHREGN=""

 +2        SET DIR(0)="S^R:Registered Patients;N:Non-Registered Patients;B:Both Registered and Non-Registered Patients"

           SET DIR("A")="Include which Patients"

           SET DIR("B")="B"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO PROG

 +4        SET BCHREG=Y

           SET BCHREGN=Y(0)

ZIS       ;CALL TO XBDBQUE

 +1        SET XBRP="^BCHRC8P"

           SET XBRC="PROC^BCHRC8"

           SET XBRX="XIT^BCHRC8"

           SET XBNS="BCH"

 +2        DO ^XBDBQUE

 +3        DO XIT

 +4        QUIT 

ERR        WRITE $CHAR(7),$CHAR(7),!,"Must be a valid date and be Today or earlier. Time not allowed!"

           QUIT 

XIT       ;

 +1        KILL BCHPRG,BCHNONE,BCHFT,BCHF,BCHT,BCHREF,BCHQUIT,BCHJOB,BCHBTH,BCHBT,BCHET,BCHBD,BCHED,BCHBDD,BCHEDD,BCHSD,BCHODAT,BCHPROG,BCHX,BCHR,BCHR0,BCHPG,BCHDT,BCHIDAT,BCHMON,BCHTOT,BCHCH,BCHITEM,BCHNAME,BCHRN,BCHRPT,BCHBRK,BCHEOJ

 +2        KILL M,R,V,X,Y,I

 +3        KILL X,Y

 +4        QUIT 

 +5       ;

INFORM    ;

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        WRITE !?20,"**********  CHR REPORT NO. 8  **********"

 +3        WRITE !!?20,"HOURS (SERVICE+TRAVEL) BY MONTH",!!,"You must enter the time frame and the program for which the report",!,"will be run.",!!

 +4        QUIT 

 +5       ;

 +6       ;

PROC      ;EP - PROCESS REFERRAL REPORT

 +1        DO XTMP^BCHUTIL("BCHRC8","CHR CHR REPORT")

 +2        SET (BCHBT,BCHBTH)=$HOROLOG

           SET BCHJOB=$JOB

 +3        DO D

           DO EOJ

 +4        QUIT 

 +5       ;

EOJ       ;

 +1        SET BCHET=$HOROLOG

 +2        QUIT 

D         ; Run by date of service

 +1        SET X1=BCHBD

           SET X2=-1

           DO C^%DTC

           SET BCHSD=X

 +2        SET BCHODAT=BCHSD_".9999"

           FOR 

               SET BCHODAT=$ORDER(^BCHR("B",BCHODAT))

               IF BCHODAT=""!((BCHODAT\1)>BCHED)

                   QUIT 

               DO D1

 +3        QUIT 

 +4       ;

D1        ;

 +1        SET (BCHR,BCHRCNT)=0

           FOR 

               SET BCHR=$ORDER(^BCHR("B",BCHODAT,BCHR))

               IF BCHR'=+BCHR

                   QUIT 

               IF $DATA(^BCHR(BCHR,0))

                   IF $PIECE(^(0),U,2)]""

                       IF $PIECE(^(0),U,3)]""

                           SET BCHR0=^(0)

                           DO PROCESS

 +2        QUIT 

PROCESS   ;

 +1        SET BCHPAT=$PIECE(BCHR0,U,4)

 +2        SET BCHNRPAT=$PIECE($GET(^BCHR(BCHR,11)),U,12)

 +3       ;BI 'BCHPAT,'BCHNRPAT Q   ;no patient

 +4        IF BCHREG="R"

               IF BCHPAT=""

                   QUIT 

 +5        IF BCHREG="N"

               IF BCHNRPAT=""

                   QUIT 

 +6        IF BCHPAT

               IF BCHNRPAT

                   SET BCHNRPAT=""

 +7        IF BCHPAT

               IF '$DATA(^DPT(BCHPAT,0))

                   QUIT 

 +8        SET BCHPROG=$PIECE(BCHR0,U,2)

 +9        IF BCHPRG

               IF BCHPRG'=BCHPROG

                   QUIT 

 +10       IF BCHRPT="PR"

               SET BCHITEM=$PIECE(BCHR0,U,3)

 +11       IF BCHRPT="PG"

               SET BCHITEM=BCHPROG

 +12       SET BCHDATE=$PIECE(BCHR0,U)

           SET Y=BCHDATE

           DO DD^%DT

           SET BCHMON=$PIECE(Y," ")_$PIECE(Y,",",2)

           SET X=BCHMON

           SET %DT=""

           DO ^%DT

           SET BCHIDAT=Y

 +13       SET BCHTOT=$PIECE(BCHR0,U,27)+$PIECE(BCHR0,U,11)

           SET BCHS=$PIECE(BCHR0,U,27)

           SET BCHT=$PIECE(BCHR0,U,11)

 +14       SET $PIECE(^(BCHMON),U)=$SELECT($DATA(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"MONTHS",BCHIDAT,BCHMON)):$PIECE(^(BCHMON),U)+BCHTOT,1:BCHTOT)

 +15       SET $PIECE(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"MONTHS",BCHIDAT,BCHMON),U,2)=$PIECE(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"MONTHS",BCHIDAT,BCHMON),U,2)+BCHS

 +16       SET $PIECE(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"MONTHS",BCHIDAT,BCHMON),U,3)=$PIECE(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"MONTHS",BCHIDAT,BCHMON),U,3)+BCHT

 +17       SET $PIECE(^("TOTAL"),U)=$SELECT($DATA(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"TOTAL")):$PIECE(^("TOTAL"),U)+BCHTOT,1:BCHTOT)

 +18       SET $PIECE(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"TOTAL"),U,2)=$PIECE(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"TOTAL"),U,2)+BCHS

 +19       SET $PIECE(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"TOTAL"),U,3)=$PIECE(^XTMP("BCHRC8",BCHJOB,BCHBT,BCHITEM,"TOTAL"),U,3)+BCHT

 +20       QUIT 

PG        ;

 +1        SET BCHRN=8

           SET BCHCH="PROGRAM"

 +2        QUIT 

PR        ;

 +1        SET BCHRN=8.2

           SET BCHCH="PROVIDER"

 +2        QUIT