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

DVBCAMR2.m

Go to the documentation of this file.
  1. DVBCAMR2 ;ALB/GTS-557/THM-REGIONAL OFFICE AMIS 290 REPORT, CALCULATIONS ; 9/28/91 6:43 AM
  1. ;;2.7;AMIE;**149,184**;Apr 10, 1995;Build 10
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ;** Version Changes
  1. ; 2.7 - GTS/Coded to adjust 35 day clock calc (Enhc 13)
  1. ;
  1. DAY30 ;exam completion
  1. N DVBADTS,DVBAPPTS,DVBACNT,DVBADTM,DVBANDE,X,X1,X2
  1. K ^TMP("DVBC",$J),^TMP($J,"SDAMA301")
  1. ;DES Type exams required to be completed in 45 days, all others 30
  1. S DVBADTS=$S(((";IDES;")[(";"_DVBAPREXM_";")):45,1:30)
  1. ;setup call to scheduling API
  1. S DVBAPPTS(1)=DTRPT_";"_EDATE,DVBAPPTS(4)=PNAM,DVBAPPTS(3)="R;I;NT"
  1. S DVBAPPTS("SORT")="P",DVBAPPTS("FLDS")="10"
  1. S DVBACNT=$$SDAPI^SDAMA301(.DVBAPPTS)
  1. I (DVBACNT'>0) K ^TMP($J,"SDAMA301") Q
  1. S DVBADTM=""
  1. F S DVBADTM=$O(^TMP($J,"SDAMA301",PNAM,DVBADTM)) Q:('+DVBADTM) D
  1. .S ^TMP("DVBC",$J,9999999-DVBADTM,DVBADTM)=""
  1. S DVBANDE=$O(^TMP("DVBC",$J,0)),DVBADTM=$O(^TMP("DVBC",$J,DVBANDE,0))
  1. D:(DVBADTM]"")
  1. .S X2=DVBADTM,X1=$S(DTSCHEDC]"":DTSCHEDC,1:DVBCNOW)
  1. .D ^%DTC ;calculate date diff
  1. .S:(X>DVBADTS) TOT(DVBAPREXM,"30DAYEX")=TOT(DVBAPREXM,"30DAYEX")+1
  1. K ^TMP($J,"SDAMA301")
  1. Q
  1. ;
  1. PENDCNT I X'<0&(X'>90) S TOT(DVBAPREXM,"P90")=TOT(DVBAPREXM,"P90")+1
  1. I X>90&(X'>120) S TOT(DVBAPREXM,"P121")=TOT(DVBAPREXM,"P121")+1
  1. I X>120&(X'>150) S TOT(DVBAPREXM,"P151")=TOT(DVBAPREXM,"P151")+1
  1. I X>150&(X'>180) S TOT(DVBAPREXM,"P181")=TOT(DVBAPREXM,"P181")+1
  1. I X>180&(X'>365) S TOT(DVBAPREXM,"P365")=TOT(DVBAPREXM,"P365")+1
  1. I X>365 S TOT(DVBAPREXM,"P366")=TOT(DVBAPREXM,"P366")+1
  1. Q
  1. ;
  1. SET ;
  1. N DVBAPREXM
  1. S DTA=^DVB(396.3,REQDA,0),DTREQ=$P(DTA,U,2),XRONUM=$P(DTA,U,3),XRONUM=$S($D(^DIC(4,+XRONUM,99)):$P(^(99),U,1),1:0) Q:XRONUM'=RONUM&(RONUM'="ALL")
  1. K XRONUM S DTRPT=$P(DTA,U,5),DTSCHEDC=$P(DTA,U,6),DTRQCMP=$P(DTA,U,7),DTTRANS=$P(DTA,U,12),DTREL=$P(DTA,U,14),RQSTAT=$P(DTA,U,18),DTCAN=$P(DTA,U,19),PRIO=$P(DTA,U,10) K DTA
  1. I DTRPT="",DTCAN]"" S DTRPT=DTCAN
  1. Q:DTRPT="" ;requests never printed
  1. ;check for Parent Request (retrieve current/parent Priority of Exam)
  1. S DVBAPREXM=$$CHKREQ^DVBCIRP1(REQDA)
  1. ;original report run (Exclude new priorities)
  1. Q:((DVBAEXMP']"")&((";BDD;QS;IDES;AO;")[(";"_DVBAPREXM_";")))
  1. ;report for specific priority
  1. Q:((DVBAEXMP]"")&(DVBAEXMP'[(";"_DVBAPREXM_";")))
  1. S:(DVBAEXMP']"") DVBAPREXM="ALL" ;identifier for totals
  1. I DTREL'<BDATE,DTREL'>EDATE D DAY30
  1. I DTRPT'<BDATE,DTRPT'>EDATE S TOT(DVBAPREXM,"SENT")=TOT(DVBAPREXM,"SENT")+1
  1. I DTRPT'<BDATE,DTRPT'>EDATE,RQSTAT'["X" S X1=$S(DTSCHEDC]"":DTSCHEDC,1:DVBCNOW),X2=DTRPT D ^%DTC I X>3 S TOT(DVBAPREXM,"3DAYSCH")=TOT(DVBAPREXM,"3DAYSCH")+1
  1. I DTREL'<BDATE&(DTREL'>EDATE),RQSTAT="C"!(RQSTAT="R") S:PRIO'="E" DVBCPCTM=$$PROCDAY^DVBCUTL2(REQDA) S:PRIO="E" DVBCPCTM=$$INSFTME^DVBCUTA1(REQDA) S TOT(DVBAPREXM,"DAYS")=TOT(DVBAPREXM,"DAYS")+DVBCPCTM K DVBCPCTM
  1. I DTRPT'>EDATE,"^P^S^T"[RQSTAT S TOT(DVBAPREXM,"PENDADJ")=TOT(DVBAPREXM,"PENDADJ")+1,X1=EDATE,X2=DTRPT D ^%DTC,PENDCNT
  1. I DTRPT'>EDATE,"^C^CT^R^RX^X^"[RQSTAT,(+DTREL>EDATE)!(+DTCAN>EDATE) S TOT(DVBAPREXM,"PENDADJ")=TOT(DVBAPREXM,"PENDADJ")+1,X1=EDATE,X2=DTRPT D ^%DTC,PENDCNT
  1. I DTREL'<BDATE&(DTREL'>EDATE),RQSTAT["C"!(RQSTAT="R") S TOT(DVBAPREXM,"COMPLETED")=TOT(DVBAPREXM,"COMPLETED")+1
  1. I DTRPT'<BDATE,DTRPT'>EDATE,PRIO="E" S TOT(DVBAPREXM,"INSUFF")=TOT(DVBAPREXM,"INSUFF")+1
  1. I DTCAN'<BDATE&(DTCAN'>EDATE),RQSTAT="X"!(RQSTAT="RX") S TOT(DVBAPREXM,"INCOMPLETE")=TOT(DVBAPREXM,"INCOMPLETE")+1
  1. K DTRPT Q
  1. ;
  1. GO ;
  1. N DVBAEXMP,DVBAP,DVBAPREXM,DVBATOT,DVBAOUT,PG
  1. S PG=0
  1. S DVBAEXMP=$S($G(DVBAPRTY)["BDD":";BDD;QS;",($G(DVBAPRTY)["IDES"):";IDES;",($G(DVBAPRTY)["AO"):";AO;",1:"")
  1. S %DT="TS",X="NOW" D ^%DT S DVBCNOW=Y K ^TMP($J)
  1. S PNAM="" F JJ=0:0 S PNAM=$O(^DVB(396.3,"B",PNAM)) Q:PNAM="" F REQDA=0:0 S REQDA=$O(^DVB(396.3,"B",PNAM,REQDA)) Q:REQDA="" D SET
  1. ;
  1. S DVBAEXMP=$S($G(DVBAPRTY)["BDD":"BDD,QS",($G(DVBAPRTY)["IDES"):"IDES",($G(DVBAPRTY)["AO"):"AO",1:"ALL")
  1. M DVBATOT=TOT ;save totals for all priorities into new array
  1. F DVBAP=1:1:$L(DVBAEXMP,",") D
  1. .K DVBAOUT S DVBAPREXM=$P(DVBAEXMP,",",DVBAP)
  1. .;re-create TOT array for each priority of exam
  1. .D CRTOT(DVBAPREXM,.DVBATOT,.TOT)
  1. .S TOT("AVGDAYS")=0
  1. .I TOT("COMPLETED")>0 S TOT("AVGDAYS")=TOT("DAYS")/TOT("COMPLETED"),TOT("AVGDAYS")=$J(TOT("AVGDAYS"),5,1)
  1. .D BULLTXT^DVBCAMR1(DVBAPREXM)
  1. .U IO D HDR F JI=0.9:0 S JI=$O(^TMP($J,JI)) Q:JI="" W ^(JI,0),! I IOST?1"C-".E,$Y>19 D PAUSE G:$D(DVBAOUT) EXIT D HDR
  1. .D PAUSE I $D(DVBAOUT) W:SBULL="Y" !!,*7,"Bulletin will NOT be sent!!",*7,! H 2 G EXIT
  1. .S:'$D(XMY) SBULL="N" I SBULL="Y" D SEND
  1. D ^%ZISC
  1. ;
  1. EXIT ;
  1. Q:(DVBAP'=$L(DVBAEXMP,",")) ;another report to run
  1. D:$D(ZTQUEUED) KILL^%ZTLOAD K PREVMO,UPDATE,XMY G KILL^DVBCUTIL
  1. ;
  1. BULL W ! S XMDUZ=DUZ,XMMG=$S($D(^VA(200,DUZ,0)):$P(^(0),U,1),1:"") D DES^XMA21
  1. Q
  1. ;
  1. SEND ;send 2507 AMIS report in bulletin
  1. N DVBAXMY M DVBAXMY=XMY
  1. S XMSUB="RO AMIS 290 Report "_$S((($G(DVBAPREXM)]"")&($G(DVBAPREXM)'="ALL")):"("_$G(DVBAPREXM)_" Exam Priority) ",1:"")_"- "
  1. S Y=BDATE1 X ^DD("DD") S XMSUB=XMSUB_Y S Y=EDATE1 X ^DD("DD") S XMSUB=XMSUB_" to "_Y,XMTEXT="^TMP($J,"
  1. D ^XMD K XMTEXT,XMSUB K ^TMP($J)
  1. I '$D(ZTSK) W !!,*7,">>> Mail message transmitted. <<<",!! H 2
  1. M XMY=DVBAXMY ;restore address list for subsequent bulletins
  1. Q
  1. ;
  1. HDR S PG=PG+1 W:(IOST?1"C-".E) @IOF
  1. W "Regional Office AMIS 290 Report for C&P Examinations",?(IOM-9),"Page: ",PG,!
  1. W $$PRHD^DVBCIUTL(DVBAPREXM),!
  1. W "For date range: " S Y=BDATE1 X ^DD("DD") W Y W " to " S Y=EDATE1 X ^DD("DD") W Y,!
  1. F LINE=1:1:80 W "-"
  1. W !!
  1. Q
  1. ;
  1. PAUSE N ANS K DVBAOUT S ANS="" I IOST?1"C-".E W *7,!!,"Press RETURN to continue or ""^"" to exit " R ANS:DTIME I '$T!(ANS[U) S DVBAOUT=1
  1. Q
  1. ;
  1. ;Input : DVBACDE - Priority of Exam code to get Totals for
  1. ; : DVBATOT - Array holding total values for each specific priority
  1. ; (By Ref)
  1. ; : TOT - array to hold totals for requested priority (By Ref)
  1. ;Output: TOT array with totals for requested priority
  1. CRTOT(DVBACDE,DVBATOT,TOT) ;create total array for specific priority exam report
  1. N JI K TOT
  1. F JI="3DAYSCH","30DAYEX","PENDADJ" D
  1. .S TOT(JI)=$G(DVBATOT(DVBACDE,JI))
  1. F JI="INSUFF","SENT","INCOMPLETE","DAYS","COMPLETED" D
  1. .S TOT(JI)=$G(DVBATOT(DVBACDE,JI))
  1. F JI="P90","P121","P151","P181","P365","P366" D
  1. .S TOT(JI)=$G(DVBATOT(DVBACDE,JI))
  1. Q