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
