- 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
