BCHRU11 ; IHS/CMI/LAB - PROCESS REPORT ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;IHS/CMI/LAB - tmp to xtmp
;
;
;
;
START ;
S (BCHBT,BCHBTH)=$H,BCHJOB=$J
K ^XTMP("BCHRU1",BCHJOB,BCHBT)
D XTMP^BCHUTIL("BCHRU1","CHR UNDUP REPORT")
D D,END
Q
;
D ; Run by date of service
S (BCHPATS,BCHPATS("F"),BCHPATS("M"),BCHPATS("ST"))=0
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) D PROC
Q
PROC ;
S BCHPROG=$P(BCHR0,U,2)
I BCHPRG,BCHPRG'=BCHPROG Q
S BCHPROV=$P(BCHR0,U,3)
I BCHPROVT="O",BCHCHR1'=BCHPROV Q
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))
I BCHPAT S BCHSEX=$P(^DPT(BCHPAT,0),U,2)
I BCHNRPAT S BCHSEX=$P($G(^BCHRPAT(BCHNRPAT,0)),U,3)
I BCHSEX="" S BCHSEX="--"
I BCHPAT S BCHTRIB=$$VAL^XBDIQ1(9000001,BCHPAT,1108)
I BCHNRPAT S BCHTRIB=$$VAL^XBDIQ1(90002.11,BCHNRPAT,.05)
I BCHTRIB="" S BCHTRIB="--"
S (BCHX,BCHC)=0 F S BCHX=$O(^BCHRPROB("AD",BCHR,BCHX)) Q:BCHX'=+BCHX S BCHC=BCHC+1 I $P(^BCHRPROB(BCHX,0),U,4),$P(^BCHTSERV($P(^BCHRPROB(BCHX,0),U,4),0),U,3)'="LT" D @BCHRPT D
.;BY 1ST LEVEL - TOTAL LINE
.I BCHNRPAT D NON Q
.S BCHPATS("ST")=BCHPATS("ST")+$P(^BCHRPROB(BCHX,0),U,5)
.I '$D(^XTMP("BCHRU1",BCHJOB,BCHBT,"PATIENTS",BCHPAT)) D
..S BCHPATS=BCHPATS+1,BCHPATS(BCHSEX)=BCHPATS(BCHSEX)+1
..S ^XTMP("BCHRU1",BCHJOB,BCHBT,"PATIENTS",BCHPAT)=""
.S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)=$P($G(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN)),U,4)+$P(^BCHRPROB(BCHX,0),U,5)
.S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)=$P($G(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1)),U,4)+$P(^BCHRPROB(BCHX,0),U,5)
.I '$D(^XTMP("BCHRU1",BCHJOB,BCHBT,"PATIENTS",BCHPAT,BCHPROBN)) D
..S $P(^(BCHPROBN),U)=$S($D(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN)):$P(^(BCHPROBN),U)+1,1:1)
..I BCHSEX="F" S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)=$P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)+1
..I BCHSEX="M" S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)=$P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)+1
..S ^XTMP("BCHRU1",BCHJOB,BCHBT,"PATIENTS",BCHPAT,BCHPROBN)=""
.;SUBTOTALS
.I '$D(^XTMP("BCHRU1",BCHJOB,BCHBT,"PATIENTS",BCHPAT,BCHPROBN,BCHSUB1)) D
..S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U)=$S($D(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1)):$P(^(BCHSUB1),U)+1,1:1)
..I BCHSEX="F" S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,2)=$P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,2)+1
..I BCHSEX="M" S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,3)=$P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,3)+1
..S ^XTMP("BCHRU1",BCHJOB,BCHBT,"PATIENTS",BCHPAT,BCHPROBN,BCHSUB1)=""
Q
X ;health area
S BCHPROB=$P(^BCHRPROB(BCHX,0),U)
S BCHPROBN=$P(^BCHTPROB(BCHPROB,0),U)_"|"_$P(^BCHTPROB(BCHPROB,0),U,2)
S BCHSUB1=$P(^BCHRPROB(BCHX,0),U,4)
I BCHSUB1="" S BCHSUB1="NO ACTIVITY ENTERED|**" Q
S BCHSUB1=$P(^BCHTSERV(BCHSUB1,0),U)_"|"_$P(^BCHTSERV(BCHSUB1,0),U,3)
Q
Y ;activity
S BCHPROB=$P(^BCHRPROB(BCHX,0),U,4)
I BCHPROB="" S BCHPROBN="NO SERVICE ENTERED|**"
I BCHPROB]"" S BCHPROBN=$P(^BCHTSERV(BCHPROB,0),U)_"|"_$P(^BCHTSERV(BCHPROB,0),U,3)
S BCHSUB1=$P(^BCHRPROB(BCHX,0),U)
I BCHSUB1="" S BCHSUB1="NO PROBLEM ENTERED|**" Q
S BCHSUB1=$P(^BCHTPROB(BCHSUB1,0),U)_"|"_$P(^BCHTPROB(BCHSUB1,0),U,2)
Q
1 ;CHR
S BCHPROB=$$VAL^XBDIQ1(90002,BCHR,.03)
I BCHPROB="" S BCHPROBN="NO CHR ENTERED|**"
I BCHPROB]"" S BCHPROBN="|"_BCHPROB
I BCHSUB3="H" D
.S BCHSUB1=$P(^BCHRPROB(BCHX,0),U)
.I BCHSUB1="" S BCHSUB1="NO PROBLEM ENTERED|**" Q
.S BCHSUB1=$P(^BCHTPROB(BCHSUB1,0),U)_"|"_$P(^BCHTPROB(BCHSUB1,0),U,2)
I BCHSUB3'="H" D
.S BCHSUB1=$P(^BCHRPROB(BCHX,0),U,4)
.I BCHSUB1="" S BCHSUB1="NO ACTIVITY ENTERED|**" Q
.S BCHSUB1=$P(^BCHTSERV(BCHSUB1,0),U)_"|"_$P(^BCHTSERV(BCHSUB1,0),U,3)
Q
2 ;age/hp
I BCHPAT S BCHPROB=$$AGE^AUPNPAT(BCHPAT,BCHED),BCHPROB=$$PAD(BCHPROB,4)
I BCHNRPAT S BCHPROB=$$AGE(BCHNRPAT,BCHED),BCHPROB=$$PAD(BCHPROB,4)
S BCHPROBN="|"_BCHPROB
I BCHSUB3="H" D
.S BCHSUB1=$P(^BCHRPROB(BCHX,0),U)
.I BCHSUB1="" S BCHSUB1="NO PROBLEM ENTERED|**" Q
.S BCHSUB1=$P(^BCHTPROB(BCHSUB1,0),U)_"|"_$P(^BCHTPROB(BCHSUB1,0),U,2)
I BCHSUB3'="H" D
.S BCHSUB1=$P(^BCHRPROB(BCHX,0),U,4)
.I BCHSUB1="" S BCHSUB1="NO ACTIVITY ENTERED|**" Q
.S BCHSUB1=$P(^BCHTSERV(BCHSUB1,0),U)_"|"_$P(^BCHTSERV(BCHSUB1,0),U,3)
Q
3 ;
S BCHPROB=$S(BCHSEX="M":"MALE",BCHSEX="F":"FEMALE",1:"UNKNOWN")
S BCHPROBN="|"_BCHPROB
I BCHSUB3="H" D
.S BCHSUB1=$P(^BCHRPROB(BCHX,0),U)
.I BCHSUB1="" S BCHSUB1="NO PROBLEM ENTERED|**" Q
.S BCHSUB1=$P(^BCHTPROB(BCHSUB1,0),U)_"|"_$P(^BCHTPROB(BCHSUB1,0),U,2)
I BCHSUB3'="H" D
.S BCHSUB1=$P(^BCHRPROB(BCHX,0),U,4)
.I BCHSUB1="" S BCHSUB1="NO ACTIVITY ENTERED|**" Q
.S BCHSUB1=$P(^BCHTSERV(BCHSUB1,0),U)_"|"_$P(^BCHTSERV(BCHSUB1,0),U,3)
Q
4 ;
S BCHPROB=BCHTRIB
S BCHPROBN="|"_BCHPROB
I BCHSUB3="H" D
.S BCHSUB1=$P(^BCHRPROB(BCHX,0),U)
.I BCHSUB1="" S BCHSUB1="NO PROBLEM ENTERED|**" Q
.S BCHSUB1=$P(^BCHTPROB(BCHSUB1,0),U)_"|"_$P(^BCHTPROB(BCHSUB1,0),U,2)
I BCHSUB3'="H" D
.S BCHSUB1=$P(^BCHRPROB(BCHX,0),U,4)
.I BCHSUB1="" S BCHSUB1="NO ACTIVITY ENTERED|**" Q
.S BCHSUB1=$P(^BCHTSERV(BCHSUB1,0),U)_"|"_$P(^BCHTSERV(BCHSUB1,0),U,3)
Q
5 ;
S BCHPROB=$$VAL^XBDIQ1(90002,BCHR,.02)
I BCHPROB="" S BCHPROBN="NO PROGRAM ENTERED|**"
I BCHPROB]"" S BCHPROBN=$$VAL^XBDIQ1(90002,BCHR,.029)_"|"_BCHPROB
I BCHSUB3="H" D
.S BCHSUB1=$P(^BCHRPROB(BCHX,0),U)
.I BCHSUB1="" S BCHSUB1="NO PROBLEM ENTERED|**" Q
.S BCHSUB1=$P(^BCHTPROB(BCHSUB1,0),U)_"|"_$P(^BCHTPROB(BCHSUB1,0),U,2)
I BCHSUB3'="H" D
.S BCHSUB1=$P(^BCHRPROB(BCHX,0),U,4)
.I BCHSUB1="" S BCHSUB1="NO ACTIVITY ENTERED|**" Q
.S BCHSUB1=$P(^BCHTSERV(BCHSUB1,0),U)_"|"_$P(^BCHTSERV(BCHSUB1,0),U,3)
Q
PAD(D,L) ; -- SUBRTN to pad length of data
; -- D=data L=length
S L=L-$L(D)
Q $E($$REPEAT^XLFSTR(" ",L),1,L)_D
;
NON ;
S BCHPATS("ST")=BCHPATS("ST")+$P(^BCHRPROB(BCHX,0),U,5)
I '$D(^XTMP("BCHRU1",BCHJOB,BCHBT,"NON REG",BCHNRPAT)) D
.S BCHPATS=BCHPATS+1,BCHPATS(BCHSEX)=$G(BCHPATS(BCHSEX))+1
.S ^XTMP("BCHRU1",BCHJOB,BCHBT,"NON REG",BCHNRPAT)=""
S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)=$P($G(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN)),U,4)+$P(^BCHRPROB(BCHX,0),U,5)
S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)=$P($G(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1)),U,4)+$P(^BCHRPROB(BCHX,0),U,5)
I '$D(^XTMP("BCHRU1",BCHJOB,BCHBT,"NON REG",BCHNRPAT,BCHPROBN)) D
.S $P(^(BCHPROBN),U)=$S($D(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN)):$P(^(BCHPROBN),U)+1,1:1)
.I BCHSEX="F" S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)=$P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)+1
.I BCHSEX="M" S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)=$P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)+1
.S ^XTMP("BCHRU1",BCHJOB,BCHBT,"NON REG",BCHNRPAT,BCHPROBN)=""
;SUBTOTALS
I '$D(^XTMP("BCHRU1",BCHJOB,BCHBT,"NON REG",BCHNRPAT,BCHPROBN,BCHSUB1)) D
.S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U)=$S($D(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1)):$P(^(BCHSUB1),U)+1,1:1)
.I BCHSEX="F" S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,2)=$P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,2)+1
.I BCHSEX="M" S $P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,3)=$P(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,3)+1
.S ^XTMP("BCHRU1",BCHJOB,BCHBT,"NON REG",BCHNRPAT,BCHPROBN,BCHSUB1)=""
Q
AGE(P,E) ;
NEW D,A,%
S F="Y"
S D=$P($G(^BCHRPAT(P,0)),U,2)
I D="" Q "??"
S %=$$FMDIFF^XLFDT(E,D)
S %1=%\365.25
I F="Y" Q %1
Q $S(%1>2:%1_" YRS",%<31:%_" DYS",1:%\30_" MOS")
BCHRU11 ; 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 ;
+4 ;
+5 ;
+6 ;
START ;
+1 SET (BCHBT,BCHBTH)=$HOROLOG
SET BCHJOB=$JOB
+2 KILL ^XTMP("BCHRU1",BCHJOB,BCHBT)
+3 DO XTMP^BCHUTIL("BCHRU1","CHR UNDUP REPORT")
+4 DO D
DO END
+5 QUIT
+6 ;
D ; Run by date of service
+1 SET (BCHPATS,BCHPATS("F"),BCHPATS("M"),BCHPATS("ST"))=0
+2 SET X1=BCHBD
SET X2=-1
DO C^%DTC
SET BCHSD=X
+3 SET BCHODAT=BCHSD_".9999"
FOR
SET BCHODAT=$ORDER(^BCHR("B",BCHODAT))
IF BCHODAT=""!((BCHODAT\1)>BCHED)
QUIT
DO D1
+4 QUIT
+5 ;
END ;
+1 SET BCHET=$HOROLOG
+2 DO EOJ
+3 QUIT
EOJ ;
+1 QUIT
D1 ;
+1 SET (BCHR,BCHRCNT)=0
+2 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 PROC
+3 QUIT
PROC ;
+1 SET BCHPROG=$PIECE(BCHR0,U,2)
+2 IF BCHPRG
IF BCHPRG'=BCHPROG
QUIT
+3 SET BCHPROV=$PIECE(BCHR0,U,3)
+4 IF BCHPROVT="O"
IF BCHCHR1'=BCHPROV
QUIT
+5 SET BCHPAT=$PIECE(BCHR0,U,4)
+6 SET BCHNRPAT=$PIECE($GET(^BCHR(BCHR,11)),U,12)
+7 ;no patient
IF 'BCHPAT
IF 'BCHNRPAT
QUIT
+8 IF BCHREG="R"
IF BCHPAT=""
QUIT
+9 IF BCHREG="N"
IF BCHNRPAT=""
QUIT
+10 IF BCHPAT
IF BCHNRPAT
SET BCHNRPAT=""
+11 IF BCHPAT
IF '$DATA(^DPT(BCHPAT,0))
QUIT
+12 IF BCHPAT
SET BCHSEX=$PIECE(^DPT(BCHPAT,0),U,2)
+13 IF BCHNRPAT
SET BCHSEX=$PIECE($GET(^BCHRPAT(BCHNRPAT,0)),U,3)
+14 IF BCHSEX=""
SET BCHSEX="--"
+15 IF BCHPAT
SET BCHTRIB=$$VAL^XBDIQ1(9000001,BCHPAT,1108)
+16 IF BCHNRPAT
SET BCHTRIB=$$VAL^XBDIQ1(90002.11,BCHNRPAT,.05)
+17 IF BCHTRIB=""
SET BCHTRIB="--"
+18 SET (BCHX,BCHC)=0
FOR
SET BCHX=$ORDER(^BCHRPROB("AD",BCHR,BCHX))
IF BCHX'=+BCHX
QUIT
SET BCHC=BCHC+1
IF $PIECE(^BCHRPROB(BCHX,0),U,4)
IF $PIECE(^BCHTSERV($PIECE(^BCHRPROB(BCHX,0),U,4),0),U,3)'="LT"
DO @BCHRPT
Begin DoDot:1
+19 ;BY 1ST LEVEL - TOTAL LINE
+20 IF BCHNRPAT
DO NON
QUIT
+21 SET BCHPATS("ST")=BCHPATS("ST")+$PIECE(^BCHRPROB(BCHX,0),U,5)
+22 IF '$DATA(^XTMP("BCHRU1",BCHJOB,BCHBT,"PATIENTS",BCHPAT))
Begin DoDot:2
+23 SET BCHPATS=BCHPATS+1
SET BCHPATS(BCHSEX)=BCHPATS(BCHSEX)+1
+24 SET ^XTMP("BCHRU1",BCHJOB,BCHBT,"PATIENTS",BCHPAT)=""
End DoDot:2
+25 SET $PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)=$PIECE($GET(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN)),U,4)+$PIECE(^BCHRPROB(BCHX,0),U,5)
+26 SET $PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)=$PIECE($GET(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1)),U,4)+$PIECE(^BCHRPROB(BCHX,0),U,5)
+27 IF '$DATA(^XTMP("BCHRU1",BCHJOB,BCHBT,"PATIENTS",BCHPAT,BCHPROBN))
Begin DoDot:2
+28 SET $PIECE(^(BCHPROBN),U)=$SELECT($DATA(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN)):$PIECE(^(BCHPROBN),U)+1,1:1)
+29 IF BCHSEX="F"
SET $PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)=$PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)+1
+30 IF BCHSEX="M"
SET $PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)=$PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)+1
+31 SET ^XTMP("BCHRU1",BCHJOB,BCHBT,"PATIENTS",BCHPAT,BCHPROBN)=""
End DoDot:2
+32 ;SUBTOTALS
+33 IF '$DATA(^XTMP("BCHRU1",BCHJOB,BCHBT,"PATIENTS",BCHPAT,BCHPROBN,BCHSUB1))
Begin DoDot:2
+34 SET $PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U)=$SELECT($DATA(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1)):$PIECE(^(BCHSUB1),U)+1,1:1)
+35 IF BCHSEX="F"
SET $PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,2)=$PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,2)+1
+36 IF BCHSEX="M"
SET $PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,3)=$PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,3)+1
+37 SET ^XTMP("BCHRU1",BCHJOB,BCHBT,"PATIENTS",BCHPAT,BCHPROBN,BCHSUB1)=""
End DoDot:2
End DoDot:1
+38 QUIT
X ;health area
+1 SET BCHPROB=$PIECE(^BCHRPROB(BCHX,0),U)
+2 SET BCHPROBN=$PIECE(^BCHTPROB(BCHPROB,0),U)_"|"_$PIECE(^BCHTPROB(BCHPROB,0),U,2)
+3 SET BCHSUB1=$PIECE(^BCHRPROB(BCHX,0),U,4)
+4 IF BCHSUB1=""
SET BCHSUB1="NO ACTIVITY ENTERED|**"
QUIT
+5 SET BCHSUB1=$PIECE(^BCHTSERV(BCHSUB1,0),U)_"|"_$PIECE(^BCHTSERV(BCHSUB1,0),U,3)
+6 QUIT
Y ;activity
+1 SET BCHPROB=$PIECE(^BCHRPROB(BCHX,0),U,4)
+2 IF BCHPROB=""
SET BCHPROBN="NO SERVICE ENTERED|**"
+3 IF BCHPROB]""
SET BCHPROBN=$PIECE(^BCHTSERV(BCHPROB,0),U)_"|"_$PIECE(^BCHTSERV(BCHPROB,0),U,3)
+4 SET BCHSUB1=$PIECE(^BCHRPROB(BCHX,0),U)
+5 IF BCHSUB1=""
SET BCHSUB1="NO PROBLEM ENTERED|**"
QUIT
+6 SET BCHSUB1=$PIECE(^BCHTPROB(BCHSUB1,0),U)_"|"_$PIECE(^BCHTPROB(BCHSUB1,0),U,2)
+7 QUIT
1 ;CHR
+1 SET BCHPROB=$$VAL^XBDIQ1(90002,BCHR,.03)
+2 IF BCHPROB=""
SET BCHPROBN="NO CHR ENTERED|**"
+3 IF BCHPROB]""
SET BCHPROBN="|"_BCHPROB
+4 IF BCHSUB3="H"
Begin DoDot:1
+5 SET BCHSUB1=$PIECE(^BCHRPROB(BCHX,0),U)
+6 IF BCHSUB1=""
SET BCHSUB1="NO PROBLEM ENTERED|**"
QUIT
+7 SET BCHSUB1=$PIECE(^BCHTPROB(BCHSUB1,0),U)_"|"_$PIECE(^BCHTPROB(BCHSUB1,0),U,2)
End DoDot:1
+8 IF BCHSUB3'="H"
Begin DoDot:1
+9 SET BCHSUB1=$PIECE(^BCHRPROB(BCHX,0),U,4)
+10 IF BCHSUB1=""
SET BCHSUB1="NO ACTIVITY ENTERED|**"
QUIT
+11 SET BCHSUB1=$PIECE(^BCHTSERV(BCHSUB1,0),U)_"|"_$PIECE(^BCHTSERV(BCHSUB1,0),U,3)
End DoDot:1
+12 QUIT
2 ;age/hp
+1 IF BCHPAT
SET BCHPROB=$$AGE^AUPNPAT(BCHPAT,BCHED)
SET BCHPROB=$$PAD(BCHPROB,4)
+2 IF BCHNRPAT
SET BCHPROB=$$AGE(BCHNRPAT,BCHED)
SET BCHPROB=$$PAD(BCHPROB,4)
+3 SET BCHPROBN="|"_BCHPROB
+4 IF BCHSUB3="H"
Begin DoDot:1
+5 SET BCHSUB1=$PIECE(^BCHRPROB(BCHX,0),U)
+6 IF BCHSUB1=""
SET BCHSUB1="NO PROBLEM ENTERED|**"
QUIT
+7 SET BCHSUB1=$PIECE(^BCHTPROB(BCHSUB1,0),U)_"|"_$PIECE(^BCHTPROB(BCHSUB1,0),U,2)
End DoDot:1
+8 IF BCHSUB3'="H"
Begin DoDot:1
+9 SET BCHSUB1=$PIECE(^BCHRPROB(BCHX,0),U,4)
+10 IF BCHSUB1=""
SET BCHSUB1="NO ACTIVITY ENTERED|**"
QUIT
+11 SET BCHSUB1=$PIECE(^BCHTSERV(BCHSUB1,0),U)_"|"_$PIECE(^BCHTSERV(BCHSUB1,0),U,3)
End DoDot:1
+12 QUIT
3 ;
+1 SET BCHPROB=$SELECT(BCHSEX="M":"MALE",BCHSEX="F":"FEMALE",1:"UNKNOWN")
+2 SET BCHPROBN="|"_BCHPROB
+3 IF BCHSUB3="H"
Begin DoDot:1
+4 SET BCHSUB1=$PIECE(^BCHRPROB(BCHX,0),U)
+5 IF BCHSUB1=""
SET BCHSUB1="NO PROBLEM ENTERED|**"
QUIT
+6 SET BCHSUB1=$PIECE(^BCHTPROB(BCHSUB1,0),U)_"|"_$PIECE(^BCHTPROB(BCHSUB1,0),U,2)
End DoDot:1
+7 IF BCHSUB3'="H"
Begin DoDot:1
+8 SET BCHSUB1=$PIECE(^BCHRPROB(BCHX,0),U,4)
+9 IF BCHSUB1=""
SET BCHSUB1="NO ACTIVITY ENTERED|**"
QUIT
+10 SET BCHSUB1=$PIECE(^BCHTSERV(BCHSUB1,0),U)_"|"_$PIECE(^BCHTSERV(BCHSUB1,0),U,3)
End DoDot:1
+11 QUIT
4 ;
+1 SET BCHPROB=BCHTRIB
+2 SET BCHPROBN="|"_BCHPROB
+3 IF BCHSUB3="H"
Begin DoDot:1
+4 SET BCHSUB1=$PIECE(^BCHRPROB(BCHX,0),U)
+5 IF BCHSUB1=""
SET BCHSUB1="NO PROBLEM ENTERED|**"
QUIT
+6 SET BCHSUB1=$PIECE(^BCHTPROB(BCHSUB1,0),U)_"|"_$PIECE(^BCHTPROB(BCHSUB1,0),U,2)
End DoDot:1
+7 IF BCHSUB3'="H"
Begin DoDot:1
+8 SET BCHSUB1=$PIECE(^BCHRPROB(BCHX,0),U,4)
+9 IF BCHSUB1=""
SET BCHSUB1="NO ACTIVITY ENTERED|**"
QUIT
+10 SET BCHSUB1=$PIECE(^BCHTSERV(BCHSUB1,0),U)_"|"_$PIECE(^BCHTSERV(BCHSUB1,0),U,3)
End DoDot:1
+11 QUIT
5 ;
+1 SET BCHPROB=$$VAL^XBDIQ1(90002,BCHR,.02)
+2 IF BCHPROB=""
SET BCHPROBN="NO PROGRAM ENTERED|**"
+3 IF BCHPROB]""
SET BCHPROBN=$$VAL^XBDIQ1(90002,BCHR,.029)_"|"_BCHPROB
+4 IF BCHSUB3="H"
Begin DoDot:1
+5 SET BCHSUB1=$PIECE(^BCHRPROB(BCHX,0),U)
+6 IF BCHSUB1=""
SET BCHSUB1="NO PROBLEM ENTERED|**"
QUIT
+7 SET BCHSUB1=$PIECE(^BCHTPROB(BCHSUB1,0),U)_"|"_$PIECE(^BCHTPROB(BCHSUB1,0),U,2)
End DoDot:1
+8 IF BCHSUB3'="H"
Begin DoDot:1
+9 SET BCHSUB1=$PIECE(^BCHRPROB(BCHX,0),U,4)
+10 IF BCHSUB1=""
SET BCHSUB1="NO ACTIVITY ENTERED|**"
QUIT
+11 SET BCHSUB1=$PIECE(^BCHTSERV(BCHSUB1,0),U)_"|"_$PIECE(^BCHTSERV(BCHSUB1,0),U,3)
End DoDot:1
+12 QUIT
PAD(D,L) ; -- SUBRTN to pad length of data
+1 ; -- D=data L=length
+2 SET L=L-$LENGTH(D)
+3 QUIT $EXTRACT($$REPEAT^XLFSTR(" ",L),1,L)_D
+4 ;
NON ;
+1 SET BCHPATS("ST")=BCHPATS("ST")+$PIECE(^BCHRPROB(BCHX,0),U,5)
+2 IF '$DATA(^XTMP("BCHRU1",BCHJOB,BCHBT,"NON REG",BCHNRPAT))
Begin DoDot:1
+3 SET BCHPATS=BCHPATS+1
SET BCHPATS(BCHSEX)=$GET(BCHPATS(BCHSEX))+1
+4 SET ^XTMP("BCHRU1",BCHJOB,BCHBT,"NON REG",BCHNRPAT)=""
End DoDot:1
+5 SET $PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)=$PIECE($GET(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN)),U,4)+$PIECE(^BCHRPROB(BCHX,0),U,5)
+6 SET $PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)=$PIECE($GET(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1)),U,4)+$PIECE(^BCHRPROB(BCHX,0),U,5)
+7 IF '$DATA(^XTMP("BCHRU1",BCHJOB,BCHBT,"NON REG",BCHNRPAT,BCHPROBN))
Begin DoDot:1
+8 SET $PIECE(^(BCHPROBN),U)=$SELECT($DATA(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN)):$PIECE(^(BCHPROBN),U)+1,1:1)
+9 IF BCHSEX="F"
SET $PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)=$PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)+1
+10 IF BCHSEX="M"
SET $PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)=$PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)+1
+11 SET ^XTMP("BCHRU1",BCHJOB,BCHBT,"NON REG",BCHNRPAT,BCHPROBN)=""
End DoDot:1
+12 ;SUBTOTALS
+13 IF '$DATA(^XTMP("BCHRU1",BCHJOB,BCHBT,"NON REG",BCHNRPAT,BCHPROBN,BCHSUB1))
Begin DoDot:1
+14 SET $PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U)=$SELECT($DATA(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1)):$PIECE(^(BCHSUB1),U)+1,1:1)
+15 IF BCHSEX="F"
SET $PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,2)=$PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,2)+1
+16 IF BCHSEX="M"
SET $PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,3)=$PIECE(^XTMP("BCHRU1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,3)+1
+17 SET ^XTMP("BCHRU1",BCHJOB,BCHBT,"NON REG",BCHNRPAT,BCHPROBN,BCHSUB1)=""
End DoDot:1
+18 QUIT
AGE(P,E) ;
+1 NEW D,A,%
+2 SET F="Y"
+3 SET D=$PIECE($GET(^BCHRPAT(P,0)),U,2)
+4 IF D=""
QUIT "??"
+5 SET %=$$FMDIFF^XLFDT(E,D)
+6 SET %1=%\365.25
+7 IF F="Y"
QUIT %1
+8 QUIT $SELECT(%1>2:%1_" YRS",%<31:%_" DYS",1:%\30_" MOS")
