- BCHRC11 ; IHS/CMI/LAB - PROCESS REPORT ;
- ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
- ;IHS/CMI/LAB - tmp to xtmp
- ;
- ;
- ;
- ;
- START ;
- S (BCHBT,BCHBTH)=$H,BCHJOB=$J
- D XTMP^BCHUTIL("BCHRC1","CHR CHR REPORT")
- D 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 D
- .S BCHC=BCHC+1
- .I BCHLEAVE="D" I $P(^BCHRPROB(BCHX,0),U,4),$P(^BCHTSERV($P(^BCHRPROB(BCHX,0),U,4),0),U,3)="LT" Q
- .D @BCHRPT
- .D
- ..;BY 1ST LEVEL
- ..S $P(^(BCHPROBN),U)=$S($D(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN)):$P(^(BCHPROBN),U)+1,1:1)
- ..S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)+$P(^BCHRPROB(BCHX,0),U,5)
- ..I BCHC=1 S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)+$P(BCHR0,U,11)
- ..I BCHRPT=3,BCHC=1 D
- ...S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)+$P(BCHR0,U,12)
- ..I BCHRPT'=3 D
- ...S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)+$P(BCHR0,U,12)
- ..;SUBTOTALS
- ..S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U)=$S($D(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1)):$P(^(BCHSUB1),U)+1,1:1)
- ..S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,2)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,2)+$P(^BCHRPROB(BCHX,0),U,5)
- ..I BCHC=1 S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,3)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,3)+$P(BCHR0,U,11)
- ..I BCHRPT=3,BCHC=1 D
- ...S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)+$P(BCHR0,U,12)
- ..I BCHRPT'=3 D
- ...S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)+$P(BCHR0,U,12)
- ..;TOTALS
- ..S $P(^("*TOTAL*"),U)=$S($D(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*")):$P(^("*TOTAL*"),U)+1,1:1)
- ..S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,2)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,2)+$P(^BCHRPROB(BCHX,0),U,5)
- ..I BCHC=1 S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,3)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,3)+$P(BCHR0,U,11)
- ..I BCHRPT=3,BCHC=1 S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,4)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,4)+$P(BCHR0,U,12)
- ..I BCHRPT'=3 S $P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,4)=$P(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,4)+$P(BCHR0,U,12)
- Q
- 1 ;health area
- S BCHPROB=$P(^BCHRPROB(BCHX,0),U)
- S BCHPROBN=$P(^BCHTPROB(BCHPROB,0),U)_"|"_$P(^BCHTPROB(BCHPROB,0),U,2)
- S BCHSUB1=$P(^BCHRPROB(BCHX,0),U,4)
- I BCHSUB1="" S BCHSUB1="NO ACTIVITY ENTERED|**" Q
- S BCHSUB1=$P(^BCHTSERV(BCHSUB1,0),U)_"|"_$P(^BCHTSERV(BCHSUB1,0),U,3)
- Q
- 2 ;activity
- S BCHPROB=$P(^BCHRPROB(BCHX,0),U,4)
- I BCHPROB="" S BCHPROBN="NO SERVICE ENTERED|**"
- I BCHPROB]"" S BCHPROBN=$P(^BCHTSERV(BCHPROB,0),U)_"|"_$P(^BCHTSERV(BCHPROB,0),U,3)
- S BCHSUB1=$P(^BCHRPROB(BCHX,0),U)
- I BCHSUB1="" S BCHSUB1="NO PROBLEM ENTERED|**" Q
- S BCHSUB1=$P(^BCHTPROB(BCHSUB1,0),U)_"|"_$P(^BCHTPROB(BCHSUB1,0),U,2)
- Q
- 3 ;setting
- S BCHPROB=$P(BCHR0,U,6)
- I BCHPROB="" S BCHPROBN="NO SETTING ENTERED|**" Q
- S BCHPROBN=$P(^BCHTACTL(BCHPROB,0),U)_"|"_$P(^(0),U,5)
- S BCHSUB1=$$VAL^XBDIQ1(90002,BCHR,.03)
- I BCHSUB1="" S BCHSUB1="UNKNOWN"
- Q
- BCHRC11 ; 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 SET (BCHBT,BCHBTH)=$HOROLOG
- SET BCHJOB=$JOB
- +2 DO XTMP^BCHUTIL("BCHRC1","CHR CHR REPORT")
- +3 DO D
- DO END
- +4 QUIT
- +5 ;
- 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
- Begin DoDot:1
- +13 SET BCHC=BCHC+1
- +14 IF BCHLEAVE="D"
- IF $PIECE(^BCHRPROB(BCHX,0),U,4)
- IF $PIECE(^BCHTSERV($PIECE(^BCHRPROB(BCHX,0),U,4),0),U,3)="LT"
- QUIT
- +15 DO @BCHRPT
- +16 Begin DoDot:2
- +17 ;BY 1ST LEVEL
- +18 SET $PIECE(^(BCHPROBN),U)=$SELECT($DATA(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN)):$PIECE(^(BCHPROBN),U)+1,1:1)
- +19 SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,2)+$PIECE(^BCHRPROB(BCHX,0),U,5)
- +20 IF BCHC=1
- SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,3)+$PIECE(BCHR0,U,11)
- +21 IF BCHRPT=3
- IF BCHC=1
- Begin DoDot:3
- +22 SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)+$PIECE(BCHR0,U,12)
- End DoDot:3
- +23 IF BCHRPT'=3
- Begin DoDot:3
- +24 SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN),U,4)+$PIECE(BCHR0,U,12)
- End DoDot:3
- +25 ;SUBTOTALS
- +26 SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U)=$SELECT($DATA(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1)):$PIECE(^(BCHSUB1),U)+1,1:1)
- +27 SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,2)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,2)+$PIECE(^BCHRPROB(BCHX,0),U,5)
- +28 IF BCHC=1
- SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,3)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,3)+$PIECE(BCHR0,U,11)
- +29 IF BCHRPT=3
- IF BCHC=1
- Begin DoDot:3
- +30 SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)+$PIECE(BCHR0,U,12)
- End DoDot:3
- +31 IF BCHRPT'=3
- Begin DoDot:3
- +32 SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA",BCHPROBN,BCHSUB1),U,4)+$PIECE(BCHR0,U,12)
- End DoDot:3
- +33 ;TOTALS
- +34 SET $PIECE(^("*TOTAL*"),U)=$SELECT($DATA(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*")):$PIECE(^("*TOTAL*"),U)+1,1:1)
- +35 SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,2)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,2)+$PIECE(^BCHRPROB(BCHX,0),U,5)
- +36 IF BCHC=1
- SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,3)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,3)+$PIECE(BCHR0,U,11)
- +37 IF BCHRPT=3
- IF BCHC=1
- SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,4)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,4)+$PIECE(BCHR0,U,12)
- +38 IF BCHRPT'=3
- SET $PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,4)=$PIECE(^XTMP("BCHRC1",BCHJOB,BCHBT,"DATA","*TOTAL*"),U,4)+$PIECE(BCHR0,U,12)
- End DoDot:2
- End DoDot:1
- +39 QUIT
- 1 ;health area
- +1 SET BCHPROB=$PIECE(^BCHRPROB(BCHX,0),U)
- +2 SET BCHPROBN=$PIECE(^BCHTPROB(BCHPROB,0),U)_"|"_$PIECE(^BCHTPROB(BCHPROB,0),U,2)
- +3 SET BCHSUB1=$PIECE(^BCHRPROB(BCHX,0),U,4)
- +4 IF BCHSUB1=""
- SET BCHSUB1="NO ACTIVITY ENTERED|**"
- QUIT
- +5 SET BCHSUB1=$PIECE(^BCHTSERV(BCHSUB1,0),U)_"|"_$PIECE(^BCHTSERV(BCHSUB1,0),U,3)
- +6 QUIT
- 2 ;activity
- +1 SET BCHPROB=$PIECE(^BCHRPROB(BCHX,0),U,4)
- +2 IF BCHPROB=""
- SET BCHPROBN="NO SERVICE ENTERED|**"
- +3 IF BCHPROB]""
- SET BCHPROBN=$PIECE(^BCHTSERV(BCHPROB,0),U)_"|"_$PIECE(^BCHTSERV(BCHPROB,0),U,3)
- +4 SET BCHSUB1=$PIECE(^BCHRPROB(BCHX,0),U)
- +5 IF BCHSUB1=""
- SET BCHSUB1="NO PROBLEM ENTERED|**"
- QUIT
- +6 SET BCHSUB1=$PIECE(^BCHTPROB(BCHSUB1,0),U)_"|"_$PIECE(^BCHTPROB(BCHSUB1,0),U,2)
- +7 QUIT
- 3 ;setting
- +1 SET BCHPROB=$PIECE(BCHR0,U,6)
- +2 IF BCHPROB=""
- SET BCHPROBN="NO SETTING ENTERED|**"
- QUIT
- +3 SET BCHPROBN=$PIECE(^BCHTACTL(BCHPROB,0),U)_"|"_$PIECE(^(0),U,5)
- +4 SET BCHSUB1=$$VAL^XBDIQ1(90002,BCHR,.03)
- +5 IF BCHSUB1=""
- SET BCHSUB1="UNKNOWN"
- +6 QUIT
