BSDROUT1.m

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)))