- 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
