BCHVDO ; IHS/CMI/LAB - BROWSE VISITS ;
;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
;
;
START ;
NEW BCHX,BCHY,BCHR0,DFN,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,AUPNSEX,BCHV,BCHBD,BCHED
NEW D,R
K BCHV
W:$D(IOF) @IOF
W $$CTR^BCHRLU("List One Patient's Visits",80)
PAT ;
D GETPAT^BCHULV
I 'BCHPAT,'BCHNRPAT D XIT Q
WHICH ;
S BCHQUIT=0
S BCHW=""
S DIR(0)="S^L:Patient's Last Visit;N:Patient's Last N Visits;D:Visits in a Date Range;A:All of this Patient's Visits"
S DIR("A")="Browse which subset of visits for "_$S(BCHPAT:$P(^DPT(BCHPAT,0),U,1),1:$P(^BCHRPAT(BCHNRPAT,0),U,1)),DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
S BCHW=Y
D @BCHW Q:BCHQUIT
ZIS ;call to XBDBQUE
S XBRP="PRINT^BCHVDO",XBRC="",XBRX="XIT^BCHVDO",XBNS="BCH"
D ^XBDBQUE
D XIT
Q
PRINT ;
S BCHPG=0
K BCHQUIT
I '$D(BCHV) D HEADER W !!,"Patient had no CHR visits in the time period." D XIT Q
D HEADER
S BCHD=0 F S BCHD=$O(BCHV(BCHD)) Q:BCHD=""!($D(BCHQUIT)) D
.S BCHR=0 F S BCHR=$O(BCHV(BCHD,BCHR)) Q:BCHR=""!($D(BCHQUIT)) D
..S BCHR0=^BCHR(BCHR,0)
..D PRINT1
..Q
.Q
Q
PRINT1 ;
I $Y>(IOSL-3) D HEADER Q:$D(BCHQUIT)
W !,$E($P(BCHR0,U),4,5),"/",$E($P(BCHR0,U),6,7),"/",(1700+($E($P(BCHR0,U),1,3)))
W ?11,$E($$PPNAME^BCHUTIL(BCHR),1,20)
S BCHACTL=$P(BCHR0,U,6) I BCHACTL]"" S BCHACTL=$E($P(^BCHTACTL(BCHACTL,0),U),1,10)
S BCHSFAC=$P(BCHR0,U,5) I BCHSFAC]"" S BCHSFAC=$E($P(^AUTTLOC(BCHSFAC,0),U,2),1,10)
I BCHSFAC="" S BCHSFAC=BCHACTL
W ?32,BCHSFAC
I '$D(^BCHRPROB("AD",BCHR)) W ?45," --"
E S BCHP=0,BCHC=0 F S BCHP=$O(^BCHRPROB("AD",BCHR,BCHP)) Q:BCHP'=+BCHP S BCHPREC=^BCHRPROB(BCHP,0) D GETPROB W:BCHC ! W ?45,BCHX S BCHC=BCHC+1
Q
GETPROB ;
S BCHX=""
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 N=$P(BCHPREC,U,6) I N,$D(^AUTNPOV(N,0)) S N=$P(^AUTNPOV(N,0),U)
S X=X_$S(N]"":$E(N,1,25),1:" ")
S BCHX=BCHX_X
Q
I 'BCHPG G HEADER1
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
W:$D(IOF) @IOF S BCHPG=BCHPG+1
S X="********** CONFIDENTIAL PATIENT INFORMATION **********" W !,$$CTR^BCHRLU(X,80),!
W ?(80-$L($P(^DIC(4,DUZ(2),0),U))/2),$P(^DIC(4,DUZ(2),0),U),?($S(80=132:120,1:72)),"Page ",BCHPG
S BCHTEXT="VISITS by CHR's"
W !?(80-$L(BCHTEXT)/2),BCHTEXT
I BCHPAT D
.S X="Patient Name: "_$P(^DPT(BCHPAT,0),U,1)
.W !!,$$CTR^BCHRLU(X,80)
.S X="Health Record Number: "_$$HRN^AUPNPAT(BCHPAT,DUZ(2))
.W !,$$CTR^BCHRLU(X,80)
.S X="DOB: "_$$FMTE^XLFDT($$DOB^AUPNPAT(BCHPAT))
.W !,$$CTR^BCHRLU(X,80)
;S BCHTEXT="Visit Dates: "_$$FMTE^XLFDT(BCHBD)_" and "_$$FMTE^XLFDT(BCHED)
;W !!,$$CTR^BCHRUL(X,80)
I BCHNRPAT D
.S X="Patient Name: "_$P(^BCHRPAT(BCHNRPAT,0),U,1)
.W !!,$$CTR^BCHRLU(X,80)
.S X="CHR ID: "_$P(^BCHRPAT(BCHNRPAT,0),U,9)
.W !,$$CTR^BCHRLU(X,80)
.S X="DOB: "_$$VAL^XBDIQ1(90002.11,BCHNRPAT,.02)
.W !,$$CTR^BCHRLU(X,80)
W !,$TR($J(" ",80)," ","=")
W !," DATE",?11,"CHR",?32,"LOCATION",?45,"ASSESSMENTS - POVS"
W !,$TR($J(" ",80)," ","-")
Q
;
L ;get patients last visit
;BCHV array
I BCHPAT S X="AE",P=BCHPAT
I BCHNRPAT S X="ANRE",P=BCHNRPAT
I '$D(^BCHR(X,P)) W !!,"No visits on file for this patient.",! S BCHQUIT=1 Q
S D=$O(^BCHR(X,P,"")),R=$O(^BCHR("AE",P,D,""))
I R S BCHV(D,R)=""
Q
N ;patients last N visits
S N=""
S DIR(0)="N^1:99:0",DIR("A")="How many visits should be displayed",DIR("B")="5" KILL DA D ^DIR KILL DIR
I $D(DIRUT) S BCHQUIT=1 Q
S N=Y
I BCHPAT S X="AE",P=BCHPAT
I BCHNRPAT S X="ANRE",P=BCHNRPAT
S (C,D)=0 F S D=$O(^BCHR(X,P,D)) Q:D'=+D!(C=N) S V=0 F S V=$O(^BCHR(X,P,D,V)) Q:V'=+V!(C=N) S C=C+1,BCHV(D,V)=""
Q
A ;all visits
S D=0,V=0
I BCHPAT S X="AE",P=BCHPAT
I BCHNRPAT S X="ANRE",P=BCHNRPAT
F S D=$O(^BCHR(X,P,D)) Q:D'=+D S V=0 F S V=$O(^BCHR(X,P,D,V)) Q:V'=+V S BCHV(D,V)=""
Q
D ;date range
K BCHED,BCHBD
K DIR W ! S DIR(0)="DO^::EXP",DIR("A")="Enter Beginning Date of Visit"
D ^DIR S:Y<1 BCHQUIT=1 Q:Y<1 S BCHBD=Y
K DIR S DIR(0)="DO^::EXP",DIR("A")="Enter Ending Date of Visit"
D ^DIR S:Y<1 BCHQUIT=1 Q:Y<1 S BCHED=Y
;
I BCHED<BCHBD D G D
. W !!,$C(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
I BCHPAT S X="AE",P=BCHPAT
I BCHNRPAT S X="ANRE",P=BCHNRPAT
S E=9999999-BCHBD,D=9999999-BCHED-1_".99" F S D=$O(^BCHR(X,P,D)) Q:D'=+D!($P(D,".")>E) S V=0 F S V=$O(^BCHR(X,P,D,V)) Q:V'=+V S BCHV(D,V)=""
Q
XIT ;
D EN^XBVK("BCH")
D KILL^AUPNPAT
D ^XBFMK
Q
BCHVDO ; IHS/CMI/LAB - BROWSE VISITS ;
+1 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27
+2 ;
+3 ;
START ;
+1 NEW BCHX,BCHY,BCHR0,DFN,AUPNPAT,AUPNDOB,AUPNDOD,AUPNDAYS,AUPNSEX,BCHV,BCHBD,BCHED
+2 NEW D,R
+3 KILL BCHV
+4 IF $DATA(IOF)
WRITE @IOF
+5 WRITE $$CTR^BCHRLU("List One Patient's Visits",80)
PAT ;
+1 DO GETPAT^BCHULV
+2 IF 'BCHPAT
IF 'BCHNRPAT
DO XIT
QUIT
WHICH ;
+1 SET BCHQUIT=0
+2 SET BCHW=""
+3 SET DIR(0)="S^L:Patient's Last Visit;N:Patient's Last N Visits;D:Visits in a Date Range;A:All of this Patient's Visits"
+4 SET DIR("A")="Browse which subset of visits for "_$SELECT(BCHPAT:$PIECE(^DPT(BCHPAT,0),U,1),1:$PIECE(^BCHRPAT(BCHNRPAT,0),U,1))
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
QUIT
+6 SET BCHW=Y
+7 DO @BCHW
IF BCHQUIT
QUIT
ZIS ;call to XBDBQUE
+1 SET XBRP="PRINT^BCHVDO"
SET XBRC=""
SET XBRX="XIT^BCHVDO"
SET XBNS="BCH"
+2 DO ^XBDBQUE
+3 DO XIT
+4 QUIT
PRINT ;
+1 SET BCHPG=0
+2 KILL BCHQUIT
+3 IF '$DATA(BCHV)
DO HEADER
WRITE !!,"Patient had no CHR visits in the time period."
DO XIT
QUIT
+4 DO HEADER
+5 SET BCHD=0
FOR
SET BCHD=$ORDER(BCHV(BCHD))
IF BCHD=""!($DATA(BCHQUIT))
QUIT
Begin DoDot:1
+6 SET BCHR=0
FOR
SET BCHR=$ORDER(BCHV(BCHD,BCHR))
IF BCHR=""!($DATA(BCHQUIT))
QUIT
Begin DoDot:2
+7 SET BCHR0=^BCHR(BCHR,0)
+8 DO PRINT1
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT
PRINT1 ;
+1 IF $Y>(IOSL-3)
DO HEADER
IF $DATA(BCHQUIT)
QUIT
+2 WRITE !,$EXTRACT($PIECE(BCHR0,U),4,5),"/",$EXTRACT($PIECE(BCHR0,U),6,7),"/",(1700+($EXTRACT($PIECE(BCHR0,U),1,3)))
+3 WRITE ?11,$EXTRACT($$PPNAME^BCHUTIL(BCHR),1,20)
+4 SET BCHACTL=$PIECE(BCHR0,U,6)
IF BCHACTL]""
SET BCHACTL=$EXTRACT($PIECE(^BCHTACTL(BCHACTL,0),U),1,10)
+5 SET BCHSFAC=$PIECE(BCHR0,U,5)
IF BCHSFAC]""
SET BCHSFAC=$EXTRACT($PIECE(^AUTTLOC(BCHSFAC,0),U,2),1,10)
+6 IF BCHSFAC=""
SET BCHSFAC=BCHACTL
+7 WRITE ?32,BCHSFAC
+8 IF '$DATA(^BCHRPROB("AD",BCHR))
WRITE ?45," --"
+9 IF '$TEST
SET BCHP=0
SET BCHC=0
FOR
SET BCHP=$ORDER(^BCHRPROB("AD",BCHR,BCHP))
IF BCHP'=+BCHP
QUIT
SET BCHPREC=^BCHRPROB(BCHP,0)
DO GETPROB
IF BCHC
WRITE !
WRITE ?45,BCHX
SET BCHC=BCHC+1
+10 QUIT
GETPROB ;
+1 SET BCHX=""
+2 SET X=$PIECE(^BCHTPROB($PIECE(BCHPREC,U),0),U,2)_" "
+3 SET X=X_$SELECT($PIECE(BCHPREC,U,4)]"":$PIECE(^BCHTSERV($PIECE(BCHPREC,U,4),0),U,3),1:" ")_" "
+4 SET X=X_$JUSTIFY($PIECE(BCHPREC,U,5),3)_" "
+5 SET N=$PIECE(BCHPREC,U,6)
IF N
IF $DATA(^AUTNPOV(N,0))
SET N=$PIECE(^AUTNPOV(N,0),U)
+6 SET X=X_$SELECT(N]"":$EXTRACT(N,1,25),1:" ")
+7 SET BCHX=BCHX_X
+8 QUIT
+1 IF 'BCHPG
GOTO HEADER1
+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
+1 IF $DATA(IOF)
WRITE @IOF
SET BCHPG=BCHPG+1
+2 SET X="********** CONFIDENTIAL PATIENT INFORMATION **********"
WRITE !,$$CTR^BCHRLU(X,80),!
+3 WRITE ?(80-$LENGTH($PIECE(^DIC(4,DUZ(2),0),U))/2),$PIECE(^DIC(4,DUZ(2),0),U),?($SELECT(80=132:120,1:72)),"Page ",BCHPG
+4 SET BCHTEXT="VISITS by CHR's"
+5 WRITE !?(80-$LENGTH(BCHTEXT)/2),BCHTEXT
+6 IF BCHPAT
Begin DoDot:1
+7 SET X="Patient Name: "_$PIECE(^DPT(BCHPAT,0),U,1)
+8 WRITE !!,$$CTR^BCHRLU(X,80)
+9 SET X="Health Record Number: "_$$HRN^AUPNPAT(BCHPAT,DUZ(2))
+10 WRITE !,$$CTR^BCHRLU(X,80)
+11 SET X="DOB: "_$$FMTE^XLFDT($$DOB^AUPNPAT(BCHPAT))
+12 WRITE !,$$CTR^BCHRLU(X,80)
End DoDot:1
+13 ;S BCHTEXT="Visit Dates: "_$$FMTE^XLFDT(BCHBD)_" and "_$$FMTE^XLFDT(BCHED)
+14 ;W !!,$$CTR^BCHRUL(X,80)
+15 IF BCHNRPAT
Begin DoDot:1
+16 SET X="Patient Name: "_$PIECE(^BCHRPAT(BCHNRPAT,0),U,1)
+17 WRITE !!,$$CTR^BCHRLU(X,80)
+18 SET X="CHR ID: "_$PIECE(^BCHRPAT(BCHNRPAT,0),U,9)
+19 WRITE !,$$CTR^BCHRLU(X,80)
+20 SET X="DOB: "_$$VAL^XBDIQ1(90002.11,BCHNRPAT,.02)
+21 WRITE !,$$CTR^BCHRLU(X,80)
End DoDot:1
+22 WRITE !,$TRANSLATE($JUSTIFY(" ",80)," ","=")
+23 WRITE !," DATE",?11,"CHR",?32,"LOCATION",?45,"ASSESSMENTS - POVS"
+24 WRITE !,$TRANSLATE($JUSTIFY(" ",80)," ","-")
+25 QUIT
+26 ;
L ;get patients last visit
+1 ;BCHV array
+2 IF BCHPAT
SET X="AE"
SET P=BCHPAT
+3 IF BCHNRPAT
SET X="ANRE"
SET P=BCHNRPAT
+4 IF '$DATA(^BCHR(X,P))
WRITE !!,"No visits on file for this patient.",!
SET BCHQUIT=1
QUIT
+5 SET D=$ORDER(^BCHR(X,P,""))
SET R=$ORDER(^BCHR("AE",P,D,""))
+6 IF R
SET BCHV(D,R)=""
+7 QUIT
N ;patients last N visits
+1 SET N=""
+2 SET DIR(0)="N^1:99:0"
SET DIR("A")="How many visits should be displayed"
SET DIR("B")="5"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
SET BCHQUIT=1
QUIT
+4 SET N=Y
+5 IF BCHPAT
SET X="AE"
SET P=BCHPAT
+6 IF BCHNRPAT
SET X="ANRE"
SET P=BCHNRPAT
+7 SET (C,D)=0
FOR
SET D=$ORDER(^BCHR(X,P,D))
IF D'=+D!(C=N)
QUIT
SET V=0
FOR
SET V=$ORDER(^BCHR(X,P,D,V))
IF V'=+V!(C=N)
QUIT
SET C=C+1
SET BCHV(D,V)=""
+8 QUIT
A ;all visits
+1 SET D=0
SET V=0
+2 IF BCHPAT
SET X="AE"
SET P=BCHPAT
+3 IF BCHNRPAT
SET X="ANRE"
SET P=BCHNRPAT
+4 FOR
SET D=$ORDER(^BCHR(X,P,D))
IF D'=+D
QUIT
SET V=0
FOR
SET V=$ORDER(^BCHR(X,P,D,V))
IF V'=+V
QUIT
SET BCHV(D,V)=""
+5 QUIT
D ;date range
+1 KILL BCHED,BCHBD
+2 KILL DIR
WRITE !
SET DIR(0)="DO^::EXP"
SET DIR("A")="Enter Beginning Date of Visit"
+3 DO ^DIR
IF Y<1
SET BCHQUIT=1
IF Y<1
QUIT
SET BCHBD=Y
+4 KILL DIR
SET DIR(0)="DO^::EXP"
SET DIR("A")="Enter Ending Date of Visit"
+5 DO ^DIR
IF Y<1
SET BCHQUIT=1
IF Y<1
QUIT
SET BCHED=Y
+6 ;
+7 IF BCHED<BCHBD
Begin DoDot:1
+8 WRITE !!,$CHAR(7),"Sorry, Ending Date MUST not be earlier than Beginning Date."
End DoDot:1
GOTO D
+9 IF BCHPAT
SET X="AE"
SET P=BCHPAT
+10 IF BCHNRPAT
SET X="ANRE"
SET P=BCHNRPAT
+11 SET E=9999999-BCHBD
SET D=9999999-BCHED-1_".99"
FOR
SET D=$ORDER(^BCHR(X,P,D))
IF D'=+D!($PIECE(D,".")>E)
QUIT
SET V=0
FOR
SET V=$ORDER(^BCHR(X,P,D,V))
IF V'=+V
QUIT
SET BCHV(D,V)=""
+12 QUIT
XIT ;
+1 DO EN^XBVK("BCH")
+2 DO KILL^AUPNPAT
+3 DO ^XBFMK
+4 QUIT
