Routine: BSDX43

BSDX43 ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;

 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010

EN ;

 W !!,$$CTR("*** Patient Wellness Handout ***"),!!

SELTYP ;

 K DIADD,DLAYGO

 D ^XBFMK

 K DIC S DIC="^APCHPWHT(",DIC("A")="Select Patient Wellness Handout type: ",DIC(0)="AEQM"

 S X="" I DUZ(2),$D(^APCCCTRL(DUZ(2),0))#2 S X=$P(^(0),U,16)

 I $D(^DISV(DUZ,"^APCHPWHT(")) S Y=^("^APCHPWHT(") I $D(^APCHPWHT(Y,0)) S X=$P(^(0),U,1)

 S:X="" X="ADULT REGULAR"

 S DIC("B")=X

 D ^DIC K DIC

 I Y=-1 D EXIT Q

 S APCHPWHT=+Y

SELPT ;

W !

 S DFN=""

 K DIC S DIC=9000001,DIC("A")="Select patient: ",DIC(0)="AEQM" D ^DIC K DIC

 I Y=-1 G SELTYP

 S DFN=+Y W:$D(^AUPNPAT(DFN,41,DUZ(2),0)) !,"Patient's chart number is ",$P(^(0),U,2),!

 I $$AGE^AUPNPAT(DFN,DT)<18 W !,"Warning:  This handout is designed for patients 18 and older.  This",!,"patient is under 18.  Please select a different patient." K DFN G SELPT

 ;.S APCHSQ=""

 ;.K DIR S DIR(0)="Y",DIR("A")="Do you wish to continue and print the handout",DIR("B")="N" KILL DA D ^DIR KILL DIR

 ;.I 'Y S APCHSQ=1

;.Q

 D ZIS

 D EXIT

EN2(APCHPWHT,P) ;EP

 NEW DFN

 S DFN=P

 D ZIS

WISD(DFN,SDATE,BSDMODE,APCHPWHT,EMSG) ;PEP; print PCC health summary

 ; .EMSG = returned error message if error

 I +DFN=0 Q

 NEW DGPGM,VAR,VAR1,DEV,POP

 S SDX="ALL",ORDER="",SDREP=0,SDSTART="",DIV=$$DIV^BSDU

 ;IHS/ITSC/LJF 6/17/2005 PATCH 1003 adde BSDNHS to variable list

 ;S VAR="DIV^ORDER^SDX^SDATE^DFN^SDREP^SDSTART^BSDMODE^BSDNHS"

 ;S VAR1="DIV;ORDER;SDX;SDATE;DFN;SDREP;SDSTART;BSDMODE;BSDNHS"

 ;end of these PATCH 1003 changes

 S DGPGM="PRINT^BSDX43"

 ;I $G(BSDDEV)]"" D ZIS^BDGF("F","PRINT^BSDX43","PCC HEALTH SUMMARY",VAR1,BSDDEV) Q

 S DEV=$S($G(BSDMODE)="CR":".05",1:".11")   ;default printer fields

 S BDGDEV=$$GET1^DIQ(9009020.2,$$DIV^BSDU,DEV)

 I BDGDEV="" K BDGDEV S EMSG="PCC Health Summary could not be printed: no default "_$S(BSDMODE="CR":"chart request",1:"walk in")_" printer defined in the IHS SCHEDULING PARAMETERS table." Q

 S IOP=BDGDEV D ^%ZIS I POP D END^SDROUT1 Q

 D PRINT

ZIS ;EP

 S Y="P"

 I $D(DIRUT) D EXIT Q

 S APCHOPT=Y

 S XBRP="PRINT^BSDX43",XBRC="",XBRX="EXIT^BSDX43",XBNS="APCH;DFN"

 D ^XBDBQUE

 D EXIT

EHR(DFN,APCHPWHT)  ;EP - CMI/GRL support for EHR

 I '$G(APCHPWHT) S APCHPWHT=$P($G(^APCCCTRL(DUZ(2),0)),U,16)

 I APCHPWHT="" S APCHPWHT=$O(^APCHPWHT("B","ADULT REGULAR",0))

 D EN^XBNEW("PRINT^APCHPWHG","DFN;APCHPWHT")

EXIT ;

 D EN^XBVK("APCH")

 K DFN

 D ^XBFMK

EXIT1 ;

 D CLEAR^VALM1

 D FULL^VALM1

 K DFN

 D ^XBFMK

ENCOMP ;EP

 NEW T,APCHPWHT

 S APCHPWHT=$P($G(^APCCCTRL(DUZ(2),0)),U,16)

 I 'APCHPWHT S APCHPWHT=$O(^APCHPWHT("B","ADULT REGULAR",0))

 I 'APCHPWHT Q

 W:$D(IOF) @IOF

 D EHR(APCHSPAT,APCHPWHT)

EN1(APCHPWHT) ;EP

 NEW APCHOLD

 D PRINT

PRINT ;EP

 U IO

 S APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"

 K ^TMP($J,"APCHPWH")

 D UPDLOG(DFN,APCHPWHT,DUZ)

 D EP1^BSDX42(DFN,APCHPWHT,1) ;gather up data in ^TMP

W ;write out array

 ;W:$D(IOF) @IOF

 K APCHQUIT

 S APCHPG=0 D HEADER

 Q:$D(APCHQUIT)

 S APCHX=0 F  S APCHX=$O(^TMP($J,"APCHPWH",APCHX)) Q:APCHX'=+APCHX!($D(APCHQUIT))  D

 .;find number of lines until next component

 .S C=0 I ^TMP($J,"APCHPWH",APCHX)["________________" S A=APCHX F  S A=$O(^TMP($J,"APCHPWH",A)) Q:A'=+A  Q:^TMP($J,"APCHPWH",A)["_______________"  S C=C+1

 .I $Y>(IOSL-$S(C<7:(C+3),1:3)) D HEADER Q:$D(APCHQUIT)

 .W !,^TMP($J,"APCHPWH",APCHX)

.Q

 I $D(APCHQUIT) S APCHSQIT=1

 ;footer

 I $E(IOST)="C",IO=IO(0) W ! K DIR S DIR(0)="EO",DIR("A")="End of Report.  Press Enter." D ^DIR K DIR Q

 D EOJ

 D ^%ZISC

EOJ ;

 K ^TMP($J,"APCHPWH")

 D EN^XBVK("APCH")

 D EN^XBVK("APCD")

 D ^XBFMK

 K BIDLLID,BIDLLPRO,BIDLLRUN,BIRESULT,BISITE

 K AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX

 K N,%,T,F,X,Y,B,C,E,F,H,J,L,N,P,T,W,ST,ST0

HEADER ;

 G:APCHPG=0 HEAD1

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

HEAD1 ;

 W:$D(IOF) @IOF

 S APCHPG=APCHPG+1

 W !,"My Wellness Handout",?45,"Report Date: ",$$FMTE^XLFDT(DT),?72,"Page: ",APCHPG,!,$TR($J("",(IOM-2))," ","-"),!

 I APCHPG>1 W "********** CONFIDENTIAL PATIENT INFORMATION ["_$P(^VA(200,DUZ,0),U,2)_"]  "_$$FMTE^XLFDT(DT)_" **********",!

CTR(X,Y) ;EP - Center X in a field Y wide.

 Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X

 ;----------

USR() ;EP - Return name of current user from ^VA(200.

 Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")

 ;----------

LOC() ;EP - Return location name from file 4 based on DUZ(2).

 Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")

 ;----------

UPDLOG(P,T,D) ;EP - update pwh log

 I $G(P)="" Q

 I $G(T)="" Q

 NEW DIC,X,DD,DO,D0

 S X=P,DIC="^APCHPWHL(",DIC(0)="L",DIADD=1,DLAYGO=9001027

 S DIC("DR")=".02////"_T_";.03////"_D_";.04////"_DT_";.05///"_$$NOW^XLFDT_";.06////"_DUZ(2)

 K DD,D0,D0

 D FILE^DICN

 D ^XBFMK

 K DIADD,DLAYGO

UPDDEF ;EP - called from option to update default PWH for the site

 W !!,"This option is used to set the default Patient Wellness Handout"

 W !,"for a site."

 W !!

 K DIC S DIC="^APCCCTRL(",DIC("B")=$P(^DIC(4,DUZ(2),0),U),DIC(0)="AEMQ" D ^DIC K DIC

 I Y=-1 Q

 S DA=+Y,DIE="^APCCCTRL(",DR=".16" D ^DIE

 D ^XBFMK

BSDX43    ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;

 +1       ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010

EN        ;

 +1        WRITE !!,$$CTR("*** Patient Wellness Handout ***"),!!

SELTYP    ;

 +1        KILL DIADD,DLAYGO

 +2        DO ^XBFMK

 +3        KILL DIC

           SET DIC="^APCHPWHT("

           SET DIC("A")="Select Patient Wellness Handout type: "

           SET DIC(0)="AEQM"

 +4        SET X=""

           IF DUZ(2)

               IF $DATA(^APCCCTRL(DUZ(2),0))#2

                   SET X=$PIECE(^(0),U,16)

 +5        IF $DATA(^DISV(DUZ,"^APCHPWHT("))

               SET Y=^("^APCHPWHT(")

               IF $DATA(^APCHPWHT(Y,0))

                   SET X=$PIECE(^(0),U,1)

 +6        IF X=""

               SET X="ADULT REGULAR"

 +7        SET DIC("B")=X

 +8        DO ^DIC

           KILL DIC

 +9        IF Y=-1

               DO EXIT

               QUIT

 +10       SET APCHPWHT=+Y

SELPT     ;

 +1        WRITE !

 +2        SET DFN=""

 +3        KILL DIC

           SET DIC=9000001

           SET DIC("A")="Select patient: "

           SET DIC(0)="AEQM"

           DO ^DIC

           KILL DIC

 +4        IF Y=-1

               GOTO SELTYP

 +5        SET DFN=+Y

           IF $DATA(^AUPNPAT(DFN,41,DUZ(2),0))

               WRITE !,"Patient's chart number is ",$PIECE(^(0),U,2),!

 +6        IF $$AGE^AUPNPAT(DFN,DT)<18

               WRITE !,"Warning:  This handout is designed for patients 18 and older.  This",!,"patient is under 18.  Please select a different patient."

               KILL DFN

               GOTO SELPT

 +7       ;.S APCHSQ=""

 +8       ;.K DIR S DIR(0)="Y",DIR("A")="Do you wish to continue and print the handout",DIR("B")="N" KILL DA D ^DIR KILL DIR

 +9       ;.I 'Y S APCHSQ=1

 +10      ;.Q

 +11       DO ZIS

 +12       DO EXIT

 +13       QUIT

 +14      ;

EN2(APCHPWHT,P) ;EP

 +1        NEW DFN

 +2        SET DFN=P

 +3        DO ZIS

 +4        QUIT

 +5       ;

WISD(DFN,SDATE,BSDMODE,APCHPWHT,EMSG) ;PEP; print PCC health summary

 +1       ; .EMSG = returned error message if error

 +2       ;

 +3        IF +DFN=0

               QUIT

 +4       ;

 +5        NEW DGPGM,VAR,VAR1,DEV,POP

 +6        SET SDX="ALL"

           SET ORDER=""

           SET SDREP=0

           SET SDSTART=""

           SET DIV=$$DIV^BSDU

 +7       ;

 +8       ;IHS/ITSC/LJF 6/17/2005 PATCH 1003 adde BSDNHS to variable list

 +9       ;S VAR="DIV^ORDER^SDX^SDATE^DFN^SDREP^SDSTART^BSDMODE^BSDNHS"

 +10      ;S VAR1="DIV;ORDER;SDX;SDATE;DFN;SDREP;SDSTART;BSDMODE;BSDNHS"

 +11      ;end of these PATCH 1003 changes

 +12      ;

 +13       SET DGPGM="PRINT^BSDX43"

 +14      ;I $G(BSDDEV)]"" D ZIS^BDGF("F","PRINT^BSDX43","PCC HEALTH SUMMARY",VAR1,BSDDEV) Q

 +15      ;default printer fields

           SET DEV=$SELECT($GET(BSDMODE)="CR":".05",1:".11")

 +16       SET BDGDEV=$$GET1^DIQ(9009020.2,$$DIV^BSDU,DEV)

 +17       IF BDGDEV=""

               KILL BDGDEV

               SET EMSG="PCC Health Summary could not be printed: no default "_$SELECT(BSDMODE="CR":"chart request",1:"walk in")_" printer defined in the IHS SCHEDULING PARAMETERS table."

               QUIT

 +18       SET IOP=BDGDEV

           DO ^%ZIS

           IF POP

               DO END^SDROUT1

               QUIT

 +19       DO PRINT

 +20       QUIT

 +21      ;

ZIS       ;EP

 +1        SET Y="P"

 +2        IF $DATA(DIRUT)

               DO EXIT

               QUIT

 +3        SET APCHOPT=Y

 +4        SET XBRP="PRINT^BSDX43"

           SET XBRC=""

           SET XBRX="EXIT^BSDX43"

           SET XBNS="APCH;DFN"

 +5        DO ^XBDBQUE

 +6        DO EXIT

 +7        QUIT

 +8       ;

EHR(DFN,APCHPWHT) ;EP - CMI/GRL support for EHR

 +1        IF '$GET(APCHPWHT)

               SET APCHPWHT=$PIECE($GET(^APCCCTRL(DUZ(2),0)),U,16)

 +2        IF APCHPWHT=""

               SET APCHPWHT=$ORDER(^APCHPWHT("B","ADULT REGULAR",0))

 +3        DO EN^XBNEW("PRINT^APCHPWHG","DFN;APCHPWHT")

 +4        QUIT

EXIT      ;

 +1        DO EN^XBVK("APCH")

 +2        KILL DFN

 +3        DO ^XBFMK

 +4        QUIT

 +5       ;

 +6       ;

EXIT1     ;

 +1        DO CLEAR^VALM1

 +2        DO FULL^VALM1

 +3        KILL DFN

 +4        DO ^XBFMK

 +5        QUIT

 +6       ;

ENCOMP    ;EP

 +1        NEW T,APCHPWHT

 +2        SET APCHPWHT=$PIECE($GET(^APCCCTRL(DUZ(2),0)),U,16)

 +3        IF 'APCHPWHT

               SET APCHPWHT=$ORDER(^APCHPWHT("B","ADULT REGULAR",0))

 +4        IF 'APCHPWHT

               QUIT

 +5        IF $DATA(IOF)

               WRITE @IOF

 +6        DO EHR(APCHSPAT,APCHPWHT)

 +7        QUIT

 +8       ;

EN1(APCHPWHT) ;EP

 +1        NEW APCHOLD

 +2        DO PRINT

 +3        QUIT

PRINT     ;EP

 +1        USE IO

 +2        SET APCHSCVD="S:Y]"""" Y=+Y,Y=$E(Y,4,5)_""/""_$S($E(Y,6,7):$E(Y,6,7)_""/"",1:"""")_$E(Y,2,3)"

 +3        KILL ^TMP($JOB,"APCHPWH")

 +4        DO UPDLOG(DFN,APCHPWHT,DUZ)

 +5       ;gather up data in ^TMP

           DO EP1^BSDX42(DFN,APCHPWHT,1)

W         ;write out array

 +1       ;W:$D(IOF) @IOF

 +2        KILL APCHQUIT

 +3        SET APCHPG=0

           DO HEADER

 +4        IF $DATA(APCHQUIT)

               QUIT

 +5        SET APCHX=0

FOR

               SET APCHX=$ORDER(^TMP($JOB,"APCHPWH",APCHX))

               IF APCHX'=+APCHX!($DATA(APCHQUIT))

                   QUIT

               Begin DoDot:1

 +6       ;find number of lines until next component

 +7                SET C=0

                   IF ^TMP($JOB,"APCHPWH",APCHX)["________________"

                       SET A=APCHX

FOR

                           SET A=$ORDER(^TMP($JOB,"APCHPWH",A))

                           IF A'=+A

                               QUIT

                           IF ^TMP($JOB,"APCHPWH",A)["_______________"

                               QUIT

                           SET C=C+1

 +8                IF $Y>(IOSL-$SELECT(C<7:(C+3),1:3))

                       DO HEADER

                       IF $DATA(APCHQUIT)

                           QUIT

 +9                WRITE !,^TMP($JOB,"APCHPWH",APCHX)

 +10               QUIT

               End DoDot:1

 +11       IF $DATA(APCHQUIT)

               SET APCHSQIT=1

 +12      ;footer

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

               IF IO=IO(0)

                   WRITE !

                   KILL DIR

                   SET DIR(0)="EO"

                   SET DIR("A")="End of Report.  Press Enter."

                   DO ^DIR

                   KILL DIR

                   QUIT

 +14       DO EOJ

 +15       DO ^%ZISC

 +16       QUIT

 +17      ;

EOJ       ;

 +1       ;

 +2        KILL ^TMP($JOB,"APCHPWH")

 +3        DO EN^XBVK("APCH")

 +4        DO EN^XBVK("APCD")

 +5        DO ^XBFMK

 +6        KILL BIDLLID,BIDLLPRO,BIDLLRUN,BIRESULT,BISITE

 +7        KILL AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX

 +8        KILL N,%,T,F,X,Y,B,C,E,F,H,J,L,N,P,T,W,ST,ST0

 +9        QUIT

HEADER    ;

 +1        IF APCHPG=0

               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 APCHQUIT=""

                       QUIT

HEAD1     ;

 +1        IF $DATA(IOF)

               WRITE @IOF

 +2        SET APCHPG=APCHPG+1

 +3        WRITE !,"My Wellness Handout",?45,"Report Date: ",$$FMTE^XLFDT(DT),?72,"Page: ",APCHPG,!,$TRANSLATE($JUSTIFY("",(IOM-2))," ","-"),!

 +4        IF APCHPG>1

               WRITE "********** CONFIDENTIAL PATIENT INFORMATION ["_$PIECE(^VA(200,DUZ,0),U,2)_"]  "_$$FMTE^XLFDT(DT)_" **********",!

 +5        QUIT

CTR(X,Y)  ;EP - Center X in a field Y wide.

 +1        QUIT $JUSTIFY("",$SELECT($DATA(Y):Y,1:IOM)-$LENGTH(X)\2)_X

 +2       ;----------

USR()     ;EP - Return name of current user from ^VA(200.

 +1        QUIT $SELECT($GET(DUZ):$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")

 +2       ;----------

LOC()     ;EP - Return location name from file 4 based on DUZ(2).

 +1        QUIT $SELECT($GET(DUZ(2)):$SELECT($DATA(^DIC(4,DUZ(2),0)):$PIECE(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")

 +2       ;----------

 +3       ;

UPDLOG(P,T,D) ;EP - update pwh log

 +1        IF $GET(P)=""

               QUIT

 +2        IF $GET(T)=""

               QUIT

 +3        NEW DIC,X,DD,DO,D0

 +4        SET X=P

           SET DIC="^APCHPWHL("

           SET DIC(0)="L"

           SET DIADD=1

           SET DLAYGO=9001027

 +5        SET DIC("DR")=".02////"_T_";.03////"_D_";.04////"_DT_";.05///"_$$NOW^XLFDT_";.06////"_DUZ(2)

 +6        KILL DD,D0,D0

 +7        DO FILE^DICN

 +8        DO ^XBFMK

 +9        KILL DIADD,DLAYGO

 +10       QUIT

 +11      ;

UPDDEF    ;EP - called from option to update default PWH for the site

 +1        WRITE !!,"This option is used to set the default Patient Wellness Handout"

 +2        WRITE !,"for a site."

 +3        WRITE !!

 +4        KILL DIC

           SET DIC="^APCCCTRL("

           SET DIC("B")=$PIECE(^DIC(4,DUZ(2),0),U)

           SET DIC(0)="AEMQ"

           DO ^DIC

           KILL DIC

 +5        IF Y=-1

               QUIT

 +6        SET DA=+Y

           SET DIE="^APCCCTRL("

           SET DR=".16"

           DO ^DIE

 +7        DO ^XBFMK

 +8        QUIT

 +9       ;

BSDX43.m