BCHRC11 ; 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
D XTMP^BCHUTIL("BCHRC1","CHR CHR REPORT")
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) 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 D
.S BCHC=BCHC+1
.I BCHLEAVE="D" I $P(^BCHRPROB(BCHX,0),U,4),$P(^BCHTSERV($P(^BCHRPROB(BCHX,0),U,4),0),U,3)="LT" Q
.D @BCHRPT
.D
..;BY 1ST LEVEL
..S $P(^(BCHPROBN),U)=$S($D(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN)):$P(^(BCHPROBN),U)+1,1:1)
..S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)+$P(^BCHRPROB(BCHX,0),U,5)
..I BCHC=1 S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)+$P(BCHR0,U,11)
..I BCHRPT=3,BCHC=1 D
...S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)+$P(BCHR0,U,12)
..I BCHRPT'=3 D
...S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)+$P(BCHR0,U,12)
..;SUBTOTALS
..S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U)=$S($D(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1)):$P(^(BCHSUB1),U)+1,1:1)
..S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,2)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,2)+$P(^BCHRPROB(BCHX,0),U,5)
..I BCHC=1 S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,3)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,3)+$P(BCHR0,U,11)
..I BCHRPT=3,BCHC=1 D
...S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)+$P(BCHR0,U,12)
..I BCHRPT'=3 D
...S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)+$P(BCHR0,U,12)
..;TOTALS
..S $P(^("*TOTAL*"),U)=$S($D(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*")):$P(^("*TOTAL*"),U)+1,1:1)
..S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,2)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,2)+$P(^BCHRPROB(BCHX,0),U,5)
..I BCHC=1 S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,3)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,3)+$P(BCHR0,U,11)
..I BCHRPT=3,BCHC=1 S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,4)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,4)+$P(BCHR0,U,12)
..I BCHRPT'=3 S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,4)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,4)+$P(BCHR0,U,12)
Q
1 ;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
2 ;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
3 ;setting
S BCHPROB=$P(BCHR0,U,6)
I BCHPROB="" S BCHPROBN="NO SETTING ENTERED|**" Q
S BCHPROBN=$P(^BCHTACTL(BCHPROB,0),U)_"|"_$P(^(0),U,5)
S BCHSUB1=$$VAL^XBDIQ1(90002,BCHR,.03)
I BCHSUB1="" S BCHSUB1="UNKNOWN"
Q
BCHRC11 ; 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 DO XTMP^BCHUTIL("BCHRC1","CHR CHR REPORT")
+3 DO D
DO END
+4 QUIT
+5 ;
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)
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 SET (BCHX,BCHC)=0
FOR
SET BCHX=$ORDER(^BCHRPROB("AD",BCHR,BCHX))
IF BCHX'=+BCHX
QUIT
Begin DoDot:1
+13 SET BCHC=BCHC+1
+14 IF BCHLEAVE="D"
IF $PIECE(^BCHRPROB(BCHX,0),U,4)
IF $PIECE(^BCHTSERV($PIECE(^BCHRPROB(BCHX,0),U,4),0),U,3)="LT"
QUIT
+15 DO @BCHRPT
+16 Begin DoDot:2
+17 ;BY 1ST LEVEL
+18 SET $PIECE(^(BCHPROBN),U)=$SELECT($DATA(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN)):$PIECE(^(BCHPROBN),U)+1,1:1)
+19 SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)+$PIECE(^BCHRPROB(BCHX,0),U,5)
+20 IF BCHC=1
SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)+$PIECE(BCHR0,U,11)
+21 IF BCHRPT=3
IF BCHC=1
Begin DoDot:3
+22 SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)+$PIECE(BCHR0,U,12)
End DoDot:3
+23 IF BCHRPT'=3
Begin DoDot:3
+24 SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)+$PIECE(BCHR0,U,12)
End DoDot:3
+25 ;SUBTOTALS
+26 SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U)=$SELECT($DATA(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1)):$PIECE(^(BCHSUB1),U)+1,1:1)
+27 SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,2)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,2)+$PIECE(^BCHRPROB(BCHX,0),U,5)
+28 IF BCHC=1
SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,3)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,3)+$PIECE(BCHR0,U,11)
+29 IF BCHRPT=3
IF BCHC=1
Begin DoDot:3
+30 SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)+$PIECE(BCHR0,U,12)
End DoDot:3
+31 IF BCHRPT'=3
Begin DoDot:3
+32 SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)+$PIECE(BCHR0,U,12)
End DoDot:3
+33 ;TOTALS
+34 SET $PIECE(^("*TOTAL*"),U)=$SELECT($DATA(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*")):$PIECE(^("*TOTAL*"),U)+1,1:1)
+35 SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,2)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,2)+$PIECE(^BCHRPROB(BCHX,0),U,5)
+36 IF BCHC=1
SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,3)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,3)+$PIECE(BCHR0,U,11)
+37 IF BCHRPT=3
IF BCHC=1
SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,4)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,4)+$PIECE(BCHR0,U,12)
+38 IF BCHRPT'=3
SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,4)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,4)+$PIECE(BCHR0,U,12)
End DoDot:2
End DoDot:1
+39 QUIT
1 ;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
2 ;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
3 ;setting
+1 SET BCHPROB=$PIECE(BCHR0,U,6)
+2 IF BCHPROB=""
SET BCHPROBN="NO SETTING ENTERED|**"
QUIT
+3 SET BCHPROBN=$PIECE(^BCHTACTL(BCHPROB,0),U)_"|"_$PIECE(^(0),U,5)
+4 SET BCHSUB1=$$VAL^XBDIQ1(90002,BCHR,.03)
+5 IF BCHSUB1=""
SET BCHSUB1="UNKNOWN"
+6 QUIT
