SDECRT1 ;ALB/SAT - VISTA SCHEDULING RPCS ;JAN 15, 2016
;;5.3;Scheduling;**627**;Aug 13, 1993;Build 249
;
Q
;
PRINT(ORDER,SDATE,SDX,SDSTART,SDSTOP,SDREP) ;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^SDECRT0(DFN,+$O(^TMP("SDRS",$J,SORT,TERM,DFN,0)))=0),(ORDER=2),($$MORERS=0) Q
I ($$FIRST^SDECRT0(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)\2) W ! ;move to middle of piece of paper
. 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" D
. W !,"CR-"_$E(DATE,4,5)_"/"_$E(DATE,6,7)_"-"_($E(DATE,1,3)+1700)
;
; mark walkins, same day appts and chart requests
I $P(CLN,U,3)'="CR" W ?9,$P(CLN,U,3)
;
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
;
;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
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="DUPLICATE",SECOND W !
E I $G(SDCNT)>0 W @IOF
W !,"FACILITY: ",$$GET1^DIQ(40.8,$$DIV,.01)
W ?40,"**",$E($$CONF^SDECU,1,25),"**"
S BSDPG=$G(BSDPG)+1 W !,"PAGE ",BSDPG,?10,"OUTPATIENT ROUTING SLIP"
;
W !!,$$GET1^DIQ(2,DFN,.01),?30,"HRCN: ",$$HRCN^SDECF2(DFN,+$G(DUZ(2)))
;
W !?5,"DOB: ",$$GET1^DIQ(2,DFN,.03)
W ?44,"APPT DT: ",$$FMTE^XLFDT(SDATE,5)
;
I $$DEAD^SDECF2(DFN) W !?10,"**** PATIENT DIED ON ",$$DOD^SDECF2(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
Q
;
OTHER(DFN) ; -- calls other forms
Q:$$GET1^DIQ(9009020.2,$$DIV,.04)'="YES" ;print forms with rs?
;
; 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
Q
;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
Q
;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,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^SDECU
;
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) ;-- check to see if the original device got closed and if so reopen it
N IOP
I SDEV="" Q IO
I IO=SDEV Q IO
S IOP=SDEV D ^%ZIS
Q IO
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECRT1 9952 printed Oct 16, 2024@18:53:12 Page 2
SDECRT1 ;ALB/SAT - VISTA SCHEDULING RPCS ;JAN 15, 2016
+1 ;;5.3;Scheduling;**627**;Aug 13, 1993;Build 249
+2 ;
+3 QUIT
+4 ;
PRINT(ORDER,SDATE,SDX,SDSTART,SDSTOP,SDREP) ;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^SDECRT0(DFN,+$ORDER(^TMP("SDRS",$JOB,SORT,TERM,DFN,0)))=0)
IF (ORDER=2)
IF ($$MORERS=0)
QUIT
+9 IF ($$FIRST^SDECRT0(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 ;move to middle of piece of paper
FOR
if $Y>((IOSL)\2)
QUIT
WRITE !
+28 ;dashed line between routing slips
WRITE !,$$REPEAT^XLFSTR("-",IOM)
+29 DO RS(SORT,TERM,DFN,FIRST)
End DoDot:1
+30 QUIT
+31 ;
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 IF $PIECE(CLN,U,3)="CR"
Begin DoDot:1
+5 WRITE !,"CR-"_$EXTRACT(DATE,4,5)_"/"_$EXTRACT(DATE,6,7)_"-"_($EXTRACT(DATE,1,3)+1700)
End DoDot:1
+6 ;
+7 ; mark walkins, same day appts and chart requests
+8 IF $PIECE(CLN,U,3)'="CR"
WRITE ?9,$PIECE(CLN,U,3)
+9 ;
+10 ;xray or lab stop
SET X=CLN
IF $PIECE(CLN,U,2)]""
SET X=$PIECE(CLN,U,2)_" Stop"
+11 ;clinic name
IF '$TEST
SET X=$$GET1^DIQ(44,+CLN,.01)
+12 ;print it
WRITE ?13,$EXTRACT(X,1,25)
+13 IF $PIECE(CLN,U,2)=""
Begin DoDot:1
+14 ;adjust print head
IF $$FORMAT="SHORT"
WRITE !?11
+15 IF '$TEST
WRITE ?40
+16 ;physical location
WRITE $$GET1^DIQ(44,+CLN,10)
+17 ;clinic telephone
if $$FORMAT'="SHORT"
WRITE ?68,$$GET1^DIQ(44,+CLN,99)
End DoDot:1
+18 ;
+19 ;chart request
+20 SET X=0
FOR
SET X=$ORDER(^SC(+CLN,"C",DATE\1,1,X))
if 'X
QUIT
Begin DoDot:1
+21 if +$GET(^SC(+CLN,"C",DATE\1,1,X,0))'=DFN
QUIT
+22 SET Y=$GET(^SC(+CLN,"C",DATE\1,1,X,9999999))
+23 ;
+24 NEW COL
SET COL=$SELECT($$FORMAT="SHORT":3,1:13)
+25 ;deliver to info
WRITE !?COL,$PIECE(Y,U,3)
+26 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
+27 QUIT
+28 ;
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
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 IF $$FORMAT="DUPLICATE"
IF SECOND
WRITE !
+2 IF '$TEST
IF $GET(SDCNT)>0
WRITE @IOF
+3 WRITE !,"FACILITY: ",$$GET1^DIQ(40.8,$$DIV,.01)
+4 WRITE ?40,"**",$EXTRACT($$CONF^SDECU,1,25),"**"
+5 SET BSDPG=$GET(BSDPG)+1
WRITE !,"PAGE ",BSDPG,?10,"OUTPATIENT ROUTING SLIP"
+6 ;
+7 WRITE !!,$$GET1^DIQ(2,DFN,.01),?30,"HRCN: ",$$HRCN^SDECF2(DFN,+$GET(DUZ(2)))
+8 ;
+9 WRITE !?5,"DOB: ",$$GET1^DIQ(2,DFN,.03)
+10 WRITE ?44,"APPT DT: ",$$FMTE^XLFDT(SDATE,5)
+11 ;
+12 IF $$DEAD^SDECF2(DFN)
WRITE !?10,"**** PATIENT DIED ON ",$$DOD^SDECF2(DFN)," ****"
+13 ;
+14 ;rest only needs to be on first page
if BSDPG>1
QUIT
+15 ;
+16 IF $$FORMAT="LONG"
Begin DoDot:1
+17 ;street
NEW VAPA,I
DO ADD^VADPT
FOR I=1:1:3
if VAPA(I)]""
WRITE !,VAPA(I)
+18 ;city,state,zip
WRITE !,VAPA(4),", ",$PIECE(VAPA(5),U,2)," ",VAPA(6)
End DoDot:1
+19 QUIT
+20 ;
OTHER(DFN) ; -- calls other forms
+1 ;print forms with rs?
if $$GET1^DIQ(9009020.2,$$DIV,.04)'="YES"
QUIT
+2 ;
+3 ; only print extra forms with first routing slip for day
+4 IF (ORDER=2)!(ORDER=3)
if '$GET(^TMP("SDRS",$JOB,DFN,SORT))
QUIT
+5 ;
+6 ; health summary
DO HS(DFN,SDATE)
+7 ; med profile
DO MP(DFN,SDATE)
+8 ;cmi/anch/maw 5/9/2008 add check to see if device is still open
SET IO=$$CHKDV($GET(BDGSDEV))
+9 ; action profile
DO APRO(DFN,SDATE)
+10 ; address/insurance update
DO AIU(DFN,SDATE)
+11 QUIT
+12 ;
HS(DFN,SDATE) ; -- health summary
+1 QUIT
+2 ;NEW Y
+3 ;S Y=$$ONE(DFN,SDATE,.04) I 'Y Q
+4 ;D HS^BSDFORM(DFN,$P(Y,U,2)) Q
+5 ;
MP(DFN,SDATE) ; -- med profile
+1 QUIT
+2 ;NEW BSDRX
+3 ;S BSDRX=$$ONE(DFN,SDATE,.06) I 'BSDRX Q
+4 ;I $P(BSDRX,U,2)'=2 D MP^BSDFORM(DFN)
+5 ;Q
+6 ;
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 ;D APRO^BSDFORM(CLN,DFN,SDATE)
End DoDot:1
+7 QUIT
+8 ;
AIU(DFN,SDATE) ; -- insurance update
+1 QUIT
+2 ;
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^SDECU
+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) ;-- check to see if the original device got closed and if so reopen it
+1 NEW IOP
+2 IF SDEV=""
QUIT IO
+3 IF IO=SDEV
QUIT IO
+4 SET IOP=SDEV
DO ^%ZIS
+5 QUIT IO
+6 ;
