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

BSDCCR0.m

Go to the documentation of this file. 
  1. BSDCCR0 ; IHS/ANMC/LJF - CLINIC CAPACITY REPORT ; 
  1.  ;;5.3;PIMS;**1011**;APR 26, 2002
  1.  ;IHS modified COPY OF SCRPW70 before VA patch #223
  1.  ;IHS/ANMC/LJF 10/06/2000 removed message about 132 columns
  1.  ;                        changed report title
  1.  ;                        expanded clinic list if princ clinic chosen
  1.  ;                        used IHS call for clinic code question
  1.  ;
  1.  ;cmi/flag/maw 11/9/2009 PATCH 1011 added call to CLINIC^BSDU so taxonomy can be called
  1.  ;
  1.  ;
  1.  N SDEX,SDDIV,DIR,SDFMT,SDMAX,SDSORT,SDOUT,X,Y,DTOUT,DUOUT
  1.  S (SDEX,SDOUT)=0
  1.  ;D TITL^SCRPW50("Clinic Appointment Availability Report")  ;IHS/ANMC/LJF 10/6/2000
  1.  D TITL^SCRPW50("Clinic Appointment Capacity Report")  ;IHS/ANMC/LJF 10/6/2000
  1.  I '$$DIVA^SCRPW17(.SDDIV) S SDOUT=1 G EXIT^BSDCCR4
  1.  D SUBT^SCRPW50("**** Date Range Selection ****")
  1.  W ! S %DT="AEX",%DT("A")="Beginning date: " D ^%DT I Y<1 S SDOUT=1 G EXIT^BSDCCR4
  1.  S SDBDT=Y X ^DD("DD") S SDPBDT=Y
  1. EDT S %DT("A")="   Ending date: " W ! D ^%DT I Y<1 S SDOUT=1 G EXIT^BSDCCR4
  1.  I Y<SDBDT W !!,$C(7),"End date cannot be before begin date!",! G EDT
  1.  S SDEDT=Y_.999999 X ^DD("DD") S SDPEDT=Y
  1.  S SDMAX=Y D SUBT^SCRPW50("**** Report Format Selection ***")
  1.  S DIR(0)="S^S:SUMMARY FOR DATE RANGE;D:DETAIL BY DAY",DIR("A")="Select report format"
  1.  W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT^BSDCCR4
  1.  ;S SDFMT=Y G:SDFMT="S" QUE S DIR("B")="CLINIC NAME"
  1.  S SDFMT=Y S DIR("B")="CLINIC NAME"
  1.  ;
  1.  ;IHS/ANMC/LJF 10/6/2000 modified lines below
  1.  ;S DIR(0)="S^CL:CLINIC NAME;CP:CREDIT PAIR",DIR("A")="Specify limiting category for detail"
  1.  ;S DIR("?")="Indicate if availability should be limited by clinic name or DSS credit pair."
  1.  S DIR(0)="S^CL:CLINIC NAME;CC:CLINIC CODE",DIR("A")="Specify limiting category for detail"
  1.  S DIR("?")="Indicate if availability should be limited by clinic name or clinic stop code."
  1.  ;IHS/ANMC/LJF 10/6/2000 end of code changes
  1.  ;
  1.  W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT^BSDCCR4
  1.  S SDSORT=Y I '$$SORT(.SDSORT) S SDOUT=1 G EXIT^BSDCCR4
  1.  G:SDOUT EXIT^BSDCCR4
  1. QUE ;I SDBDT'>DT W !!,"This report requires 132 column output!"  ;IHS/ANMC/LJF 10/6/2000
  1.  N ZTSAVE F X="SDEX","SDBDT","SDPBDT","SDEDT","SDPEDT","SDDIV","SDDIV(","SDFMT","SDSORT","SDSORT(" S ZTSAVE(X)=""
  1.  W ! D EN^XUTMDEVQ("START^BSDCCR2","Clinic Appointment Availability Report",.ZTSAVE) S SDOUT=1 G EXIT^BSDCCR4
  1.  ;
  1. SORT(SDSORT) ;Gather sort values for detailed report
  1.  ;Input: SDSORT=sort category (pass by reference)
  1.  ;Output: '1' if selection(s) made, '0' otherwise
  1.  ;        SDSORT(clinic name)=clinic ifn 
  1.  ;                    (or)
  1.  ;        SDSORT(credit pair)=credit pair
  1.  ;
  1.  I SDSORT="CC" S SDSORT="CP"  ;IHS/ANMC/LJF 10/6/2000
  1.  D @SDSORT Q $D(SDSORT)>1
  1.  ;
  1. CL ;Select clinics for detail
  1.  N SDQUIT S (SDQUIT,SDOUT)=0
  1.  ;N DIC,SDQUIT S (SDQUIT,SDOUT)=0
  1.  ;S DIC="^SC(",DIC(0)="AEMQ",DIC("A")="Select CLINIC: ",DIC("S")="I $P(^(0),U,3)=""C"""
  1.  ;W ! F  Q:SDOUT!SDQUIT  D
  1.  ;.D ^DIC I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
  1.  ;.I X="" S SDQUIT=1 Q
  1.  ;.I Y S SDSORT($P(Y,U,2))=+Y
  1.  ;.Q
  1.  D CLINIC^BSDU(1)
  1.  N SDA
  1.  S SDA=0 F  S SDA=$O(VAUTC(SDA)) Q:SDA=""  D
  1.  . S SDSORT(SDA)=$G(VAUTC(SDA))
  1.  D EXPNDPC^BSDU(1,.SDSORT)  ;IHS/ANMC/LJF 10/6/2000
  1.  Q
  1.  ;
  1. CP ;Get credit pairs for detail
  1.  D CP^BSDCCRL Q  ;IHS/ANMC/LJF 10/6/2000
  1.  N DIR,SDQUIT S (SDQUIT,SDOUT)=0
  1.  S DIR(0)="NO:101000:999000:0",DIR("A")="Select clinic DSS credit pair"
  1.  S DIR("?",1)="Specify a six digit number that represents the primary and secondary stop"
  1.  S DIR("?",2)="code of clinics you wish to evaluate.  For clinics that do not have a"
  1.  S DIR("?",3)="secondary stop code, enter ""000"" as the second half of the credit pair"
  1.  S DIR("?")="(eg. ""323000"")."
  1.  W ! F  Q:SDOUT!SDQUIT  D
  1.  .D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
  1.  .I X="" S SDQUIT=1 Q
  1.  .I '$$VCP(Y) W "  Invalid credit pair!" Q
  1.  .S SDSORT(Y)=Y
  1.  .Q
  1.  Q
  1.  ;
  1. VCP(Y) ;Validate credit pair
  1.  ;Input: Y=credit pair
  1.  ;Output: '1' if valid, '0' otherwise
  1.  Q:Y'?6N 0
  1.  Q:'$D(^DIC(40.7,"C",$E(Y,1,3))) 0
  1.  Q:$E(Y,4,6)="000" 1
  1.  Q:'$D(^DIC(40.7,"C",$E(Y,4,6))) 0
  1.  Q 1
  1.  ;
  1. RESEND ;Entry point for manually initiating extracts for the current month
  1.  N DIR,SDXTMP,SDMON,SDI,SDT
  1.  W !!,$C(7),"NOTE:  Use of this utility will result in the transmission of extract data to"
  1.  W !,"Austin.  It should only be used if automatically queued extracts failed to run."
  1.  M SDXTMP=^XTMP("SD53P192") D QDIS^BSDCCR4(.SDXTMP)
  1.  F SDI=1,2 I $G(SDXTMP("EXTRACT",SDI,"DATE"))<DT D  Q:$D(DTOUT)!$D(DUOUT)
  1.  .W !!,"Extract ",SDI," doesn't appear to be tasked to run repetitively in the future."
  1.  .S DIR(0)="Y",DIR("A")="Do you wish to schedule it now",DIR("B")="YES"
  1.  .W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT)  D:Y RQUE(SDI)
  1.  .Q
  1.  Q:$D(DTOUT)!$D(DUOUT)
  1.  S DIR(0)="Y",DIR("B")="NO"
  1.  F SDI=1,2 D  Q:$D(DTOUT)!$D(DUOUT)
  1.  .S SDT=DT S:SDI=1 SDT=$S($E(SDT,4,5)="01":$E(SDT,1,3)-1_12_$E(SDT,6,7),1:$E(SDT,1,5)-1_$E(SDT,6,7))
  1.  .S DIR("A")="Do you want transmit Extract "_SDI_" for "_$P($$MON^BSDCCR4(SDI,SDT,.SDMON),U)_" to Austin"
  1.  .W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT)  D:Y QUEUE(.SDMON)
  1.  .Q
  1.  Q
  1.  ;
  1. REQUE ;Entry point for initiating repetitive tasking of extracts
  1.  N DIR,SDXTMP
  1.  M SDXTMP=^XTMP("SD53P192") D QDIS^BSDCCR4(.SDXTMP)
  1.  I '$D(SDXTMP) D  W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT)  I Y D RQUE("B") Q
  1.  .S DIR(0)="Y",DIR("A")="Do you want to schedule both extracts now"
  1.  .S DIR("B")="YES"
  1.  .Q
  1.  Q:$D(DTOUT)!$D(DUOUT)  K DIR
  1.  S DIR(0)="S^1:EXTRACT 1 (PROSPECTIVE);2:EXTRACT 2 (RETROSPECTIVE);B:BOTH EXTRACTS"
  1.  S DIR("?",1)="Extract 1 returns future clinic availability, extract 2 returns previous",DIR("?")="clinic availability and utilization."
  1.  S DIR("A")="Specify which extract you wish to schedule"
  1.  W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT)  D RQUE(Y)
  1.  Q
  1.  ;
  1. RQUE(SDEX) ;Schedule extract for repetitive run
  1.  ;Input: SDEX=extract type, '1', '2' or 'B' for both
  1.  I SDEX="B" D RQUE(1) Q:$D(DTOUT)!$D(DUOUT)  D RQUE(2) Q
  1.  N SDMON,SDNOW,SDOUT,DIR,Y,SDT
  1.  S SDNOW=$$NOW^XLFDT(),SDOUT=0,Y=$G(SDXTMP("EXTRACT",SDEX,"DATE"))
  1.  I Y>SDNOW D  Q:$D(DTOUT)!$D(DUOUT)  Q:SDOUT
  1.  .W !!,"Extract ",SDEX," appears to be queued for the future--"
  1.  .X ^DD("DD") W !!,"Scheduled for: ",Y,", task number: ",$G(SDXTMP("EXTRACT",SDEX,"TASK"))
  1.  .S DIR(0)="Y",DIR("B")="NO"
  1.  .S DIR("A")="Do you want to delete this task and re-schedule extract "_SDEX
  1.  .W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT)  S SDOUT='Y
  1.  .Q:'Y  S ZTSK=$G(SDXTMP("EXTRACT",SDEX,"TASK")) D KILL^%ZTLOAD
  1.  .K ^XTMP("SD53P192","EXTRACT",SDEX) Q
  1.  S SDT=$$WHEN^BSDCCR4(SDEX),SDRPT=$$MON^BSDCCR4(SDEX,SDT,.SDMON)
  1.  D SCHED^BSDCCR4(SDEX,SDT,SDRPT,.SDMON) Q
  1.  ;
  1. QUEUE(SDMON) ;Queue extraction for re-run
  1.  ;Input: SDMON=array of input parameters (as described in MON^BSDCCR4)
  1.  N %DT,SDI,Y,ZTSK,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSAVE
  1.  S Y=DT_.22 X ^DD("DD") S %DT("B")=Y,%DT("A")="Queue to run: "
  1.  S %DT="AEFXR" W ! D ^%DT I Y<1 G QQ
  1.  S ZTDTH=Y,ZTSAVE("SDMON(")="",ZTRTN="RUN^BSDCCR4(0)",ZTIO=""
  1.  S ZTDESC="Clinic Appointment Wait Time Extract ("_SDMON("SDEX")_")"
  1.  F SDI=1:1:20 D ^%ZTLOAD Q:$G(ZTSK)
  1.  ;
  1. QQ I '$G(ZTSK) W !!,"Extract not queued!!!",! Q
  1.  W !!,"Task number: ",ZTSK,! Q
  1.  ;
  1. TXXM ;Transmit extract data
  1.  N SDFAC,SDL,SDIV,SDCP,SC,SDI,SDX,SDEX,SDY,SDZ,SDP,SDSIZE,SDMG
  1.  S SDFAC=$P($$SITE^VASITE(),U,3),SDXM=1,SDL=0,SDIV="",SDSIZE=0
  1.  S SDEX=$S(SDPAST:2,1:1),SDMG=$P($G(^SD(404.91,1,"PATCH192")),U,(6+SDEX))
  1.  S:SDMG="" SDMG="G.SC CLINIC WAIT TIME"
  1.  F  S SDIV=$O(^TMP("SD",$J,SDIV)) Q:SDIV=""  S SDCP=0 D
  1.  .F  S SDCP=$O(^TMP("SD",$J,SDIV,SDCP)) Q:'SDCP  S SC=0 D
  1.  ..F  S SC=$O(^TMP("SD",$J,SDIV,SDCP,SC)) Q:'SC  D
  1.  ...I SDSIZE>29000 D EXXM(SDMG)
  1.  ...S SDX="#"_SDFAC_U_SDEXDT_U_SDEX_U_SDBDT_U_$P(SDIV,U,2)_U_SDCP_U_SC_U
  1.  ...S SDI="" F  S SDI=$O(^TMP("SD",$J,SDIV,SDCP,SC,SDI)) Q:SDI=""  D
  1.  ....S SDY=^TMP("SD",$J,SDIV,SDCP,SC,SDI) Q:'$L(SDY)
  1.  ....F SDP=1:1 S SDZ=$P(SDY,U,SDP) Q:SDZ=""  D
  1.  .....I $L(SDX)>220 D XMTX(SDX) S SDX=""
  1.  .....S SDX=SDX_$S($E(SDX,$L(SDX))=U:"",1:"|")_SDZ
  1.  .....Q
  1.  ....Q
  1.  ...I SDEX=1 S SDX=SDX_"$" D XMTX(SDX) Q
  1.  ...S SDY=$G(^TMP("SDNAVA",$J,SDIV,SDCP,SC))  ;get next ava. info.
  1.  ...S SDY=$$NAVA(SDY)
  1.  ...I $L(SDX)+$L(SDY)>240 D XMTX(SDX) S SDX=""
  1.  ...S SDX=SDX_SDY_"$" D XMTX(SDX)
  1.  ...Q
  1.  ..Q
  1.  .Q
  1.  D:$D(^TMP("SDXM",$J)) EXXM(SDMG)
  1.  Q
  1.  ;
  1. EXXM(XMG) ;Send extract mail message
  1.  ;Input: XMG=mail group to receive message
  1.  N XMSUB,XMDUZ,XMDUN,XMTEXT,XMY,XMZ
  1.  S XMSUB="Clinic Appointment Waiting Time Extract ("_SDEX_")"
  1.  S (XMDUZ,XMDUN)="Patch SD*5.3*192",XMTEXT="^TMP(""SDXM"",$J,"
  1.  S XMY(XMG)="" D ^XMD
  1.  K ^TMP("SDXM",$J) S SDXM=1,SDSIZE=0
  1.  Q
  1.  ;
  1. XMTX(SDX) ;Set mail message line
  1.  ;Input: SDX=text value
  1.  S ^TMP("SDXM",$J,SDXM)=SDX,SDXM=SDXM+1,SDSIZE=SDSIZE+$L(SDX)
  1.  Q
  1.  ;
  1.  ;Input: SDY=next ava. numbers from ^TMP("SDNAVA",$J,SDCP,SC)
  1.  ;
  1.  N SDI,SDX
  1.  S SDX="^" F SDI=0:1:3 D
  1.  .S:SDI SDX=SDX_"|"
  1.  .S SDX=SDX_SDI_"~"_+$P(SDY,U,(SDI+SDI+1))_"~"_+$P(SDY,U,(SDI+SDI+2))
  1.  .Q
  1.  Q SDX