BCHULKUP.m

BCHULKUP ; IHS/CMI/LAB - lookup up record ; 

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

 ;

EN ;

 ;

 ;Display all records for the provider, on this date.

 D HOME^%ZIS W:$D(IOF) @IOF

 D EOJ

 I BCHPROV]"",'$D(^BCHR("AA",BCHDATE,BCHPROV)) W !!,"No records currently on file for ",$P(^VA(200,BCHPROV,0),U),".",! Q

 S BCHDASH="--------------------------------------------------------------------------------"

 D COLLECT

 I BCHRCNT=1 S BCHR=BCHVRECS(1) D EOJ Q

 I BCHRCNT=0 K BCHR D EOJ Q

 D DISPRECS

 D SELECT

EOJ ;

 K BCHQUIT,BCHPG,BCHODAT,BCHDASH,BCHVRECS,BCHP,BCHR0,BCHRCNT,BCHRECN,BCHX

 Q

HEAD ;

 I 'BCHPG G HEAD1

 I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S BCHQUIT="" Q

HEAD1 ;

 S BCHPG=BCHPG+1

 W:$D(IOF) @IOF

 W !,BCHDASH

 W !,"CHR records for " S Y=BCHDATE D DD^%DT W Y I BCHPROV]"" W ?32,"CHR (Provider):  ",$P(^VA(200,BCHPROV,0),U)

 W !,BCHDASH

 W !," #",?5,"CHR/PROVIDER",?21,"HP  SC  MIN  NARRATIVE",?53,"LOC",?60,"PATIENT NAME",!,BCHDASH

 Q

SELECT ;

 K BCHR

 W ! S DIR(0)="NO^1:"_BCHRCNT_":0",DIR("A")="Select record" D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 I $D(DIRUT) W !,"No Records selected." D PAUSE^BCHUTIL1 Q

 I '$D(BCHVRECS(+Y)) W !,"Invalid selection!!" G SELECT

 S BCHR=BCHVRECS(+Y)

 Q

COLLECT ;

 S BCHODAT=(BCHDATE-1)_".9999",(BCHRCNT,BCHR)=0 F  S BCHODAT=$O(^BCHR("B",BCHODAT)) Q:BCHODAT=""!(BCHODAT>(BCHDATE_".9999"))!($D(BCHQUIT))  D

 .S BCHR=0 F  S BCHR=$O(^BCHR("B",BCHODAT,BCHR)) Q:BCHR'=+BCHR!($D(BCHQUIT))  S BCHR0=^BCHR(BCHR,0) D

 ..I BCHPROV]"",BCHPROV'=$P(BCHR0,U,3) Q

 ..S BCHRCNT=BCHRCNT+1,BCHVRECS(BCHRCNT)=BCHR

 ..Q

 .Q

 Q

DISPRECS ;display records for selection by user

 S BCHPG=0

 D HEAD

 S (BCHPG,BCHRECN,BCHR)=0 F  S BCHRECN=$O(BCHVRECS(BCHRECN)) Q:BCHRECN'=+BCHRECN  S BCHR=BCHVRECS(BCHRECN),BCHR0=^BCHR(BCHR,0) D

 .I $Y>(IOSL-2) D HEAD Q:$D(BCHQUIT)

 .W !,BCHRECN,?5,$E($$PPNAME^BCHUTIL(BCHR),1,15)

 .I '$D(^BCHRPROB("AD",BCHR)) W ?25,"           --"

 .E  D GETPROB W ?21,BCHX

 .W ?53,$S($P(^BCHR(BCHR,0),U,6)]"":$E($P(^BCHTACTL($P(^BCHR(BCHR,0),U,6),0),U),1,5),1:"????")

 .I $P(^BCHR(BCHR,0),U,4)]"" W ?60,$E($P(^DPT($P(^BCHR(BCHR,0),U,4),0),U),1,20)

 .E  I $P($G(^BCHR(BCHR,11)),U)]"" W ?60,$E($P(^BCHR(BCHR,11),U),1,20)

 .E  W ?66,"<none>"

 .Q

 Q

GETPROB ;

 S BCHX=""

 S BCHP=$O(^BCHRPROB("AD",BCHR,0)),BCHPREC=^BCHRPROB(BCHP,0)

 S X=$P(^BCHTPROB($P(BCHPREC,U),0),U,2)_"  "

 S X=X_$S($P(BCHPREC,U,4)]"":$P(^BCHTSERV($P(BCHPREC,U,4),0),U,3),1:"  ")_"  "

 S X=X_$J($P(BCHPREC,U,5),3)_"  "

 S X=X_$S($P(BCHPREC,U,6)]"":$E($P(^AUTNPOV($P(BCHPREC,U,6),0),U),1,16),1:"  ")

 S X=$$RBLK^BCHUARL(X,31)

 S BCHX=BCHX_X

 Q

BCHULKUP  ; IHS/CMI/LAB - lookup up record ; 

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

 +2       ;

EN        ;

 +1       ;

 +2       ;Display all records for the provider, on this date.

 +3        DO HOME^%ZIS

           IF $DATA(IOF)

               WRITE @IOF

 +4        DO EOJ

 +5        IF BCHPROV]""

               IF '$DATA(^BCHR("AA",BCHDATE,BCHPROV))

                   WRITE !!,"No records currently on file for ",$PIECE(^VA(200,BCHPROV,0),U),".",!

                   QUIT 

 +6        SET BCHDASH="--------------------------------------------------------------------------------"

 +7        DO COLLECT

 +8        IF BCHRCNT=1

               SET BCHR=BCHVRECS(1)

               DO EOJ

               QUIT 

 +9        IF BCHRCNT=0

               KILL BCHR

               DO EOJ

               QUIT 

 +10       DO DISPRECS

 +11       DO SELECT

EOJ       ;

 +1        KILL BCHQUIT,BCHPG,BCHODAT,BCHDASH,BCHVRECS,BCHP,BCHR0,BCHRCNT,BCHRECN,BCHX

 +2        QUIT 

HEAD      ;

 +1        IF 'BCHPG

               GOTO HEAD1

 +2        IF $EXTRACT(IOST)="C"

               IF IO=IO(0)

                   WRITE !

                   SET DIR(0)="EO"

                   DO ^DIR

                   KILL DIR

                   IF Y=0!(Y="^")!($DATA(DTOUT))

                       SET BCHQUIT=""

                       QUIT 

HEAD1     ;

 +1        SET BCHPG=BCHPG+1

 +2        IF $DATA(IOF)

               WRITE @IOF

 +3        WRITE !,BCHDASH

 +4        WRITE !,"CHR records for "

           SET Y=BCHDATE

           DO DD^%DT

           WRITE Y

           IF BCHPROV]""

               WRITE ?32,"CHR (Provider):  ",$PIECE(^VA(200,BCHPROV,0),U)

 +5        WRITE !,BCHDASH

 +6        WRITE !," #",?5,"CHR/PROVIDER",?21,"HP  SC  MIN  NARRATIVE",?53,"LOC",?60,"PATIENT NAME",!,BCHDASH

 +7        QUIT 

SELECT    ;

 +1        KILL BCHR

 +2        WRITE !

           SET DIR(0)="NO^1:"_BCHRCNT_":0"

           SET DIR("A")="Select record"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        IF $DATA(DIRUT)

               WRITE !,"No Records selected."

               DO PAUSE^BCHUTIL1

               QUIT 

 +4        IF '$DATA(BCHVRECS(+Y))

               WRITE !,"Invalid selection!!"

               GOTO SELECT

 +5        SET BCHR=BCHVRECS(+Y)

 +6        QUIT 

COLLECT   ;

 +1        SET BCHODAT=(BCHDATE-1)_".9999"

           SET (BCHRCNT,BCHR)=0

           FOR 

               SET BCHODAT=$ORDER(^BCHR("B",BCHODAT))

               IF BCHODAT=""!(BCHODAT>(BCHDATE_".9999"))!($DATA(BCHQUIT))

                   QUIT 

               Begin DoDot:1

 +2                SET BCHR=0

                   FOR 

                       SET BCHR=$ORDER(^BCHR("B",BCHODAT,BCHR))

                       IF BCHR'=+BCHR!($DATA(BCHQUIT))

                           QUIT 

                       SET BCHR0=^BCHR(BCHR,0)

                       Begin DoDot:2

 +3                        IF BCHPROV]""

                               IF BCHPROV'=$PIECE(BCHR0,U,3)

                                   QUIT 

 +4                        SET BCHRCNT=BCHRCNT+1

                           SET BCHVRECS(BCHRCNT)=BCHR

 +5                        QUIT 

                       End DoDot:2

 +6                QUIT 

               End DoDot:1

 +7        QUIT 

DISPRECS  ;display records for selection by user

 +1        SET BCHPG=0

 +2        DO HEAD

 +3        SET (BCHPG,BCHRECN,BCHR)=0

           FOR 

               SET BCHRECN=$ORDER(BCHVRECS(BCHRECN))

               IF BCHRECN'=+BCHRECN

                   QUIT 

               SET BCHR=BCHVRECS(BCHRECN)

               SET BCHR0=^BCHR(BCHR,0)

               Begin DoDot:1

 +4                IF $Y>(IOSL-2)

                       DO HEAD

                       IF $DATA(BCHQUIT)

                           QUIT 

 +5                WRITE !,BCHRECN,?5,$EXTRACT($$PPNAME^BCHUTIL(BCHR),1,15)

 +6                IF '$DATA(^BCHRPROB("AD",BCHR))

                       WRITE ?25,"           --"

 +7               IF '$TEST

                       DO GETPROB

                       WRITE ?21,BCHX

 +8                WRITE ?53,$SELECT($PIECE(^BCHR(BCHR,0),U,6)]"":$EXTRACT($PIECE(^BCHTACTL($PIECE(^BCHR(BCHR,0),U,6),0),U),1,5),1:"????")

 +9                IF $PIECE(^BCHR(BCHR,0),U,4)]""

                       WRITE ?60,$EXTRACT($PIECE(^DPT($PIECE(^BCHR(BCHR,0),U,4),0),U),1,20)

 +10              IF '$TEST

                       IF $PIECE($GET(^BCHR(BCHR,11)),U)]""

                           WRITE ?60,$EXTRACT($PIECE(^BCHR(BCHR,11),U),1,20)

 +11              IF '$TEST

                       WRITE ?66,"<none>"

 +12               QUIT 

               End DoDot:1

 +13       QUIT 

GETPROB   ;

 +1        SET BCHX=""

 +2        SET BCHP=$ORDER(^BCHRPROB("AD",BCHR,0))

           SET BCHPREC=^BCHRPROB(BCHP,0)

 +3        SET X=$PIECE(^BCHTPROB($PIECE(BCHPREC,U),0),U,2)_"  "

 +4        SET X=X_$SELECT($PIECE(BCHPREC,U,4)]"":$PIECE(^BCHTSERV($PIECE(BCHPREC,U,4),0),U,3),1:"  ")_"  "

 +5        SET X=X_$JUSTIFY($PIECE(BCHPREC,U,5),3)_"  "

 +6        SET X=X_$SELECT($PIECE(BCHPREC,U,6)]"":$EXTRACT($PIECE(^AUTNPOV($PIECE(BCHPREC,U,6),0),U),1,16),1:"  ")

 +7        SET X=$$RBLK^BCHUARL(X,31)

 +8        SET BCHX=BCHX_X

 +9        QUIT