BSDX42 ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
;
ZIS ;
S Y=DFN
I $D(DIRUT) D EXIT Q
S APCHOPT=Y
S XBRP="PRINT^BSDX42",XBRC="",XBRX="EXIT^BSDX42",XBNS="APCH;DFN"
D ^XBDBQUE
D EXIT
Q
;
WISDW(DFN,SDATE,EMSG) ;PEP; print Wellness handout
; .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
;
S DGPGM="PRINT^BSDX42"
S DEV=".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
;
EXIT ;
D EN^XBVK("APCH")
D ^XBFMK
Q
;
PRINT ;
OUTPUT ;
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("APCH",$J)
D EP(DFN) ;gather up data
W ;write out array
;W:$D(IOF) @IOF
K APCHQUIT
W !,"********** Patient Wellness Handout ********** ["_$P(^VA(200,DUZ,0),U,2)_"] "_$$FMTE^XLFDT(DT)_" **********"
S APCHX=0 F S APCHX=$O(^TMP($J,"APCHPWH",APCHX)) Q:APCHX'=+APCHX!($D(APCHQUIT)) D
.I $Y>(IOSL-3) D HEADER Q:$D(APCHQUIT)
.W !,^TMP($J,"APCHPWH",APCHX)
.Q
I $D(APCHQUIT) S APCHSQIT=1
D EOJ
D ^%ZISC
Q
;
EOJ ;
;
K ^TMP("APCHPHS",$J)
K ^TMP($J,"APCHPWH")
D EN^XBVK("APCH")
D EN^XBVK("APCD")
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
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
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")
;----------
EP(APCHSDFN) ;PEP - PASS DFN get back array of patient care summary
;at this point you are stuck with ^TMP("APCHPHS",$J,"PMH"
;CHANGE TO GO TO NEW PWH
S APCHPWHT=$O(^APCHPWHT("B","ADULT REGULAR",0))
D EP1(APCHSDFN,APCHPWHT)
Q
EP1(APCHSDFN,APCHPWHT,APCHPRTH) ;PEP - PASS DFN get back array of patient wellness handout
;handout returned in ^TMP("APCHPHS",$J,"APCHPWH"
;APCHPWHT - ien of the PWH type
;APCHPRTH - 1 if you don't want the header line printed
K ^TMP($J,"APCHPWH")
S ^TMP($J,"APCHPWH",0)=0
I '$G(APCHPWHT) S APCHPWHT=$O(^APCHPWHT("B","ADULT REGULAR",0))
I '$G(APCHPWHT) Q
D SETARRAY
Q
SETARRAY ;set up array containing pwh
;all handouts get this demographic section
NEW X,APCHPRV,APCHSO,APCHSCMP,APCHSCMI
I '$G(APCHPRTH) S X="My Wellness Handout",$E(X,40)="Report Date: "_$$FMTE^XLFDT(DT) D S(X)
S X="********** CONFIDENTIAL PATIENT INFORMATION ["_$P(^VA(200,DUZ,0),U,2)_"] "_$$FMTE^XLFDT(DT)_" **********" D S(X)
;S X=$P($P(^DPT(APCHSDFN,0),U),",",2)_" "_$P($P(^DPT(APCHSDFN,0),U),",")_" HRN: "_$$HRN^AUPNPAT(APCHSDFN,DUZ(2)),$E(X,50)=$S($P(^APCCCTRL(DUZ(2),0),U,13)]"":$P(^APCCCTRL(DUZ(2),0),U,13),1:$P(^DIC(4,DUZ(2),0),U)) D S(X,1)
S X=$P(^DPT(APCHSDFN,0),U)_" HRN: "_$$HRN^AUPNPAT(APCHSDFN,DUZ(2)),$E(X,50)=$S($P(^APCCCTRL(DUZ(2),0),U,13)]"":$P(^APCCCTRL(DUZ(2),0),U,13),1:$P(^DIC(4,DUZ(2),0),U)) D S(X,1)
S X=$$VAL^XBDIQ1(2,APCHSDFN,.111)
S $E(X,50)=$$VAL^XBDIQ1(9999999.06,DUZ(2),.15)_$S($$VAL^XBDIQ1(9999999.06,DUZ(2),.15)]"":", ",1:" ")_$S($P($G(^AUTTLOC(DUZ(2),0)),U,14):$P(^DIC(5,$$VALI^XBDIQ1(9999999.06,DUZ(2),.16),0),U,2),1:"")_" "_$$VAL^XBDIQ1(9999999.06,DUZ(2),.17) D S(X)
S X=$$VAL^XBDIQ1(2,APCHSDFN,.114)_$S($$VAL^XBDIQ1(2,APCHSDFN,.114)]"":", ",1:" ")_$$VAL^XBDIQ1(2,APCHSDFN,.115)_" "_$$VAL^XBDIQ1(2,APCHSDFN,.116)
S APCHPRV=$$DPCP(APCHSDFN)
I APCHPRV D
.S $E(X,50)=$P(^VA(200,APCHPRV,0),U) D S(X)
I 'APCHPRV D S(X)
S X=$$VAL^XBDIQ1(2,APCHSDFN,.131),$E(X,50)=$P(^AUTTLOC(DUZ(2),0),U,11) D S(X) ;put provider phone at 50
;I $G(APCDVSIT)]"",$D(^AUPNVSIT("AC",APCHSDFN,APCDVSIT)) S APCHPROV=$$PRIMPROV^APCLV(APCDVSIT)
;S X="Hello "_$S($$SEX^AUPNPAT(APCHSDFN)="M":"Mr. ",1:"Ms. ")_$E($P($P(^DPT(APCHSDFN,0),U),","))_$$LOW^XLFSTR($E($P($P(^DPT(APCHSDFN,0),U),","),2,99))_"," D S(X,1)
S X="Thank you for choosing "_$S($P(^APCCCTRL(DUZ(2),0),U,13)]"":$P(^APCCCTRL(DUZ(2),0),U,13),1:$P(^DIC(4,DUZ(2),0),U))_"." D S(X,1)
S X="This handout is a new way for you and your doctor to look at your health." D S(X)
;now process each component assigned to this type
;
COMPS ;
I $$AGE^AUPNPAT(APCHSDFN)<18 D S("This handout is designed for patients 18 years of age and older.",2) Q
S APCHSORD=0 F S APCHSORD=$O(^APCHPWHT(APCHPWHT,1,APCHSORD)) Q:APCHSORD'=+APCHSORD D
.S APCHSCMP=$P(^APCHPWHT(APCHPWHT,1,APCHSORD,0),U,2)
.Q:'APCHSCMP
.Q:'$D(^APCHPWHC(APCHSCMP,0))
.S APCHSCMI=$P(^APCHPWHC(APCHSCMP,0),U,2)
.D @($P(APCHSCMI,";",1)_U_$P(APCHSCMI,";",2))
S X="******** END CONFIDENTIAL PATIENT INFORMATION ["_$P(^VA(200,DUZ,0),U,2)_"] "_$$FMTE^XLFDT(DT)_" ********" D S(X,2)
;
DPCP(P) ;EP
NEW R
D ALLDP^BDPAPI(P,"DESIGNATED PRIMARY PROVIDER",.R)
I $D(R("DESIGNATED PRIMARY PROVIDER")) Q $P(R("DESIGNATED PRIMARY PROVIDER"),U,2)
S R=$P(^AUPNPAT(P,0),U,14) I R Q R
S R=""
Q R
;
S(Y,F,C,T) ;EP - set up array
I '$G(F) S F=0
I '$G(T) S T=0
NEW %,X
;blank lines
F F=1:1:F S X="" D S1
S X=Y
I $G(C) S L=$L(Y),T=(80-L)/2 D D S1 Q
.F %=1:1:(T-1) S X=" "_X
F %=1:1:T S X=" "_Y
D S1
Q
S1 ;
S %=$P(^TMP($J,"APCHPWH",0),U)+1,$P(^TMP($J,"APCHPWH",0),U)=%
S ^TMP($J,"APCHPWH",%)=X
Q
;
WISD(DFN,SDATE,BSDMODE,BSDDEV,BSDNHS,EMSG) ;PEP; print routing slip for walkin/same day appt
; .EMSG = returned error message if error
;
I +DFN=0 Q
;***** END 10/21/04
;
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"
;S VAR1="DIV;ORDER;SDX;SDATE;DFN;SDREP;SDSTART;BSDMODE"
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="SINGLE^BSDROUT"
I $G(BSDDEV)]"" D ZIS^BDGF("F","SINGLE^BSDROUT","ROUTING SLIP",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="Routing Slip 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 SINGLE
Q
;
ONE ;EP; called by SDROUT to print one patient's routing slip
S DFN=+$$READ^BDGF("PO^2:EQM","Select PATIENT") I DFN<1 D END^SDROUT Q
D WISD(DFN,DT,"")
Q
;
SINGLE ;EP; queued entry point for single routing slips
; called by WISD subroutine
U IO K ^TMP("SDRS",$J)
NEW BSDT,CLN,IEN,BSDMOD2
;
; find all appts for patient
I BSDMODE="CR" S BSDMOD2="CR",BSDMODE=""
S BSDT=SDATE\1
F S BSDT=$O(^DPT(DFN,"S",BSDT)) Q:'BSDT Q:(BSDT\1>SDATE) D
. S CLN=+$G(^DPT(DFN,"S",BSDT,0)) Q:'CLN ;clinic ien
. S IEN=0 F S IEN=$O(^SC(CLN,"S",BSDT,1,IEN)) Q:'IEN Q:$P($G(^SC(CLN,"S",BSDT,1,IEN,0)),U)=DFN
. Q:'IEN ;appt ien in ^sc
. D FIND^BSDROUT0(CLN,BSDT,IEN,ORDER,BSDMODE)
I $D(BSDMOD2) S BSDMODE=BSDMOD2
;
; find all chart requests for patient
S CLN=0 F S CLN=$O(^SC("AIHSCR",DFN,CLN)) Q:'CLN D
. S BSDT=(SDATE\1)-.0001
. F S BSDT=$O(^SC("AIHSCR",DFN,CLN,BSDT)) Q:'BSDT D
.. D CRSET^BSDROUT2(CLN,BSDT,DFN,ORDER)
;
K ^TMP("BSDX42",$J)
MERGE ^TMP("BSDX42",$J)=^TMP("SDRS",$J)
; if no future appts, set something so RS will print
I '$D(^TMP("BSDX42",$J)) S ^TMP("BSDX42",$J,$$GET1^DIQ(2,DFN,.01),$$TERM(DFN),DFN)=""
;
D PRINT^BSDROUT1(ORDER,SDATE)
Q
TERM(PAT) ; returns chart # in terminal digit format
NEW N,T
S N=$$HRCN^BDGF2(PAT,$G(DUZ(2))) ;chart #
S T=$$HRCNT^BDGF2(N) ;terminal digit format
I $$GET1^DIQ(9009020.2,+$$DIV^BSDU,.18)="NO" D
. S T=$$HRCND^BDGF2(N) ;use chart # per site param
Q T
BSDX42 ; IHS/OIT/HMW/MSC/SAT - WINDOWS SCHEDULING RPCS ;
+1 ;;3.0;IHS WINDOWS SCHEDULING;;DEC 09, 2010
+2 ;
ZIS ;
+1 SET Y=DFN
+2 IF $DATA(DIRUT)
DO EXIT
QUIT
+3 SET APCHOPT=Y
+4 SET XBRP="PRINT^BSDX42"
SET XBRC=""
SET XBRX="EXIT^BSDX42"
SET XBNS="APCH;DFN"
+5 DO ^XBDBQUE
+6 DO EXIT
+7 QUIT
+8 ;
WISDW(DFN,SDATE,EMSG) ;PEP; print Wellness handout
+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 SET DGPGM="PRINT^BSDX42"
+9 ;default printer fields
SET DEV=".11"
+10 SET BDGDEV=$$GET1^DIQ(9009020.2,$$DIV^BSDU,DEV)
+11 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
+12 SET IOP=BDGDEV
DO ^%ZIS
IF POP
DO END^SDROUT1
QUIT
+13 DO PRINT
+14 QUIT
+15 ;
EXIT ;
+1 DO EN^XBVK("APCH")
+2 DO ^XBFMK
+3 QUIT
+4 ;
PRINT ;
OUTPUT ;
+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("APCH",$JOB)
+4 ;gather up data
DO EP(DFN)
W ;write out array
+1 ;W:$D(IOF) @IOF
+2 KILL APCHQUIT
+3 WRITE !,"********** Patient Wellness Handout ********** ["_$PIECE(^VA(200,DUZ,0),U,2)_"] "_$$FMTE^XLFDT(DT)_" **********"
+4 SET APCHX=0
FOR
SET APCHX=$ORDER(^TMP($JOB,"APCHPWH",APCHX))
IF APCHX'=+APCHX!($DATA(APCHQUIT))
QUIT
Begin DoDot:1
+5 IF $Y>(IOSL-3)
DO HEADER
IF $DATA(APCHQUIT)
QUIT
+6 WRITE !,^TMP($JOB,"APCHPWH",APCHX)
+7 QUIT
End DoDot:1
+8 IF $DATA(APCHQUIT)
SET APCHSQIT=1
+9 DO EOJ
+10 DO ^%ZISC
+11 QUIT
+12 ;
EOJ ;
+1 ;
+2 KILL ^TMP("APCHPHS",$JOB)
+3 KILL ^TMP($JOB,"APCHPWH")
+4 DO EN^XBVK("APCH")
+5 DO EN^XBVK("APCD")
+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 $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 WRITE !,"********** CONFIDENTIAL PATIENT INFORMATION ["_$PIECE(^VA(200,DUZ,0),U,2)_"] "_$$FMTE^XLFDT(DT)_" **********",!!
+3 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 ;----------
EP(APCHSDFN) ;PEP - PASS DFN get back array of patient care summary
+1 ;at this point you are stuck with ^TMP("APCHPHS",$J,"PMH"
+2 ;CHANGE TO GO TO NEW PWH
+3 SET APCHPWHT=$ORDER(^APCHPWHT("B","ADULT REGULAR",0))
+4 DO EP1(APCHSDFN,APCHPWHT)
+5 QUIT
EP1(APCHSDFN,APCHPWHT,APCHPRTH) ;PEP - PASS DFN get back array of patient wellness handout
+1 ;handout returned in ^TMP("APCHPHS",$J,"APCHPWH"
+2 ;APCHPWHT - ien of the PWH type
+3 ;APCHPRTH - 1 if you don't want the header line printed
+4 KILL ^TMP($JOB,"APCHPWH")
+5 SET ^TMP($JOB,"APCHPWH",0)=0
+6 IF '$GET(APCHPWHT)
SET APCHPWHT=$ORDER(^APCHPWHT("B","ADULT REGULAR",0))
+7 IF '$GET(APCHPWHT)
QUIT
+8 DO SETARRAY
+9 QUIT
SETARRAY ;set up array containing pwh
+1 ;all handouts get this demographic section
+2 NEW X,APCHPRV,APCHSO,APCHSCMP,APCHSCMI
+3 IF '$GET(APCHPRTH)
SET X="My Wellness Handout"
SET $EXTRACT(X,40)="Report Date: "_$$FMTE^XLFDT(DT)
DO S(X)
+4 SET X="********** CONFIDENTIAL PATIENT INFORMATION ["_$PIECE(^VA(200,DUZ,0),U,2)_"] "_$$FMTE^XLFDT(DT)_" **********"
DO S(X)
+5 ;S X=$P($P(^DPT(APCHSDFN,0),U),",",2)_" "_$P($P(^DPT(APCHSDFN,0),U),",")_" HRN: "_$$HRN^AUPNPAT(APCHSDFN,DUZ(2)),$E(X,50)=$S($P(^APCCCTRL(DUZ(2),0),U,13)]"":$P(^APCCCTRL(DUZ(2),0),U,13),1:$P(^DIC(4,DUZ(2),0),U)) D S(X,1)
+6 SET X=$PIECE(^DPT(APCHSDFN,0),U)_" HRN: "_$$HRN^AUPNPAT(APCHSDFN,DUZ(2))
SET $EXTRACT(X,50)=$SELECT($PIECE(^APCCCTRL(DUZ(2),0),U,13)]"":$PIECE(^APCCCTRL(DUZ(2),0),U,13),1:$PIECE(^DIC(4,DUZ(2),0),U))
DO S(X,1)
+7 SET X=$$VAL^XBDIQ1(2,APCHSDFN,.111)
+8 SET $EXTRACT(X,50)=$$VAL^XBDIQ1(9999999.06,DUZ(2),.15)_$SELECT($$VAL^XBDIQ1(9999999.06,DUZ(2),.15)]"":", ",1:" ")_...
... $SELECT($PIECE($GET(^AUTTLOC(DUZ(2),0)),U,14):$PIECE(^DIC(5,$$VALI^XBDIQ1(9999999.06,DUZ(2),.16),0),U,2),1:"")_" "_$$VAL^XBDIQ1(9999999.06,DUZ(2),.17)
DO S(X)
+9 SET X=$$VAL^XBDIQ1(2,APCHSDFN,.114)_$SELECT($$VAL^XBDIQ1(2,APCHSDFN,.114)]"":", ",1:" ")_$$VAL^XBDIQ1(2,APCHSDFN,.115)_" "_$$VAL^XBDIQ1(2,APCHSDFN,.116)
+10 SET APCHPRV=$$DPCP(APCHSDFN)
+11 IF APCHPRV
Begin DoDot:1
+12 SET $EXTRACT(X,50)=$PIECE(^VA(200,APCHPRV,0),U)
DO S(X)
End DoDot:1
+13 IF 'APCHPRV
DO S(X)
+14 ;put provider phone at 50
SET X=$$VAL^XBDIQ1(2,APCHSDFN,.131)
SET $EXTRACT(X,50)=$PIECE(^AUTTLOC(DUZ(2),0),U,11)
DO S(X)
+15 ;I $G(APCDVSIT)]"",$D(^AUPNVSIT("AC",APCHSDFN,APCDVSIT)) S APCHPROV=$$PRIMPROV^APCLV(APCDVSIT)
+16 ;S X="Hello "_$S($$SEX^AUPNPAT(APCHSDFN)="M":"Mr. ",1:"Ms. ")_$E($P($P(^DPT(APCHSDFN,0),U),","))_$$LOW^XLFSTR($E($P($P(^DPT(APCHSDFN,0),U),","),2,99))_"," D S(X,1)
+17 SET X="Thank you for choosing "_$SELECT($PIECE(^APCCCTRL(DUZ(2),0),U,13)]"":$PIECE(^APCCCTRL(DUZ(2),0),U,13),1:$PIECE(^DIC(4,DUZ(2),0),U))_"."
DO S(X,1)
+18 SET X="This handout is a new way for you and your doctor to look at your health."
DO S(X)
+19 ;now process each component assigned to this type
+20 ;
COMPS ;
+1 IF $$AGE^AUPNPAT(APCHSDFN)<18
DO S("This handout is designed for patients 18 years of age and older.",2)
QUIT
+2 SET APCHSORD=0
FOR
SET APCHSORD=$ORDER(^APCHPWHT(APCHPWHT,1,APCHSORD))
IF APCHSORD'=+APCHSORD
QUIT
Begin DoDot:1
+3 SET APCHSCMP=$PIECE(^APCHPWHT(APCHPWHT,1,APCHSORD,0),U,2)
+4 IF 'APCHSCMP
QUIT
+5 IF '$DATA(^APCHPWHC(APCHSCMP,0))
QUIT
+6 SET APCHSCMI=$PIECE(^APCHPWHC(APCHSCMP,0),U,2)
+7 DO @($PIECE(APCHSCMI,";",1)_U_$PIECE(APCHSCMI,";",2))
End DoDot:1
+8 SET X="******** END CONFIDENTIAL PATIENT INFORMATION ["_$PIECE(^VA(200,DUZ,0),U,2)_"] "_$$FMTE^XLFDT(DT)_" ********"
DO S(X,2)
+9 ;
DPCP(P) ;EP
+1 NEW R
+2 DO ALLDP^BDPAPI(P,"DESIGNATED PRIMARY PROVIDER",.R)
+3 IF $DATA(R("DESIGNATED PRIMARY PROVIDER"))
QUIT $PIECE(R("DESIGNATED PRIMARY PROVIDER"),U,2)
+4 SET R=$PIECE(^AUPNPAT(P,0),U,14)
IF R
QUIT R
+5 SET R=""
+6 QUIT R
+7 ;
S(Y,F,C,T) ;EP - set up array
+1 IF '$GET(F)
SET F=0
+2 IF '$GET(T)
SET T=0
+3 NEW %,X
+4 ;blank lines
+5 FOR F=1:1:F
SET X=""
DO S1
+6 SET X=Y
+7 IF $GET(C)
SET L=$LENGTH(Y)
SET T=(80-L)/2
Begin DoDot:1
+8 FOR %=1:1:(T-1)
SET X=" "_X
End DoDot:1
DO S1
QUIT
+9 FOR %=1:1:T
SET X=" "_Y
+10 DO S1
+11 QUIT
S1 ;
+1 SET %=$PIECE(^TMP($JOB,"APCHPWH",0),U)+1
SET $PIECE(^TMP($JOB,"APCHPWH",0),U)=%
+2 SET ^TMP($JOB,"APCHPWH",%)=X
+3 QUIT
+4 ;
WISD(DFN,SDATE,BSDMODE,BSDDEV,BSDNHS,EMSG) ;PEP; print routing slip for walkin/same day appt
+1 ; .EMSG = returned error message if error
+2 ;
+3 IF +DFN=0
QUIT
+4 ;***** END 10/21/04
+5 ;
+6 NEW DGPGM,VAR,VAR1,DEV,POP
+7 SET SDX="ALL"
SET ORDER=""
SET SDREP=0
SET SDSTART=""
SET DIV=$$DIV^BSDU
+8 ;
+9 ;IHS/ITSC/LJF 6/17/2005 PATCH 1003 adde BSDNHS to variable list
+10 ;S VAR="DIV^ORDER^SDX^SDATE^DFN^SDREP^SDSTART^BSDMODE"
+11 ;S VAR1="DIV;ORDER;SDX;SDATE;DFN;SDREP;SDSTART;BSDMODE"
+12 SET VAR="DIV^ORDER^SDX^SDATE^DFN^SDREP^SDSTART^BSDMODE^BSDNHS"
+13 SET VAR1="DIV;ORDER;SDX;SDATE;DFN;SDREP;SDSTART;BSDMODE;BSDNHS"
+14 ;end of these PATCH 1003 changes
+15 ;
+16 SET DGPGM="SINGLE^BSDROUT"
+17 IF $GET(BSDDEV)]""
DO ZIS^BDGF("F","SINGLE^BSDROUT","ROUTING SLIP",VAR1,BSDDEV)
QUIT
+18 ;default printer fields
SET DEV=$SELECT($GET(BSDMODE)="CR":".05",1:".11")
+19 SET BDGDEV=$$GET1^DIQ(9009020.2,$$DIV^BSDU,DEV)
+20 IF BDGDEV=""
KILL BDGDEV
SET EMSG="Routing Slip could not be printed: no default "_$SELECT(BSDMODE="CR":"chart request",1:"walk in")_" printer defined in the IHS SCHEDULING PARAMETERS table."
QUIT
+21 SET IOP=BDGDEV
DO ^%ZIS
IF POP
DO END^SDROUT1
QUIT
+22 DO SINGLE
+23 QUIT
+24 ;
ONE ;EP; called by SDROUT to print one patient's routing slip
+1 SET DFN=+$$READ^BDGF("PO^2:EQM","Select PATIENT")
IF DFN<1
DO END^SDROUT
QUIT
+2 DO WISD(DFN,DT,"")
+3 QUIT
+4 ;
SINGLE ;EP; queued entry point for single routing slips
+1 ; called by WISD subroutine
+2 USE IO
KILL ^TMP("SDRS",$JOB)
+3 NEW BSDT,CLN,IEN,BSDMOD2
+4 ;
+5 ; find all appts for patient
+6 IF BSDMODE="CR"
SET BSDMOD2="CR"
SET BSDMODE=""
+7 SET BSDT=SDATE\1
+8 FOR
SET BSDT=$ORDER(^DPT(DFN,"S",BSDT))
IF 'BSDT
QUIT
IF (BSDT\1>SDATE)
QUIT
Begin DoDot:1
+9 ;clinic ien
SET CLN=+$GET(^DPT(DFN,"S",BSDT,0))
IF 'CLN
QUIT
+10 SET IEN=0
FOR
SET IEN=$ORDER(^SC(CLN,"S",BSDT,1,IEN))
IF 'IEN
QUIT
IF $PIECE($GET(^SC(CLN,"S",BSDT,1,IEN,0)),U)=DFN
QUIT
+11 ;appt ien in ^sc
IF 'IEN
QUIT
+12 DO FIND^BSDROUT0(CLN,BSDT,IEN,ORDER,BSDMODE)
End DoDot:1
+13 IF $DATA(BSDMOD2)
SET BSDMODE=BSDMOD2
+14 ;
+15 ; find all chart requests for patient
+16 SET CLN=0
FOR
SET CLN=$ORDER(^SC("AIHSCR",DFN,CLN))
IF 'CLN
QUIT
Begin DoDot:1
+17 SET BSDT=(SDATE\1)-.0001
+18 FOR
SET BSDT=$ORDER(^SC("AIHSCR",DFN,CLN,BSDT))
IF 'BSDT
QUIT
Begin DoDot:2
+19 DO CRSET^BSDROUT2(CLN,BSDT,DFN,ORDER)
End DoDot:2
End DoDot:1
+20 ;
+21 KILL ^TMP("BSDX42",$JOB)
+22 MERGE ^TMP("BSDX42",$JOB)=^TMP("SDRS",$JOB)
+23 ; if no future appts, set something so RS will print
+24 IF '$DATA(^TMP("BSDX42",$JOB))
SET ^TMP("BSDX42",$JOB,$$GET1^DIQ(2,DFN,.01),$$TERM(DFN),DFN)=""
+25 ;
+26 DO PRINT^BSDROUT1(ORDER,SDATE)
+27 QUIT
TERM(PAT) ; returns chart # in terminal digit format
+1 NEW N,T
+2 ;chart #
SET N=$$HRCN^BDGF2(PAT,$GET(DUZ(2)))
+3 ;terminal digit format
SET T=$$HRCNT^BDGF2(N)
+4 IF $$GET1^DIQ(9009020.2,+$$DIV^BSDU,.18)="NO"
Begin DoDot:1
+5 ;use chart # per site param
SET T=$$HRCND^BDGF2(N)
End DoDot:1
+6 QUIT T
