- BCHRC9 ; IHS/CMI/LAB - CHR Report 2 ;
- ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
- ;IHS/CMI/LAB - PATCH 6 fixed logic on total services
- ;
- 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
- ;
- 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) BD
- 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="^BCHRC9P",XBRC="PROC^BCHRC9",XBRX="XIT^BCHRC9",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 V,BCHSD,BCHBD,BCHBDD,BCHED,BCHEDD,BCHODAT,BCHR,BCHR0,X,P,S,N,BCHQUIT,BCHBTH,BCHDT,BCHNAME,BCHPRG,BCHBT,BCHJOB
- K X,Y
- Q
- ;
- INFORM ;
- W:$D(IOF) @IOF
- W !?20,"********** CHR REPORT NO. 9 **********"
- W !!?28,"DATA SUMMARY BY PROVIDER",!!,"You must enter the time frame for the report.",!
- Q
- ;
- ;
- PROC ;EP - PROCESS REFERRAL REPORT
- D XTMP^BCHUTIL("BCHRC9","CHR CHR REPORT")
- S (BCHBT,BCHBTH)=$H,BCHJOB=$J
- S ^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL")=0
- 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)
- ;I '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
- S C=$P(BCHR0,U,3),BCHNAME=$P(^VA(200,C,0),U)
- I '$D(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME)) S ^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME)=0
- S (X,C)=0 F S X=$O(^BCHRPROB("AD",BCHR,X)) Q:X'=+X S C=C+1 D
- .Q:$P(^BCHRPROB(X,0),U,4)="" ;no service entered
- .S $P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U)+1,$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U)+1
- .S S=$P(^BCHRPROB(X,0),U,4),Y=$P(^BCHTSERV(S,0),U,3)
- .I Y="LT"!(Y="AM")!(Y="OT") D
- ..S $P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,5)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,5)+$P(^BCHRPROB(X,0),U,5),$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,5)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,5)+$P(^BCHRPROB(X,0),U,5)
- ..;IHS/CMI/LAB - modified line below patch 6
- ..I C=1 S $P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,5)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,5)+$P(BCHR0,U,11),$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,5)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,5)+$P(BCHR0,U,11)
- .E D
- ..S $P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,4)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,4)+$P(^BCHRPROB(X,0),U,5),$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,4)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,4)+$P(^BCHRPROB(X,0),U,5)
- ..;IHS/CMI/LAB - patch 6 modified line below
- ..I C=1 S $P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,4)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,4)+$P(BCHR0,U,11),$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,4)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,4)+$P(BCHR0,U,11)
- .Q
- S $P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,2)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,2)+$P(BCHR0,U,12)
- S $P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,2)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,2)+$P(BCHR0,U,12)
- S N=$P(BCHR0,U,27)+$P(BCHR0,U,11)
- S $P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,3)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,3)+N,$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,3)=$P(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,3)+N
- Q
- BCHRC9 ; IHS/CMI/LAB - CHR Report 2 ;
- +1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
- +2 ;IHS/CMI/LAB - PATCH 6 fixed logic on total services
- +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 ;
- 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 BD
- +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="^BCHRC9P"
- SET XBRC="PROC^BCHRC9"
- SET XBRX="XIT^BCHRC9"
- 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 V,BCHSD,BCHBD,BCHBDD,BCHED,BCHEDD,BCHODAT,BCHR,BCHR0,X,P,S,N,BCHQUIT,BCHBTH,BCHDT,BCHNAME,BCHPRG,BCHBT,BCHJOB
- +2 KILL X,Y
- +3 QUIT
- +4 ;
- INFORM ;
- +1 IF $DATA(IOF)
- WRITE @IOF
- +2 WRITE !?20,"********** CHR REPORT NO. 9 **********"
- +3 WRITE !!?28,"DATA SUMMARY BY PROVIDER",!!,"You must enter the time frame for the report.",!
- +4 QUIT
- +5 ;
- +6 ;
- PROC ;EP - PROCESS REFERRAL REPORT
- +1 DO XTMP^BCHUTIL("BCHRC9","CHR CHR REPORT")
- +2 SET (BCHBT,BCHBTH)=$HOROLOG
- SET BCHJOB=$JOB
- +3 SET ^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL")=0
- +4 DO D
- DO EOJ
- +5 QUIT
- +6 ;
- 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 ;I '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 SET C=$PIECE(BCHR0,U,3)
- SET BCHNAME=$PIECE(^VA(200,C,0),U)
- +11 IF '$DATA(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME))
- SET ^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME)=0
- +12 SET (X,C)=0
- FOR
- SET X=$ORDER(^BCHRPROB("AD",BCHR,X))
- IF X'=+X
- QUIT
- SET C=C+1
- Begin DoDot:1
- +13 ;no service entered
- IF $PIECE(^BCHRPROB(X,0),U,4)=""
- QUIT
- +14 SET $PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U)=$PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U)+1
- SET $PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U)=$PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U)+1
- +15 SET S=$PIECE(^BCHRPROB(X,0),U,4)
- SET Y=$PIECE(^BCHTSERV(S,0),U,3)
- +16 IF Y="LT"!(Y="AM")!(Y="OT")
- Begin DoDot:2
- +17 SET $PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,5)=$PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,5)+$PIECE(^BCHRPROB(X,0),U,5)
- SET $PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,5)=$PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,5)+$PIECE(^BCHRPROB(X,0),U,5)
- +18 ;IHS/CMI/LAB - modified line below patch 6
- +19 IF C=1
- SET $PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,5)=$PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,5)+$PIECE(BCHR0,U,11)
- SET $PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,5)=$PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,5)+$PIECE(BCHR0,U,11)
- End DoDot:2
- +20 IF '$TEST
- Begin DoDot:2
- +21 SET $PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,4)=$PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,4)+$PIECE(^BCHRPROB(X,0),U,5)
- SET $PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,4)=$PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,4)+$PIECE(^BCHRPROB(X,0),U,5)
- +22 ;IHS/CMI/LAB - patch 6 modified line below
- +23 IF C=1
- SET $PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,4)=$PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,4)+$PIECE(BCHR0,U,11)
- SET $PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,4)=$PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,4)+$PIECE(BCHR0,U,11)
- End DoDot:2
- +24 QUIT
- End DoDot:1
- +25 SET $PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,2)=$PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,2)+$PIECE(BCHR0,U,12)
- +26 SET $PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,2)=$PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,2)+$PIECE(BCHR0,U,12)
- +27 SET N=$PIECE(BCHR0,U,27)+$PIECE(BCHR0,U,11)
- +28 SET $PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,3)=$PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"PROV",BCHNAME),U,3)+N
- SET $PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,3)=$PIECE(^XTMP("BCHRC9",BCHJOB,BCHBT,"TOTAL"),U,3)+N
- +29 QUIT