BSDROUT1 ; IHS/ANMC/LJF,WAR - ROUTING SLIPS PRINT ;
;;5.3;PIMS;**1001,1003,1004,1007,1009**;DEC 01, 2006
;IHS/ITSC/LJF 04/22/2004 PATCH 1001 centered duplicate routings slips on paper
;IHS/ITSC/LJF 06/17/2005 PATCH 1003 if BSDHS set to 1, don't print other documents
;IHS/OIT/LJF 07/15/2005 PATCH 1004 increment count when reprinting add-ons; needed for form feed
;cmi/anch/maw 11/22/2006 PATCH 1007 modified line in APPT for item 1007.15
;cmi/anch/maw 05/09/2008 PATCH 1009 requirement 64 added check of device in OTHER to reopen the printer if closed after med profile, added CHKDV subroutine
;
PRINT(ORDER,SDATE) ;EP; called to print routing slips
; called by SDROUT0
; assumes the following variables are set: SDSTART,SDSTOP,SDX,SDREP,DIV
; loop by sort criteria and get patient
NEW SORT,TERM,DFN,BSDI,CNT,SDCNT,SECOND
S SORT=0
F S SORT=$O(^TMP("SDRS",$J,SORT)) Q:SORT="" D
. S TERM=0 F S TERM=$O(^TMP("SDRS",$J,SORT,TERM)) Q:TERM="" D
.. S DFN=0 F S DFN=$O(^TMP("SDRS",$J,SORT,TERM,DFN)) Q:'DFN D
... ;
... I $$FORMAT="DUPLICATE" S SECOND=0 ;print 2 per page
... D RS(SORT,TERM,DFN,1) ;print one rs for file room
... ;
... ; now print a copy for each appt if parameter set that way
... I $$MORERS S CNT=$$APPTCNT(SORT,TERM,DFN) F BSDI=1:1:CNT D RS(SORT,TERM,DFN,0)
... ;
... D OTHER(DFN) ;print other forms
K SDCNT ;remove this line to print # of rs printed on end of report
K BDGSDEV ;cmi/anch/maw 5/9/2008 PATCH 1009 rqmt 64 kill storage of device name after printing of all RS and other docs
K SDSTOP D END^SDROUT1
Q
;
RS(SORT,TERM,DFN,FIRST) ; -- print rs
; quit if not first appt that day when sorting by clinic
;
;If printing >1 RS and is second or more time through, sorting by clinic, quit if not first appt that day
I (FIRST=0)&(ORDER=2) Q:'$G(^TMP("SDRS",$J,DFN,SORT))
I (FIRST=0)&(ORDER=3) Q:'$G(^TMP("SDRS",$J,DFN,SORT))
;
;if printing only one RS and sorting by clinic, quit if this is not first appt
I ($$FIRST^BSDROUT0(DFN,+$O(^TMP("SDRS",$J,SORT,TERM,DFN,0)))=0),(ORDER=2),($$MORERS=0) Q
I ($$FIRST^BSDROUT0(DFN,+$O(^TMP("SDRS",$J,SORT,TERM,DFN,0)))=0),(ORDER=3),($$MORERS=0) Q
;
NEW DATE,CLN,BSDPG
D RSHED(DFN) ;rs heading
S DATE=0 D CURHED ;current appt heading
F S DATE=$O(^TMP("SDRS",$J,SORT,TERM,DFN,DATE)) Q:'DATE D
. S CLN=^TMP("SDRS",$J,SORT,TERM,DFN,DATE)
. ;
. ; make sure RS by clinic contains all appts for date
. I (ORDER=2)!(ORDER=3) D APPTC(DFN,TERM,DATE),PRTDT(DFN,DATE,CLN,$P(CLN,U,3)) S DATE=9999999 Q
. ;
. D APPT(DFN,DATE,CLN) ;display appt info
. D PRTDT(DFN,DATE,CLN,$P(CLN,U,3)) ;record date printed
I $$FORMAT="LONG" D FUTURE(DFN) ;find future appts
D PRINTED ;date printed
;
I $$FORMAT="DUPLICATE",'SECOND D
. S SECOND=1 ;mark as second one per page
. ;F Q:$Y>((IOSL-4)\2) W ! ;move to middle of piece of paper
. F Q:$Y>((IOSL)\2) W ! ;move to middle of piece of paper ;IHS/ITSC/LJF 4/22/2004 PATCH #1001
. W !,$$REPEAT^XLFSTR("-",IOM) ;dashed line between routing slips
. D RS(SORT,TERM,DFN,FIRST)
Q
;
APPTC(DFN,TERM,DATE) ; -- loop through all patient's appts for date
NEW APDT,CLN,ARRAY,SORT
S APDT=(DATE\1)-.0001
F S APDT=$O(^TMP("SDRS1",$J,DFN,APDT)) Q:'APDT D
. S SORT=$G(^TMP("SDRS1",$J,DFN,APDT))
. S CLN=$G(^TMP("SDRS",$J,SORT,TERM,DFN,APDT))
. D APPT(DFN,APDT,CLN)
Q
;
APPT(DFN,DATE,CLN) ; -- print individual appointments
I $Y>(IOSL-3) D RSHED(DFN),CURHED
NEW X,Y
I $P(CLN,U,3)'="CR" S X=DATE D TM^SDROUT0 W !,$J(X,8) ;appt time
;I $P(CLN,U,3)="CR" W !,$J("****",7) ;no time for cr ;cmi/anch/maw 11/11/2006 orig line item 1007.16 patch 1007
;cmi/anch/maw 8/15/2007 added time at ft defiance request
I $P(CLN,U,3)="CR" D
. ;S X=DATE D TM^SDROUT0
. W !,"CR-"_$E(DATE,4,5)_"/"_$E(DATE,6,7)_"-"_($E(DATE,1,3)+1700) ;cmi/anch/maw 11/11/2006 new line item 1007.15 patch 1007
;
; mark walkins, same day appts and chart requests
;W ?9,$P(CLN,U,3) ;cmi/anch/maw orig line 3/23/2007 PATCH 1007 item 1007.15
I $P(CLN,U,3)'="CR" W ?9,$P(CLN,U,3) ;cmi/anch/maw 3/23/2007 PATCH 1007 item 1007.15
;
S X=CLN I $P(CLN,U,2)]"" S X=$P(CLN,U,2)_" Stop" ;xray or lab stop
E S X=$$GET1^DIQ(44,+CLN,.01) ;clinic name
W ?13,$E(X,1,25) ;print it
I $P(CLN,U,2)="" D
. I $$FORMAT="SHORT" W !?11 ;adjust print head
. E W ?40
. W $$GET1^DIQ(44,+CLN,10) ;physical location
. W:$$FORMAT'="SHORT" ?68,$$GET1^DIQ(44,+CLN,99) ;clinic telephone
;
S X=$$OI^BSDU2(DFN,+CLN,DATE) I X]"" W !?13,X ;other info
;
;chart request
S X=0 F S X=$O(^SC(+CLN,"C",DATE\1,1,X)) Q:'X D
. Q:+$G(^SC(+CLN,"C",DATE\1,1,X,0))'=DFN
. S Y=$G(^SC(+CLN,"C",DATE\1,1,X,9999999))
. ;
. NEW COL S COL=$S($$FORMAT="SHORT":3,1:13)
. W !?COL,$P(Y,U,3) ;deliver to info
. W !?COL,"Requested at "_$$FMTE^XLFDT($E(+Y,1,12))_" by "_$$GET1^DIQ(200,+$P(Y,U,2),.01)_" x"_$$GET1^DIQ(200,+$P(Y,U,2),.132)
Q
;
PRTDT(P,D,C,MODE) ; -- called to set date routing slip printed
NEW DIE,DA,DR
I MODE="CR" D PRTCR(P,D,C) Q ;chart request printed
Q:'$D(^DPT(P,"S",D,0))
Q:$P(^DPT(P,"S",D,0),U,2)["C"
S DIE="^DPT("_P_",""S"",",DA=D,DA(1)=P
S DR="8///Y" S:$P(^DPT(P,"S",D,0),U,13)="" DR=DR_";8.5///^S X=""NOW"""
D ^DIE
Q
;
PRTCR(PAT,DATE,CLN) ; -- set date/time chart request printed
NEW X,DIE,DA,DR,IEN
S IEN=0 F S IEN=$O(^SC(+CLN,"C",(DATE\1),1,IEN)) Q:'IEN D
. Q:+$G(^SC(+CLN,"C",(DATE\1),1,IEN,0))'=PAT ;wrong patient
. S DIE="^SC("_(+CLN)_",""C"","_(DATE\1)_",1,"
. S DA=IEN,DA(1)=DATE\1,DA(2)=+CLN,DR="9999999.04///^S X=""NOW"""
. D ^DIE
Q
;
FUTURE(DFN) ; -- print future appts
NEW BSDX,BSDY,BSDI,X,Y
; print subheading (and page heading if needed)
I $O(^DPT(DFN,"S",SDATE_".9"))>0 D
. I $Y>(IOSL-5) D RSHED(DFN)
. D FUTHED
;
; loop through future appts and print
F BSDX=SDATE_".9":0 S BSDX=$O(^DPT(DFN,"S",BSDX)) Q:BSDX="" D
. I $Y>(IOSL-5) D RSHED(DFN),FUTHED
. S BSDY=$G(^DPT(DFN,"S",BSDX,0)) ;appt data
. Q:$P(BSDY,U,2)["C" ;skip cancelled appts
. ;
. ; display extra stops if scheduled
. F BSDI=3,4,5 I $P(BSDY,U,BSDI)]"" D
.. I $Y>(IOSL-5) D RSHED(DFN),FUTHED
.. S (X,Y)=$P(BSDY,U,BSDI)
.. D TM^SDROUT0,DTS^SDUTL W !,Y,?13,$J(X,8) ;date and time
.. W ?22,$S(BSDI=3:"LAB",BSDI=4:"XRAY",1:"EKG")," Stop"
. ;
. ; display main appt
. S (X,Y)=BSDX D TM^SDROUT0,DTS^SDUTL W !,Y,?13,$J(X,8) ;date/time
. W ?21,$$GET1^DIQ(44,+BSDY,.01) ;clinic
. W ?55,$$GET1^DIQ(44,+BSDY,10) ;location
Q
;
PRINTED ; add date printed, requested by and increment count of rs printed
I SDREP,SDX'["ALL" D Q
. W !!,"DATE ORIGINALLY PRINTED : ",$$FMTE^XLFDT(SDSTART)
. W !,"DATE REPRINTED: ",$$FMTE^XLFDT(DT)
. S SDCNT=$G(SDCNT)+1 ;increment # of routing slips printed;IHS/OIT/LJF 7/15/2005 PATCH 1004
W !!,"DATE PRINTED: ",$$FMTE^XLFDT($$NOW^XLFDT)
W !,"Requested by: ",$$GET1^DIQ(200,$G(DUZ),.01)
S SDCNT=$G(SDCNT)+1 ;increment # of routing slips printed
Q
;
CURHED ; -- print current appt heading
W !!?9,"**CURRENT APPOINTMENTS**"
W !?3,"TIME",?13,"CLINIC" Q:$$FORMAT="SHORT" ;short and narrow
W ?40,"LOCATION",?68,"PHONE"
Q
;
FUTHED ; -- print future appt heading
W !!,?9,"**FUTURE APPOINTMENTS**",!,$$REPEAT^XLFSTR("=",79)
W !," DATE",?13,"TIME",?21,"CLINIC",?55,"LOCATION",!
Q
;
RSHED(DFN) ; -- routing slip heading
I $$FORMAT="SHORT" D HED^BSDROUT2 Q ;different heading for short form
;I $G(SDCNT)>0 W @IOF
I $$FORMAT="DUPLICATE",SECOND W ! ;IHS/ITSC/LJF 4/22/2004 PATCH #1001
E I $G(SDCNT)>0 W @IOF ;IHS/ITSC/LJF 4/22/2004 PATCH #1001
W !,"FACILITY: ",$$GET1^DIQ(40.8,$$DIV,.01)
W ?40,"**",$E($$CONF^BSDU,1,25),"**"
S BSDPG=$G(BSDPG)+1 W !,"PAGE ",BSDPG,?10,"OUTPATIENT ROUTING SLIP"
;
W !!,$$GET1^DIQ(2,DFN,.01),?30,"HRCN: ",$$HRCN^BDGF2(DFN,+$G(DUZ(2)))
;
W !?5,"DOB: ",$$GET1^DIQ(2,DFN,.03)
W ?44,"APPT DT: ",$$FMTE^XLFDT(SDATE,5)
;
I $$DEAD^BDGF2(DFN) W !?10,"**** PATIENT DIED ON ",$$DOD^BDGF2(DFN)," ****"
;
Q:BSDPG>1 ;rest only needs to be on first page
;
I $$FORMAT="LONG" D
. NEW VAPA,I D ADD^VADPT F I=1:1:3 W:VAPA(I)]"" !,VAPA(I) ;street
. W !,VAPA(4),", ",$P(VAPA(5),U,2)," ",VAPA(6) ;city,state,zip
;
D STATUS^BSDROUT2(DFN)
Q
;
OTHER(DFN) ; -- calls other forms
Q:$$GET1^DIQ(9009020.2,$$DIV,.04)'="YES" ;print forms with rs?
Q:$G(BSDNHS) ;IHS/ITSC/LJF 6/17/2005 PATCH 1003 if set to 1, don't print other documents
;
; only print extra forms with first routing slip for day
I (ORDER=2)!(ORDER=3) Q:'$G(^TMP("SDRS",$J,DFN,SORT))
;
D HS(DFN,SDATE) ; health summary
D MP(DFN,SDATE) ; med profile
S IO=$$CHKDV($G(BDGSDEV)) ;cmi/anch/maw 5/9/2008 add check to see if device is still open
D APRO(DFN,SDATE) ; action profile
D AIU(DFN,SDATE) ; address/insurance update
Q
;
HS(DFN,SDATE) ; -- health summary
NEW Y
S Y=$$ONE(DFN,SDATE,.04) I 'Y Q
D HS^BSDFORM(DFN,$P(Y,U,2)) Q
;
MP(DFN,SDATE) ; -- med profile
NEW BSDRX
S BSDRX=$$ONE(DFN,SDATE,.06) I 'BSDRX Q
I $P(BSDRX,U,2)'=2 D MP^BSDFORM(DFN)
Q
;
APRO(DFN,SDATE) ; -- action profiles (one for each appt where needed)
NEW BSDX,CLN,Y
S BSDX=SDATE\1
F S BSDX=$O(^DPT(DFN,"S",BSDX)) Q:BSDX="" Q:BSDX>(SDATE+.2400) D
. S CLN=$P($G(^DPT(DFN,"S",BSDX,0)),U) Q:CLN="" Q:$P(^(0),U,2)["C"
. S Y=$$GET1^DIQ(9009017.2,CLN,.06,"I") Q:Y=0 Q:Y=1
. D APRO^BSDFORM(CLN,DFN,SDATE)
Q
;
AIU(DFN,SDATE) ; -- insurance update
Q:'$$ONE(DFN,SDATE,.07) D AIU^BSDFORM(DFN,DIV) Q
;
;
ONE(DFN,SDATE,FORM) ; -- returns 1 if at least one clinic for pat wants form
NEW X,Y,Z,C
S Y=0,X=SDATE\1
F S X=$O(^DPT(DFN,"S",X)) Q:X="" Q:X>(SDATE+.2400) Q:(+Y=1) D
. S C=$P($G(^DPT(DFN,"S",X,0)),U) Q:C="" Q:$P(^(0),U,2)["C"
. S Z=$$GET1^DIQ(9009017.2,C,FORM,"I") Q:+Z=0 ;form not turned on
. I FORM=.06 S Y=1_U_Z Q
. I FORM=.04 S Y=1_U_$$GET1^DIQ(9009017.2,C,.05,"I") Q ;hs type ien
. S Y=1
;
; if none found, check chart requests
I Y=0 D
. S C=0 F S C=$O(^SC("AIHSCR",DFN,C)) Q:'C Q:Y=1 D
.. I $O(^SC("AIHSCR",DFN,C,(SDATE\1),0)) D
... S Z=$$GET1^DIQ(9009017.2,C,FORM,"I") Q:+Z=0 ;form not turned on
... I FORM=.06 S Y=1_U_Z Q
... I FORM=.04 S Y=1_U_$$GET1^DIQ(9009017.2,C,.05,"I") Q ;hs type ien
... S Y=1
Q Y
;
;
MORERS() ; -- returns 1 if want >1 rs
Q $$GET1^DIQ(9009020.2,$$DIV,.03,"I")
;
DIV() ; -- returns division ien
Q $$DIV^BSDU
;
FORMAT() ; -- returns format used - short, long or duplicate
Q $$GET1^DIQ(9009020.2,$$DIV,.16)
;
APPTCNT(A,B,C) ; -- count how many appts patient has for date
NEW CNT,X S (CNT,X)=0
F S X=$O(^TMP("SDRS",$J,A,B,C,X)) Q:'X D
. Q:$P(^TMP("SDRS",$J,A,B,C,X),U,2)]"" ;don't count test stops
. S CNT=CNT+1
Q CNT
;
CHKDV(SDEV) ;-- lets check to see if the original device got closed and if so reopen it
I SDEV="" Q IO
I IO=SDEV Q IO
S IOP=SDEV D ^%ZIS
Q IO
;
BSDROUT1 ; IHS/ANMC/LJF,WAR - ROUTING SLIPS PRINT ;
+1 ;;5.3;PIMS;**1001,1003,1004,1007,1009**;DEC 01, 2006
+2 ;IHS/ITSC/LJF 04/22/2004 PATCH 1001 centered duplicate routings slips on paper
+3 ;IHS/ITSC/LJF 06/17/2005 PATCH 1003 if BSDHS set to 1, don't print other documents
+4 ;IHS/OIT/LJF 07/15/2005 PATCH 1004 increment count when reprinting add-ons; needed for form feed
+5 ;cmi/anch/maw 11/22/2006 PATCH 1007 modified line in APPT for item 1007.15
+6 ;cmi/anch/maw 05/09/2008 PATCH 1009 requirement 64 added check of device in OTHER to reopen the printer if closed after med profile, added CHKDV subroutine
+7 ;
PRINT(ORDER,SDATE) ;EP; called to print routing slips
+1 ; called by SDROUT0
+2 ; assumes the following variables are set: SDSTART,SDSTOP,SDX,SDREP,DIV
+3 ; loop by sort criteria and get patient
+4 NEW SORT,TERM,DFN,BSDI,CNT,SDCNT,SECOND
+5 SET SORT=0
+6 FOR
SET SORT=$ORDER(^TMP("SDRS",$JOB,SORT))
IF SORT=""
QUIT
Begin DoDot:1
+7 SET TERM=0
FOR
SET TERM=$ORDER(^TMP("SDRS",$JOB,SORT,TERM))
IF TERM=""
QUIT
Begin DoDot:2
+8 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("SDRS",$JOB,SORT,TERM,DFN))
IF 'DFN
QUIT
Begin DoDot:3
+9 ;
+10 ;print 2 per page
IF $$FORMAT="DUPLICATE"
SET SECOND=0
+11 ;print one rs for file room
DO RS(SORT,TERM,DFN,1)
+12 ;
+13 ; now print a copy for each appt if parameter set that way
+14 IF $$MORERS
SET CNT=$$APPTCNT(SORT,TERM,DFN)
FOR BSDI=1:1:CNT
DO RS(SORT,TERM,DFN,0)
+15 ;
+16 ;print other forms
DO OTHER(DFN)
End DoDot:3
End DoDot:2
End DoDot:1
+17 ;remove this line to print # of rs printed on end of report
KILL SDCNT
+18 ;cmi/anch/maw 5/9/2008 PATCH 1009 rqmt 64 kill storage of device name after printing of all RS and other docs
KILL BDGSDEV
+19 KILL SDSTOP
DO END^SDROUT1
+20 QUIT
+21 ;
RS(SORT,TERM,DFN,FIRST) ; -- print rs
+1 ; quit if not first appt that day when sorting by clinic
+2 ;
+3 ;If printing >1 RS and is second or more time through, sorting by clinic, quit if not first appt that day
+4 IF (FIRST=0)&(ORDER=2)
IF '$GET(^TMP("SDRS",$JOB,DFN,SORT))
QUIT
+5 IF (FIRST=0)&(ORDER=3)
IF '$GET(^TMP("SDRS",$JOB,DFN,SORT))
QUIT
+6 ;
+7 ;if printing only one RS and sorting by clinic, quit if this is not first appt
+8 IF ($$FIRST^BSDROUT0(DFN,+$ORDER(^TMP("SDRS",$JOB,SORT,TERM,DFN,0)))=0)
IF (ORDER=2)
IF ($$MORERS=0)
QUIT
+9 IF ($$FIRST^BSDROUT0(DFN,+$ORDER(^TMP("SDRS",$JOB,SORT,TERM,DFN,0)))=0)
IF (ORDER=3)
IF ($$MORERS=0)
QUIT
+10 ;
+11 NEW DATE,CLN,BSDPG
+12 ;rs heading
DO RSHED(DFN)
+13 ;current appt heading
SET DATE=0
DO CURHED
+14 FOR
SET DATE=$ORDER(^TMP("SDRS",$JOB,SORT,TERM,DFN,DATE))
IF 'DATE
QUIT
Begin DoDot:1
+15 SET CLN=^TMP("SDRS",$JOB,SORT,TERM,DFN,DATE)
+16 ;
+17 ; make sure RS by clinic contains all appts for date
+18 IF (ORDER=2)!(ORDER=3)
DO APPTC(DFN,TERM,DATE)
DO PRTDT(DFN,DATE,CLN,$PIECE(CLN,U,3))
SET DATE=9999999
QUIT
+19 ;
+20 ;display appt info
DO APPT(DFN,DATE,CLN)
+21 ;record date printed
DO PRTDT(DFN,DATE,CLN,$PIECE(CLN,U,3))
End DoDot:1
+22 ;find future appts
IF $$FORMAT="LONG"
DO FUTURE(DFN)
+23 ;date printed
DO PRINTED
+24 ;
+25 IF $$FORMAT="DUPLICATE"
IF 'SECOND
Begin DoDot:1
+26 ;mark as second one per page
SET SECOND=1
+27 ;F Q:$Y>((IOSL-4)\2) W ! ;move to middle of piece of paper
+28 ;move to middle of piece of paper ;IHS/ITSC/LJF 4/22/2004 PATCH #1001
FOR
IF $Y>((IOSL)\2)
QUIT
WRITE !
+29 ;dashed line between routing slips
WRITE !,$$REPEAT^XLFSTR("-",IOM)
+30 DO RS(SORT,TERM,DFN,FIRST)
End DoDot:1
+31 QUIT
+32 ;
APPTC(DFN,TERM,DATE) ; -- loop through all patient's appts for date
+1 NEW APDT,CLN,ARRAY,SORT
+2 SET APDT=(DATE\1)-.0001
+3 FOR
SET APDT=$ORDER(^TMP("SDRS1",$JOB,DFN,APDT))
IF 'APDT
QUIT
Begin DoDot:1
+4 SET SORT=$GET(^TMP("SDRS1",$JOB,DFN,APDT))
+5 SET CLN=$GET(^TMP("SDRS",$JOB,SORT,TERM,DFN,APDT))
+6 DO APPT(DFN,APDT,CLN)
End DoDot:1
+7 QUIT
+8 ;
APPT(DFN,DATE,CLN) ; -- print individual appointments
+1 IF $Y>(IOSL-3)
DO RSHED(DFN)
DO CURHED
+2 NEW X,Y
+3 ;appt time
IF $PIECE(CLN,U,3)'="CR"
SET X=DATE
DO TM^SDROUT0
WRITE !,$JUSTIFY(X,8)
+4 ;I $P(CLN,U,3)="CR" W !,$J("****",7) ;no time for cr ;cmi/anch/maw 11/11/2006 orig line item 1007.16 patch 1007
+5 ;cmi/anch/maw 8/15/2007 added time at ft defiance request
+6 IF $PIECE(CLN,U,3)="CR"
Begin DoDot:1
+7 ;S X=DATE D TM^SDROUT0
+8 ;cmi/anch/maw 11/11/2006 new line item 1007.15 patch 1007
WRITE !,"CR-"_$EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"-"_($EXTRACT(DATE,1,3)+1700)
End DoDot:1
+9 ;
+10 ; mark walkins, same day appts and chart requests
+11 ;W ?9,$P(CLN,U,3) ;cmi/anch/maw orig line 3/23/2007 PATCH 1007 item 1007.15
+12 ;cmi/anch/maw 3/23/2007 PATCH 1007 item 1007.15
IF $PIECE(CLN,U,3)'="CR"
WRITE ?9,$PIECE(CLN,U,3)
+13 ;
+14 ;xray or lab stop
SET X=CLN
IF $PIECE(CLN,U,2)]""
SET X=$PIECE(CLN,U,2)_" Stop"
+15 ;clinic name
IF '$TEST
SET X=$$GET1^DIQ(44,+CLN,.01)
+16 ;print it
WRITE ?13,$EXTRACT(X,1,25)
+17 IF $PIECE(CLN,U,2)=""
Begin DoDot:1
+18 ;adjust print head
IF $$FORMAT="SHORT"
WRITE !?11
+19 IF '$TEST
WRITE ?40
+20 ;physical location
WRITE $$GET1^DIQ(44,+CLN,10)
+21 ;clinic telephone
IF $$FORMAT'="SHORT"
WRITE ?68,$$GET1^DIQ(44,+CLN,99)
End DoDot:1
+22 ;
+23 ;other info
SET X=$$OI^BSDU2(DFN,+CLN,DATE)
IF X]""
WRITE !?13,X
+24 ;
+25 ;chart request
+26 SET X=0
FOR
SET X=$ORDER(^SC(+CLN,"C",DATE\1,1,X))
IF 'X
QUIT
Begin DoDot:1
+27 IF +$GET(^SC(+CLN,"C",DATE\1,1,X,0))'=DFN
QUIT
+28 SET Y=$GET(^SC(+CLN,"C",DATE\1,1,X,9999999))
+29 ;
+30 NEW COL
SET COL=$SELECT($$FORMAT="SHORT":3,1:13)
+31 ;deliver to info
WRITE !?COL,$PIECE(Y,U,3)
+32 WRITE !?COL,"Requested at "_$$FMTE^XLFDT($EXTRACT(+Y,1,12))_" by "_$$GET1^DIQ(200,+$PIECE(Y,U,2),.01)_" x"_$$GET1^DIQ(200,+$PIECE(Y,U,2),.132)
End DoDot:1
+33 QUIT
+34 ;
PRTDT(P,D,C,MODE) ; -- called to set date routing slip printed
+1 NEW DIE,DA,DR
+2 ;chart request printed
IF MODE="CR"
DO PRTCR(P,D,C)
QUIT
+3 IF '$DATA(^DPT(P,"S",D,0))
QUIT
+4 IF $PIECE(^DPT(P,"S",D,0),U,2)["C"
QUIT
+5 SET DIE="^DPT("_P_",""S"","
SET DA=D
SET DA(1)=P
+6 SET DR="8///Y"
IF $PIECE(^DPT(P,"S",D,0),U,13)=""
SET DR=DR_";8.5///^S X=""NOW"""
+7 DO ^DIE
+8 QUIT
+9 ;
PRTCR(PAT,DATE,CLN) ; -- set date/time chart request printed
+1 NEW X,DIE,DA,DR,IEN
+2 SET IEN=0
FOR
SET IEN=$ORDER(^SC(+CLN,"C",(DATE\1),1,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+3 ;wrong patient
IF +$GET(^SC(+CLN,"C",(DATE\1),1,IEN,0))'=PAT
QUIT
+4 SET DIE="^SC("_(+CLN)_",""C"","_(DATE\1)_",1,"
+5 SET DA=IEN
SET DA(1)=DATE\1
SET DA(2)=+CLN
SET DR="9999999.04///^S X=""NOW"""
+6 DO ^DIE
End DoDot:1
+7 QUIT
+8 ;
FUTURE(DFN) ; -- print future appts
+1 NEW BSDX,BSDY,BSDI,X,Y
+2 ; print subheading (and page heading if needed)
+3 IF $ORDER(^DPT(DFN,"S",SDATE_".9"))>0
Begin DoDot:1
+4 IF $Y>(IOSL-5)
DO RSHED(DFN)
+5 DO FUTHED
End DoDot:1
+6 ;
+7 ; loop through future appts and print
+8 FOR BSDX=SDATE_".9":0
SET BSDX=$ORDER(^DPT(DFN,"S",BSDX))
IF BSDX=""
QUIT
Begin DoDot:1
+9 IF $Y>(IOSL-5)
DO RSHED(DFN)
DO FUTHED
+10 ;appt data
SET BSDY=$GET(^DPT(DFN,"S",BSDX,0))
+11 ;skip cancelled appts
IF $PIECE(BSDY,U,2)["C"
QUIT
+12 ;
+13 ; display extra stops if scheduled
+14 FOR BSDI=3,4,5
IF $PIECE(BSDY,U,BSDI)]""
Begin DoDot:2
+15 IF $Y>(IOSL-5)
DO RSHED(DFN)
DO FUTHED
+16 SET (X,Y)=$PIECE(BSDY,U,BSDI)
+17 ;date and time
DO TM^SDROUT0
DO DTS^SDUTL
WRITE !,Y,?13,$JUSTIFY(X,8)
+18 WRITE ?22,$SELECT(BSDI=3:"LAB",BSDI=4:"XRAY",1:"EKG")," Stop"
End DoDot:2
+19 ;
+20 ; display main appt
+21 ;date/time
SET (X,Y)=BSDX
DO TM^SDROUT0
DO DTS^SDUTL
WRITE !,Y,?13,$JUSTIFY(X,8)
+22 ;clinic
WRITE ?21,$$GET1^DIQ(44,+BSDY,.01)
+23 ;location
WRITE ?55,$$GET1^DIQ(44,+BSDY,10)
End DoDot:1
+24 QUIT
+25 ;
PRINTED ; add date printed, requested by and increment count of rs printed
+1 IF SDREP
IF SDX'["ALL"
Begin DoDot:1
+2 WRITE !!,"DATE ORIGINALLY PRINTED : ",$$FMTE^XLFDT(SDSTART)
+3 WRITE !,"DATE REPRINTED: ",$$FMTE^XLFDT(DT)
+4 ;increment # of routing slips printed;IHS/OIT/LJF 7/15/2005 PATCH 1004
SET SDCNT=$GET(SDCNT)+1
End DoDot:1
QUIT
+5 WRITE !!,"DATE PRINTED: ",$$FMTE^XLFDT($$NOW^XLFDT)
+6 WRITE !,"Requested by: ",$$GET1^DIQ(200,$GET(DUZ),.01)
+7 ;increment # of routing slips printed
SET SDCNT=$GET(SDCNT)+1
+8 QUIT
+9 ;
CURHED ; -- print current appt heading
+1 WRITE !!?9,"**CURRENT APPOINTMENTS**"
+2 ;short and narrow
WRITE !?3,"TIME",?13,"CLINIC"
IF $$FORMAT="SHORT"
QUIT
+3 WRITE ?40,"LOCATION",?68,"PHONE"
+4 QUIT
+5 ;
FUTHED ; -- print future appt heading
+1 WRITE !!,?9,"**FUTURE APPOINTMENTS**",!,$$REPEAT^XLFSTR("=",79)
+2 WRITE !," DATE",?13,"TIME",?21,"CLINIC",?55,"LOCATION",!
+3 QUIT
+4 ;
RSHED(DFN) ; -- routing slip heading
+1 ;different heading for short form
IF $$FORMAT="SHORT"
DO HED^BSDROUT2
QUIT
+2 ;I $G(SDCNT)>0 W @IOF
+3 ;IHS/ITSC/LJF 4/22/2004 PATCH #1001
IF $$FORMAT="DUPLICATE"
IF SECOND
WRITE !
+4 ;IHS/ITSC/LJF 4/22/2004 PATCH #1001
IF '$TEST
IF $GET(SDCNT)>0
WRITE @IOF
+5 WRITE !,"FACILITY: ",$$GET1^DIQ(40.8,$$DIV,.01)
+6 WRITE ?40,"**",$EXTRACT($$CONF^BSDU,1,25),"**"
+7 SET BSDPG=$GET(BSDPG)+1
WRITE !,"PAGE ",BSDPG,?10,"OUTPATIENT ROUTING SLIP"
+8 ;
+9 WRITE !!,$$GET1^DIQ(2,DFN,.01),?30,"HRCN: ",$$HRCN^BDGF2(DFN,+$GET(DUZ(2)))
+10 ;
+11 WRITE !?5,"DOB: ",$$GET1^DIQ(2,DFN,.03)
+12 WRITE ?44,"APPT DT: ",$$FMTE^XLFDT(SDATE,5)
+13 ;
+14 IF $$DEAD^BDGF2(DFN)
WRITE !?10,"**** PATIENT DIED ON ",$$DOD^BDGF2(DFN)," ****"
+15 ;
+16 ;rest only needs to be on first page
IF BSDPG>1
QUIT
+17 ;
+18 IF $$FORMAT="LONG"
Begin DoDot:1
+19 ;street
NEW VAPA,I
DO ADD^VADPT
FOR I=1:1:3
IF VAPA(I)]""
WRITE !,VAPA(I)
+20 ;city,state,zip
WRITE !,VAPA(4),", ",$PIECE(VAPA(5),U,2)," ",VAPA(6)
End DoDot:1
+21 ;
+22 DO STATUS^BSDROUT2(DFN)
+23 QUIT
+24 ;
OTHER(DFN) ; -- calls other forms
+1 ;print forms with rs?
IF $$GET1^DIQ(9009020.2,$$DIV,.04)'="YES"
QUIT
+2 ;IHS/ITSC/LJF 6/17/2005 PATCH 1003 if set to 1, don't print other documents
IF $GET(BSDNHS)
QUIT
+3 ;
+4 ; only print extra forms with first routing slip for day
+5 IF (ORDER=2)!(ORDER=3)
IF '$GET(^TMP("SDRS",$JOB,DFN,SORT))
QUIT
+6 ;
+7 ; health summary
DO HS(DFN,SDATE)
+8 ; med profile
DO MP(DFN,SDATE)
+9 ;cmi/anch/maw 5/9/2008 add check to see if device is still open
SET IO=$$CHKDV($GET(BDGSDEV))
+10 ; action profile
DO APRO(DFN,SDATE)
+11 ; address/insurance update
DO AIU(DFN,SDATE)
+12 QUIT
+13 ;
HS(DFN,SDATE) ; -- health summary
+1 NEW Y
+2 SET Y=$$ONE(DFN,SDATE,.04)
IF 'Y
QUIT
+3 DO HS^BSDFORM(DFN,$PIECE(Y,U,2))
QUIT
+4 ;
MP(DFN,SDATE) ; -- med profile
+1 NEW BSDRX
+2 SET BSDRX=$$ONE(DFN,SDATE,.06)
IF 'BSDRX
QUIT
+3 IF $PIECE(BSDRX,U,2)'=2
DO MP^BSDFORM(DFN)
+4 QUIT
+5 ;
APRO(DFN,SDATE) ; -- action profiles (one for each appt where needed)
+1 NEW BSDX,CLN,Y
+2 SET BSDX=SDATE\1
+3 FOR
SET BSDX=$ORDER(^DPT(DFN,"S",BSDX))
IF BSDX=""
QUIT
IF BSDX>(SDATE+.2400)
QUIT
Begin DoDot:1
+4 SET CLN=$PIECE($GET(^DPT(DFN,"S",BSDX,0)),U)
IF CLN=""
QUIT
IF $PIECE(^(0),U,2)["C"
QUIT
+5 SET Y=$$GET1^DIQ(9009017.2,CLN,.06,"I")
IF Y=0
QUIT
IF Y=1
QUIT
+6 DO APRO^BSDFORM(CLN,DFN,SDATE)
End DoDot:1
+7 QUIT
+8 ;
AIU(DFN,SDATE) ; -- insurance update
+1 IF '$$ONE(DFN,SDATE,.07)
QUIT
DO AIU^BSDFORM(DFN,DIV)
QUIT
+2 ;
+3 ;
ONE(DFN,SDATE,FORM) ; -- returns 1 if at least one clinic for pat wants form
+1 NEW X,Y,Z,C
+2 SET Y=0
SET X=SDATE\1
+3 FOR
SET X=$ORDER(^DPT(DFN,"S",X))
IF X=""
QUIT
IF X>(SDATE+.2400)
QUIT
IF (+Y=1)
QUIT
Begin DoDot:1
+4 SET C=$PIECE($GET(^DPT(DFN,"S",X,0)),U)
IF C=""
QUIT
IF $PIECE(^(0),U,2)["C"
QUIT
+5 ;form not turned on
SET Z=$$GET1^DIQ(9009017.2,C,FORM,"I")
IF +Z=0
QUIT
+6 IF FORM=.06
SET Y=1_U_Z
QUIT
+7 ;hs type ien
IF FORM=.04
SET Y=1_U_$$GET1^DIQ(9009017.2,C,.05,"I")
QUIT
+8 SET Y=1
End DoDot:1
+9 ;
+10 ; if none found, check chart requests
+11 IF Y=0
Begin DoDot:1
+12 SET C=0
FOR
SET C=$ORDER(^SC("AIHSCR",DFN,C))
IF 'C
QUIT
IF Y=1
QUIT
Begin DoDot:2
+13 IF $ORDER(^SC("AIHSCR",DFN,C,(SDATE\1),0))
Begin DoDot:3
+14 ;form not turned on
SET Z=$$GET1^DIQ(9009017.2,C,FORM,"I")
IF +Z=0
QUIT
+15 IF FORM=.06
SET Y=1_U_Z
QUIT
+16 ;hs type ien
IF FORM=.04
SET Y=1_U_$$GET1^DIQ(9009017.2,C,.05,"I")
QUIT
+17 SET Y=1
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT Y
+19 ;
+20 ;
MORERS() ; -- returns 1 if want >1 rs
+1 QUIT $$GET1^DIQ(9009020.2,$$DIV,.03,"I")
+2 ;
DIV() ; -- returns division ien
+1 QUIT $$DIV^BSDU
+2 ;
FORMAT() ; -- returns format used - short, long or duplicate
+1 QUIT $$GET1^DIQ(9009020.2,$$DIV,.16)
+2 ;
APPTCNT(A,B,C) ; -- count how many appts patient has for date
+1 NEW CNT,X
SET (CNT,X)=0
+2 FOR
SET X=$ORDER(^TMP("SDRS",$JOB,A,B,C,X))
IF 'X
QUIT
Begin DoDot:1
+3 ;don't count test stops
IF $PIECE(^TMP("SDRS",$JOB,A,B,C,X),U,2)]""
QUIT
+4 SET CNT=CNT+1
End DoDot:1
+5 QUIT CNT
+6 ;
CHKDV(SDEV) ;-- lets check to see if the original device got closed and if so reopen it
+1 IF SDEV=""
QUIT IO
+2 IF IO=SDEV
QUIT IO
+3 SET IOP=SDEV
DO ^%ZIS
+4 QUIT IO
+5 ;
