BCHVDO.m

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

HEADER ;EP

 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

HEADER1 ;

 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 

HEADER    ;EP

 +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 

HEADER1   ;

 +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