Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BCHRC2

BCHRC2.m

Go to the documentation of this file. 
  1. BCHRC2 ; IHS/CMI/LAB - CHR Report 2 ; 
  1.  ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
  1.  ;IHS/CMI/LAB - tmp to xtmp
  1.  ;
  1.  I '$G(DUZ(2)) W $C(7),$C(7),!!,"SITE NOT SET IN DUZ(2) - NOTIFY SITE MANAGER!!",!! Q
  1.  S BCHJOB=$J,BCHBTH=$H
  1.  D INFORM
  1. GETDATES ;
  1. BD ;get beginning date
  1.  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
  1.  I $D(DIRUT) G XIT
  1.  S BCHBD=Y
  1. ED ;get ending date
  1.  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
  1.  I $D(DIRUT) G BD
  1.  S BCHED=Y
  1.  S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X
  1.  ;
  1. PROG ;
  1.  S BCHPRG=""
  1.  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
  1.  G:$D(DIRUT) BD
  1.  I Y=1 S BCHPRG="" G CHRT
  1. PROG1 ;enter program
  1.  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
  1.  S BCHPRG=+Y
  1. CHRT ;
  1.  K BCHPROVT
  1.  S DIR(0)="S^O:One CHR;A:All CHRs",DIR("A")="Include Data for",DIR("B")="A" KILL DA D ^DIR KILL DIR
  1.  I $D(DIRUT) G PROG
  1.  S BCHPROVT=Y
  1.  I BCHPROVT="A" G REG
  1. CHR1 ;
  1.  K DIC
  1.  S DIC=200,DIC(0)="AEMQ",DIC("A")="Enter the CHR: " D ^DIC
  1.  I Y=-1 G CHRT
  1.  S BCHCHR1=+Y
  1. REG ;
  1.  S BCHREG="",BCHREGN=""
  1.  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
  1.  I $D(DIRUT) G CHRT
  1.  S BCHREG=Y,BCHREGN=Y(0)
  1. ZIS ;CALL TO XBDBQUE
  1.  S XBRP="^BCHRC2P",XBRC="PROC^BCHRC2",XBRX="XIT^BCHRC2",XBNS="BCH"
  1.  D ^XBDBQUE
  1.  D XIT
  1.  Q
  1. ERR W $C(7),$C(7),!,"Must be a valid date and be Today or earlier. Time not allowed!" Q
  1. XIT ;
  1.  K BCHPRG,BCHTT,BCHFT,BCHF,BCHT,BCHREF,BCHQUIT,BCHJOB,BCHBTH,BCHBT,BCHET,BCHBD,BCHED,BCHBDD,BCHEDD,BCHSD,BCHODAT,BCHPROG,BCHX,BCHR,BCHR0,BCHPG,BCHDT
  1.  K X,Y
  1.  Q
  1.  ;
  1. INFORM ;
  1.  W:$D(IOF) @IOF
  1.  W !?20,"**********  CHR REPORT NO. 4  **********"
  1.  W !!?26,"NUMBER OF REFERRALS FROM/TO",!!,"You must enter the time frame and the program for which the report",!,"will be run.",!!
  1.  Q
  1.  ;
  1.  ;
  1. PROC ;EP - PROCESS REFERRAL REPORT
  1.  D XTMP^BCHUTIL("BCHRC2","CHR CHR REPORT")
  1.  S (BCHBT,BCHBTH)=$H,BCHJOB=$J
  1.  S X=0 F  S X=$O(^BCHTREF(X)) Q:X'=+X  S ^XTMP("BCHRC2",BCHJOB,BCHBT,X,"FROM")=0,^XTMP("BCHRC2",BCHJOB,BCHBT,X,"TO")=0
  1.  S ^XTMP("BCHRC2",BCHJOB,BCHBT,"TOTAL","FROM")=0,^XTMP("BCHRC2",BCHJOB,BCHBT,"TOTAL","TO")=0
  1.  D D,EOJ
  1.  Q
  1.  ;
  1. EOJ ;
  1.  S BCHET=$H
  1.  Q
  1. D ; Run by date of service
  1.  S X1=BCHBD,X2=-1 D C^%DTC S BCHSD=X
  1.  S BCHODAT=BCHSD_".9999" F  S BCHODAT=$O(^BCHR("B",BCHODAT)) Q:BCHODAT=""!((BCHODAT\1)>BCHED)  D D1
  1.  Q
  1.  ;
  1. D1 ;
  1.  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
  1.  Q
  1. PROCESS ;
  1.  S BCHPAT=$P(BCHR0,U,4)
  1.  S BCHNRPAT=$P($G(^BCHR(BCHR,11)),U,12)
  1.  I 'BCHPAT,'BCHNRPAT Q   ;no patient  - PATIENT RELATED ONLY
  1.  I BCHREG="R",BCHPAT="" Q
  1.  I BCHREG="N",BCHNRPAT="" Q
  1.  I BCHPAT,BCHNRPAT S BCHNRPAT=""
  1.  I BCHPAT Q:'$D(^DPT(BCHPAT,0))
  1.  S BCHPROG=$P(BCHR0,U,2)
  1.  I BCHPRG,BCHPRG'=BCHPROG Q
  1.  S BCHPROV=$P(BCHR0,U,3)
  1.  I BCHPROVT="O",BCHCHR1'=BCHPROV Q
  1.  Q:$P(BCHR0,U,12)'=1  ;ONLY # SERVED 1
  1.  Q:$P(BCHR0,U,29)  ;no group records
  1.  S (BCHX,BCHC)=0 F  S BCHX=$O(^BCHRPROB("AD",BCHR,BCHX)) Q:BCHX'=+BCHX  I $P(^BCHRPROB(BCHX,0),U,4),$P(^BCHTSERV($P(^BCHRPROB(BCHX,0),U,4),0),U,3)'=99 S BCHC=BCHC+1
  1.  Q:'BCHC  ;if none are not travel do not count
  1.  ;S BCHREF=$P(BCHR0,U,7) I BCHREF S ^XTMP("BCHRC2",BCHJOB,BCHBT,BCHREF,"FROM")=^XTMP("BCHRC2",BCHJOB,BCHBT,BCHREF,"FROM")+$P(BCHR0,U,12),^XTMP("BCHRC2",BCHJOB,BCHBT,"TOTAL","FROM")=^XTMP("BCHRC2",BCHJOB,BCHBT,"TOTAL","FROM")+$P(BCHR0,U,12)
  1.  ;S BCHREF=$P(BCHR0,U,8) I BCHREF S ^XTMP("BCHRC2",BCHJOB,BCHBT,BCHREF,"TO")=^XTMP("BCHRC2",BCHJOB,BCHBT,BCHREF,"TO")+$P(BCHR0,U,12),^XTMP("BCHRC2",BCHJOB,BCHBT,"TOTAL","TO")=^XTMP("BCHRC2",BCHJOB,BCHBT,"TOTAL","TO")+$P(BCHR0,U,12)
  1.  S X=0 F  S X=$O(^BCHR(BCHR,41,X)) Q:X'=+X  D
  1.  .S BCHREF=$P(^BCHR(BCHR,41,X,0),U,1)
  1.  .Q:'BCHREF
  1.  .S ^XTMP("BCHRC2",BCHJOB,BCHBT,BCHREF,"FROM")=^XTMP("BCHRC2",BCHJOB,BCHBT,BCHREF,"FROM")+$P(BCHR0,U,12),^XTMP("BCHRC2",BCHJOB,BCHBT,"TOTAL","FROM")=^XTMP("BCHRC2",BCHJOB,BCHBT,"TOTAL","FROM")+$P(BCHR0,U,12)
  1.  S X=0 F  S X=$O(^BCHR(BCHR,42,X)) Q:X'=+X  D
  1.  .S BCHREF=$P(^BCHR(BCHR,42,X,0),U,1)
  1.  .Q:'BCHREF
  1.  .S ^XTMP("BCHRC2",BCHJOB,BCHBT,BCHREF,"TO")=^XTMP("BCHRC2",BCHJOB,BCHBT,BCHREF,"TO")+$P(BCHR0,U,12),^XTMP("BCHRC2",BCHJOB,BCHBT,"TOTAL","TO")=^XTMP("BCHRC2",BCHJOB,BCHBT,"TOTAL","TO")+$P(BCHR0,U,12)
  1.  Q