BSDWKR8 ; cmi/flag/maw - BSD Advanced Access Report [ 01/04/2005 4:42 PM ]
;;5.3;PIMS;**1012,1013**;APR 26, 2002
;
ASK ; -- ask user questions
NEW VAUTC,VAUTD,POP,BSDBD,BSDED,BSDTT,BSDDET,BSDSUB,BSDSRT,BSDSEEN,Y
;
S BSDSUB=$$READ^BDGF("SO^C:Clinic;P:Principal Clinic;V:Provider;T:Team","Subtotal Report by","","^D HELP1^BSDWKR8")
Q:BSDSUB="" Q:BSDSUB=U
;
; get clinic arrays based on subtotal category
I (BSDSUB="C")!(BSDSUB="P") D CLINIC^BSDU(2) Q:$D(BSDQ)
I (BSDSUB="V")!(BSDSUB="T") D PCASK^BSDU(2,BSDSUB) Q:$D(BSDQ)
;
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
;
;cmi/maw exclude demo patients here
D DEMOCHK^APCLUTL(.BSDDEMO)
Q:BSDDEMO=-1
;
S Y=$$BROWSE^BDGF Q:"PB"'[Y I Y="B" D EN Q ;browse in list mgr mode
D ZIS^BDGF("PQ","START^BSDWKR8","ADVANCED ACCESS","BSDSUB;BSDBD;BSDED;VAUTC*;VAUTD*")
Q
;
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 ADVANCED ACCESS")
D CLEAR^VALM1
Q
;
HDR ; -- header code
S VALMHDR(1)=$$SP(30)_"Advanced Access Report"
S VALMHDR(2)=$$SP(20)_"For dates: "_$$RANGE^BDGF(BSDBD,BSDED)
S VALMHDR(3)=$$SP(40)_"External Demand"_$$SP(8)_"Internal"_$$SP(3)_"Unmet"
Q
;
INIT ; -- init variables and list array
S VALMCNT=0 K ^TMP("BSDWKR8",$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,APPTM,WI,FU,WL,AP
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 SUB=$$SUB1(CLN,NAME) ;get subcategory for 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
... Q:$$DEMO^APCLUTL(PAT,$G(BSDDEMO))
... S APPTM=$P($G(^SC(CLN,"S",APPT,1,APPN,0)),U,7) ;date appointment made
... S STATUS=$$VAL^XBDIQ1(2.98,PAT_","_APPT,100) ;current status
... S AP=$$CNTAPP(CLN,APPT) ;count all appointments made this day
... ;S AP=$S($P(APPTM,".")=$P(APPT,"."):1,1:0) ;check if appointment made on same day
... S WI=$S($$VALI^XBDIQ1(2.98,PAT_","_APPT,9)=4:1,1:0) ;type of appointment
... S FU=$$VALI^XBDIQ1(2.98,PAT_","_APPT,28)
... S WL=$$FNDWL(CLN,$P(APPT,"."))
... Q:STATUS["CANCEL"
... Q:STATUS="NON-COUNT" Q:STATUS="DELETED"
... S TYPE=$$TYPE(CLN,APPT,APPN,PAT,STATUS) ;type of appt
... ; increment totals
... D INCR(SUB,TYPE,NAME,APPT,AP,WI,FU,WL)
;
N S1,S2,AC,WC,FC,LC,INT
S S1=0 F S S1=$O(^TMP("BSD",$J,S1)) Q:S1="" D
. Q:S1="TOT"
. S LINE=$$PAD($$FMTE^XLFDT(S1),14)
. D SET(LINE,.VALMCNT)
. S S2=0 F S S2=$O(^TMP("BSD",$J,S1,S2)) Q:S2="" D
.. S AC=+$G(^TMP("BSD",$J,S1,S2,"APPT"))
.. S WC=+$G(^TMP("BSD",$J,S1,S2,"WI"))
.. S FC=+$G(^TMP("BSD",$J,S1,S2,"FU"))
.. S LC=+$G(^TMP("BSD",$J,S1,S2,"WL"))
.. S LINE=""
.. S LINE=LINE_$$PAD($$SP(13)_S2,40)
.. S LINE=LINE_$$PAD(AC,11)
.. S LINE=LINE_$$PAD(WC,12)
.. S LINE=LINE_$$PAD(FC,11)
.. S LINE=LINE_$$PAD(LC,11)
.. D SET(LINE,.VALMCNT)
. D SET("",.VALMCNT)
. S LINE=""
. S LINE="External Demand Subtotal"
. S LINE=LINE_$$SP(16)
. S INT=+$G(^TMP("BSD",$J,"TOT",S1,"EXTERNAL"))
. S LINE=LINE_$$PAD(INT,10)
. ;S LINE=LINE_$$PAD(+$G(^TMP("BSD",$J,"TOT",S1,"WI")),12)
. D SET(LINE,.VALMCNT)
. S LINE=""
. S LINE=LINE_"Internal Demand Subtotal"
. S LINE=LINE_$$SP(16)
. S LINE=LINE_$$PAD(+$G(^TMP("BSD",$J,"TOT",S1,"FU")),11)
. D SET(LINE,.VALMCNT)
. S LINE=""
. S LINE=LINE_"Unmet Demand Subtotal"
. S LINE=LINE_$$SP(19)
. S LINE=LINE_$$PAD(+$G(^TMP("BSD",$J,"TOT",S1,"WL")),11)
. D SET(LINE,.VALMCNT)
. D SET("",.VALMCNT)
D SET("",.VALMCNT)
D SET("",.VALMCNT)
S LINE="External Demand Total"
S LINE=LINE_$$SP(19)
S LINE=LINE_+$G(^TMP("BSD",$J,"TOT","EXTTOTAL"))
S LINE=LINE_$$SP(10)_"FU Total"_$$SP(4)
S LINE=LINE_$G(^TMP("BSD",$J,"TOT","FUTOTAL"))
D SET(LINE,.VALMCNT)
K ^TMP("BSD",$J)
Q
;
SUB1(C,N) ; -- return name of subcategory for clinic C
I BSDSUB="P" Q $$PRIN^BSDU(C)
I BSDSUB="V" Q $P($$PRV^BSDU(C),U,2)
I BSDSUB="T" Q $P($$TEAM^BSDU(C),U,2)
Q N
;
TYPE(C,D,N,P,S) ; -- return type of appt.
; returns column #
; 1=sched, 2=same day, 3=walk-in, 4=overbook, 5=inpt, 6=no-show
I S["NO-SHOW" Q 6 ;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 X=9,(D\1)=($P($G(^SC(C,"S",D,1,N,0)),U,7)\1) Q 3 ;same day CR
I X=9,(D\1)'=($P($G(^SC(C,"S",D,1,N,0)),U,7)\1) Q 1 ;future CR
I X=3,(D\1)=($P($G(^SC(C,"S",D,1,N,0)),U,7)\1) Q 2 ;same day appt
I $G(^SC(C,"S",D,1,N,"OB"))="O" Q 4 ;sched overbook
I X=3 Q 1 ;scheduled
Q "??" ;error in case one slips thru
;
INCR(SUB,TYPE,NAME,APPT,A,W,F,L) ; increment totals
NEW DATE S DATE=APPT\1
S:'$D(^TMP("BSD",$J,DATE,SUB,"APPT")) ^TMP("BSD",$J,DATE,SUB,"APPT")=0
S ^TMP("BSD",$J,DATE,SUB,"APPT")=^TMP("BSD",$J,DATE,SUB,"APPT")+A
S:'$D(^TMP("BSD",$J,DATE,SUB,"WI")) ^TMP("BSD",$J,DATE,SUB,"WI")=0
S ^TMP("BSD",$J,DATE,SUB,"WI")=^TMP("BSD",$J,DATE,SUB,"WI")+W
S:'$D(^TMP("BSD",$J,DATE,SUB,"FU")) ^TMP("BSD",$J,DATE,SUB,"FU")=0
S ^TMP("BSD",$J,DATE,SUB,"FU")=^TMP("BSD",$J,DATE,SUB,"FU")+F
S:'$D(^TMP("BSD",$J,DATE,SUB,"WL")) ^TMP("BSD",$J,DATE,SUB,"WL")=0
S ^TMP("BSD",$J,DATE,SUB,"WL")=^TMP("BSD",$J,DATE,SUB,"WL")+L
S:'$D(^TMP("BSD",$J,"TOT",DATE,"APPT")) ^TMP("BSD",$J,"TOT",DATE,"APPT")=0
S ^TMP("BSD",$J,"TOT",DATE,"APPT")=^TMP("BSD",$J,"TOT",DATE,"APPT")+A
S:'$D(^TMP("BSD",$J,DATE,"TOT","WI")) ^TMP("BSD",$J,"TOT",DATE,"WI")=0
S ^TMP("BSD",$J,"TOT",DATE,"WI")=^TMP("BSD",$J,"TOT",DATE,"WI")+W
S:'$D(^TMP("BSD",$J,"TOT",DATE,"FU")) ^TMP("BSD",$J,"TOT",DATE,"FU")=0
S ^TMP("BSD",$J,"TOT",DATE,"FU")=^TMP("BSD",$J,"TOT",DATE,"FU")+F
S:'$D(^TMP("BSD",$J,"TOT",DATE,"WL")) ^TMP("BSD",$J,"TOT",DATE,"WL")=0
S ^TMP("BSD",$J,"TOT",DATE,"WL")=^TMP("BSD",$J,"TOT",DATE,"WL")+L
S:'$D(^TMP("BSD",$J,"TOT",DATE,"EXTERNAL")) ^TMP("BSD",$J,"TOT",DATE,"EXTERNAL")=0
S ^TMP("BSD",$J,"TOT",DATE,"EXTERNAL")=^TMP("BSD",$J,"TOT",DATE,"EXTERNAL")+(A+W)
S:'$D(^TMP("BSD",$J,"TOT",DATE,"TOTAL")) ^TMP("BSD",$J,"TOT",DATE,"TOTAL")=0
S ^TMP("BSD",$J,"TOT",DATE,"TOTAL")=^TMP("BSD",$J,"TOT",DATE,"TOTAL")+(A+W+F)
S:'$D(^TMP("BSD",$J,"TOT","FUTOTAL")) ^TMP("BSD",$J,"TOT","FUTOTAL")=0
S ^TMP("BSD",$J,"TOT","FUTOTAL")=^TMP("BSD",$J,"TOT","FUTOTAL")+F
S:'$D(^TMP("BSD",$J,"TOT","EXTTOTAL")) ^TMP("BSD",$J,"TOT","EXTTOTAL")=0
S ^TMP("BSD",$J,"TOT","EXTTOTAL")=^TMP("BSD",$J,"TOT","EXTTOTAL")+(A+W)
S:'$D(^TMP("BSD",$J,"TOT","GRANDTOTAL")) ^TMP("BSD",$J,"TOT","GRANDTOTAL")=0
S ^TMP("BSD",$J,"TOT","GRANDTOTAL")=^TMP("BSD",$J,"TOT","GRANDTOTAL")+(A+W+F)
Q
;
FNDWL(C,A) ;-- check to see if a patient is on the wait list
N AD,CNT,CL,BDA,PAT
S CNT=0
I $G(CNTR(C,A)) Q 0
S CL=$O(^BSDWL("B",C,0))
I '$G(CL) Q 0
S BDA=0 F S BDA=$O(^BSDWL(CL,1,BDA)) Q:'BDA D
. Q:$P($G(^BSDWL(CL,1,BDA,0)),U,7)
. S PAT=+$P($G(^BSDWL(CL,1,BDA,0)),U)
. S AD=$P($G(^BSDWL(CL,1,BDA,0)),U,3)
. Q:$$DEMO^APCLUTL(PAT,$G(BSDDEMO))
. I AD=A S CNT=CNT+1
S CNTR(C,A)=1
Q +$G(CNT)
;
CNTAPP(C,A) ;-- count all appointments made on date passed in for clinic
N AD,CNT,DAM,BDA,BDI,BDO,PAT,AP,BG,ED
S AP=$P(A,".")
S CNT=0
I $G(ACNTR(C,AP)) Q 0
S BG=AP-.0001,ED=AP+.9999
S BDA=BG F S BDA=$O(^SC("AIHSDAM",C,BDA)) Q:'BDA!(BDA>ED) D
. S BDI=0 F S BDI=$O(^SC("AIHSDAM",C,BDA,BDI)) Q:'BDI D
.. S BDO=0 F S BDO=$O(^SC("AIHSDAM",C,BDA,BDI,BDO)) Q:'BDO D
... S PAT=+$P($G(^SC(C,"S",BDI,1,BDO,0)),U)
... Q:'$G(PAT) ;ihs/cmi/maw 08/08/2011 added for missing patient pointer
... Q:'$D(^DPT(PAT,"S",BDI)) ;another bad data filter
... Q:$$VALI^XBDIQ1(2.98,PAT_","_BDI,9)=4 ;8/19/2010 screen out walkins per lisa dolan email
... S DAM=$P(BDA,".")
... Q:$$DEMO^APCLUTL(PAT,$G(BSDDEMO))
... I DAM=AP S CNT=CNT+1
S ACNTR(C,AP)=1
Q +$G(CNT)
;
SET(LINE,NUM) ; -- sets display line into array
S NUM=NUM+1
S ^TMP("BSDWKR8",$J,NUM,0)=LINE
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
HELP1 ;EP; help for subtotal question
D MSG^BDGF("This report will subtotal results any of 4 ways:",2,0)
D MSG^BDGF(" Choose C to subtotal by individual clinic;",1,0)
D MSG^BDGF(" Choose P to subtotal by principal clinic;",1,0)
D MSG^BDGF(" Choose V to subtotal by a clinic's provider;",1,0)
D MSG^BDGF(" Choose T to subtotal by a clinic's team.",1,0)
D MSG^BDGF("Clinics not affiliated with a principal clinic,",2,0)
D MSG^BDGF("provider or team, will be subtotaled under the",1,0)
D MSG^BDGF("""Unaffiliated"" designation.",1,1)
Q
;
EXIT ; -- exit code
K ^TMP("BSDWKR8",$J),CNTR,BSDDEMO,ACNTR
Q
;
EXPND ; -- expand code
Q
;
PRINT ; print report to paper
U IO D HDG
NEW X S X=0 F S X=$O(^TMP("BSDWKR8",$J,X)) Q:'X D
. I $Y>(IOSL-4) D HDG
. W !,^TMP("BSDWKR8",$J,X,0)
D ^%ZISC,EXIT
Q
;
HDG ; heading for paper report
D HDR W @IOF ;,?30,"Advanced Access Report"
F I=1:1 Q:'$D(VALMHDR(I)) W !,VALMHDR(I)
W !,$$REPEAT^XLFSTR("-",80)
W !,"Date",?13,"Category",?40,"Appt",?51,"WI"
W ?63,"FU",?74,"WL"
W !,$$REPEAT^XLFSTR("=",80)
Q
;
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)
BSDWKR8 ; cmi/flag/maw - BSD Advanced Access Report [ 01/04/2005 4:42 PM ]
+1 ;;5.3;PIMS;**1012,1013**;APR 26, 2002
+2 ;
ASK ; -- ask user questions
+1 NEW VAUTC,VAUTD,POP,BSDBD,BSDED,BSDTT,BSDDET,BSDSUB,BSDSRT,BSDSEEN,Y
+2 ;
+3 SET BSDSUB=$$READ^BDGF("SO^C:Clinic;P:Principal Clinic;V:Provider;T:Team","Subtotal Report by","","^D HELP1^BSDWKR8")
+4 IF BSDSUB=""
QUIT
IF BSDSUB=U
QUIT
+5 ;
+6 ; get clinic arrays based on subtotal category
+7 IF (BSDSUB="C")!(BSDSUB="P")
DO CLINIC^BSDU(2)
IF $DATA(BSDQ)
QUIT
+8 IF (BSDSUB="V")!(BSDSUB="T")
DO PCASK^BSDU(2,BSDSUB)
IF $DATA(BSDQ)
QUIT
+9 ;
+10 SET BSDBD=$$READ^BDGF("DO^::EX","Select First Date to Search")
IF 'BSDBD
QUIT
+11 SET BSDED=$$READ^BDGF("DO^::EX","Select Last Date to Search")
IF 'BSDED
QUIT
+12 ;
+13 ;cmi/maw exclude demo patients here
+14 DO DEMOCHK^APCLUTL(.BSDDEMO)
+15 IF BSDDEMO=-1
QUIT
+16 ;
+17 ;browse in list mgr mode
SET Y=$$BROWSE^BDGF
IF "PB"'[Y
QUIT
IF Y="B"
DO EN
QUIT
+18 DO ZIS^BDGF("PQ","START^BSDWKR8","ADVANCED ACCESS","BSDSUB;BSDBD;BSDED;VAUTC*;VAUTD*")
+19 QUIT
+20 ;
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 ADVANCED ACCESS")
+3 DO CLEAR^VALM1
+4 QUIT
+5 ;
HDR ; -- header code
+1 SET VALMHDR(1)=$$SP(30)_"Advanced Access Report"
+2 SET VALMHDR(2)=$$SP(20)_"For dates: "_$$RANGE^BDGF(BSDBD,BSDED)
+3 SET VALMHDR(3)=$$SP(40)_"External Demand"_$$SP(8)_"Internal"_$$SP(3)_"Unmet"
+4 QUIT
+5 ;
INIT ; -- init variables and list array
+1 SET VALMCNT=0
KILL ^TMP("BSDWKR8",$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,APPTM,WI,FU,WL,AP
+6 SET CLN=0
FOR
SET CLN=$ORDER(@BSDAR@(CLN))
IF 'CLN
QUIT
Begin DoDot:1
+7 ;No Div entered for this clinic
IF '$$GET1^DIQ(44,CLN,3.5,"I")
QUIT
+8 ;this Div notd
IF $DATA(VAUTD)
IF (VAUTD'=1&('$DATA(VAUTD($$GET1^DIQ(44,CLN,3.5,"I")))))
QUIT
+9 ;quit if principal clinic
IF $DATA(^SC("AIHSPC",CLN))
QUIT
+10 ;set clinic's name
SET NAME=$$GET1^DIQ(44,CLN,.01)
+11 ;get subcategory for clinic
SET SUB=$$SUB1(CLN,NAME)
+12 ;
+13 ; -- then by appt date (within range)
+14 SET APPT=BSDBD
SET END=BSDED+.2400
+15 FOR
SET APPT=$ORDER(^SC(CLN,"S",APPT))
IF 'APPT!(APPT>END)
QUIT
Begin DoDot:2
+16 ;
+17 ; -- then find appts to count
+18 SET APPN=0
+19 FOR
SET APPN=$ORDER(^SC(CLN,"S",APPT,1,APPN))
IF 'APPN
QUIT
Begin DoDot:3
+20 ;patient ien
SET PAT=+^SC(CLN,"S",APPT,1,APPN,0)
+21 IF $$DEMO^APCLUTL(PAT,$GET(BSDDEMO))
QUIT
+22 ;date appointment made
SET APPTM=$PIECE($GET(^SC(CLN,"S",APPT,1,APPN,0)),U,7)
+23 ;current status
SET STATUS=$$VAL^XBDIQ1(2.98,PAT_","_APPT,100)
+24 ;count all appointments made this day
SET AP=$$CNTAPP(CLN,APPT)
+25 ;S AP=$S($P(APPTM,".")=$P(APPT,"."):1,1:0) ;check if appointment made on same day
+26 ;type of appointment
SET WI=$SELECT($$VALI^XBDIQ1(2.98,PAT_","_APPT,9)=4:1,1:0)
+27 SET FU=$$VALI^XBDIQ1(2.98,PAT_","_APPT,28)
+28 SET WL=$$FNDWL(CLN,$PIECE(APPT,"."))
+29 IF STATUS["CANCEL"
QUIT
+30 IF STATUS="NON-COUNT"
QUIT
IF STATUS="DELETED"
QUIT
+31 ;type of appt
SET TYPE=$$TYPE(CLN,APPT,APPN,PAT,STATUS)
+32 ; increment totals
+33 DO INCR(SUB,TYPE,NAME,APPT,AP,WI,FU,WL)
End DoDot:3
End DoDot:2
End DoDot:1
+34 ;
+35 NEW S1,S2,AC,WC,FC,LC,INT
+36 SET S1=0
FOR
SET S1=$ORDER(^TMP("BSD",$JOB,S1))
IF S1=""
QUIT
Begin DoDot:1
+37 IF S1="TOT"
QUIT
+38 SET LINE=$$PAD($$FMTE^XLFDT(S1),14)
+39 DO SET(LINE,.VALMCNT)
+40 SET S2=0
FOR
SET S2=$ORDER(^TMP("BSD",$JOB,S1,S2))
IF S2=""
QUIT
Begin DoDot:2
+41 SET AC=+$GET(^TMP("BSD",$JOB,S1,S2,"APPT"))
+42 SET WC=+$GET(^TMP("BSD",$JOB,S1,S2,"WI"))
+43 SET FC=+$GET(^TMP("BSD",$JOB,S1,S2,"FU"))
+44 SET LC=+$GET(^TMP("BSD",$JOB,S1,S2,"WL"))
+45 SET LINE=""
+46 SET LINE=LINE_$$PAD($$SP(13)_S2,40)
+47 SET LINE=LINE_$$PAD(AC,11)
+48 SET LINE=LINE_$$PAD(WC,12)
+49 SET LINE=LINE_$$PAD(FC,11)
+50 SET LINE=LINE_$$PAD(LC,11)
+51 DO SET(LINE,.VALMCNT)
End DoDot:2
+52 DO SET("",.VALMCNT)
+53 SET LINE=""
+54 SET LINE="External Demand Subtotal"
+55 SET LINE=LINE_$$SP(16)
+56 SET INT=+$GET(^TMP("BSD",$JOB,"TOT",S1,"EXTERNAL"))
+57 SET LINE=LINE_$$PAD(INT,10)
+58 ;S LINE=LINE_$$PAD(+$G(^TMP("BSD",$J,"TOT",S1,"WI")),12)
+59 DO SET(LINE,.VALMCNT)
+60 SET LINE=""
+61 SET LINE=LINE_"Internal Demand Subtotal"
+62 SET LINE=LINE_$$SP(16)
+63 SET LINE=LINE_$$PAD(+$GET(^TMP("BSD",$JOB,"TOT",S1,"FU")),11)
+64 DO SET(LINE,.VALMCNT)
+65 SET LINE=""
+66 SET LINE=LINE_"Unmet Demand Subtotal"
+67 SET LINE=LINE_$$SP(19)
+68 SET LINE=LINE_$$PAD(+$GET(^TMP("BSD",$JOB,"TOT",S1,"WL")),11)
+69 DO SET(LINE,.VALMCNT)
+70 DO SET("",.VALMCNT)
End DoDot:1
+71 DO SET("",.VALMCNT)
+72 DO SET("",.VALMCNT)
+73 SET LINE="External Demand Total"
+74 SET LINE=LINE_$$SP(19)
+75 SET LINE=LINE_+$GET(^TMP("BSD",$JOB,"TOT","EXTTOTAL"))
+76 SET LINE=LINE_$$SP(10)_"FU Total"_$$SP(4)
+77 SET LINE=LINE_$GET(^TMP("BSD",$JOB,"TOT","FUTOTAL"))
+78 DO SET(LINE,.VALMCNT)
+79 KILL ^TMP("BSD",$JOB)
+80 QUIT
+81 ;
SUB1(C,N) ; -- return name of subcategory for clinic C
+1 IF BSDSUB="P"
QUIT $$PRIN^BSDU(C)
+2 IF BSDSUB="V"
QUIT $PIECE($$PRV^BSDU(C),U,2)
+3 IF BSDSUB="T"
QUIT $PIECE($$TEAM^BSDU(C),U,2)
+4 QUIT N
+5 ;
TYPE(C,D,N,P,S) ; -- return type of appt.
+1 ; returns column #
+2 ; 1=sched, 2=same day, 3=walk-in, 4=overbook, 5=inpt, 6=no-show
+3 ;no-show
IF S["NO-SHOW"
QUIT 6
+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 X=9
IF (D\1)=($PIECE($GET(^SC(C,"S",D,1,N,0)),U,7)\1)
QUIT 3
+7 ;future CR
IF X=9
IF (D\1)'=($PIECE($GET(^SC(C,"S",D,1,N,0)),U,7)\1)
QUIT 1
+8 ;same day appt
IF X=3
IF (D\1)=($PIECE($GET(^SC(C,"S",D,1,N,0)),U,7)\1)
QUIT 2
+9 ;sched overbook
IF $GET(^SC(C,"S",D,1,N,"OB"))="O"
QUIT 4
+10 ;scheduled
IF X=3
QUIT 1
+11 ;error in case one slips thru
QUIT "??"
+12 ;
INCR(SUB,TYPE,NAME,APPT,A,W,F,L) ; increment totals
+1 NEW DATE
SET DATE=APPT\1
+2 IF '$DATA(^TMP("BSD",$JOB,DATE,SUB,"APPT"))
SET ^TMP("BSD",$JOB,DATE,SUB,"APPT")=0
+3 SET ^TMP("BSD",$JOB,DATE,SUB,"APPT")=^TMP("BSD",$JOB,DATE,SUB,"APPT")+A
+4 IF '$DATA(^TMP("BSD",$JOB,DATE,SUB,"WI"))
SET ^TMP("BSD",$JOB,DATE,SUB,"WI")=0
+5 SET ^TMP("BSD",$JOB,DATE,SUB,"WI")=^TMP("BSD",$JOB,DATE,SUB,"WI")+W
+6 IF '$DATA(^TMP("BSD",$JOB,DATE,SUB,"FU"))
SET ^TMP("BSD",$JOB,DATE,SUB,"FU")=0
+7 SET ^TMP("BSD",$JOB,DATE,SUB,"FU")=^TMP("BSD",$JOB,DATE,SUB,"FU")+F
+8 IF '$DATA(^TMP("BSD",$JOB,DATE,SUB,"WL"))
SET ^TMP("BSD",$JOB,DATE,SUB,"WL")=0
+9 SET ^TMP("BSD",$JOB,DATE,SUB,"WL")=^TMP("BSD",$JOB,DATE,SUB,"WL")+L
+10 IF '$DATA(^TMP("BSD",$JOB,"TOT",DATE,"APPT"))
SET ^TMP("BSD",$JOB,"TOT",DATE,"APPT")=0
+11 SET ^TMP("BSD",$JOB,"TOT",DATE,"APPT")=^TMP("BSD",$JOB,"TOT",DATE,"APPT")+A
+12 IF '$DATA(^TMP("BSD",$JOB,DATE,"TOT","WI"))
SET ^TMP("BSD",$JOB,"TOT",DATE,"WI")=0
+13 SET ^TMP("BSD",$JOB,"TOT",DATE,"WI")=^TMP("BSD",$JOB,"TOT",DATE,"WI")+W
+14 IF '$DATA(^TMP("BSD",$JOB,"TOT",DATE,"FU"))
SET ^TMP("BSD",$JOB,"TOT",DATE,"FU")=0
+15 SET ^TMP("BSD",$JOB,"TOT",DATE,"FU")=^TMP("BSD",$JOB,"TOT",DATE,"FU")+F
+16 IF '$DATA(^TMP("BSD",$JOB,"TOT",DATE,"WL"))
SET ^TMP("BSD",$JOB,"TOT",DATE,"WL")=0
+17 SET ^TMP("BSD",$JOB,"TOT",DATE,"WL")=^TMP("BSD",$JOB,"TOT",DATE,"WL")+L
+18 IF '$DATA(^TMP("BSD",$JOB,"TOT",DATE,"EXTERNAL"))
SET ^TMP("BSD",$JOB,"TOT",DATE,"EXTERNAL")=0
+19 SET ^TMP("BSD",$JOB,"TOT",DATE,"EXTERNAL")=^TMP("BSD",$JOB,"TOT",DATE,"EXTERNAL")+(A+W)
+20 IF '$DATA(^TMP("BSD",$JOB,"TOT",DATE,"TOTAL"))
SET ^TMP("BSD",$JOB,"TOT",DATE,"TOTAL")=0
+21 SET ^TMP("BSD",$JOB,"TOT",DATE,"TOTAL")=^TMP("BSD",$JOB,"TOT",DATE,"TOTAL")+(A+W+F)
+22 IF '$DATA(^TMP("BSD",$JOB,"TOT","FUTOTAL"))
SET ^TMP("BSD",$JOB,"TOT","FUTOTAL")=0
+23 SET ^TMP("BSD",$JOB,"TOT","FUTOTAL")=^TMP("BSD",$JOB,"TOT","FUTOTAL")+F
+24 IF '$DATA(^TMP("BSD",$JOB,"TOT","EXTTOTAL"))
SET ^TMP("BSD",$JOB,"TOT","EXTTOTAL")=0
+25 SET ^TMP("BSD",$JOB,"TOT","EXTTOTAL")=^TMP("BSD",$JOB,"TOT","EXTTOTAL")+(A+W)
+26 IF '$DATA(^TMP("BSD",$JOB,"TOT","GRANDTOTAL"))
SET ^TMP("BSD",$JOB,"TOT","GRANDTOTAL")=0
+27 SET ^TMP("BSD",$JOB,"TOT","GRANDTOTAL")=^TMP("BSD",$JOB,"TOT","GRANDTOTAL")+(A+W+F)
+28 QUIT
+29 ;
FNDWL(C,A) ;-- check to see if a patient is on the wait list
+1 NEW AD,CNT,CL,BDA,PAT
+2 SET CNT=0
+3 IF $GET(CNTR(C,A))
QUIT 0
+4 SET CL=$ORDER(^BSDWL("B",C,0))
+5 IF '$GET(CL)
QUIT 0
+6 SET BDA=0
FOR
SET BDA=$ORDER(^BSDWL(CL,1,BDA))
IF 'BDA
QUIT
Begin DoDot:1
+7 IF $PIECE($GET(^BSDWL(CL,1,BDA,0)),U,7)
QUIT
+8 SET PAT=+$PIECE($GET(^BSDWL(CL,1,BDA,0)),U)
+9 SET AD=$PIECE($GET(^BSDWL(CL,1,BDA,0)),U,3)
+10 IF $$DEMO^APCLUTL(PAT,$GET(BSDDEMO))
QUIT
+11 IF AD=A
SET CNT=CNT+1
End DoDot:1
+12 SET CNTR(C,A)=1
+13 QUIT +$GET(CNT)
+14 ;
CNTAPP(C,A) ;-- count all appointments made on date passed in for clinic
+1 NEW AD,CNT,DAM,BDA,BDI,BDO,PAT,AP,BG,ED
+2 SET AP=$PIECE(A,".")
+3 SET CNT=0
+4 IF $GET(ACNTR(C,AP))
QUIT 0
+5 SET BG=AP-.0001
SET ED=AP+.9999
+6 SET BDA=BG
FOR
SET BDA=$ORDER(^SC("AIHSDAM",C,BDA))
IF 'BDA!(BDA>ED)
QUIT
Begin DoDot:1
+7 SET BDI=0
FOR
SET BDI=$ORDER(^SC("AIHSDAM",C,BDA,BDI))
IF 'BDI
QUIT
Begin DoDot:2
+8 SET BDO=0
FOR
SET BDO=$ORDER(^SC("AIHSDAM",C,BDA,BDI,BDO))
IF 'BDO
QUIT
Begin DoDot:3
+9 SET PAT=+$PIECE($GET(^SC(C,"S",BDI,1,BDO,0)),U)
+10 ;ihs/cmi/maw 08/08/2011 added for missing patient pointer
IF '$GET(PAT)
QUIT
+11 ;another bad data filter
IF '$DATA(^DPT(PAT,"S",BDI))
QUIT
+12 ;8/19/2010 screen out walkins per lisa dolan email
IF $$VALI^XBDIQ1(2.98,PAT_","_BDI,9)=4
QUIT
+13 SET DAM=$PIECE(BDA,".")
+14 IF $$DEMO^APCLUTL(PAT,$GET(BSDDEMO))
QUIT
+15 IF DAM=AP
SET CNT=CNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+16 SET ACNTR(C,AP)=1
+17 QUIT +$GET(CNT)
+18 ;
SET(LINE,NUM) ; -- sets display line into array
+1 SET NUM=NUM+1
+2 SET ^TMP("BSDWKR8",$JOB,NUM,0)=LINE
+3 QUIT
+4 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
HELP1 ;EP; help for subtotal question
+1 DO MSG^BDGF("This report will subtotal results any of 4 ways:",2,0)
+2 DO MSG^BDGF(" Choose C to subtotal by individual clinic;",1,0)
+3 DO MSG^BDGF(" Choose P to subtotal by principal clinic;",1,0)
+4 DO MSG^BDGF(" Choose V to subtotal by a clinic's provider;",1,0)
+5 DO MSG^BDGF(" Choose T to subtotal by a clinic's team.",1,0)
+6 DO MSG^BDGF("Clinics not affiliated with a principal clinic,",2,0)
+7 DO MSG^BDGF("provider or team, will be subtotaled under the",1,0)
+8 DO MSG^BDGF("""Unaffiliated"" designation.",1,1)
+9 QUIT
+10 ;
EXIT ; -- exit code
+1 KILL ^TMP("BSDWKR8",$JOB),CNTR,BSDDEMO,ACNTR
+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("BSDWKR8",$JOB,X))
IF 'X
QUIT
Begin DoDot:1
+3 IF $Y>(IOSL-4)
DO HDG
+4 WRITE !,^TMP("BSDWKR8",$JOB,X,0)
End DoDot:1
+5 DO ^%ZISC
DO EXIT
+6 QUIT
+7 ;
HDG ; heading for paper report
+1 ;,?30,"Advanced Access Report"
DO HDR
WRITE @IOF
+2 FOR I=1:1
IF '$DATA(VALMHDR(I))
QUIT
WRITE !,VALMHDR(I)
+3 WRITE !,$$REPEAT^XLFSTR("-",80)
+4 WRITE !,"Date",?13,"Category",?40,"Appt",?51,"WI"
+5 WRITE ?63,"FU",?74,"WL"
+6 WRITE !,$$REPEAT^XLFSTR("=",80)
+7 QUIT
+8 ;
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)
