BCHRCH1 ; 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("BCHRCH","CHR CHR REPORT")
S BCHTT=0
S (BCHBT,BCHBTH)=$H,BCHJOB=$J
D D
D SETTMP
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 S BCHC=BCHC+1 D
.Q:$P(^BCHRPROB(BCHX,0),U,4)=""
.S P=$P(^BCHRPROB(BCHX,0),U),A=$P(^BCHRPROB(BCHX,0),U,4),S=$P(^BCHRPROB(BCHX,0),U,5)
.S BCHTT=BCHTT+S I BCHC=1 S BCHTT=BCHTT+$P(BCHR0,U,11)
.S ^(P)=$S($D(^XTMP("BCHRCH",BCHJOB,BCHBT,"PROBLEM",P)):^(P)+S,1:S) I BCHC=1 S ^(P)=^(P)+$P(BCHR0,U,11)
.S ^(A)=$S($D(^XTMP("BCHRCH",BCHJOB,BCHBT,"ACTIVITY",A)):^(A)+S,1:S) I BCHC=1 S ^(A)=^(A)+$P(BCHR0,U,11)
Q
;
SETTMP ;
S X=0 F S X=$O(^XTMP("BCHRCH",BCHJOB,BCHBT,"ACTIVITY",X)) Q:X'=+X S ^XTMP("BCHRCH",BCHJOB,BCHBT,"TOP ACTS",9999999-^(X),X)=X_U_^(X)_U_(^(X)/BCHTT)
S X=0 F S X=$O(^XTMP("BCHRCH",BCHJOB,BCHBT,"PROBLEM",X)) Q:X'=+X S ^XTMP("BCHRCH",BCHJOB,BCHBT,"TOP PROBS",9999999-^(X),X)=X_U_^(X)_U_(^(X)/BCHTT)
Q
BCHRCH1 ; 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 DO XTMP^BCHUTIL("BCHRCH","CHR CHR REPORT")
+2 SET BCHTT=0
+3 SET (BCHBT,BCHBTH)=$HOROLOG
SET BCHJOB=$JOB
+4 DO D
+5 DO SETTMP
+6 DO END
+7 QUIT
+8 ;
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
SET BCHC=BCHC+1
Begin DoDot:1
+13 IF $PIECE(^BCHRPROB(BCHX,0),U,4)=""
QUIT
+14 SET P=$PIECE(^BCHRPROB(BCHX,0),U)
SET A=$PIECE(^BCHRPROB(BCHX,0),U,4)
SET S=$PIECE(^BCHRPROB(BCHX,0),U,5)
+15 SET BCHTT=BCHTT+S
IF BCHC=1
SET BCHTT=BCHTT+$PIECE(BCHR0,U,11)
+16 SET ^(P)=$SELECT($DATA(^XTMP("BCHRCH",BCHJOB,BCHBT,"PROBLEM",P)):^(P)+S,1:S)
IF BCHC=1
SET ^(P)=^(P)+$PIECE(BCHR0,U,11)
+17 SET ^(A)=$SELECT($DATA(^XTMP("BCHRCH",BCHJOB,BCHBT,"ACTIVITY",A)):^(A)+S,1:S)
IF BCHC=1
SET ^(A)=^(A)+$PIECE(BCHR0,U,11)
End DoDot:1
+18 QUIT
+19 ;
SETTMP ;
+1 SET X=0
FOR
SET X=$ORDER(^XTMP("BCHRCH",BCHJOB,BCHBT,"ACTIVITY",X))
IF X'=+X
QUIT
SET ^XTMP("BCHRCH",BCHJOB,BCHBT,"TOP ACTS",9999999-^(X),X)=X_U_^(X)_U_(^(X)/BCHTT)
+2 SET X=0
FOR
SET X=$ORDER(^XTMP("BCHRCH",BCHJOB,BCHBT,"PROBLEM",X))
IF X'=+X
QUIT
SET ^XTMP("BCHRCH",BCHJOB,BCHBT,"TOP PROBS",9999999-^(X),X)=X_U_^(X)_U_(^(X)/BCHTT)
+3 QUIT
