BCHRL1 ; IHS/CMI/LAB - PROCESS CHR RECORD LIST ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;IHS/CMI/LAB - tmp to xtmp
;
;
;
START ;
D XTMP^BCHUTIL("BCHRL","CHR GENERAL RETRIEVAL")
S (BCHBT,BCHBTH)=$H,BCHJOB=$J,BCHRCNT=0
S BCHPROC=BCHPTVS_BCHTYPE
I $D(BCHRDTR),BCHPTVS="P" D VD,END Q
D @BCHPROC,END
Q
;
VS ;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) S BCHR0=^BCHR(BCHR,0),DFN=$P(BCHR0,U,4) D PROC,EOJ
Q
VD ; 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
;
PP ;
S BCHR=0 F S BCHR=$O(^DPT(BCHR)) Q:BCHR'=+BCHR I '$P(^DPT(BCHR,0),U,19) S DFN=BCHR D PROC
Q
;
PS ;
S BCHR=0 F S BCHR=$O(^DIBT(BCHSEAT,1,BCHR)) Q:BCHR'=+BCHR I $D(^DPT(BCHR,0)),'$P(^(0),U,19) S DFN=BCHR D PROC,EOJ
Q
;
;
END ;
S BCHET=$H
D EOJ
Q
EOJ ;
Q
V1 ;
S BCHR="" 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=^BCHR(BCHR,0),DFN=$P(BCHR0,U,4) D PROC,EOJ
Q
PROC ;
S BCHR11=$G(^BCHR(BCHR,11)),BCHR12=$G(^BCHR(BCHR,12)),BCHR13=$G(^BCHR(BCHR,13))
I BCHPTVS="P",DFN="" Q
D SCREENS
Q:$D(BCHSKIP)
K BCHSRT,BCHPRNT S BCHCRIT=BCHSORT,BCHX=0 X:$D(^BCHSORT(BCHSORT,5)) ^BCHSORT(BCHSORT,5) I '$D(BCHPRNT) D
. I BCHPTVS="V" S Y=$P($P(BCHR0,U),".") D DD^%DT S BCHPRNT=Y Q
. S BCHPRNT=$P(^DPT(DFN,0),U)
. Q
S BCHSRT=BCHPRNT I BCHSRT="" S BCHSRT="??"
I '$D(BCHRDTR) S ^XTMP("BCHRL",BCHJOB,BCHBTH,"DATA HITS",BCHSRT,BCHR)="",BCHRCNT=BCHRCNT+1
I $D(BCHRDTR) S ^XTMP("BCHRL",BCHJOB,BCHBTH,"DATA HITS",BCHSRT,DFN)="",BCHRCNT=BCHRCNT+1
Q:'$G(DFN)
Q:$D(^XTMP("BCHRL",BCHJOB,BCHBTH,"PATIENTS",DFN))
S ^XTMP("BCHRL",BCHJOB,BCHBTH,"PATIENTS",DFN)="",BCHPTCT=BCHPTCT+1
Q
SCREENS ;
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 ;
K X,BCHSPEC S X="",BCHX=0
X:$D(^BCHSORT(BCHI,1)) ^(1)
I X="" S BCHSKIP="" Q
I '$D(BCHSPEC),'$D(^BCHTRPT(BCHRPT,11,BCHI,11,"B",X)) S BCHSKIP="" Q
Q
MULT ;
K BCHFOUN,BCHSKIP,BCHSPEC,X S BCHX=0,X=""
X:$D(^BCHSORT(BCHI,1)) ^(1)
I $O(X(""))="" S BCHSKIP="" Q
I '$D(BCHSPEC) S Y="" F S Y=$O(X(Y)) Q:Y="" I $D(^BCHTRPT(BCHRPT,11,BCHI,11,"B",Y)) S BCHFOUN="" Q
I $D(BCHSPEC),$D(X) S BCHFOUN=1 Q
S:'$D(BCHFOUN) BCHSKIP=""
Q
XIT ;EP - CALLED FROM BCHRL
K BCHBD,BCHBDD,BCHED,BCHEDD,BCHSD,BCHSORT,BCHSORV,BCHTCW,BCHRPT,BCHLHDR,BCHDISP,%H,BCHET,BCHLINE,BCHPRNM,BCHPRNT,BCHSKIP,BCHTYPE,BCHSPAG,BCHEN1,BCHSEAT,BCHPTVS,BCHPROC,BCH,BCHCAND,BCHHDR,BCHHEAD,BCHGDB,BCHGDE,BCHGDS
K BCHACE,BCHCTYP,BCHFLG,BCHG,BCHNAME,BCHNIFN,BCHSAVE,BCHTITL,BCHQUIT,BCHPCNT,BCHQFLG,BCHPTCT,BCHTL,BCHXREF,BCHSRTR,BCHSRTV,BCHGBD,BCHGBE,BCHGBS
K C,D,D0,DA,DIC,DD,DFN,DIADD,DLAYGO,DICR,DIE,DIK,DINUM,DIQ,DIR,DIRUT,DUOUT,DTOUT,DR,J,I,J,K,M,S,TS,X,Y,DIG,DIH,DIV,DQ,DDH
XIT1 ;EP
K BCHANS,BCHBTH,BCHC,BCHCNT,BCHCRIT,BCHCUT,BCHD,BCHDISP,BCHDONE,BCHHIGH,BCHI,BCHJOB,BCHQMAN,BCHSEL,BCHTEXT,BCHRAR,BCHSKIP,BCHPRNT,BCHPRNM,BCHLINE,BCHRCNT,BCHDFET,BCHY,DFN
K X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M,ZTIO,DUOUT,DIR,DTOUT,V,Z,I,DIC,DIK,DIADD,DLAYGO,DA,DR,DIE,DIU,AMQQTAX,DINUM,BCHPACK,BCHEP1,BCHEP2,D,BCHLENG,BCHLHDR,BCHSAVE
Q
BCHRL1 ; IHS/CMI/LAB - PROCESS CHR RECORD 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("BCHRL","CHR GENERAL RETRIEVAL")
+2 SET (BCHBT,BCHBTH)=$HOROLOG
SET BCHJOB=$JOB
SET BCHRCNT=0
+3 SET BCHPROC=BCHPTVS_BCHTYPE
+4 IF $DATA(BCHRDTR)
IF BCHPTVS="P"
DO VD
DO END
QUIT
+5 DO @BCHPROC
DO END
+6 QUIT
+7 ;
VS ;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)
SET BCHR0=^BCHR(BCHR,0)
SET DFN=$PIECE(BCHR0,U,4)
DO PROC
DO EOJ
+2 QUIT
VD ; 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 ;
PP ;
+1 SET BCHR=0
FOR
SET BCHR=$ORDER(^DPT(BCHR))
IF BCHR'=+BCHR
QUIT
IF '$PIECE(^DPT(BCHR,0),U,19)
SET DFN=BCHR
DO PROC
+2 QUIT
+3 ;
PS ;
+1 SET BCHR=0
FOR
SET BCHR=$ORDER(^DIBT(BCHSEAT,1,BCHR))
IF BCHR'=+BCHR
QUIT
IF $DATA(^DPT(BCHR,0))
IF '$PIECE(^(0),U,19)
SET DFN=BCHR
DO PROC
DO EOJ
+2 QUIT
+3 ;
+4 ;
END ;
+1 SET BCHET=$HOROLOG
+2 DO EOJ
+3 QUIT
EOJ ;
+1 QUIT
V1 ;
+1 SET BCHR=""
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=^BCHR(BCHR,0)
SET DFN=$PIECE(BCHR0,U,4)
DO PROC
DO EOJ
+2 QUIT
PROC ;
+1 SET BCHR11=$GET(^BCHR(BCHR,11))
SET BCHR12=$GET(^BCHR(BCHR,12))
SET BCHR13=$GET(^BCHR(BCHR,13))
+2 IF BCHPTVS="P"
IF DFN=""
QUIT
+3 DO SCREENS
+4 IF $DATA(BCHSKIP)
QUIT
+5 KILL BCHSRT,BCHPRNT
SET BCHCRIT=BCHSORT
SET BCHX=0
IF $DATA(^BCHSORT(BCHSORT,5))
XECUTE ^BCHSORT(BCHSORT,5)
IF '$DATA(BCHPRNT)
Begin DoDot:1
+6 IF BCHPTVS="V"
SET Y=$PIECE($PIECE(BCHR0,U),".")
DO DD^%DT
SET BCHPRNT=Y
QUIT
+7 SET BCHPRNT=$PIECE(^DPT(DFN,0),U)
+8 QUIT
End DoDot:1
+9 SET BCHSRT=BCHPRNT
IF BCHSRT=""
SET BCHSRT="??"
+10 IF '$DATA(BCHRDTR)
SET ^XTMP("BCHRL",BCHJOB,BCHBTH,"DATA HITS",BCHSRT,BCHR)=""
SET BCHRCNT=BCHRCNT+1
+11 IF $DATA(BCHRDTR)
SET ^XTMP("BCHRL",BCHJOB,BCHBTH,"DATA HITS",BCHSRT,DFN)=""
SET BCHRCNT=BCHRCNT+1
+12 IF '$GET(DFN)
QUIT
+13 IF $DATA(^XTMP("BCHRL",BCHJOB,BCHBTH,"PATIENTS",DFN))
QUIT
+14 SET ^XTMP("BCHRL",BCHJOB,BCHBTH,"PATIENTS",DFN)=""
SET BCHPTCT=BCHPTCT+1
+15 QUIT
SCREENS ;
+1 KILL BCHSKIP
+2 SET BCHI=0
FOR
SET BCHI=$ORDER(^BCHTRPT(BCHRPT,11,BCHI))
IF BCHI'=+BCHI!($DATA(BCHSKIP))
QUIT
Begin DoDot:1
+3 IF '$PIECE(^BCHSORT(BCHI,0),U,8)
DO SINGLE
QUIT
+4 DO MULT
+5 QUIT
End DoDot:1
+6 QUIT
SINGLE ;
+1 KILL X,BCHSPEC
SET X=""
SET BCHX=0
+2 IF $DATA(^BCHSORT(BCHI,1))
XECUTE ^(1)
+3 IF X=""
SET BCHSKIP=""
QUIT
+4 IF '$DATA(BCHSPEC)
IF '$DATA(^BCHTRPT(BCHRPT,11,BCHI,11,"B",X))
SET BCHSKIP=""
QUIT
+5 QUIT
MULT ;
+1 KILL BCHFOUN,BCHSKIP,BCHSPEC,X
SET BCHX=0
SET X=""
+2 IF $DATA(^BCHSORT(BCHI,1))
XECUTE ^(1)
+3 IF $ORDER(X(""))=""
SET BCHSKIP=""
QUIT
+4 IF '$DATA(BCHSPEC)
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(BCHSPEC)
IF $DATA(X)
SET BCHFOUN=1
QUIT
+6 IF '$DATA(BCHFOUN)
SET BCHSKIP=""
+7 QUIT
XIT ;EP - CALLED FROM BCHRL
+1 KILL BCHBD,BCHBDD,BCHED,BCHEDD,BCHSD,BCHSORT,BCHSORV,BCHTCW,BCHRPT,BCHLHDR,BCHDISP,%H,BCHET,BCHLINE,BCHPRNM,BCHPRNT,BCHSKIP,BCHTYPE,BCHSPAG,BCHEN1,BCHSEAT,BCHPTVS,BCHPROC,BCH,BCHCAND,BCHHDR,BCHHEAD,BCHGDB,BCHGDE,BCHGDS
+2 KILL BCHACE,BCHCTYP,BCHFLG,BCHG,BCHNAME,BCHNIFN,BCHSAVE,BCHTITL,BCHQUIT,BCHPCNT,BCHQFLG,BCHPTCT,BCHTL,BCHXREF,BCHSRTR,BCHSRTV,BCHGBD,BCHGBE,BCHGBS
+3 KILL C,D,D0,DA,DIC,DD,DFN,DIADD,DLAYGO,DICR,DIE,DIK,DINUM,DIQ,DIR,DIRUT,DUOUT,DTOUT,DR,J,I,J,K,M,S,TS,X,Y,DIG,DIH,DIV,DQ,DDH
XIT1 ;EP
+1 KILL BCHANS,BCHBTH,BCHC,BCHCNT,BCHCRIT,BCHCUT,BCHD,BCHDISP,BCHDONE,BCHHIGH,BCHI,BCHJOB,BCHQMAN,BCHSEL,BCHTEXT,BCHRAR,BCHSKIP,BCHPRNT,BCHPRNM,BCHLINE,BCHRCNT,BCHDFET,BCHY,DFN
+2 KILL X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M,ZTIO,DUOUT,DIR,DTOUT,V,Z,I,DIC,DIK,DIADD,DLAYGO,DA,DR,DIE,DIU,AMQQTAX,DINUM,BCHPACK,BCHEP1,BCHEP2,D,BCHLENG,BCHLHDR,BCHSAVE
+3 QUIT
