BCHRC51 ; IHS/CMI/LAB - PROCESS REPORT ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;IHS/CMI/LAB - tmp to xtmp
;
START ;
D XTMP^BCHUTIL("BCHRC5","CHR CHR REPORT")
S (BCHBT,BCHBTH)=$H,BCHJOB=$J,BCHTF=0,BCHTM=0
S BCHRNN=BCHRBIN,BCHRA="" F I=1:1 S BCHRX=$P(BCHRNN,";",I) Q:BCHRX="" D SETA
S BCHRDOBS=BCHRA
D D,END
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
;
END ;
S BCHET=$H
D EOJ
Q
EOJ ;
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),BCHR11=$G(^BCHR(BCHR,11)) D PROC
Q
PROC ;
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 BCHPROV=$P(BCHR0,U,3)
I BCHPROVT="O",BCHCHR1'=BCHPROV Q
;S (BCHX,BCHC)=0 F S BCHX=$O(^BCHRPROB("AD",BCHR,BCHX)) Q:BCHX'=+BCHX S BCHC=BCHC+1 D
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)'="LT" S BCHC=BCHC+1 D
.S BCHPROB=$P(^BCHRPROB(BCHX,0),U),BCHPROBN=$P(^BCHTPROB(BCHPROB,0),U)_"|"_$P(^BCHTPROB(BCHPROB,0),U,2)
.D SETTMP
.Q
Q
SETTMP ;
S DFN=$P(BCHR0,U,4) I DFN S DOB=$P(^DPT(DFN,0),U,3)
I 'DFN S DOB=$P(BCHR11,U,2)
Q:DOB']""
I DFN S SEX=$P(^DPT(DFN,0),U,2)
I 'DFN S SEX=$P(BCHR11,U,3)
Q:SEX="" ;no sex available
Q:$P(BCHR0,U,12)'=1
S BCHRAGE="" D GETAGE
Q:'BCHRAGE
I SEX="F" S BCHTF=BCHTF+1
I SEX="M" S BCHTM=BCHTM+1
S ^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",BCHRAGE,SEX)=$G(^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",BCHRAGE,SEX))+1
S ^(SEX)=$S($D(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHPROB,BCHRAGE,SEX)):^(SEX)+1,1:1)
S ^(SEX)=$S($D(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHPROB,"TOTAL",SEX)):^(SEX)+1,1:1)
Q
GETAGE ;
F I=1:1 S BCHRNN=$P(BCHRA,";",I) Q:BCHRNN="" S BCHRX=$P(BCHRNN,"-"),BCHRY=$P(BCHRNN,"-",2) I DOB'<BCHRX,DOB'>BCHRY S BCHRAGE=I Q
Q
;
SETA ;
S BCHRY=$P(BCHRX,"-"),BCHRZ=$P(BCHRX,"-",2)
I BCHRA]"" S BCHRA=BCHRA_";"
S BCHRA=BCHRA_(DT+1-(10000*(BCHRZ+1)))_"-"_(DT-(BCHRY*10000))
S ^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",I,"F")=0,^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",I,"M")=0
Q
BCHRC51 ; IHS/CMI/LAB - PROCESS REPORT ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;IHS/CMI/LAB - tmp to xtmp
+3 ;
START ;
+1 DO XTMP^BCHUTIL("BCHRC5","CHR CHR REPORT")
+2 SET (BCHBT,BCHBTH)=$HOROLOG
SET BCHJOB=$JOB
SET BCHTF=0
SET BCHTM=0
+3 SET BCHRNN=BCHRBIN
SET BCHRA=""
FOR I=1:1
SET BCHRX=$PIECE(BCHRNN,";",I)
IF BCHRX=""
QUIT
DO SETA
+4 SET BCHRDOBS=BCHRA
+5 DO D
DO END
+6 QUIT
+7 ;
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 ;
END ;
+1 SET BCHET=$HOROLOG
+2 DO EOJ
+3 QUIT
EOJ ;
+1 QUIT
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)
SET BCHR11=$GET(^BCHR(BCHR,11))
DO PROC
+2 QUIT
PROC ;
+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 BCHPROV=$PIECE(BCHR0,U,3)
+11 IF BCHPROVT="O"
IF BCHCHR1'=BCHPROV
QUIT
+12 ;S (BCHX,BCHC)=0 F S BCHX=$O(^BCHRPROB("AD",BCHR,BCHX)) Q:BCHX'=+BCHX S BCHC=BCHC+1 D
+13 SET (BCHX,BCHC)=0
FOR
SET BCHX=$ORDER(^BCHRPROB("AD",BCHR,BCHX))
IF BCHX'=+BCHX
QUIT
IF $PIECE(^BCHRPROB(BCHX,0),U,4)
IF $PIECE(^BCHTSERV($PIECE(^BCHRPROB(BCHX,0),U,4),0),U,3)'="LT"
SET BCHC=BCHC+1
Begin DoDot:1
+14 SET BCHPROB=$PIECE(^BCHRPROB(BCHX,0),U)
SET BCHPROBN=$PIECE(^BCHTPROB(BCHPROB,0),U)_"|"_$PIECE(^BCHTPROB(BCHPROB,0),U,2)
+15 DO SETTMP
+16 QUIT
End DoDot:1
+17 QUIT
SETTMP ;
+1 SET DFN=$PIECE(BCHR0,U,4)
IF DFN
SET DOB=$PIECE(^DPT(DFN,0),U,3)
+2 IF 'DFN
SET DOB=$PIECE(BCHR11,U,2)
+3 IF DOB']""
QUIT
+4 IF DFN
SET SEX=$PIECE(^DPT(DFN,0),U,2)
+5 IF 'DFN
SET SEX=$PIECE(BCHR11,U,3)
+6 ;no sex available
IF SEX=""
QUIT
+7 IF $PIECE(BCHR0,U,12)'=1
QUIT
+8 SET BCHRAGE=""
DO GETAGE
+9 IF 'BCHRAGE
QUIT
+10 IF SEX="F"
SET BCHTF=BCHTF+1
+11 IF SEX="M"
SET BCHTM=BCHTM+1
+12 SET ^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",BCHRAGE,SEX)=$GET(^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",BCHRAGE,SEX))+1
+13 SET ^(SEX)=$SELECT($DATA(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHPROB,BCHRAGE,SEX)):^(SEX)+1,1:1)
+14 SET ^(SEX)=$SELECT($DATA(^XTMP("BCHRC5",BCHJOB,BCHBT,"HA",BCHPROB,"TOTAL",SEX)):^(SEX)+1,1:1)
+15 QUIT
GETAGE ;
+1 FOR I=1:1
SET BCHRNN=$PIECE(BCHRA,";",I)
IF BCHRNN=""
QUIT
SET BCHRX=$PIECE(BCHRNN,"-")
SET BCHRY=$PIECE(BCHRNN,"-",2)
IF DOB'<BCHRX
IF DOB'>BCHRY
SET BCHRAGE=I
QUIT
+2 QUIT
+3 ;
SETA ;
+1 SET BCHRY=$PIECE(BCHRX,"-")
SET BCHRZ=$PIECE(BCHRX,"-",2)
+2 IF BCHRA]""
SET BCHRA=BCHRA_";"
+3 SET BCHRA=BCHRA_(DT+1-(10000*(BCHRZ+1)))_"-"_(DT-(BCHRY*10000))
+4 SET ^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",I,"F")=0
SET ^XTMP("BCHRC5",BCHJOB,BCHBT,"TOTAL AGE",I,"M")=0
+5 QUIT
