Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BSDWKR8

BSDWKR8.m

Go to the documentation of this file. 
  1. BSDWKR8 ; cmi/flag/maw - BSD Advanced Access Report [ 01/04/2005  4:42 PM ]
  1.  ;;5.3;PIMS;**1012,1013**;APR 26, 2002
  1.  ;
  1. ASK ; -- ask user questions
  1.  NEW VAUTC,VAUTD,POP,BSDBD,BSDED,BSDTT,BSDDET,BSDSUB,BSDSRT,BSDSEEN,Y
  1.  ;
  1.  S BSDSUB=$$READ^BDGF("SO^C:Clinic;P:Principal Clinic;V:Provider;T:Team","Subtotal Report by","","^D HELP1^BSDWKR8")
  1.  Q:BSDSUB=""  Q:BSDSUB=U
  1.  ;
  1.  ; get clinic arrays based on subtotal category
  1.  I (BSDSUB="C")!(BSDSUB="P") D CLINIC^BSDU(2) Q:$D(BSDQ)
  1.  I (BSDSUB="V")!(BSDSUB="T") D PCASK^BSDU(2,BSDSUB) Q:$D(BSDQ)
  1.  ;
  1.  S BSDBD=$$READ^BDGF("DO^::EX","Select First Date to Search") Q:'BSDBD
  1.  S BSDED=$$READ^BDGF("DO^::EX","Select Last Date to Search") Q:'BSDED
  1.  ;
  1.  ;cmi/maw exclude demo patients here
  1.  D DEMOCHK^APCLUTL(.BSDDEMO)
  1.  Q:BSDDEMO=-1
  1.  ;
  1.  S Y=$$BROWSE^BDGF Q:"PB"'[Y  I Y="B" D EN Q  ;browse in list mgr mode
  1.  D ZIS^BDGF("PQ","START^BSDWKR8","ADVANCED ACCESS","BSDSUB;BSDBD;BSDED;VAUTC*;VAUTD*")
  1.  Q
  1.  ;
  1. START ;EP; -- re-entry for printing to paper
  1.  D INIT,PRINT Q
  1.  ;
  1. EN ; -- main entry point for BSDRM WORK STATS
  1.  NEW VALMCNT D TERM^VALM0,CLEAR^VALM1
  1.  D EN^VALM("BSDRM ADVANCED ACCESS")
  1.  D CLEAR^VALM1
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  S VALMHDR(1)=$$SP(30)_"Advanced Access Report"
  1.  S VALMHDR(2)=$$SP(20)_"For dates: "_$$RANGE^BDGF(BSDBD,BSDED)
  1.  S VALMHDR(3)=$$SP(40)_"External Demand"_$$SP(8)_"Internal"_$$SP(3)_"Unmet"
  1.  Q
  1.  ;
  1. INIT ; -- init variables and list array
  1.  S VALMCNT=0 K ^TMP("BSDWKR8",$J),^TMP("BSD",$J)
  1.  NEW BSDAR S BSDAR=$S(VAUTC:"^SC",1:"VAUTC")
  1.  ;
  1.  ; -- loop by clinic
  1.  NEW CLN,NAME,SUB,APPT,APPN,PAT,STATUS,TYPE,SUB2,END,APPTM,WI,FU,WL,AP
  1.  S CLN=0 F  S CLN=$O(@BSDAR@(CLN)) Q:'CLN  D
  1.  . Q:'$$GET1^DIQ(44,CLN,3.5,"I")  ;No Div entered for this clinic
  1.  . I $D(VAUTD) Q:(VAUTD'=1&('$D(VAUTD($$GET1^DIQ(44,CLN,3.5,"I")))))  ;this Div notd
  1.  . Q:$D(^SC("AIHSPC",CLN))               ;quit if principal clinic
  1.  . S NAME=$$GET1^DIQ(44,CLN,.01)         ;set clinic's name
  1.  . S SUB=$$SUB1(CLN,NAME)                ;get subcategory for clinic
  1.  . ;
  1.  . ; -- then by appt date (within range)
  1.  . S APPT=BSDBD,END=BSDED+.2400
  1.  . F  S APPT=$O(^SC(CLN,"S",APPT)) Q:'APPT!(APPT>END)  D
  1.  .. ;
  1.  .. ; -- then find appts to count
  1.  .. S APPN=0
  1.  .. F  S APPN=$O(^SC(CLN,"S",APPT,1,APPN)) Q:'APPN  D
  1.  ... S PAT=+^SC(CLN,"S",APPT,1,APPN,0)             ;patient ien
  1.  ... Q:$$DEMO^APCLUTL(PAT,$G(BSDDEMO))
  1.  ... S APPTM=$P($G(^SC(CLN,"S",APPT,1,APPN,0)),U,7)  ;date appointment made
  1.  ... S STATUS=$$VAL^XBDIQ1(2.98,PAT_","_APPT,100)  ;current status
  1.  ... S AP=$$CNTAPP(CLN,APPT)  ;count all appointments made this day
  1.  ... ;S AP=$S($P(APPTM,".")=$P(APPT,"."):1,1:0)  ;check if appointment made on same day
  1.  ... S WI=$S($$VALI^XBDIQ1(2.98,PAT_","_APPT,9)=4:1,1:0)  ;type of appointment
  1.  ... S FU=$$VALI^XBDIQ1(2.98,PAT_","_APPT,28)
  1.  ... S WL=$$FNDWL(CLN,$P(APPT,"."))
  1.  ... Q:STATUS["CANCEL"
  1.  ... Q:STATUS="NON-COUNT"  Q:STATUS="DELETED"
  1.  ... S TYPE=$$TYPE(CLN,APPT,APPN,PAT,STATUS)      ;type of appt
  1.  ... ; increment totals
  1.  ... D INCR(SUB,TYPE,NAME,APPT,AP,WI,FU,WL)
  1.  ;
  1.  N S1,S2,AC,WC,FC,LC,INT
  1.  S S1=0 F  S S1=$O(^TMP("BSD",$J,S1)) Q:S1=""  D
  1.  . Q:S1="TOT"
  1.  . S LINE=$$PAD($$FMTE^XLFDT(S1),14)
  1.  . D SET(LINE,.VALMCNT)
  1.  . S S2=0 F  S S2=$O(^TMP("BSD",$J,S1,S2)) Q:S2=""  D
  1.  .. S AC=+$G(^TMP("BSD",$J,S1,S2,"APPT"))
  1.  .. S WC=+$G(^TMP("BSD",$J,S1,S2,"WI"))
  1.  .. S FC=+$G(^TMP("BSD",$J,S1,S2,"FU"))
  1.  .. S LC=+$G(^TMP("BSD",$J,S1,S2,"WL"))
  1.  .. S LINE=""
  1.  .. S LINE=LINE_$$PAD($$SP(13)_S2,40)
  1.  .. S LINE=LINE_$$PAD(AC,11)
  1.  .. S LINE=LINE_$$PAD(WC,12)
  1.  .. S LINE=LINE_$$PAD(FC,11)
  1.  .. S LINE=LINE_$$PAD(LC,11)
  1.  .. D SET(LINE,.VALMCNT)
  1.  . D SET("",.VALMCNT)
  1.  . S LINE=""
  1.  . S LINE="External Demand Subtotal"
  1.  . S LINE=LINE_$$SP(16)
  1.  . S INT=+$G(^TMP("BSD",$J,"TOT",S1,"EXTERNAL"))
  1.  . S LINE=LINE_$$PAD(INT,10)
  1.  . ;S LINE=LINE_$$PAD(+$G(^TMP("BSD",$J,"TOT",S1,"WI")),12)
  1.  . D SET(LINE,.VALMCNT)
  1.  . S LINE=""
  1.  . S LINE=LINE_"Internal Demand Subtotal"
  1.  . S LINE=LINE_$$SP(16)
  1.  . S LINE=LINE_$$PAD(+$G(^TMP("BSD",$J,"TOT",S1,"FU")),11)
  1.  . D SET(LINE,.VALMCNT)
  1.  . S LINE=""
  1.  . S LINE=LINE_"Unmet Demand Subtotal"
  1.  . S LINE=LINE_$$SP(19)
  1.  . S LINE=LINE_$$PAD(+$G(^TMP("BSD",$J,"TOT",S1,"WL")),11)
  1.  . D SET(LINE,.VALMCNT)
  1.  . D SET("",.VALMCNT)
  1.  D SET("",.VALMCNT)
  1.  D SET("",.VALMCNT)
  1.  S LINE="External Demand Total"
  1.  S LINE=LINE_$$SP(19)
  1.  S LINE=LINE_+$G(^TMP("BSD",$J,"TOT","EXTTOTAL"))
  1.  S LINE=LINE_$$SP(10)_"FU Total"_$$SP(4)
  1.  S LINE=LINE_$G(^TMP("BSD",$J,"TOT","FUTOTAL"))
  1.  D SET(LINE,.VALMCNT)
  1.  K ^TMP("BSD",$J)
  1.  Q
  1.  ;
  1. SUB1(C,N) ; -- return name of subcategory for clinic C 
  1.  I BSDSUB="P" Q $$PRIN^BSDU(C)
  1.  I BSDSUB="V" Q $P($$PRV^BSDU(C),U,2)
  1.  I BSDSUB="T" Q $P($$TEAM^BSDU(C),U,2)
  1.  Q N
  1.  ;
  1. TYPE(C,D,N,P,S) ; -- return type of appt.
  1.  ; returns column #
  1.  ;     1=sched, 2=same day, 3=walk-in, 4=overbook, 5=inpt, 6=no-show
  1.  I S["NO-SHOW" Q 6                                   ;no-show
  1.  I S["INPAT" Q 5                                     ;inpatient
  1.  NEW X S X=$P($G(^DPT(P,"S",D,0)),U,7) I X=4 Q 3         ;walkin
  1.  I X=9,(D\1)=($P($G(^SC(C,"S",D,1,N,0)),U,7)\1) Q 3    ;same day CR
  1.  I X=9,(D\1)'=($P($G(^SC(C,"S",D,1,N,0)),U,7)\1) Q 1   ;future CR
  1.  I X=3,(D\1)=($P($G(^SC(C,"S",D,1,N,0)),U,7)\1) Q 2    ;same day appt
  1.  I $G(^SC(C,"S",D,1,N,"OB"))="O" Q 4                 ;sched overbook
  1.  I X=3 Q 1                                           ;scheduled
  1.  Q "??"    ;error in case one slips thru
  1.  ;
  1. INCR(SUB,TYPE,NAME,APPT,A,W,F,L) ; increment totals
  1.  NEW DATE S DATE=APPT\1
  1.  S:'$D(^TMP("BSD",$J,DATE,SUB,"APPT")) ^TMP("BSD",$J,DATE,SUB,"APPT")=0
  1.  S ^TMP("BSD",$J,DATE,SUB,"APPT")=^TMP("BSD",$J,DATE,SUB,"APPT")+A
  1.  S:'$D(^TMP("BSD",$J,DATE,SUB,"WI")) ^TMP("BSD",$J,DATE,SUB,"WI")=0
  1.  S ^TMP("BSD",$J,DATE,SUB,"WI")=^TMP("BSD",$J,DATE,SUB,"WI")+W
  1.  S:'$D(^TMP("BSD",$J,DATE,SUB,"FU")) ^TMP("BSD",$J,DATE,SUB,"FU")=0
  1.  S ^TMP("BSD",$J,DATE,SUB,"FU")=^TMP("BSD",$J,DATE,SUB,"FU")+F
  1.  S:'$D(^TMP("BSD",$J,DATE,SUB,"WL")) ^TMP("BSD",$J,DATE,SUB,"WL")=0
  1.  S ^TMP("BSD",$J,DATE,SUB,"WL")=^TMP("BSD",$J,DATE,SUB,"WL")+L
  1.  S:'$D(^TMP("BSD",$J,"TOT",DATE,"APPT")) ^TMP("BSD",$J,"TOT",DATE,"APPT")=0
  1.  S ^TMP("BSD",$J,"TOT",DATE,"APPT")=^TMP("BSD",$J,"TOT",DATE,"APPT")+A
  1.  S:'$D(^TMP("BSD",$J,DATE,"TOT","WI")) ^TMP("BSD",$J,"TOT",DATE,"WI")=0
  1.  S ^TMP("BSD",$J,"TOT",DATE,"WI")=^TMP("BSD",$J,"TOT",DATE,"WI")+W
  1.  S:'$D(^TMP("BSD",$J,"TOT",DATE,"FU")) ^TMP("BSD",$J,"TOT",DATE,"FU")=0
  1.  S ^TMP("BSD",$J,"TOT",DATE,"FU")=^TMP("BSD",$J,"TOT",DATE,"FU")+F
  1.  S:'$D(^TMP("BSD",$J,"TOT",DATE,"WL")) ^TMP("BSD",$J,"TOT",DATE,"WL")=0
  1.  S ^TMP("BSD",$J,"TOT",DATE,"WL")=^TMP("BSD",$J,"TOT",DATE,"WL")+L
  1.  S:'$D(^TMP("BSD",$J,"TOT",DATE,"EXTERNAL")) ^TMP("BSD",$J,"TOT",DATE,"EXTERNAL")=0
  1.  S ^TMP("BSD",$J,"TOT",DATE,"EXTERNAL")=^TMP("BSD",$J,"TOT",DATE,"EXTERNAL")+(A+W)
  1.  S:'$D(^TMP("BSD",$J,"TOT",DATE,"TOTAL")) ^TMP("BSD",$J,"TOT",DATE,"TOTAL")=0
  1.  S ^TMP("BSD",$J,"TOT",DATE,"TOTAL")=^TMP("BSD",$J,"TOT",DATE,"TOTAL")+(A+W+F)
  1.  S:'$D(^TMP("BSD",$J,"TOT","FUTOTAL")) ^TMP("BSD",$J,"TOT","FUTOTAL")=0
  1.  S ^TMP("BSD",$J,"TOT","FUTOTAL")=^TMP("BSD",$J,"TOT","FUTOTAL")+F
  1.  S:'$D(^TMP("BSD",$J,"TOT","EXTTOTAL")) ^TMP("BSD",$J,"TOT","EXTTOTAL")=0
  1.  S ^TMP("BSD",$J,"TOT","EXTTOTAL")=^TMP("BSD",$J,"TOT","EXTTOTAL")+(A+W)
  1.  S:'$D(^TMP("BSD",$J,"TOT","GRANDTOTAL")) ^TMP("BSD",$J,"TOT","GRANDTOTAL")=0
  1.  S ^TMP("BSD",$J,"TOT","GRANDTOTAL")=^TMP("BSD",$J,"TOT","GRANDTOTAL")+(A+W+F)
  1.  Q
  1.  ;
  1. FNDWL(C,A) ;-- check to see if a patient is on the wait list
  1.  N AD,CNT,CL,BDA,PAT
  1.  S CNT=0
  1.  I $G(CNTR(C,A)) Q 0
  1.  S CL=$O(^BSDWL("B",C,0))
  1.  I '$G(CL) Q 0
  1.  S BDA=0 F  S BDA=$O(^BSDWL(CL,1,BDA)) Q:'BDA  D
  1.  . Q:$P($G(^BSDWL(CL,1,BDA,0)),U,7)
  1.  . S PAT=+$P($G(^BSDWL(CL,1,BDA,0)),U)
  1.  . S AD=$P($G(^BSDWL(CL,1,BDA,0)),U,3)
  1.  . Q:$$DEMO^APCLUTL(PAT,$G(BSDDEMO))
  1.  . I AD=A S CNT=CNT+1
  1.  S CNTR(C,A)=1
  1.  Q +$G(CNT)
  1.  ;
  1. CNTAPP(C,A) ;-- count all appointments made on date passed in for clinic
  1.  N AD,CNT,DAM,BDA,BDI,BDO,PAT,AP,BG,ED
  1.  S AP=$P(A,".")
  1.  S CNT=0
  1.  I $G(ACNTR(C,AP)) Q 0
  1.  S BG=AP-.0001,ED=AP+.9999
  1.  S BDA=BG F  S BDA=$O(^SC("AIHSDAM",C,BDA)) Q:'BDA!(BDA>ED)  D
  1.  . S BDI=0 F  S BDI=$O(^SC("AIHSDAM",C,BDA,BDI)) Q:'BDI  D
  1.  .. S BDO=0 F  S BDO=$O(^SC("AIHSDAM",C,BDA,BDI,BDO)) Q:'BDO  D
  1.  ... S PAT=+$P($G(^SC(C,"S",BDI,1,BDO,0)),U)
  1.  ... Q:'$G(PAT)  ;ihs/cmi/maw 08/08/2011 added for missing patient pointer
  1.  ... Q:'$D(^DPT(PAT,"S",BDI))  ;another bad data filter
  1.  ... Q:$$VALI^XBDIQ1(2.98,PAT_","_BDI,9)=4  ;8/19/2010 screen out walkins per lisa dolan email
  1.  ... S DAM=$P(BDA,".")
  1.  ... Q:$$DEMO^APCLUTL(PAT,$G(BSDDEMO))
  1.  ... I DAM=AP S CNT=CNT+1
  1.  S ACNTR(C,AP)=1
  1.  Q +$G(CNT)
  1.  ;
  1. SET(LINE,NUM) ; -- sets display line into array
  1.  S NUM=NUM+1
  1.  S ^TMP("BSDWKR8",$J,NUM,0)=LINE
  1.  Q
  1.  ;
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. HELP1 ;EP; help for subtotal question
  1.  D MSG^BDGF("This report will subtotal results any of 4 ways:",2,0)
  1.  D MSG^BDGF("  Choose C to subtotal by individual clinic;",1,0)
  1.  D MSG^BDGF("  Choose P to subtotal by principal clinic;",1,0)
  1.  D MSG^BDGF("  Choose V to subtotal by a clinic's provider;",1,0)
  1.  D MSG^BDGF("  Choose T to subtotal by a clinic's team.",1,0)
  1.  D MSG^BDGF("Clinics not affiliated with a principal clinic,",2,0)
  1.  D MSG^BDGF("provider or team, will be subtotaled under the",1,0)
  1.  D MSG^BDGF("""Unaffiliated"" designation.",1,1)
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  K ^TMP("BSDWKR8",$J),CNTR,BSDDEMO,ACNTR
  1.  Q
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;
  1. PRINT ; print report to paper
  1.  U IO D HDG
  1.  NEW X S X=0 F  S X=$O(^TMP("BSDWKR8",$J,X)) Q:'X  D
  1.  . I $Y>(IOSL-4) D HDG
  1.  . W !,^TMP("BSDWKR8",$J,X,0)
  1.  D ^%ZISC,EXIT
  1.  Q
  1.  ;
  1. HDG ; heading for paper report
  1.  D HDR W @IOF  ;,?30,"Advanced Access Report"
  1.  F I=1:1 Q:'$D(VALMHDR(I))  W !,VALMHDR(I)
  1.  W !,$$REPEAT^XLFSTR("-",80)
  1.  W !,"Date",?13,"Category",?40,"Appt",?51,"WI"
  1.  W ?63,"FU",?74,"WL"
  1.  W !,$$REPEAT^XLFSTR("=",80)
  1.  Q
  1.  ;
  1. PAD(D,L) ;EP -- SUBRTN to pad length of data
  1.  ; -- D=data L=length
  1.  Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
  1.  ;
  1. SP(N) ; -- SUBRTN to pad N number of spaces
  1.  Q $$PAD(" ",N)