BCHRP31.m

BCHRP31 ; IHS/CMI/LAB - PROCESS REPORT ; 

 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27

 ;IHS/CMI/LAB - tmp to xtmp

 ;

 ;

 ;

 ;

START ;

 D XTMP^BCHUTIL("BCHRP3","CHR ACTIVITY REPORT")

 S (BCHBT,BCHBTH)=$H,BCHJOB=$J

 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)]"",$D(^BCHRPROB("AD",BCHR)) S BCHR0=^BCHR(BCHR,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),BCHPROGN=$P(^BCHTPROG(BCHPROG,0),U)_" ("_$P(^(0),U,5)_")"

 I BCHPRG,BCHPRG'=BCHPROG Q  ;not correct program

 S BCHLOC=$P(BCHR0,U,6) Q:BCHLOC=""  S BCHLOCN=$P(^BCHTACTL(BCHLOC,0),U)

 S BCHPROV=$P(BCHR0,U,3) Q:BCHPROV=""  S BCHPNAME=$P(^VA(200,BCHPROV,0),U)

 S BCHX=0 F  S BCHX=$O(^BCHRPROB("AD",BCHR,BCHX)) Q:BCHX'=+BCHX  S BCHACT=$P(^BCHRPROB(BCHX,0),U,4),BCHPROB=$P(^(0),U) I BCHACT]""  D

 .S BCHACTN=$P(^BCHTSERV(BCHACT,0),U)_" ("_$P(^(0),U,3)_")"

 .S BCHPROB=$P(^BCHTPROB(BCHPROB,0),U)_" ("_$P(^(0),U,2)_")"

 .S $P(^(BCHPROB),U)=$S($D(^XTMP("BCHRP3",BCHJOB,BCHBT,"RECORDS",BCHPROGN,BCHLOCN,BCHPNAME,BCHACTN,BCHPROB)):$P(^(BCHPROB),U)+1,1:1)

 .S $P(^XTMP("BCHRP3",BCHJOB,BCHBT,"RECORDS",BCHPROGN,BCHLOCN,BCHPNAME,BCHACTN,BCHPROB),U,2)=$P(^XTMP("BCHRP3",BCHJOB,BCHBT,"RECORDS",BCHPROGN,BCHLOCN,BCHPNAME,BCHACTN,BCHPROB),U,2)+$P(^BCHRPROB(BCHX,0),U,5)

 Q

BCHRP31   ; 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        DO XTMP^BCHUTIL("BCHRP3","CHR ACTIVITY REPORT")

 +2        SET (BCHBT,BCHBTH)=$HOROLOG

           SET BCHJOB=$JOB

 +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)]""

                           IF $DATA(^BCHRPROB("AD",BCHR))

                               SET BCHR0=^BCHR(BCHR,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)

           SET BCHPROGN=$PIECE(^BCHTPROG(BCHPROG,0),U)_" ("_$PIECE(^(0),U,5)_")"

 +9       ;not correct program

           IF BCHPRG

               IF BCHPRG'=BCHPROG

                   QUIT 

 +10       SET BCHLOC=$PIECE(BCHR0,U,6)

           IF BCHLOC=""

               QUIT 

           SET BCHLOCN=$PIECE(^BCHTACTL(BCHLOC,0),U)

 +11       SET BCHPROV=$PIECE(BCHR0,U,3)

           IF BCHPROV=""

               QUIT 

           SET BCHPNAME=$PIECE(^VA(200,BCHPROV,0),U)

 +12       SET BCHX=0

           FOR 

               SET BCHX=$ORDER(^BCHRPROB("AD",BCHR,BCHX))

               IF BCHX'=+BCHX

                   QUIT 

               SET BCHACT=$PIECE(^BCHRPROB(BCHX,0),U,4)

               SET BCHPROB=$PIECE(^(0),U)

               IF BCHACT]""

                   Begin DoDot:1

 +13                   SET BCHACTN=$PIECE(^BCHTSERV(BCHACT,0),U)_" ("_$PIECE(^(0),U,3)_")"

 +14                   SET BCHPROB=$PIECE(^BCHTPROB(BCHPROB,0),U)_" ("_$PIECE(^(0),U,2)_")"

 +15                   SET $PIECE(^(BCHPROB),U)=$SELECT($DATA(^XTMP("BCHRP3",BCHJOB,BCHBT,"RECORDS",BCHPROGN,BCHLOCN,BCHPNAME,BCHACTN,BCHPROB)):$PIECE(^(BCHPROB),U)+1,1:1)

 +16                   SET $PIECE(^XTMP("BCHRP3",BCHJOB,BCHBT,"RECORDS",BCHPROGN,BCHLOCN,BCHPNAME,BCHACTN,BCHPROB),U,2)=$PIECE(^XTMP("BCHRP3",BCHJOB,BCHBT,"RECORDS",BCHPROGN,BCHLOCN,BCHPNAME,BCHACTN,BCHPROB),U,2)+$PIECE(^BCHRPROB(BCHX,0),U,5)

                   End DoDot:1

 +17       QUIT