BSDROUT ; IHS/ANMC/LJF,WAR - IHS CALLS FROM SDROUT ;
;;5.3;PIMS;**1001,1003,1005,1006,1007,1009,1010,1011**;DEC 01, 2006
;IHS/ITSC/WAR 8/19/2004 PATCH #1001 set date range for appt letter from tomorrow to a year from now
;IHS/ITSC/WAR 10/21/2004 PATCH 1001 Check for DFN if user enters by Clinic, but does not select a Pt
;IHS/ITSC/LJF 10/25/2004 PATCH 1001 Changed default for Want to print Appt Letter to YES
;IHS/ITSC/LJF 06/17/2005 PATCH 1003 added ability to call for single RS without a health summary
;IHS/OIT/LJF 02/16/2006 PATCH 1005 added RSCI subroutine to pull charts at checkin
; 07/07/2006 PATCH 1006 WISD now a PEP (public entry point); used by ERS
;cmi/anch/maw 11/22/2006 PATCH 1007 added modifications for items 1007.05 and 1007.16
;cmi/anch/maw 01/20/2007 PATCH 1007 added mods in APPT to check for mult appt book flab BSDMK item 1007.13
;cmi/anch/maw 04/07/2008 PATCH 1009 added code in RSCI and APPT for default prompt for chart request requirement 61
;cmi/anch/maw 05/01/2009 PATCH 1010 added code in RSCI and APPT to default BSDPAR to first entry if DIV is not defined
;cmi/flag/maw 10/15/2009 PATCH 1011 added code PWH to get patient wellness handout RQMT121
;
ASK ;EP; called by SDROUT to ask rest of the questions
NEW BSDI,BSDQ
S BSDQ=0
F BSDI="SORT","DATE","CLINIC","REPRINT" D @BSDI I BSDQ D END^SDROUT Q
I 'BSDQ D DEVICE
Q
;
SORT ; ask user for sort choice
S ORDER=$$READ^BDGF("S^1:TERMINAL DIGIT;2:CLINIC NAME;3:PRINCIPAL CLINIC;4:PATIENT NAME","Choose Sort Order","","^D R3HELP^BSDROUT")
I (ORDER="")!(ORDER=U) S BSDQ=1
Q
;
DATE ; ask appt date to process
S SDATE=$$READ^BDGF("DO^::EXF","PRINT ROUTING SLIPS FOR WHAT DATE")
I SDATE<1 S BSDQ=1
Q
;
CLINIC ; ask clinic selection if sort 2 or 3
;
I (ORDER=1)!(ORDER=4) S VAUTC=1 D Q
. I $G(DIV)="" S VAUTD=1 Q ;set to all divisions
. S VAUTD=0,VAUTD(DIV)=$$DIVNM^BSDU(DIV) ;division already set
D CLINIC^BSDU(2,"",1) S BSDQ=$S($D(BSDQ):1,1:0) Q
;
REPRINT ; ask if this is a reprint
Q:$G(SDX)'["ADD" ;cmi/anch/maw added line for item 1007.16 patch 1007
S SDREP=$$READ^BDGF("Y","IS THIS A REPRINT OF A PREVIOUS RUN","NO")
I SDREP=U S BSDQ=1 Q
I SDREP=0 D Q
. I (ORDER=2)!(ORDER=3) Q
. D RANGE("PRINT")
;
I SDX["ADD" S SDSTART=$$READ^BDGF("DO^::EX","REPRINT ADD-ONS THAT WERE RUN ON WHAT DATE") S:SDSTART<1 BSDQ=1 Q
I (ORDER=1)!(ORDER=4) D RANGE("REPRINT")
Q
;
RANGE(TYPE) ; ask to print a small batch
NEW BSDX,HELP
S BSDX=$S(ORDER=1:"TERMINAL DIGIT",1:"PATIENT NAME")
S HELP="THE "_TYPE_" WILL BEGIN PRINTING AT THE "_BSDX_"YOU SPECIFY"
S SDSTART=$$READ^BDGF("F^1:30","ENTER "_BSDX_" TO BEGIN "_TYPE_" FROM","FIRST",HELP)
I SDSTART=U S BSDQ=1 Q
I SDSTART="FIRST" S SDSTART="" Q
I ORDER=1,SDSTART'?2N D MSG^BDGF("Must enter 2 digits",2,1) D RANGE(TYPE) Q
;
RANGE2 ;
S SDSTOP=$$READ^BDGF("F^1:30","ENTER "_BSDX_" ON WHICH TO STOP PRINT","LAST")
I SDSTOP=U S BSDQ=1 Q
I SDSTOP="LAST" S SDSTOP="" Q
I ORDER=1,SDSTOP'?2N D MSG^BDGF("Must enter 2 digits",2,1) D RANGE2 Q
Q
;
DEVICE ; ask print device
S VAR="DIV^VAUTC^VAUTC(^SDX^ORDER^SDATE^SDIQ^SDREP^SDSTART^SDSTOP^VAUTD^VAUTD("
S DGPGM="START^BSDROUT"
S BDGDEV=$$GET1^DIQ(40.8,$$DIV^BSDU,9) K:BDGDEV="" BDGDEV
D ZIS^DGUTQ I POP D END^SDROUT1 Q
D START^BSDROUT
Q
;
START ;EP; entry point when printing routing slip batch
; IHS modified version of START^SDROUT
K ^TMP("SDRS",$J) U IO
K ^TMP("SDRS1",$J)
S Y=SDATE D DTS^SDUTL S APDATE=Y,Y=DT D DTS^SDUTL S PRDATE=Y
;
NEW BSDSC,BSDGD,BSDL,SC
I $G(VAUTC)=1 D
.S BSDSCIND="S BSDSC=$O(^SC(BSDSC))"
E D
.S BSDSCIND="S BSDSC=$O(VAUTC(BSDSC))"
S BSDSC=0 F X BSDSCIND Q:'BSDSC S SC=BSDSC D CHECK^SDROUT I $T D
. S BSDGD=SDATE
. F S BSDGD=$O(^SC(BSDSC,"S",BSDGD)) Q:('BSDGD)!(BSDGD>(SDATE+1)) D
.. I $D(^SC(BSDSC,"S",BSDGD,1)) S BSDL=0 F S BSDL=$O(^SC(BSDSC,"S",BSDGD,1,BSDL)) Q:'BSDL I $D(^(BSDL,0)),$P(^(0),U,9)'="C" D FIND^BSDROUT0(BSDSC,BSDGD,BSDL,ORDER,"")
D CRLOOP^BSDROUT2
D PRINT^BSDROUT1(ORDER,SDATE)
Q
;
R3HELP ;EP; user help for Sort question
D MSG^BDGF("Select the order in which you want the routing slips printed.",2,1)
D MSG^BDGF(" Choose 1 to print by terminal digit order",1,0)
D MSG^BDGF(" (Or by chart # order if site parameter set that way.)",1,0)
D MSG^BDGF(" Choose 2 to print by name for selected clinics.",1,0)
D MSG^BDGF(" Choose 3 to print by principal clinic names.",1,0)
D MSG^BDGF(" (Subtotaled by terminal digit within these categories.)",1,0)
D MSG^BDGF(" Choose 4 to print alphabetically by patient name.",1,1)
Q
;
;IHS/ITSC/LJF 6/17/2005 PATCH 1003 added BSDNHS parameter
;IHS/OIT/LJF 07/07/2006 PATCH 1006 now a public entry point
WISD(DFN,SDATE,BSDMODE,BSDDEV,BSDNHS) ;PEP; print routing slip for walkin/same day appt
; called by SDAMWI1 for walkins; BSDMODE="WI"
; called by ONE^BSDROUT for single patient rs; BSDMODE=""
; called by APPT for same day appt; BSDMODE="SD"
; called by BSDAPP for chart requests for today
; called by RS protocol with BSDNHS=1 so no health summary will print;PATCH 1003
;
;IHS/ITSC/WAR 10/21/04; PATCH #1001
; Check for DFN if user enters by Clinic, but does not select a Pt
I +DFN=0 D
.S DIR(0)="N^"_VALMBG_":"_VALMLST
.D ^DIR
.I +Y>0 S DFN=+$P($G(^TMP("SDAMIDX",$J,+Y)),U,2)
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)]"",$G(DGQUIET) D ZIS^BDGF("F","SINGLE^BSDROUT","ROUTING SLIP",VAR1,BSDDEV) Q
S DEV=$S(BSDMODE="CR":".05",1:".11") ;default printer fields
S BDGDEV=$$GET1^DIQ(9009020.2,$$DIV^BSDU,DEV)
I BDGDEV="" K BDGDEV I $G(DGQUIET) Q
S %ZIS("A")="FILE ROOM PRINTER: " D ZIS^DGUTQ 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)
;
; if no future appts, set something so RS will print
I '$D(^TMP("SDRS",$J)) S ^TMP("SDRS",$J,$$GET1^DIQ(2,DFN,.01),$$TERM(DFN),DFN)=""
;
D PRINT^BSDROUT1(ORDER,SDATE)
Q
;
APPT(EVENT,DFN,DATE) ;EP; called by BSDAM APPT SLIP protocol
; which is called by BSDAM APPOINTMENT EVENTS protocol
; which is called by EVT^SDAMEVT via MAKE^SDAMEVT via ^SDM1A
; from making appointment
;
;cmi/maw 1/20/2007 check for mult appt book flag BSDMK, if there quit until it is not patch 1007 item 1007.13'
Q:$G(BSDMK)
;cmi/maw 1/20/2007 end of mods
;
Q:$G(SDMODE)=2 ;quiet mode
; save variables not used that event driver needs back
NEW SDT,SDCL,SDDA,SDATA,SDAMEVT,SDMODE
NEW SDC
Q:IOST'["C-" ;quit if printer is device
Q:$G(BSDNO) ;quit if rebook
Q:EVENT'=1 ;not make appt
Q:$P($G(^DPT(DFN,"S",DATE,0)),U,7)'=3 ;not sched appt
;
; print routing slip for same day appt
N BSDPAR ;cmi/maw 5/2/2009 patch 1010
S BSDPAR=$O(^BSDPAR("B",0)) ;cmi/maw 5/2/2009 patch 1010
I (DATE\1)=($P(^DPT(DFN,"S",DATE,0),U,19)\1) D Q
. I '$G(DIV) Q:$$READ^BDGF("Y","Want Chart Requested",$S($P($G(^BSDPAR(BSDPAR,0)),U,25):"YES",1:"NO"),"^D HELPA^BSDROUT")'=1 ;cmi/maw 04/07/2008 orig line
. I $G(DIV) Q:$$READ^BDGF("Y","Want Chart Requested",$S($P($G(^BSDPAR(DIV,0)),U,25):"YES",1:"NO"),"^D HELPA^BSDROUT")'=1 ;cmi/maw 04/07/2008 PATCH 1009 mod line for default
. D WISD(DFN,DATE,"SD",$$GET1^DIQ(9009020.2,$$DIV^BSDU,.05))
;
; ask to print appt letter for patient
Q:$$GET1^DIQ(9009020.2,$$DIV^BSDU,.02)'="YES" ;site parameter
;Q:$$READ^BDGF("Y","Want to Print Appointment Letter for Patient","NO","^D HELPB^BSDROUT")'=1
Q:$$READ^BDGF("Y","Want to Print Appointment Letter for Patient","YES","^D HELPB^BSDROUT")'=1 ;IHS/ITSC/LJF 10/25/2004 PATCH 1001
;
; set up variables for call
NEW X,L2,SDCONC,SDLT,DIV,SDV1,SDFORM,SDLET,SDLT1,SDBD,SDED,SDTIME
NEW S1,VAUTD,VAUTN,L0
NEW SDDAT ;saved for multibook rtn
S L2="^SDL1",SDCONC="B",SDLT=1,L0="P"
S DIV=$$DIV^BSDU,SDV1=DIV,SDFORM=+$$GET1^DIQ(40.8,DIV,30.01,"I")
S VAUTD=0,VAUTD(DIV)=$$GET1^DIQ(40.8,DIV,.01)
;cmi/anch/maw 11/22/06 split below line to get letter format
;cmi/anch/maw 11/22/2006 adding code to select letter format if field .23 of IHS SCHEDULING PARAMETER file is set to yes item 1007.04 and 1007.05 patch 1007
S X=+$G(^DPT(DFN,"S",DATE,0)) ;cmi/anch/maw 11/22/06 added item 1007.04 patch 1007
S SDLET="" ;cmi/anch/maw 11/22/06 added line for item 1007.04 patch 1007
I $$GET1^DIQ(9009020.2,DIV,.23,"I") D ;cmi/anch/maw 11/22/06 added for item 1007.04 patch 1007
. S SDLET=+$$READ^BDGF("P^407.5:EMQZ","Select Letter",$$GET1^DIQ(44,X,2509)) ;cmi/anch/maw 11/22/06 added for item 1007.04 patch 1007
I $G(SDLET) D MSG^BDGF($$GET1^DIQ(407.5,SDLET,.01)_" letter selected",2,1) ;cmi/anch/maw 12/5/2006 added to display letter selected
;
;S X=+$G(^DPT(DFN,"S",DATE,0)),SDLET=$$GET1^DIQ(44,X,2509,"I") ;cmi/anch/maw 11/22/06 orig line item 1007.04 patch 1007
I SDLET="" S SDLET=$$GET1^DIQ(44,X,2509,"I") ;cmi/anch/maw 11/22/06 item 1007.04 patch 1007
I SDLET="" S SDLET=$O(^VA(407.5,"B","APPOINTMENT SLIP",0))
I SDLET="" D MSG^BDGF("Sorry, no letter set up to print. See Application Coordinator.",2,1) Q
;
;IHS/ITSC/WAR 8/19/2004 PATCH #1001 set date range starting with tomorrow
;S SDLT1=SDLET,SDBD=DT,SDED=$$FMADD^XLFDT(DT,365),SDTIME="*"
S SDLT1=SDLET,SDBD=$$FMADD^XLFDT(DT,1),SDED=$$FMADD^XLFDT(DT,365),SDTIME="*"
S VAUTN=0,VAUTN(DFN)=$$GET1^DIQ(2,DFN,.01),S1="P"
;
D QUE^SDLTP
Q
;
PWH(EVENT,DFN,DATE) ;EP; called by BSDAM PWH AT CHECKIN protocol;cmi/flag/maw 10/19/2009 PATCH 1011
Q:$T(EN2^APCHPWHG)="" ;pcc v2.0 not loaded
I '$G(DATE) S DATE=DT
; which is called by BSDAM APPOINTMENT EVENTS protocol
; Used at sites with so many no-shows that charts are not pulled until patients arrive
;
Q:$G(SDMODE)=2 ;quiet mode
; save variables not used that event driver needs back
NEW SDDA,SDATA,SDAMEVT,SDMODE,SDC,VALMY,SDI,SDAT,BSDPWH
Q:IOST'["C-" ;quit if printer is device
I $G(EVENT)'="OR" Q:EVENT'=4 ;not checkin
;Q:$$GET1^DIQ(9009020.2,$$DIV^BSDU,.22)'="YES" ;parameter not turned on
I $G(EVENT)'="OR" Q:$P($G(^DPT(DFN,"S",DATE,0)),U,7)'=3 ;not sched appt
I $G(EVENT)'="OR" Q:'$$CI^BSDU2(DFN,SDCL,DATE,$$SCIEN^BSDU2(DFN,SDCL,DATE)) ;quit if check in deleted
;
S DIV=$$DIV^BSDU
Q:$$READ^BDGF("Y","Want Patient Wellness Handout","NO","^D HELPA^BSDROUT")'=1
S BSDPWH=$$SELTYP
Q:'$G(BSDPWH)
D EN2^APCHPWHG(BSDPWH,DFN)
I $D(VALMBCK),VALMBCK="R" D REFRESH^VALM S VALMBCK=$P(VALMBCK,"R")_$P(VALMBCK,"R",2)
Q
;
SELTYP() ;
K DIADD,DLAYGO
N BSDPWHT
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 Q 0
S BSDPWHT=+Y
Q BSDPWHT
;
RSCI(EVENT,DFN,DATE) ;EP; called by BSDAM RS AT CHECKIN protocol;IHS/OIT/LJF 02/16/2006 PATCH 1005
; which is called by BSDAM APPOINTMENT EVENTS protocol
; Used at sites with so many no-shows that charts are not pulled until patients arrive
;
Q:$G(SDMODE)=2 ;quiet mode
; save variables not used that event driver needs back
NEW SDDA,SDATA,SDAMEVT,SDMODE,SDC,VALMY,SDI,SDAT
Q:IOST'["C-" ;quit if printer is device
Q:EVENT'=4 ;not checkin
Q:$$GET1^DIQ(9009020.2,$$DIV^BSDU,.22)'="YES" ;parameter not turned on
Q:$P($G(^DPT(DFN,"S",DATE,0)),U,7)'=3 ;not sched appt
Q:'$$CI^BSDU2(DFN,SDCL,DATE,$$SCIEN^BSDU2(DFN,SDCL,DATE)) ;quit if check in deleted
;
;Q:$$READ^BDGF("Y","Want Chart Requested","YES","^D HELPA^BSDROUT")'=1 ;cmi/maw 04/07/2008 orig line
;cmi/maw 7/17/2008 PATCH 1009 the following 2 lines are now part of patch 1009 due to DIV being undefined as various times
S DIV=$$DIV^BSDU
N BSDPAR ;cmi/maw 5/2/2009 patch 1010
S BSDPAR=$O(^BSDPAR("B",0)) ;cmi/maw 5/2/2009 patch 1010
I $G(DIV) Q:$$READ^BDGF("Y","Want Chart Requested",$S($P($G(^BSDPAR(DIV,0)),U,25):"YES",1:"YES"),"^D HELPA^BSDROUT")'=1 ;cmi/maw 04/07/2008 PATCH 1009 mod line for default
I '$G(DIV) Q:$$READ^BDGF("Y","Want Chart Requested",$S($P($G(^BSDPAR(BSDPAR,0)),U,25):"YES",1:"YES"),"^D HELPA^BSDROUT")'=1
;cmi/maw 7/17/2008 PATCH 1009 end of mods
D WISD(DFN,DATE,"RS",$$GET1^DIQ(9009020.2,$$DIV^BSDU,.05))
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
;
HELPA ;EP; called as help for "Want Chart Requested?" question
W !,"Since this is a same day appointment, do you need the paper"
W !,"chart pulled? Answer YES to have the routing slip print in"
W !,"medical records."
Q
;
HELPB ;EP; called as help for "Print Appt Letter?" question
W !,"Answer YES to print a reminder letter for this appointment." Q
BSDROUT ; IHS/ANMC/LJF,WAR - IHS CALLS FROM SDROUT ;
+1 ;;5.3;PIMS;**1001,1003,1005,1006,1007,1009,1010,1011**;DEC 01, 2006
+2 ;IHS/ITSC/WAR 8/19/2004 PATCH #1001 set date range for appt letter from tomorrow to a year from now
+3 ;IHS/ITSC/WAR 10/21/2004 PATCH 1001 Check for DFN if user enters by Clinic, but does not select a Pt
+4 ;IHS/ITSC/LJF 10/25/2004 PATCH 1001 Changed default for Want to print Appt Letter to YES
+5 ;IHS/ITSC/LJF 06/17/2005 PATCH 1003 added ability to call for single RS without a health summary
+6 ;IHS/OIT/LJF 02/16/2006 PATCH 1005 added RSCI subroutine to pull charts at checkin
+7 ; 07/07/2006 PATCH 1006 WISD now a PEP (public entry point); used by ERS
+8 ;cmi/anch/maw 11/22/2006 PATCH 1007 added modifications for items 1007.05 and 1007.16
+9 ;cmi/anch/maw 01/20/2007 PATCH 1007 added mods in APPT to check for mult appt book flab BSDMK item 1007.13
+10 ;cmi/anch/maw 04/07/2008 PATCH 1009 added code in RSCI and APPT for default prompt for chart request requirement 61
+11 ;cmi/anch/maw 05/01/2009 PATCH 1010 added code in RSCI and APPT to default BSDPAR to first entry if DIV is not defined
+12 ;cmi/flag/maw 10/15/2009 PATCH 1011 added code PWH to get patient wellness handout RQMT121
+13 ;
ASK ;EP; called by SDROUT to ask rest of the questions
+1 NEW BSDI,BSDQ
+2 SET BSDQ=0
+3 FOR BSDI="SORT","DATE","CLINIC","REPRINT"
DO @BSDI
IF BSDQ
DO END^SDROUT
QUIT
+4 IF 'BSDQ
DO DEVICE
+5 QUIT
+6 ;
SORT ; ask user for sort choice
+1 SET ORDER=$$READ^BDGF("S^1:TERMINAL DIGIT;2:CLINIC NAME;3:PRINCIPAL CLINIC;4:PATIENT NAME","Choose Sort Order","","^D R3HELP^BSDROUT")
+2 IF (ORDER="")!(ORDER=U)
SET BSDQ=1
+3 QUIT
+4 ;
DATE ; ask appt date to process
+1 SET SDATE=$$READ^BDGF("DO^::EXF","PRINT ROUTING SLIPS FOR WHAT DATE")
+2 IF SDATE<1
SET BSDQ=1
+3 QUIT
+4 ;
CLINIC ; ask clinic selection if sort 2 or 3
+1 ;
+2 IF (ORDER=1)!(ORDER=4)
SET VAUTC=1
Begin DoDot:1
+3 ;set to all divisions
IF $GET(DIV)=""
SET VAUTD=1
QUIT
+4 ;division already set
SET VAUTD=0
SET VAUTD(DIV)=$$DIVNM^BSDU(DIV)
End DoDot:1
QUIT
+5 DO CLINIC^BSDU(2,"",1)
SET BSDQ=$SELECT($DATA(BSDQ):1,1:0)
QUIT
+6 ;
REPRINT ; ask if this is a reprint
+1 ;cmi/anch/maw added line for item 1007.16 patch 1007
IF $GET(SDX)'["ADD"
QUIT
+2 SET SDREP=$$READ^BDGF("Y","IS THIS A REPRINT OF A PREVIOUS RUN","NO")
+3 IF SDREP=U
SET BSDQ=1
QUIT
+4 IF SDREP=0
Begin DoDot:1
+5 IF (ORDER=2)!(ORDER=3)
QUIT
+6 DO RANGE("PRINT")
End DoDot:1
QUIT
+7 ;
+8 IF SDX["ADD"
SET SDSTART=$$READ^BDGF("DO^::EX","REPRINT ADD-ONS THAT WERE RUN ON WHAT DATE")
IF SDSTART<1
SET BSDQ=1
QUIT
+9 IF (ORDER=1)!(ORDER=4)
DO RANGE("REPRINT")
+10 QUIT
+11 ;
RANGE(TYPE) ; ask to print a small batch
+1 NEW BSDX,HELP
+2 SET BSDX=$SELECT(ORDER=1:"TERMINAL DIGIT",1:"PATIENT NAME")
+3 SET HELP="THE "_TYPE_" WILL BEGIN PRINTING AT THE "_BSDX_"YOU SPECIFY"
+4 SET SDSTART=$$READ^BDGF("F^1:30","ENTER "_BSDX_" TO BEGIN "_TYPE_" FROM","FIRST",HELP)
+5 IF SDSTART=U
SET BSDQ=1
QUIT
+6 IF SDSTART="FIRST"
SET SDSTART=""
QUIT
+7 IF ORDER=1
IF SDSTART'?2N
DO MSG^BDGF("Must enter 2 digits",2,1)
DO RANGE(TYPE)
QUIT
+8 ;
RANGE2 ;
+1 SET SDSTOP=$$READ^BDGF("F^1:30","ENTER "_BSDX_" ON WHICH TO STOP PRINT","LAST")
+2 IF SDSTOP=U
SET BSDQ=1
QUIT
+3 IF SDSTOP="LAST"
SET SDSTOP=""
QUIT
+4 IF ORDER=1
IF SDSTOP'?2N
DO MSG^BDGF("Must enter 2 digits",2,1)
DO RANGE2
QUIT
+5 QUIT
+6 ;
DEVICE ; ask print device
+1 SET VAR="DIV^VAUTC^VAUTC(^SDX^ORDER^SDATE^SDIQ^SDREP^SDSTART^SDSTOP^VAUTD^VAUTD("
+2 SET DGPGM="START^BSDROUT"
+3 SET BDGDEV=$$GET1^DIQ(40.8,$$DIV^BSDU,9)
IF BDGDEV=""
KILL BDGDEV
+4 DO ZIS^DGUTQ
IF POP
DO END^SDROUT1
QUIT
+5 DO START^BSDROUT
+6 QUIT
+7 ;
START ;EP; entry point when printing routing slip batch
+1 ; IHS modified version of START^SDROUT
+2 KILL ^TMP("SDRS",$JOB)
USE IO
+3 KILL ^TMP("SDRS1",$JOB)
+4 SET Y=SDATE
DO DTS^SDUTL
SET APDATE=Y
SET Y=DT
DO DTS^SDUTL
SET PRDATE=Y
+5 ;
+6 NEW BSDSC,BSDGD,BSDL,SC
+7 IF $GET(VAUTC)=1
Begin DoDot:1
+8 SET BSDSCIND="S BSDSC=$O(^SC(BSDSC))"
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 SET BSDSCIND="S BSDSC=$O(VAUTC(BSDSC))"
End DoDot:1
+11 SET BSDSC=0
FOR
XECUTE BSDSCIND
IF 'BSDSC
QUIT
SET SC=BSDSC
DO CHECK^SDROUT
IF $TEST
Begin DoDot:1
+12 SET BSDGD=SDATE
+13 FOR
SET BSDGD=$ORDER(^SC(BSDSC,"S",BSDGD))
IF ('BSDGD)!(BSDGD>(SDATE+1))
QUIT
Begin DoDot:2
+14 IF $DATA(^SC(BSDSC,"S",BSDGD,1))
SET BSDL=0
FOR
SET BSDL=$ORDER(^SC(BSDSC,"S",BSDGD,1,BSDL))
IF 'BSDL
QUIT
IF $DATA(^(BSDL,0))
IF $PIECE(^(0),U,9)'="C"
DO FIND^BSDROUT0(BSDSC,BSDGD,BSDL,ORDER,"")
End DoDot:2
End DoDot:1
+15 DO CRLOOP^BSDROUT2
+16 DO PRINT^BSDROUT1(ORDER,SDATE)
+17 QUIT
+18 ;
R3HELP ;EP; user help for Sort question
+1 DO MSG^BDGF("Select the order in which you want the routing slips printed.",2,1)
+2 DO MSG^BDGF(" Choose 1 to print by terminal digit order",1,0)
+3 DO MSG^BDGF(" (Or by chart # order if site parameter set that way.)",1,0)
+4 DO MSG^BDGF(" Choose 2 to print by name for selected clinics.",1,0)
+5 DO MSG^BDGF(" Choose 3 to print by principal clinic names.",1,0)
+6 DO MSG^BDGF(" (Subtotaled by terminal digit within these categories.)",1,0)
+7 DO MSG^BDGF(" Choose 4 to print alphabetically by patient name.",1,1)
+8 QUIT
+9 ;
+10 ;IHS/ITSC/LJF 6/17/2005 PATCH 1003 added BSDNHS parameter
+11 ;IHS/OIT/LJF 07/07/2006 PATCH 1006 now a public entry point
WISD(DFN,SDATE,BSDMODE,BSDDEV,BSDNHS) ;PEP; print routing slip for walkin/same day appt
+1 ; called by SDAMWI1 for walkins; BSDMODE="WI"
+2 ; called by ONE^BSDROUT for single patient rs; BSDMODE=""
+3 ; called by APPT for same day appt; BSDMODE="SD"
+4 ; called by BSDAPP for chart requests for today
+5 ; called by RS protocol with BSDNHS=1 so no health summary will print;PATCH 1003
+6 ;
+7 ;IHS/ITSC/WAR 10/21/04; PATCH #1001
+8 ; Check for DFN if user enters by Clinic, but does not select a Pt
+9 IF +DFN=0
Begin DoDot:1
+10 SET DIR(0)="N^"_VALMBG_":"_VALMLST
+11 DO ^DIR
+12 IF +Y>0
SET DFN=+$PIECE($GET(^TMP("SDAMIDX",$JOB,+Y)),U,2)
End DoDot:1
+13 IF +DFN=0
QUIT
+14 ;***** END 10/21/04
+15 ;
+16 NEW DGPGM,VAR,VAR1,DEV,POP
+17 SET SDX="ALL"
SET ORDER=""
SET SDREP=0
SET SDSTART=""
SET DIV=$$DIV^BSDU
+18 ;
+19 ;IHS/ITSC/LJF 6/17/2005 PATCH 1003 adde BSDNHS to variable list
+20 ;S VAR="DIV^ORDER^SDX^SDATE^DFN^SDREP^SDSTART^BSDMODE"
+21 ;S VAR1="DIV;ORDER;SDX;SDATE;DFN;SDREP;SDSTART;BSDMODE"
+22 SET VAR="DIV^ORDER^SDX^SDATE^DFN^SDREP^SDSTART^BSDMODE^BSDNHS"
+23 SET VAR1="DIV;ORDER;SDX;SDATE;DFN;SDREP;SDSTART;BSDMODE;BSDNHS"
+24 ;end of these PATCH 1003 changes
+25 ;
+26 SET DGPGM="SINGLE^BSDROUT"
+27 IF $GET(BSDDEV)]""
IF $GET(DGQUIET)
DO ZIS^BDGF("F","SINGLE^BSDROUT","ROUTING SLIP",VAR1,BSDDEV)
QUIT
+28 ;default printer fields
SET DEV=$SELECT(BSDMODE="CR":".05",1:".11")
+29 SET BDGDEV=$$GET1^DIQ(9009020.2,$$DIV^BSDU,DEV)
+30 IF BDGDEV=""
KILL BDGDEV
IF $GET(DGQUIET)
QUIT
+31 SET %ZIS("A")="FILE ROOM PRINTER: "
DO ZIS^DGUTQ
IF POP
DO END^SDROUT1
QUIT
+32 DO SINGLE
+33 QUIT
+34 ;
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 ; if no future appts, set something so RS will print
+22 IF '$DATA(^TMP("SDRS",$JOB))
SET ^TMP("SDRS",$JOB,$$GET1^DIQ(2,DFN,.01),$$TERM(DFN),DFN)=""
+23 ;
+24 DO PRINT^BSDROUT1(ORDER,SDATE)
+25 QUIT
+26 ;
APPT(EVENT,DFN,DATE) ;EP; called by BSDAM APPT SLIP protocol
+1 ; which is called by BSDAM APPOINTMENT EVENTS protocol
+2 ; which is called by EVT^SDAMEVT via MAKE^SDAMEVT via ^SDM1A
+3 ; from making appointment
+4 ;
+5 ;cmi/maw 1/20/2007 check for mult appt book flag BSDMK, if there quit until it is not patch 1007 item 1007.13'
+6 IF $GET(BSDMK)
QUIT
+7 ;cmi/maw 1/20/2007 end of mods
+8 ;
+9 ;quiet mode
IF $GET(SDMODE)=2
QUIT
+10 ; save variables not used that event driver needs back
+11 NEW SDT,SDCL,SDDA,SDATA,SDAMEVT,SDMODE
+12 NEW SDC
+13 ;quit if printer is device
IF IOST'["C-"
QUIT
+14 ;quit if rebook
IF $GET(BSDNO)
QUIT
+15 ;not make appt
IF EVENT'=1
QUIT
+16 ;not sched appt
IF $PIECE($GET(^DPT(DFN,"S",DATE,0)),U,7)'=3
QUIT
+17 ;
+18 ; print routing slip for same day appt
+19 ;cmi/maw 5/2/2009 patch 1010
NEW BSDPAR
+20 ;cmi/maw 5/2/2009 patch 1010
SET BSDPAR=$ORDER(^BSDPAR("B",0))
+21 IF (DATE\1)=($PIECE(^DPT(DFN,"S",DATE,0),U,19)\1)
Begin DoDot:1
+22 ;cmi/maw 04/07/2008 orig line
IF '$GET(DIV)
IF $$READ^BDGF("Y","Want Chart Requested",$SELECT($PIECE($GET(^BSDPAR(BSDPAR,0)),U,25)
QUIT
+23 ;cmi/maw 04/07/2008 PATCH 1009 mod line for default
IF $GET(DIV)
IF $$READ^BDGF("Y","Want Chart Requested",$SELECT($PIECE($GET(^BSDPAR(DIV,0)),U,25)
QUIT
+24 DO WISD(DFN,DATE,"SD",$$GET1^DIQ(9009020.2,$$DIV^BSDU,.05))
End DoDot:1
QUIT
+25 ;
+26 ; ask to print appt letter for patient
+27 ;site parameter
IF $$GET1^DIQ(9009020.2,$$DIV^BSDU,.02)'="YES"
QUIT
+28 ;Q:$$READ^BDGF("Y","Want to Print Appointment Letter for Patient","NO","^D HELPB^BSDROUT")'=1
+29 ;IHS/ITSC/LJF 10/25/2004 PATCH 1001
IF $$READ^BDGF("Y","Want to Print Appointment Letter for Patient","YES","^D HELPB^BSDROUT")'=1
QUIT
+30 ;
+31 ; set up variables for call
+32 NEW X,L2,SDCONC,SDLT,DIV,SDV1,SDFORM,SDLET,SDLT1,SDBD,SDED,SDTIME
+33 NEW S1,VAUTD,VAUTN,L0
+34 ;saved for multibook rtn
NEW SDDAT
+35 SET L2="^SDL1"
SET SDCONC="B"
SET SDLT=1
SET L0="P"
+36 SET DIV=$$DIV^BSDU
SET SDV1=DIV
SET SDFORM=+$$GET1^DIQ(40.8,DIV,30.01,"I")
+37 SET VAUTD=0
SET VAUTD(DIV)=$$GET1^DIQ(40.8,DIV,.01)
+38 ;cmi/anch/maw 11/22/06 split below line to get letter format
+39 ;cmi/anch/maw 11/22/2006 adding code to select letter format if field .23 of IHS SCHEDULING PARAMETER file is set to yes item 1007.04 and 1007.05 patch 1007
+40 ;cmi/anch/maw 11/22/06 added item 1007.04 patch 1007
SET X=+$GET(^DPT(DFN,"S",DATE,0))
+41 ;cmi/anch/maw 11/22/06 added line for item 1007.04 patch 1007
SET SDLET=""
+42 ;cmi/anch/maw 11/22/06 added for item 1007.04 patch 1007
IF $$GET1^DIQ(9009020.2,DIV,.23,"I")
Begin DoDot:1
+43 ;cmi/anch/maw 11/22/06 added for item 1007.04 patch 1007
SET SDLET=+$$READ^BDGF("P^407.5:EMQZ","Select Letter",$$GET1^DIQ(44,X,2509))
End DoDot:1
+44 ;cmi/anch/maw 12/5/2006 added to display letter selected
IF $GET(SDLET)
DO MSG^BDGF($$GET1^DIQ(407.5,SDLET,.01)_" letter selected",2,1)
+45 ;
+46 ;S X=+$G(^DPT(DFN,"S",DATE,0)),SDLET=$$GET1^DIQ(44,X,2509,"I") ;cmi/anch/maw 11/22/06 orig line item 1007.04 patch 1007
+47 ;cmi/anch/maw 11/22/06 item 1007.04 patch 1007
IF SDLET=""
SET SDLET=$$GET1^DIQ(44,X,2509,"I")
+48 IF SDLET=""
SET SDLET=$ORDER(^VA(407.5,"B","APPOINTMENT SLIP",0))
+49 IF SDLET=""
DO MSG^BDGF("Sorry, no letter set up to print. See Application Coordinator.",2,1)
QUIT
+50 ;
+51 ;IHS/ITSC/WAR 8/19/2004 PATCH #1001 set date range starting with tomorrow
+52 ;S SDLT1=SDLET,SDBD=DT,SDED=$$FMADD^XLFDT(DT,365),SDTIME="*"
+53 SET SDLT1=SDLET
SET SDBD=$$FMADD^XLFDT(DT,1)
SET SDED=$$FMADD^XLFDT(DT,365)
SET SDTIME="*"
+54 SET VAUTN=0
SET VAUTN(DFN)=$$GET1^DIQ(2,DFN,.01)
SET S1="P"
+55 ;
+56 DO QUE^SDLTP
+57 QUIT
+58 ;
PWH(EVENT,DFN,DATE) ;EP; called by BSDAM PWH AT CHECKIN protocol;cmi/flag/maw 10/19/2009 PATCH 1011
+1 ;pcc v2.0 not loaded
IF $TEXT(EN2^APCHPWHG)=""
QUIT
+2 IF '$GET(DATE)
SET DATE=DT
+3 ; which is called by BSDAM APPOINTMENT EVENTS protocol
+4 ; Used at sites with so many no-shows that charts are not pulled until patients arrive
+5 ;
+6 ;quiet mode
IF $GET(SDMODE)=2
QUIT
+7 ; save variables not used that event driver needs back
+8 NEW SDDA,SDATA,SDAMEVT,SDMODE,SDC,VALMY,SDI,SDAT,BSDPWH
+9 ;quit if printer is device
IF IOST'["C-"
QUIT
+10 ;not checkin
IF $GET(EVENT)'="OR"
IF EVENT'=4
QUIT
+11 ;Q:$$GET1^DIQ(9009020.2,$$DIV^BSDU,.22)'="YES" ;parameter not turned on
+12 ;not sched appt
IF $GET(EVENT)'="OR"
IF $PIECE($GET(^DPT(DFN,"S",DATE,0)),U,7)'=3
QUIT
+13 ;quit if check in deleted
IF $GET(EVENT)'="OR"
IF '$$CI^BSDU2(DFN,SDCL,DATE,$$SCIEN^BSDU2(DFN,SDCL,DATE))
QUIT
+14 ;
+15 SET DIV=$$DIV^BSDU
+16 IF $$READ^BDGF("Y","Want Patient Wellness Handout","NO","^D HELPA^BSDROUT")'=1
QUIT
+17 SET BSDPWH=$$SELTYP
+18 IF '$GET(BSDPWH)
QUIT
+19 DO EN2^APCHPWHG(BSDPWH,DFN)
+20 IF $DATA(VALMBCK)
IF VALMBCK="R"
DO REFRESH^VALM
SET VALMBCK=$PIECE(VALMBCK,"R")_$PIECE(VALMBCK,"R",2)
+21 QUIT
+22 ;
SELTYP() ;
+1 KILL DIADD,DLAYGO
+2 NEW BSDPWHT
+3 DO ^XBFMK
+4 KILL DIC
SET DIC="^APCHPWHT("
SET DIC("A")="Select Patient Wellness Handout type: "
SET DIC(0)="AEQM"
+5 SET X=""
IF DUZ(2)
IF $DATA(^APCCCTRL(DUZ(2),0))#2
SET X=$PIECE(^(0),U,16)
+6 IF $DATA(^DISV(DUZ,"^APCHPWHT("))
SET Y=^("^APCHPWHT(")
IF $DATA(^APCHPWHT(Y,0))
SET X=$PIECE(^(0),U,1)
+7 IF X=""
SET X="ADULT REGULAR"
+8 SET DIC("B")=X
+9 DO ^DIC
KILL DIC
+10 IF Y=-1
QUIT 0
+11 SET BSDPWHT=+Y
+12 QUIT BSDPWHT
+13 ;
RSCI(EVENT,DFN,DATE) ;EP; called by BSDAM RS AT CHECKIN protocol;IHS/OIT/LJF 02/16/2006 PATCH 1005
+1 ; which is called by BSDAM APPOINTMENT EVENTS protocol
+2 ; Used at sites with so many no-shows that charts are not pulled until patients arrive
+3 ;
+4 ;quiet mode
IF $GET(SDMODE)=2
QUIT
+5 ; save variables not used that event driver needs back
+6 NEW SDDA,SDATA,SDAMEVT,SDMODE,SDC,VALMY,SDI,SDAT
+7 ;quit if printer is device
IF IOST'["C-"
QUIT
+8 ;not checkin
IF EVENT'=4
QUIT
+9 ;parameter not turned on
IF $$GET1^DIQ(9009020.2,$$DIV^BSDU,.22)'="YES"
QUIT
+10 ;not sched appt
IF $PIECE($GET(^DPT(DFN,"S",DATE,0)),U,7)'=3
QUIT
+11 ;quit if check in deleted
IF '$$CI^BSDU2(DFN,SDCL,DATE,$$SCIEN^BSDU2(DFN,SDCL,DATE))
QUIT
+12 ;
+13 ;Q:$$READ^BDGF("Y","Want Chart Requested","YES","^D HELPA^BSDROUT")'=1 ;cmi/maw 04/07/2008 orig line
+14 ;cmi/maw 7/17/2008 PATCH 1009 the following 2 lines are now part of patch 1009 due to DIV being undefined as various times
+15 SET DIV=$$DIV^BSDU
+16 ;cmi/maw 5/2/2009 patch 1010
NEW BSDPAR
+17 ;cmi/maw 5/2/2009 patch 1010
SET BSDPAR=$ORDER(^BSDPAR("B",0))
+18 ;cmi/maw 04/07/2008 PATCH 1009 mod line for default
IF $GET(DIV)
IF $$READ^BDGF("Y","Want Chart Requested",$SELECT($PIECE($GET(^BSDPAR(DIV,0)),U,25)
QUIT
+19 IF '$GET(DIV)
IF $$READ^BDGF("Y","Want Chart Requested",$SELECT($PIECE($GET(^BSDPAR(BSDPAR,0)),U,25)
QUIT
+20 ;cmi/maw 7/17/2008 PATCH 1009 end of mods
+21 DO WISD(DFN,DATE,"RS",$$GET1^DIQ(9009020.2,$$DIV^BSDU,.05))
+22 QUIT
+23 ;
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
+7 ;
HELPA ;EP; called as help for "Want Chart Requested?" question
+1 WRITE !,"Since this is a same day appointment, do you need the paper"
+2 WRITE !,"chart pulled? Answer YES to have the routing slip print in"
+3 WRITE !,"medical records."
+4 QUIT
+5 ;
HELPB ;EP; called as help for "Print Appt Letter?" question
+1 WRITE !,"Answer YES to print a reminder letter for this appointment."
QUIT
