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
Q
;
EN2(APCHPWHT,P) ;EP
NEW DFN
S DFN=P
D ZIS
Q
;
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
Q
;
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
Q
;
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")
Q
EXIT ;
D EN^XBVK("APCH")
K DFN
D ^XBFMK
Q
;
;
EXIT1 ;
D CLEAR^VALM1
D FULL^VALM1
K DFN
D ^XBFMK
Q
;
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)
Q
;
EN1(APCHPWHT) ;EP
NEW APCHOLD
D PRINT
Q
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
Q
;
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
Q
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)_" **********",!
Q
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
Q
;
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
Q
;
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
+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 ;
