BCHRPT4 ; IHS/CMI/LAB - PROCESS VISIT LIST ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;IHS/CMI/LAB - tmp to xtmp
;
;
;
START ;
D XTMP^BCHUTIL("BCHRPT","CHR RECORD LIST")
D XTMP^BCHUTIL("BCHRAP2","CHR REPORT")
D XTMP^BCHUTIL("BCHTEN","CHR TOP TEN DX")
S (BCHBT,BCHBTH)=$H,BCHJOB=$J
I $P(^BCHRCNT(BCHRPTC,0),U,11)]"" S BCHRPREP=$P(^(0),U,11) S BCHRPREP=$TR(BCHRPREP,"~","^") D @BCHRPREP
D D,END
Q
;
S ;run by search template
S BCHR=0 F S BCHR=$O(^DIBT(BCHSEAT,1,BCHR)) Q:BCHR'=+BCHR I $D(^BCHR(BCHR,0)),$P(^(0),U,9),'$P(^(0),U,11) D PROC,EOJ
Q
D ; Run by visit date
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 V1
Q
;
END ;
I $P(^BCHRCNT(BCHRPTC,0),U,9)]"" S BCHRPOSP=$P(^(0),U,9) S BCHRPOSP=$TR(BCHRPOSP,"~","^") D @BCHRPOSP
S BCHET=$H
D EOJ
Q
EOJ ;
K BCHB,BCHI,BCHR,BCHRCNT
Q
V1 ;
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),DFN=$P(BCHR0,U,4) D PROC
Q
PROC ;
S BCHR0=^BCHR(BCHR,0)
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 BCHR11=$G(^BCHR(BCHR,11)),BCHR12=$G(^BCHR(BCHR,12)),BCHR13=$G(^BCHR(BCHR,13))
D SCREENS
Q:$D(BCHSKIP)
K BCHSRT,BCHPRNT S BCHCRIT=BCHSORT,BCHX=0
X:$D(^BCHSORT(BCHSORT,5)) ^BCHSORT(BCHSORT,5) I $G(BCHPRNT)']"" D
. I BCHPTVS="V" S Y=$P($P(BCHR0,U),".") S BCHPRNT=Y Q
. S BCHPRNT=$S($G(DFN):$P(^DPT(DFN,0),U),1:$P($G(^BCHR(BCHR,11)),U))
.Q
S BCHSRT=BCHPRNT I BCHSRT="" S BCHSRT="NONE AVAILABLE"
I $G(BCHRPTST)]"" D @(BCHRPTST) Q
S ^XTMP("BCHRPT",BCHJOB,BCHBTH,"RECORDS",BCHSRT,BCHR)=""
Q
SCREENS ;
S DFN=$P(BCHR0,U,4)
K BCHSKIP
S BCHI=0 F S BCHI=$O(^BCHTRPT(BCHRPT,11,BCHI)) Q:BCHI'=+BCHI!($D(BCHSKIP)) D
.I '$P(^BCHSORT(BCHI,0),U,8) D SINGLE Q
.D MULT
.Q
Q
SINGLE ;
S X=""
X:$D(^BCHSORT(BCHI,1)) ^(1)
I X="" S BCHSKIP="" Q
I '$D(^BCHTRPT(BCHRPT,11,BCHI,11,"B",X)) S BCHSKIP="" Q
Q
MULT ;
K BCHFOUN,BCHSKIP,X S BCHX=0,X=""
X:$D(^BCHSORT(BCHI,1)) ^(1)
I '$L($O(X)) S BCHSKIP="" Q
S Y="" F S Y=$O(X(Y)) Q:Y="" I $D(^BCHTRPT(BCHRPT,11,BCHI,11,"B",Y)) S BCHFOUN="" Q
S:'$D(BCHFOUN) BCHSKIP=""
Q
BCHRPT4 ; IHS/CMI/LAB - PROCESS VISIT LIST ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;IHS/CMI/LAB - tmp to xtmp
+3 ;
+4 ;
+5 ;
START ;
+1 DO XTMP^BCHUTIL("BCHRPT","CHR RECORD LIST")
+2 DO XTMP^BCHUTIL("BCHRAP2","CHR REPORT")
+3 DO XTMP^BCHUTIL("BCHTEN","CHR TOP TEN DX")
+4 SET (BCHBT,BCHBTH)=$HOROLOG
SET BCHJOB=$JOB
+5 IF $PIECE(^BCHRCNT(BCHRPTC,0),U,11)]""
SET BCHRPREP=$PIECE(^(0),U,11)
SET BCHRPREP=$TRANSLATE(BCHRPREP,"~","^")
DO @BCHRPREP
+6 DO D
DO END
+7 QUIT
+8 ;
S ;run by search template
+1 SET BCHR=0
FOR
SET BCHR=$ORDER(^DIBT(BCHSEAT,1,BCHR))
IF BCHR'=+BCHR
QUIT
IF $DATA(^BCHR(BCHR,0))
IF $PIECE(^(0),U,9)
IF '$PIECE(^(0),U,11)
DO PROC
DO EOJ
+2 QUIT
D ; Run by visit date
+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 V1
+3 QUIT
+4 ;
END ;
+1 IF $PIECE(^BCHRCNT(BCHRPTC,0),U,9)]""
SET BCHRPOSP=$PIECE(^(0),U,9)
SET BCHRPOSP=$TRANSLATE(BCHRPOSP,"~","^")
DO @BCHRPOSP
+2 SET BCHET=$HOROLOG
+3 DO EOJ
+4 QUIT
EOJ ;
+1 KILL BCHB,BCHI,BCHR,BCHRCNT
+2 QUIT
V1 ;
+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 DFN=$PIECE(BCHR0,U,4)
DO PROC
+2 QUIT
PROC ;
+1 SET BCHR0=^BCHR(BCHR,0)
+2 SET BCHPAT=$PIECE(BCHR0,U,4)
+3 SET BCHNRPAT=$PIECE($GET(^BCHR(BCHR,11)),U,12)
+4 ;I 'BCHPAT,'BCHNRPAT Q ;no patient
+5 IF BCHREG="R"
IF BCHPAT=""
QUIT
+6 IF BCHREG="N"
IF BCHNRPAT=""
QUIT
+7 IF BCHPAT
IF BCHNRPAT
SET BCHNRPAT=""
+8 IF BCHPAT
IF '$DATA(^DPT(BCHPAT,0))
QUIT
+9 SET BCHR11=$GET(^BCHR(BCHR,11))
SET BCHR12=$GET(^BCHR(BCHR,12))
SET BCHR13=$GET(^BCHR(BCHR,13))
+10 DO SCREENS
+11 IF $DATA(BCHSKIP)
QUIT
+12 KILL BCHSRT,BCHPRNT
SET BCHCRIT=BCHSORT
SET BCHX=0
+13 IF $DATA(^BCHSORT(BCHSORT,5))
XECUTE ^BCHSORT(BCHSORT,5)
IF $GET(BCHPRNT)']""
Begin DoDot:1
+14 IF BCHPTVS="V"
SET Y=$PIECE($PIECE(BCHR0,U),".")
SET BCHPRNT=Y
QUIT
+15 SET BCHPRNT=$SELECT($GET(DFN):$PIECE(^DPT(DFN,0),U),1:$PIECE($GET(^BCHR(BCHR,11)),U))
+16 QUIT
End DoDot:1
+17 SET BCHSRT=BCHPRNT
IF BCHSRT=""
SET BCHSRT="NONE AVAILABLE"
+18 IF $GET(BCHRPTST)]""
DO @(BCHRPTST)
QUIT
+19 SET ^XTMP("BCHRPT",BCHJOB,BCHBTH,"RECORDS",BCHSRT,BCHR)=""
+20 QUIT
SCREENS ;
+1 SET DFN=$PIECE(BCHR0,U,4)
+2 KILL BCHSKIP
+3 SET BCHI=0
FOR
SET BCHI=$ORDER(^BCHTRPT(BCHRPT,11,BCHI))
IF BCHI'=+BCHI!($DATA(BCHSKIP))
QUIT
Begin DoDot:1
+4 IF '$PIECE(^BCHSORT(BCHI,0),U,8)
DO SINGLE
QUIT
+5 DO MULT
+6 QUIT
End DoDot:1
+7 QUIT
SINGLE ;
+1 SET X=""
+2 IF $DATA(^BCHSORT(BCHI,1))
XECUTE ^(1)
+3 IF X=""
SET BCHSKIP=""
QUIT
+4 IF '$DATA(^BCHTRPT(BCHRPT,11,BCHI,11,"B",X))
SET BCHSKIP=""
QUIT
+5 QUIT
MULT ;
+1 KILL BCHFOUN,BCHSKIP,X
SET BCHX=0
SET X=""
+2 IF $DATA(^BCHSORT(BCHI,1))
XECUTE ^(1)
+3 IF '$LENGTH($ORDER(X))
SET BCHSKIP=""
QUIT
+4 SET Y=""
FOR
SET Y=$ORDER(X(Y))
IF Y=""
QUIT
IF $DATA(^BCHTRPT(BCHRPT,11,BCHI,11,"B",Y))
SET BCHFOUN=""
QUIT
+5 IF '$DATA(BCHFOUN)
SET BCHSKIP=""
+6 QUIT
