- 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
