Routine: BSDWKR7

BSDWKR7 ;cmi/anch/maw - BSD Chart Request and Routing Slip Report 2/20/2007 2:42:22 PM

 ;;5.3;PIMS;**1007**;FEB 27, 2007

 ;cmi/anch/maw 2/20/2007 PATCH 1007 item 1007.25

ASK ; -- ask user questions

 NEW VAUTC,VAUTD,POP,BSDBD,BSDED,BSDTT,BSDDET,BSDSUB,BSDSRT,BSDSEEN,Y

 S BSDSUB="C"

 S BSDBD=$$READ^BDGF("DO^::EX","Select First Date to Search") Q:'BSDBD

 S BSDED=$$READ^BDGF("DO^::EX","Select Last Date to Search") Q:'BSDED

 ; get clinic arrays based on subtotal category

 I (BSDSUB="C")!(BSDSUB="P") D CLINIC^BSDU(2) Q:$D(BSDQ)

 S BSDSRT=$$READ^BDGF("S^C:Clinic Name;P:Principal Clinic;O:Clinic Code;D:Date","Sort By","Clinic Name")

 Q:BSDSRT=U

 ;S BSDDET=$$READ^BDGF("Y","Subtotal sort criteria as well","NO","^D HELP1^BSDWKR7") Q:BSDDET=U

 S Y=$$BROWSE^BDGF Q:"PB"'[Y  I Y="B" D EN Q  ;browse in list mgr mode

 D ZIS^BDGF("PQ","START^BSDWKR7","ROUTING SLIP/CHART REQUEST","BSDDET;BSDSUB;BSDSRT;BSDBD;BSDED;VAUTC*;VAUTD*")

START ;EP; -- re-entry for printing to paper

 D INIT,PRINT Q

EN ; -- main entry point for BSDRM WORK STATS

 NEW VALMCNT D TERM^VALM0,CLEAR^VALM1

 D EN^VALM("BSDRM RS/CR REPORT")

 D CLEAR^VALM1

HDR ; -- header code

 S VALMHDR(1)=$$SP(19)_"Routing Slips and Chart Requests by Month"

 S VALMHDR(2)=$$SP(20)_"For dates: "_$$RANGE^BDGF(BSDBD,BSDED)

INIT ; -- init variables and list array

 S VALMCNT=0 K ^TMP("BSDWKR7",$J),^TMP("BSD",$J)

 NEW BSDAR S BSDAR=$S(VAUTC:"^SC",1:"VAUTC")

 ; -- loop by clinic

 NEW CLN,NAME,SUB,APPT,APPN,PAT,STATUS,TYPE,SUB2,END,BSDS,BSDSCD,BSDPC,BSDH

 I BSDSRT="C" S BSDH="CLINIC NAME"

 I BSDSRT="P" S BSDH="PRINCIPAL CLINIC"

 I BSDSRT="O" S BSDH="CLINIC CODE"

 I BSDSRT="D" S BSDH="DATE"

 S CLN=0 F  S CLN=$O(@BSDAR@(CLN)) Q:'CLN  D

 . Q:'$$GET1^DIQ(44,CLN,3.5,"I")  ;No Div entered for this clinic

 . I $D(VAUTD) Q:(VAUTD'=1&('$D(VAUTD($$GET1^DIQ(44,CLN,3.5,"I")))))  ;this Div notd

 . Q:$D(^SC("AIHSPC",CLN))               ;quit if principal clinic

 . S NAME=$$GET1^DIQ(44,CLN,.01)         ;set clinic's name

 . S BSDSCD=$$GET1^DIQ(44,CLN,8)         ;clinic code

 . S BSDPC=$$GET1^DIQ(44,CLN,1916)       ;principal clinic

. ;

 . ; -- then by appt date (within range)

 . S APPT=BSDBD,END=BSDED+.2400

 . F  S APPT=$O(^SC(CLN,"S",APPT)) Q:'APPT!(APPT>END)  D

 .. ;

 .. ; -- then find appts to count

 .. S APPN=0

 .. F  S APPN=$O(^SC(CLN,"S",APPT,1,APPN)) Q:'APPN  D

 ... S PAT=+^SC(CLN,"S",APPT,1,APPN,0)             ;patient ien

 ... S STATUS=$$VAL^XBDIQ1(2.98,PAT_","_APPT,100)  ;current status

 ... Q:STATUS["CANCEL"

 ... Q:STATUS="FUTURE"

 ... Q:STATUS="NON-COUNT"

 ... Q:STATUS="DELETED"

 ... I BSDSRT="C" S BSDS=NAME

 ... I BSDSRT="P" S BSDS=$S(BSDPC]"":BSDPC,1:NAME)

 ... I BSDSRT="O" S BSDS=BSDSCD

 ... I BSDSRT="D" S BSDS=$$FMTE^XLFDT($P(APPT,"."))

 ... S BSDMON=$E($P(APPT,"."),1,5)  ;get the month so I can count

 ... ;

 ... S TYPE=$$TYPE(CLN,APPT,APPN,PAT,STATUS,BSDH)      ;type of appt

 ... K BSDRSP

 ... I $P($G(^DPT(PAT,"S",APPT,0)),U,7) S BSDRSP=1

 ... ;

 ... ; increment totals

 ... I TYPE=3 D  Q

 .... D INCR(BSDS,BSDH,3,+$G(BSDRSP),BSDMON)  ;count walkins

 ... D INCR(BSDS,BSDH,1,+$G(BSDRSP),BSDMON)  ;count rs/sched

. ;

 . ; -- then by appt date (within range)

 . S APCR=BSDBD,END=BSDED+.2400

 . F  S APCR=$O(^SC(CLN,"C",APCR)) Q:'APCR!(APCR>END)  D

 .. ;

 .. ; -- then find appts to count

 .. S APCN=0

 .. F  S APCN=$O(^SC(CLN,"C",APCR,1,APCN)) Q:'APCN  D

 ... S PAT=+^SC(CLN,"C",APCR,1,APCN,0)             ;patient ien

 ... ;S STATUS=$$VAL^XBDIQ1(2.98,PAT_","_APCR,100)  ;current status

 ... ;Q:STATUS["CANCEL"

 ... ;Q:STATUS="FUTURE"

 ... ;Q:STATUS="NON-COUNT"

 ... ;Q:STATUS="DELETED"

 ... I BSDSRT="C" S BSDS=NAME

 ... I BSDSRT="P" S BSDS=$S(BSDPC]"":BSDPC,1:NAME)

 ... I BSDSRT="O" S BSDS=BSDSCD

 ... I BSDSRT="D" S BSDS=$$FMTE^XLFDT($P(APCR,"."))

 ... S BSDMON=$E($P(APCR,"."),1,5)  ;get the month so I can count

 ... ;

 ... ;S TYPE=$$TYPE(CLN,APPT,APPN,PAT,STATUS,BSDH)      ;type of appt

 ... K BSDRSP

 ... I $P($G(^DPT(PAT,"S",APCR,0)),U,7) S BSDRSP=1

 ... ;

 ... ; increment totals

 ... D INCR(BSDS,BSDH,2,+$G(BSDRSP),BSDMON)

 N BSDDA,BSDRS

 S BSDDA=0 F  S BSDDA=$O(^TMP("BSD",$J,BSDDA)) Q:BSDDA=""  D

 . N BSDIEN

 . S BSDIEN=0 F  S BSDIEN=$O(^TMP("BSD",$J,BSDDA,BSDIEN)) Q:BSDIEN=""  D

 .. I BSDDA'="DATE" D SET("",.VALMCNT)  ;cmi/anch/maw 8/14/2007 patch 1007

 .. I BSDDA'="DATE" D SET(BSDIEN,.VALMCNT)  ;cmi/anch/maw 8/14/2007 patch 1007

 .. N BSDOEN

 .. S BSDOEN=0 F  S BSDOEN=$O(^TMP("BSD",$J,BSDDA,BSDIEN,BSDOEN)) Q:'BSDOEN  D

 ... ;D SET($$MON(BSDOEN),.VALMCNT)

 ... ;TODO FIX IF DATE SORT

 ... N BSDCR,BSDSA,BSDWI,RS

 ... S BSDRS=+$G(^TMP("BSD",$J,BSDDA,BSDIEN,BSDOEN,"RS"))

 ... S BSDCR=+$G(^TMP("BSD",$J,BSDDA,BSDIEN,BSDOEN,2))

 ... S BSDSA=+$G(^TMP("BSD",$J,BSDDA,BSDIEN,BSDOEN,1))

 ... S BSDWI=+$G(^TMP("BSD",$J,BSDDA,BSDIEN,BSDOEN,3))

 ... I BSDDA'="DATE" S LINE=$$MON(BSDOEN)_$$SP(9)_$$PAD(BSDRS,20)  ;cmi/anch/maw 8/14/2007 patch 1007 added month print here

 ... I BSDDA="DATE" S LINE=BSDIEN_$$SP(4)_$$PAD(BSDRS,20)  ;cmi/anch/maw 8/14/2007 patch 1007 added date print here

 ... S LINE=LINE_$$PAD(BSDCR,20)

 ... S LINE=LINE_$$PAD(BSDSA,15)

 ... S LINE=LINE_$$PAD(BSDWI,10)

 ... D SET(LINE,.VALMCNT)

 .. Q:BSDDA="DATE"

 .. N BSDCRS,BSDCCR,BSDCSA,BSDCWI

 .. S BSDCRS=+$G(^TMP("BSDS",$J,BSDDA,BSDIEN,"RS"))

 .. S BSDCCR=+$G(^TMP("BSDS",$J,BSDDA,BSDIEN,2))

 .. S BSDCSA=+$G(^TMP("BSDS",$J,BSDDA,BSDIEN,1))

 .. S BSDCWI=+$G(^TMP("BSDS",$J,BSDDA,BSDIEN,3))

 .. S LINE="Sub Total"_$$SP(8)_$$PAD(BSDCRS,20)

 .. S LINE=LINE_$$PAD(BSDCCR,20)

 .. S LINE=LINE_$$PAD(BSDCSA,15)

 .. S LINE=LINE_$$PAD(BSDCWI,10)

 .. D SET("",.VALMCNT)

 .. D SET(LINE,.VALMCNT)

 D SET("",.VALMCNT)

 D SET("REPORT TOTALS",.VALMCNT)

 N BSDRST,BSDCRT,BSDSAT,BSDWIT

 S BSDRST=+$G(^TMP("BSDTOT",$J,"RS"))

 S BSDCRT=+$G(^TMP("BSDTOT",$J,2))

 S BSDSAT=+$G(^TMP("BSDTOT",$J,1))

 S BSDWIT=+$G(^TMP("BSDTOT",$J,3))

 I BSDH="DATE" D

 . S LINE=$$SP(16)_$$PAD(BSDRST,20)  ;cmi/anch/maw 8/14/2007 patch 1007

 I BSDH'="DATE" D

 . S LINE=$$SP(17)_$$PAD(BSDRST,20)  ;cmi/anch/maw 8/14/2007 patch 1007

 S LINE=LINE_$$PAD(BSDCRT,20)

 S LINE=LINE_$$PAD(BSDSAT,15)

 S LINE=LINE_$$PAD(BSDWIT,10)

 D SET(LINE,.VALMCNT)

 K ^TMP("BSD",$J)

 K ^TMP("BSDTOT",$J)

 K ^TMP("BSDS",$J)

TYPE(C,D,N,P,S,H) ; -- return type of appt.

 ; returns column #

 ;     1=appt, 2=chart request, 3=walk-in

 I S["NO-SHOW" Q 1                                   ;no-show

 I S["INPAT" Q 5                                     ;inpatient

 NEW X S X=$P($G(^DPT(P,"S",D,0)),U,7) I X=4 Q 3         ;walkin

 I (D\1)=($P($G(^SC(C,"C",D,1,N,9999999)),U,7)\1) Q 2    ;same day CR

 I H'="DATE",(D\1)'=($P($G(^SC(C,"C",D,1,N,9999999)),U,7)\1) Q 2   ;future CR

 I X=3,(D\1)=($P($G(^DPT(P,"S",D,0)),U,19)\1) Q 1    ;same day appt

 I H'="DATE",X=3,(D\1)'=($P($G(^DPT(P,"S",D,0)),U,19)\1) Q 1  ;future appt

 I X=3 Q 1  ;scheduled

 Q "??"    ;error in case one slips thru

INCR(SUB,SUBH,TYPE,RS,MON) ; increment totals

 Q:TYPE=5

 I RS D

 . S ^TMP("BSD",$J,SUBH,SUB,MON,"RS")=$G(^TMP("BSD",$J,SUBH,SUB,MON,"RS"))+1

 . S ^TMP("BSDS",$J,SUBH,SUB,"RS")=$G(^TMP("BSDS",$J,SUBH,SUB,"RS"))+1

 . S ^TMP("BSDTOT",$J,"RS")=$G(^TMP("BSDTOT",$J,"RS"))+1

 S ^TMP("BSD",$J,SUBH,SUB,MON,TYPE)=$G(^TMP("BSD",$J,SUBH,SUB,MON,TYPE))+1

 S ^TMP("BSDS",$J,SUBH,SUB,TYPE)=$G(^TMP("BSDS",$J,SUBH,SUB,TYPE))+1

 S ^TMP("BSDTOT",$J,TYPE)=$G(^TMP("BSDTOT",$J,TYPE))+1

SET(LINE,NUM) ; -- sets display line into array

 S NUM=NUM+1

 S ^TMP("BSDWKR7",$J,NUM,0)=LINE

HELP ; -- help code

 S X="?" D DISP^XQORM1 W !!

HELP1 ;EP; help for print individual dates question

 D MSG^BDGF("The report will subtotal by Chart requests,",2,0)

 D MSG^BDGF("scheduled appointments, and walkins.",1,0)

 D MSG^BDGF("Answer YES to have it subtotal by sort criteria",1,0)

 D MSG^BDGF("as well.",1,1)

EXIT ; -- exit code

 K ^TMP("BSDWKR7",$J)

EXPND ; -- expand code

PRINT ; print report to paper

 U IO D HDG

 NEW X S X=0 F  S X=$O(^TMP("BSDWKR7",$J,X)) Q:'X  D

 . I $Y>(IOSL-4) D HDG

 . W !,^TMP("BSDWKR7",$J,X,0)

 D ^%ZISC,EXIT

HDG ; heading for paper report

 D HDR W @IOF,?30,"Routing Slip Statistics"

 F I=1:1 Q:'$D(VALMHDR(I))  W !,VALMHDR(I)

 W !,$$REPEAT^XLFSTR("-",80)

 W !,?10,"Routing Slips",?30,"Chart Requests",?50,"Sch Appts",?70,"Walkins"

 W !,$$REPEAT^XLFSTR("=",80)

PAD(D,L) ;EP -- SUBRTN to pad length of data

 ; -- D=data L=length

 Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)

SP(N) ; -- SUBRTN to pad N number of spaces

 Q $$PAD(" ",N)

MON(MI) ;-- return external month

 S MY=$E(MI,1,3)+1700

 S MI=$E(MI,4,5)

 I MI="01" S MO="Jan"

 I MI="02" S MO="Feb"

 I MI="03" S MO="Mar"

 I MI="04" S MO="Apr"

 I MI="05" S MO="May"

 I MI="06" S MO="Jun"

 I MI="07" S MO="Jul"

 I MI="08" S MO="Aug"

 I MI="09" S MO="Sep"

 I MI="10" S MO="Oct"

 I MI="11" S MO="Nov"

 I MI="12" S MO="Dec"

 Q MO_" "_MY

BSDWKR7   ;cmi/anch/maw - BSD Chart Request and Routing Slip Report 2/20/2007 2:42:22 PM

 +1       ;;5.3;PIMS;**1007**;FEB 27, 2007

 +2       ;

 +3       ;cmi/anch/maw 2/20/2007 PATCH 1007 item 1007.25

 +4       ;

ASK       ; -- ask user questions

 +1        NEW VAUTC,VAUTD,POP,BSDBD,BSDED,BSDTT,BSDDET,BSDSUB,BSDSRT,BSDSEEN,Y

 +2       ;

 +3        SET BSDSUB="C"

 +4       ;

 +5        SET BSDBD=$$READ^BDGF("DO^::EX","Select First Date to Search")

           IF 'BSDBD

               QUIT

 +6        SET BSDED=$$READ^BDGF("DO^::EX","Select Last Date to Search")

           IF 'BSDED

               QUIT

 +7       ;

 +8       ; get clinic arrays based on subtotal category

 +9        IF (BSDSUB="C")!(BSDSUB="P")

               DO CLINIC^BSDU(2)

               IF $DATA(BSDQ)

                   QUIT

 +10      ;

 +11       SET BSDSRT=$$READ^BDGF("S^C:Clinic Name;P:Principal Clinic;O:Clinic Code;D:Date","Sort By","Clinic Name")

 +12       IF BSDSRT=U

               QUIT

 +13      ;

 +14      ;S BSDDET=$$READ^BDGF("Y","Subtotal sort criteria as well","NO","^D HELP1^BSDWKR7") Q:BSDDET=U

 +15      ;

 +16      ;browse in list mgr mode

           SET Y=$$BROWSE^BDGF

           IF "PB"'[Y

               QUIT

           IF Y="B"

               DO EN

               QUIT

 +17       DO ZIS^BDGF("PQ","START^BSDWKR7","ROUTING SLIP/CHART REQUEST","BSDDET;BSDSUB;BSDSRT;BSDBD;BSDED;VAUTC*;VAUTD*")

 +18       QUIT

 +19      ;

START     ;EP; -- re-entry for printing to paper

 +1        DO INIT

           DO PRINT

           QUIT

 +2       ;

EN        ; -- main entry point for BSDRM WORK STATS

 +1        NEW VALMCNT

           DO TERM^VALM0

           DO CLEAR^VALM1

 +2        DO EN^VALM("BSDRM RS/CR REPORT")

 +3        DO CLEAR^VALM1

 +4        QUIT

 +5       ;

HDR       ; -- header code

 +1        SET VALMHDR(1)=$$SP(19)_"Routing Slips and Chart Requests by Month"

 +2        SET VALMHDR(2)=$$SP(20)_"For dates: "_$$RANGE^BDGF(BSDBD,BSDED)

 +3        QUIT

 +4       ;

INIT      ; -- init variables and list array

 +1        SET VALMCNT=0

           KILL ^TMP("BSDWKR7",$JOB),^TMP("BSD",$JOB)

 +2        NEW BSDAR

           SET BSDAR=$SELECT(VAUTC:"^SC",1:"VAUTC")

 +3       ;

 +4       ; -- loop by clinic

 +5        NEW CLN,NAME,SUB,APPT,APPN,PAT,STATUS,TYPE,SUB2,END,BSDS,BSDSCD,BSDPC,BSDH

 +6        IF BSDSRT="C"

               SET BSDH="CLINIC NAME"

 +7        IF BSDSRT="P"

               SET BSDH="PRINCIPAL CLINIC"

 +8        IF BSDSRT="O"

               SET BSDH="CLINIC CODE"

 +9        IF BSDSRT="D"

               SET BSDH="DATE"

 +10       SET CLN=0

FOR

               SET CLN=$ORDER(@BSDAR@(CLN))

               IF 'CLN

                   QUIT

               Begin DoDot:1

 +11      ;No Div entered for this clinic

                   IF '$$GET1^DIQ(44,CLN,3.5,"I")

                       QUIT

 +12      ;this Div notd

                   IF $DATA(VAUTD)

                       IF (VAUTD'=1&('$DATA(VAUTD($$GET1^DIQ(44,CLN,3.5,"I")))))

                           QUIT

 +13      ;quit if principal clinic

                   IF $DATA(^SC("AIHSPC",CLN))

                       QUIT

 +14      ;set clinic's name

                   SET NAME=$$GET1^DIQ(44,CLN,.01)

 +15      ;clinic code

                   SET BSDSCD=$$GET1^DIQ(44,CLN,8)

 +16      ;principal clinic

                   SET BSDPC=$$GET1^DIQ(44,CLN,1916)

 +17      ;

 +18      ; -- then by appt date (within range)

 +19               SET APPT=BSDBD

                   SET END=BSDED+.2400

 +20               FOR

                       SET APPT=$ORDER(^SC(CLN,"S",APPT))

                       IF 'APPT!(APPT>END)

                           QUIT

                       Begin DoDot:2

 +21      ;

 +22      ; -- then find appts to count

 +23                       SET APPN=0

 +24                       FOR

                               SET APPN=$ORDER(^SC(CLN,"S",APPT,1,APPN))

                               IF 'APPN

                                   QUIT

                               Begin DoDot:3

 +25      ;patient ien

                                   SET PAT=+^SC(CLN,"S",APPT,1,APPN,0)

 +26      ;current status

                                   SET STATUS=$$VAL^XBDIQ1(2.98,PAT_","_APPT,100)

 +27                               IF STATUS["CANCEL"

                                       QUIT

 +28                               IF STATUS="FUTURE"

                                       QUIT

 +29                               IF STATUS="NON-COUNT"

                                       QUIT

 +30                               IF STATUS="DELETED"

                                       QUIT

 +31                               IF BSDSRT="C"

                                       SET BSDS=NAME

 +32                               IF BSDSRT="P"

                                       SET BSDS=$SELECT(BSDPC]"":BSDPC,1:NAME)

 +33                               IF BSDSRT="O"

                                       SET BSDS=BSDSCD

 +34                               IF BSDSRT="D"

                                       SET BSDS=$$FMTE^XLFDT($PIECE(APPT,"."))

 +35      ;get the month so I can count

                                   SET BSDMON=$EXTRACT($PIECE(APPT,"."),1,5)

 +36      ;

 +37      ;type of appt

                                   SET TYPE=$$TYPE(CLN,APPT,APPN,PAT,STATUS,BSDH)

 +38                               KILL BSDRSP

 +39                               IF $PIECE($GET(^DPT(PAT,"S",APPT,0)),U,7)

                                       SET BSDRSP=1

 +40      ;

 +41      ; increment totals

 +42                               IF TYPE=3

                                       Begin DoDot:4

 +43      ;count walkins

                                           DO INCR(BSDS,BSDH,3,+$GET(BSDRSP),BSDMON)

                                       End DoDot:4

                                       QUIT

 +44      ;count rs/sched

                                   DO INCR(BSDS,BSDH,1,+$GET(BSDRSP),BSDMON)

                               End DoDot:3

                       End DoDot:2

 +45      ;

 +46      ; -- then by appt date (within range)

 +47               SET APCR=BSDBD

                   SET END=BSDED+.2400

 +48               FOR

                       SET APCR=$ORDER(^SC(CLN,"C",APCR))

                       IF 'APCR!(APCR>END)

                           QUIT

                       Begin DoDot:2

 +49      ;

 +50      ; -- then find appts to count

 +51                       SET APCN=0

 +52                       FOR

                               SET APCN=$ORDER(^SC(CLN,"C",APCR,1,APCN))

                               IF 'APCN

                                   QUIT

                               Begin DoDot:3

 +53      ;patient ien

                                   SET PAT=+^SC(CLN,"C",APCR,1,APCN,0)

 +54      ;S STATUS=$$VAL^XBDIQ1(2.98,PAT_","_APCR,100)  ;current status

 +55      ;Q:STATUS["CANCEL"

 +56      ;Q:STATUS="FUTURE"

 +57      ;Q:STATUS="NON-COUNT"

 +58      ;Q:STATUS="DELETED"

 +59                               IF BSDSRT="C"

                                       SET BSDS=NAME

 +60                               IF BSDSRT="P"

                                       SET BSDS=$SELECT(BSDPC]"":BSDPC,1:NAME)

 +61                               IF BSDSRT="O"

                                       SET BSDS=BSDSCD

 +62                               IF BSDSRT="D"

                                       SET BSDS=$$FMTE^XLFDT($PIECE(APCR,"."))

 +63      ;get the month so I can count

                                   SET BSDMON=$EXTRACT($PIECE(APCR,"."),1,5)

 +64      ;

 +65      ;S TYPE=$$TYPE(CLN,APPT,APPN,PAT,STATUS,BSDH)      ;type of appt

 +66                               KILL BSDRSP

 +67                               IF $PIECE($GET(^DPT(PAT,"S",APCR,0)),U,7)

                                       SET BSDRSP=1

 +68      ;

 +69      ; increment totals

 +70                               DO INCR(BSDS,BSDH,2,+$GET(BSDRSP),BSDMON)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +71      ;

 +72      ;

 +73       NEW BSDDA,BSDRS

 +74       SET BSDDA=0

FOR

               SET BSDDA=$ORDER(^TMP("BSD",$JOB,BSDDA))

               IF BSDDA=""

                   QUIT

               Begin DoDot:1

 +75               NEW BSDIEN

 +76               SET BSDIEN=0

FOR

                       SET BSDIEN=$ORDER(^TMP("BSD",$JOB,BSDDA,BSDIEN))

                       IF BSDIEN=""

                           QUIT

                       Begin DoDot:2

 +77      ;cmi/anch/maw 8/14/2007 patch 1007

                           IF BSDDA'="DATE"

                               DO SET("",.VALMCNT)

 +78      ;cmi/anch/maw 8/14/2007 patch 1007

                           IF BSDDA'="DATE"

                               DO SET(BSDIEN,.VALMCNT)

 +79                       NEW BSDOEN

 +80                       SET BSDOEN=0

FOR

                               SET BSDOEN">EN=$ORDER(^TMP("BSD",$JOB,BSDDA,BSDIEN">EN,BSDOEN">EN))

                               IF 'BSDOEN

                                   QUIT

                               Begin DoDot:3

 +81      ;D SET($$MON(BSDOEN),.VALMCNT)

 +82      ;TODO FIX IF DATE SORT

 +83                               NEW BSDCR,BSDSA,BSDWI,RS

 +84                               SET BSDRS=+$GET(^TMP("BSD",$JOB,BSDDA,BSDIEN,BSDOEN,"RS"))

 +85                               SET BSDCR=+$GET(^TMP("BSD",$JOB,BSDDA,BSDIEN,BSDOEN,2))

 +86                               SET BSDSA=+$GET(^TMP("BSD",$JOB,BSDDA,BSDIEN,BSDOEN,1))

 +87                               SET BSDWI=+$GET(^TMP("BSD",$JOB,BSDDA,BSDIEN,BSDOEN,3))

 +88      ;cmi/anch/maw 8/14/2007 patch 1007 added month print here

                                   IF BSDDA'="DATE"

                                       SET LINE=$$MON(BSDOEN)_$$SP(9)_$$PAD(BSDRS,20)

 +89      ;cmi/anch/maw 8/14/2007 patch 1007 added date print here

                                   IF BSDDA="DATE"

                                       SET LINE=BSDIEN_$$SP(4)_$$PAD(BSDRS,20)

 +90                               SET LINE=LINE_$$PAD(BSDCR,20)

 +91                               SET LINE=LINE_$$PAD(BSDSA,15)

 +92                               SET LINE=LINE_$$PAD(BSDWI,10)

 +93                               DO SET(LINE,.VALMCNT)

                               End DoDot:3

 +94                       IF BSDDA="DATE"

                               QUIT

 +95                       NEW BSDCRS,BSDCCR,BSDCSA,BSDCWI

 +96                       SET BSDCRS=+$GET(^TMP("BSDS",$JOB,BSDDA,BSDIEN,"RS"))

 +97                       SET BSDCCR=+$GET(^TMP("BSDS",$JOB,BSDDA,BSDIEN,2))

 +98                       SET BSDCSA=+$GET(^TMP("BSDS",$JOB,BSDDA,BSDIEN,1))

 +99                       SET BSDCWI=+$GET(^TMP("BSDS",$JOB,BSDDA,BSDIEN,3))

 +100                      SET LINE="Sub Total"_$$SP(8)_$$PAD(BSDCRS,20)

 +101                      SET LINE=LINE_$$PAD(BSDCCR,20)

 +102                      SET LINE=LINE_$$PAD(BSDCSA,15)

 +103                      SET LINE=LINE_$$PAD(BSDCWI,10)

 +104                      DO SET("",.VALMCNT)

 +105                      DO SET(LINE,.VALMCNT)

                       End DoDot:2

               End DoDot:1

 +106      DO SET("",.VALMCNT)

 +107      DO SET("REPORT TOTALS",.VALMCNT)

 +108      NEW BSDRST,BSDCRT,BSDSAT,BSDWIT

 +109      SET BSDRST=+$GET(^TMP("BSDTOT",$JOB,"RS"))

 +110      SET BSDCRT=+$GET(^TMP("BSDTOT",$JOB,2))

 +111      SET BSDSAT=+$GET(^TMP("BSDTOT",$JOB,1))

 +112      SET BSDWIT=+$GET(^TMP("BSDTOT",$JOB,3))

 +113      IF BSDH="DATE"

               Begin DoDot:1

 +114     ;cmi/anch/maw 8/14/2007 patch 1007

                   SET LINE=$$SP(16)_$$PAD(BSDRST,20)

               End DoDot:1

 +115      IF BSDH'="DATE"

               Begin DoDot:1

 +116     ;cmi/anch/maw 8/14/2007 patch 1007

                   SET LINE=$$SP(17)_$$PAD(BSDRST,20)

               End DoDot:1

 +117      SET LINE=LINE_$$PAD(BSDCRT,20)

 +118      SET LINE=LINE_$$PAD(BSDSAT,15)

 +119      SET LINE=LINE_$$PAD(BSDWIT,10)

 +120      DO SET(LINE,.VALMCNT)

 +121      KILL ^TMP("BSD",$JOB)

 +122      KILL ^TMP("BSDTOT",$JOB)

 +123      KILL ^TMP("BSDS",$JOB)

 +124      QUIT

 +125     ;

TYPE(C,D,N,P,S,H) ; -- return type of appt.

 +1       ; returns column #

 +2       ;     1=appt, 2=chart request, 3=walk-in

 +3       ;no-show

           IF S["NO-SHOW"

               QUIT 1

 +4       ;inpatient

           IF S["INPAT"

               QUIT 5

 +5       ;walkin

           NEW X

           SET X=$PIECE($GET(^DPT(P,"S",D,0)),U,7)

           IF X=4

               QUIT 3

 +6       ;same day CR

           IF (D\1)=($PIECE($GET(^SC(C,"C",D,1,N,9999999)),U,7)\1)

               QUIT 2

 +7       ;future CR

           IF H'="DATE"

               IF (D\1)'=($PIECE($GET(^SC(C,"C",D,1,N,9999999)),U,7)\1)

                   QUIT 2

 +8       ;same day appt

           IF X=3

               IF (D\1)=($PIECE($GET(^DPT(P,"S",D,0)),U,19)\1)

                   QUIT 1

 +9       ;future appt

           IF H'="DATE"

               IF X=3

                   IF (D\1)'=($PIECE($GET(^DPT(P,"S",D,0)),U,19)\1)

                       QUIT 1

 +10      ;scheduled

           IF X=3

               QUIT 1

 +11      ;error in case one slips thru

           QUIT "??"

 +12      ;

INCR(SUB,SUBH,TYPE,RS,MON) ; increment totals

 +1        IF TYPE=5

               QUIT

 +2        IF RS

               Begin DoDot:1

 +3                SET ^TMP("BSD",$JOB,SUBH,SUB,MON,"RS")=$GET(^TMP("BSD",$JOB,SUBH,SUB,MON,"RS"))+1

 +4                SET ^TMP("BSDS",$JOB,SUBH,SUB,"RS")=$GET(^TMP("BSDS",$JOB,SUBH,SUB,"RS"))+1

 +5                SET ^TMP("BSDTOT",$JOB,"RS")=$GET(^TMP("BSDTOT",$JOB,"RS"))+1

               End DoDot:1

 +6        SET ^TMP("BSD",$JOB,SUBH,SUB,MON,TYPE)=$GET(^TMP("BSD",$JOB,SUBH,SUB,MON,TYPE))+1

 +7        SET ^TMP("BSDS",$JOB,SUBH,SUB,TYPE)=$GET(^TMP("BSDS",$JOB,SUBH,SUB,TYPE))+1

 +8        SET ^TMP("BSDTOT",$JOB,TYPE)=$GET(^TMP("BSDTOT",$JOB,TYPE))+1

 +9        QUIT

 +10      ;

SET(LINE,NUM) ; -- sets display line into array

 +1        SET NUM=NUM+1

 +2        SET ^TMP("BSDWKR7",$JOB,NUM,0)=LINE

 +3        QUIT

 +4       ;

HELP      ; -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !!

 +2        QUIT

 +3       ;

HELP1     ;EP; help for print individual dates question

 +1        DO MSG^BDGF("The report will subtotal by Chart requests,",2,0)

 +2        DO MSG^BDGF("scheduled appointments, and walkins.",1,0)

 +3        DO MSG^BDGF("Answer YES to have it subtotal by sort criteria",1,0)

 +4        DO MSG^BDGF("as well.",1,1)

 +5        QUIT

 +6       ;

EXIT      ; -- exit code

 +1        KILL ^TMP("BSDWKR7",$JOB)

 +2        QUIT

 +3       ;

EXPND     ; -- expand code

 +1        QUIT

 +2       ;

PRINT     ; print report to paper

 +1        USE IO

           DO HDG

 +2        NEW X

           SET X=0

FOR

               SET X=$ORDER(^TMP("BSDWKR7",$JOB,X))

               IF 'X

                   QUIT

               Begin DoDot:1

 +3                IF $Y>(IOSL-4)

                       DO HDG

 +4                WRITE !,^TMP("BSDWKR7",$JOB,X,0)

               End DoDot:1

 +5        DO ^%ZISC

           DO EXIT

 +6        QUIT

 +7       ;

HDG       ; heading for paper report

 +1        DO HDR

           WRITE @IOF,?30,"Routing Slip Statistics"

 +2        FOR I=1:1

               IF '$DATA(VALMHDR(I))

                   QUIT

               WRITE !,VALMHDR(I)

 +3        WRITE !,$$REPEAT^XLFSTR("-",80)

 +4        WRITE !,?10,"Routing Slips",?30,"Chart Requests",?50,"Sch Appts",?70,"Walkins"

 +5        WRITE !,$$REPEAT^XLFSTR("=",80)

 +6        QUIT

 +7       ;

PAD(D,L)  ;EP -- SUBRTN to pad length of data

 +1       ; -- D=data L=length

 +2        QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)

 +3       ;

SP(N)     ; -- SUBRTN to pad N number of spaces

 +1        QUIT $$PAD(" ",N)

 +2       ;

MON(MI)   ;-- return external month

 +1        SET MY=$EXTRACT(MI,1,3)+1700

 +2        SET MI=$EXTRACT(MI,4,5)

 +3        IF MI="01"

               SET MO="Jan"

 +4        IF MI="02"

               SET MO="Feb"

 +5        IF MI="03"

               SET MO="Mar"

 +6        IF MI="04"

               SET MO="Apr"

 +7        IF MI="05"

               SET MO="May"

 +8        IF MI="06"

               SET MO="Jun"

 +9        IF MI="07"

               SET MO="Jul"

 +10       IF MI="08"

               SET MO="Aug"

 +11       IF MI="09"

               SET MO="Sep"

 +12       IF MI="10"

               SET MO="Oct"

 +13       IF MI="11"

               SET MO="Nov"

 +14       IF MI="12"

               SET MO="Dec"

 +15       QUIT MO_" "_MY

 +16      ;

BSDWKR7.m