DVBAB2 ;ALB/KLB - CAPRI RO AMIS REPORT CONT. ;05/01/00
;;2.7;AMIE;**35,42,149,184,193**;Apr 10, 1995;Build 84
;Per VHA Directive 2004-038, this routine should not be modified.
;
DAY30 ;exam completion
N DVBADTS,DVBAPPTS,DVBACNT,DVBADTM,DVBANDE,X,X1,X2
K ^TMP("DVBC",$J),^TMP($J,"SDAMA301")
;DES Type exams required to be completed in 45 days, all others 30
S DVBADTS=$S(((";IDES;")[(";"_DVBAPREXM_";")):45,1:30)
;setup call to scheduling API
S DVBAPPTS(1)=DTRPT_";"_EDATE,DVBAPPTS(4)=PNAM,DVBAPPTS(3)="R;I;NT"
S DVBAPPTS("SORT")="P",DVBAPPTS("FLDS")="10"
S DVBACNT=$$SDAPI^SDAMA301(.DVBAPPTS)
I (DVBACNT'>0) K ^TMP($J,"SDAMA301") Q
S DVBADTM=""
F S DVBADTM=$O(^TMP($J,"SDAMA301",PNAM,DVBADTM)) Q:('+DVBADTM) D
.S ^TMP("DVBC",$J,9999999-DVBADTM,DVBADTM)=""
S DVBANDE=$O(^TMP("DVBC",$J,0)),DVBADTM=$O(^TMP("DVBC",$J,DVBANDE,0))
D:(DVBADTM]"")
.S X2=DVBADTM,X1=$S(DTSCHEDC]"":DTSCHEDC,1:DVBCNOW)
.D ^%DTC ;calculate date diff
.S:(X>DVBADTS) TOT(DVBAPREXM,"30DAYEX")=TOT(DVBAPREXM,"30DAYEX")+1
K ^TMP($J,"SDAMA301")
Q
;
PENDCNT I X'<0&(X'>90) S TOT(DVBAPREXM,"P90")=TOT(DVBAPREXM,"P90")+1
I X>90&(X'>120) S TOT(DVBAPREXM,"P121")=TOT(DVBAPREXM,"P121")+1
I X>120&(X'>150) S TOT(DVBAPREXM,"P151")=TOT(DVBAPREXM,"P151")+1
I X>150&(X'>180) S TOT(DVBAPREXM,"P181")=TOT(DVBAPREXM,"P181")+1
I X>180&(X'>365) S TOT(DVBAPREXM,"P365")=TOT(DVBAPREXM,"P365")+1
I X>365 S TOT(DVBAPREXM,"P366")=TOT(DVBAPREXM,"P366")+1
Q
;
SET ;
N DVBAPREXM
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")
; Next 2 lines check for specific division SPH/ALB - 9/3/02
I DVBDIV'="" I '$D(^DVB(396.3,REQDA,1)) Q
I DVBDIV'="" I $P(^DVB(396.3,REQDA,1),"^",4)'=DVBDIV Q
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
I DTRPT="",DTCAN]"" S DTRPT=DTCAN
Q:DTRPT="" ;requests never printed
;check for Parent Request (retrieve current/parent Priority of Exam)
S DVBAPREXM=$$CHKREQ^DVBCIRP1(REQDA)
;original report run (Exclude new priorities)
Q:((DVBAEXMP']"")&((";BDD;QS;IDES;AO;")[(";"_DVBAPREXM_";")))
;report for specific priority
Q:((DVBAEXMP]"")&(DVBAEXMP'[(";"_DVBAPREXM_";")))
S:(DVBAEXMP']"") DVBAPREXM="ALL" ;identifier for totals
;AJF;Request Status conversion ;
S RQSTAT=$$RSTAT^DVBCUTL8(REQDA)
I DTREL'<BDATE,DTREL'>EDATE D DAY30
I DTRPT'<BDATE,DTRPT'>EDATE S TOT(DVBAPREXM,"SENT")=TOT(DVBAPREXM,"SENT")+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
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
I DTRPT'>EDATE,"^P^S^T"[RQSTAT S TOT(DVBAPREXM,"PENDADJ")=TOT(DVBAPREXM,"PENDADJ")+1,X1=EDATE,X2=DTRPT D ^%DTC,PENDCNT
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
I DTREL'<BDATE&(DTREL'>EDATE),RQSTAT["C"!(RQSTAT="R") S TOT(DVBAPREXM,"COMPLETED")=TOT(DVBAPREXM,"COMPLETED")+1
I DTRPT'<BDATE,DTRPT'>EDATE,PRIO="E" S TOT(DVBAPREXM,"INSUFF")=TOT(DVBAPREXM,"INSUFF")+1
I DTCAN'<BDATE&(DTCAN'>EDATE),RQSTAT="X"!(RQSTAT="RX") S TOT(DVBAPREXM,"INCOMPLETE")=TOT(DVBAPREXM,"INCOMPLETE")+1
K DTRPT Q
;
GO ;
N DVBAEXMP,DVBAP,DVBAPREXM,DVBATOT,DVBALNE,MSG
S DVBAEXMP=$S($G(DVBAPRTY)["BDD":";BDD;QS;",($G(DVBAPRTY)["IDES"):";IDES;",($G(DVBAPRTY)["AO"):";AO;",1:"")
S DVBABCNT=0,DVBALNE="" K ^TMP($J)
S %DT="TS",X="NOW" D ^%DT S DVBCNOW=Y
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
;
S DVBAEXMP=$S($G(DVBAPRTY)["BDD":"BDD,QS",($G(DVBAPRTY)["IDES"):"IDES",($G(DVBAPRTY)["AO"):"AO",1:"ALL")
M DVBATOT=TOT ;save totals for all priorities into new array
F DVBAP=1:1:$L(DVBAEXMP,",") D
.S DVBAPREXM=$P(DVBAEXMP,",",DVBAP)
.;re-create TOT array for each priority of exam
.D CRTOT^DVBCAMR2(DVBAPREXM,.DVBATOT,.TOT)
.S TOT("AVGDAYS")=0
.I TOT("COMPLETED")>0 S TOT("AVGDAYS")=TOT("DAYS")/TOT("COMPLETED"),TOT("AVGDAYS")=$J(TOT("AVGDAYS"),5,1)
.D BULLTXT^DVBCAMR1(DVBAPREXM)
.F JI=0:0 S JI=$O(^TMP($J,JI)) Q:JI="" S DVBABCNT=DVBABCNT+1,MSG(DVBABCNT)=^TMP($J,JI,0)
.S:'$D(XMY) SBULL="N" I SBULL="Y" D SEND
.D:(DVBAP'=$L(DVBAEXMP,",")) ;another report to run
..;insert line breaks / horizontal line break
..S DVBABCNT=DVBABCNT+1,MSG(DVBABCNT)=""
..F JI=1:1:70 S $P(DVBALNE,"-",JI)="-"
..S DVBABCNT=DVBABCNT+1,MSG(DVBABCNT)=DVBALNE
..S DVBABCNT=DVBABCNT+1,MSG(DVBABCNT)=""
;
EXIT K BDATE,%DT,DVBABCNT,C,DTCAN,DTREL,DTREQ,DTRQCMP,DTSCHEDC,DTTRANS
K DVBCNOW,DVBCPCTM,EDATE,FA,FB,JI,JJ,L,PNAM,PRIO,REQDA,RONUM,RQSTAT
K SBULL,TOT,X,X1,X2,XMDUZ,XMMG,XMY,Y,YY,DVBDIV,DVBAPRTY
Q
;
BULL S XMDUZ=$P(^VA(200,DUZ,0),U),XMMG=$S($D(^VA(200,DUZ,0)):$P(^(0),U,1),1:""),XMY(DUZ)=""
Q
;
SEND ;send 2507 AMIS report in bulletin
N DVBAXMY M DVBAXMY=XMY
S XMSUB="RO AMIS 290 Report "_$S((($G(DVBAPREXM)]"")&($G(DVBAPREXM)'="ALL")):"("_$G(DVBAPREXM)_" Exam Priority) ",1:"")_"- "
S Y=BDATE X ^DD("DD") S XMSUB=XMSUB_Y S Y=EDATE X ^DD("DD") S XMSUB=XMSUB_" to "_Y,XMTEXT="^TMP($J,"
D ^XMD K XMTEXT,XMSUB,^TMP($J)
S DVBABCNT=DVBABCNT+1,MSG(DVBABCNT)=""
S DVBABCNT=DVBABCNT+1,MSG(DVBABCNT)=">>> Mail message transmitted. <<<"
M XMY=DVBAXMY ;restore address list for subsequent bulletins
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAB2 5717 printed Nov 22, 2024@16:50:34 Page 2
DVBAB2 ;ALB/KLB - CAPRI RO AMIS REPORT CONT. ;05/01/00
+1 ;;2.7;AMIE;**35,42,149,184,193**;Apr 10, 1995;Build 84
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
DAY30 ;exam completion
+1 NEW DVBADTS,DVBAPPTS,DVBACNT,DVBADTM,DVBANDE,X,X1,X2
+2 KILL ^TMP("DVBC",$JOB),^TMP($JOB,"SDAMA301")
+3 ;DES Type exams required to be completed in 45 days, all others 30
+4 SET DVBADTS=$SELECT(((";IDES;")[(";"_DVBAPREXM_";")):45,1:30)
+5 ;setup call to scheduling API
+6 SET DVBAPPTS(1)=DTRPT_";"_EDATE
SET DVBAPPTS(4)=PNAM
SET DVBAPPTS(3)="R;I;NT"
+7 SET DVBAPPTS("SORT")="P"
SET DVBAPPTS("FLDS")="10"
+8 SET DVBACNT=$$SDAPI^SDAMA301(.DVBAPPTS)
+9 IF (DVBACNT'>0)
KILL ^TMP($JOB,"SDAMA301")
QUIT
+10 SET DVBADTM=""
+11 FOR
SET DVBADTM=$ORDER(^TMP($JOB,"SDAMA301",PNAM,DVBADTM))
if ('+DVBADTM)
QUIT
Begin DoDot:1
+12 SET ^TMP("DVBC",$JOB,9999999-DVBADTM,DVBADTM)=""
End DoDot:1
+13 SET DVBANDE=$ORDER(^TMP("DVBC",$JOB,0))
SET DVBADTM=$ORDER(^TMP("DVBC",$JOB,DVBANDE,0))
+14 if (DVBADTM]"")
Begin DoDot:1
+15 SET X2=DVBADTM
SET X1=$SELECT(DTSCHEDC]"":DTSCHEDC,1:DVBCNOW)
+16 ;calculate date diff
DO ^%DTC
+17 if (X>DVBADTS)
SET TOT(DVBAPREXM,"30DAYEX")=TOT(DVBAPREXM,"30DAYEX")+1
End DoDot:1
+18 KILL ^TMP($JOB,"SDAMA301")
+19 QUIT
+20 ;
PENDCNT IF X'<0&(X'>90)
SET TOT(DVBAPREXM,"P90")=TOT(DVBAPREXM,"P90")+1
+1 IF X>90&(X'>120)
SET TOT(DVBAPREXM,"P121")=TOT(DVBAPREXM,"P121")+1
+2 IF X>120&(X'>150)
SET TOT(DVBAPREXM,"P151")=TOT(DVBAPREXM,"P151")+1
+3 IF X>150&(X'>180)
SET TOT(DVBAPREXM,"P181")=TOT(DVBAPREXM,"P181")+1
+4 IF X>180&(X'>365)
SET TOT(DVBAPREXM,"P365")=TOT(DVBAPREXM,"P365")+1
+5 IF X>365
SET TOT(DVBAPREXM,"P366")=TOT(DVBAPREXM,"P366")+1
+6 QUIT
+7 ;
SET ;
+1 NEW DVBAPREXM
+2 SET DTA=^DVB(396.3,REQDA,0)
SET DTREQ=$PIECE(DTA,U,2)
SET XRONUM=$PIECE(DTA,U,3)
SET XRONUM=$SELECT($DATA(^DIC(4,+XRONUM,99)):$PIECE(^(99),U,1),1:0)
if XRONUM'=RONUM&(RONUM'="ALL")
QUIT
+3 ; Next 2 lines check for specific division SPH/ALB - 9/3/02
+4 IF DVBDIV'=""
IF '$DATA(^DVB(396.3,REQDA,1))
QUIT
+5 IF DVBDIV'=""
IF $PIECE(^DVB(396.3,REQDA,1),"^",4)'=DVBDIV
QUIT
+6 KILL XRONUM
SET DTRPT=$PIECE(DTA,U,5)
SET DTSCHEDC=$PIECE(DTA,U,6)
SET DTRQCMP=$PIECE(DTA,U,7)
SET DTTRANS=$PIECE(DTA,U,12)
SET DTREL=$PIECE(DTA,U,14)
SET RQSTAT=$PIECE(DTA,U,18)
SET DTCAN=$PIECE(DTA,U,19)
SET PRIO=$PIECE(DTA,U,10)
KILL DTA
+7 IF DTRPT=""
IF DTCAN]""
SET DTRPT=DTCAN
+8 ;requests never printed
if DTRPT=""
QUIT
+9 ;check for Parent Request (retrieve current/parent Priority of Exam)
+10 SET DVBAPREXM=$$CHKREQ^DVBCIRP1(REQDA)
+11 ;original report run (Exclude new priorities)
+12 if ((DVBAEXMP']"")&((";BDD;QS;IDES;AO;")[(";"_DVBAPREXM_";")))
QUIT
+13 ;report for specific priority
+14 if ((DVBAEXMP]"")&(DVBAEXMP'[(";"_DVBAPREXM_";")))
QUIT
+15 ;identifier for totals
if (DVBAEXMP']"")
SET DVBAPREXM="ALL"
+16 ;AJF;Request Status conversion ;
+17 SET RQSTAT=$$RSTAT^DVBCUTL8(REQDA)
+18 IF DTREL'<BDATE
IF DTREL'>EDATE
DO DAY30
+19 IF DTRPT'<BDATE
IF DTRPT'>EDATE
SET TOT(DVBAPREXM,"SENT")=TOT(DVBAPREXM,"SENT")+1
+20 IF DTRPT'<BDATE
IF DTRPT'>EDATE
IF RQSTAT'["X"
SET X1=$SELECT(DTSCHEDC]"":DTSCHEDC,1:DVBCNOW)
SET X2=DTRPT
DO ^%DTC
IF X>3
SET TOT(DVBAPREXM,"3DAYSCH")=TOT(DVBAPREXM,"3DAYSCH")+1
+21 IF DTREL'<BDATE&(DTREL'>EDATE)
IF RQSTAT="C"!(RQSTAT="R")
if PRIO'="E"
SET DVBCPCTM=$$PROCDAY^DVBCUTL2(REQDA)
if PRIO="E"
SET DVBCPCTM=$$INSFTME^DVBCUTA1(REQDA)
SET TOT(DVBAPREXM,"DAYS")=TOT(DVBAPREXM,"DAYS")+DVBCPCTM
KILL DVBCPCTM
+22 IF DTRPT'>EDATE
IF "^P^S^T"[RQSTAT
SET TOT(DVBAPREXM,"PENDADJ")=TOT(DVBAPREXM,"PENDADJ")+1
SET X1=EDATE
SET X2=DTRPT
DO ^%DTC
DO PENDCNT
+23 IF DTRPT'>EDATE
IF "^C^CT^R^RX^X^"[RQSTAT
IF (+DTREL>EDATE)!(+DTCAN>EDATE)
SET TOT(DVBAPREXM,"PENDADJ")=TOT(DVBAPREXM,"PENDADJ")+1
SET X1=EDATE
SET X2=DTRPT
DO ^%DTC
DO PENDCNT
+24 IF DTREL'<BDATE&(DTREL'>EDATE)
IF RQSTAT["C"!(RQSTAT="R")
SET TOT(DVBAPREXM,"COMPLETED")=TOT(DVBAPREXM,"COMPLETED")+1
+25 IF DTRPT'<BDATE
IF DTRPT'>EDATE
IF PRIO="E"
SET TOT(DVBAPREXM,"INSUFF")=TOT(DVBAPREXM,"INSUFF")+1
+26 IF DTCAN'<BDATE&(DTCAN'>EDATE)
IF RQSTAT="X"!(RQSTAT="RX")
SET TOT(DVBAPREXM,"INCOMPLETE")=TOT(DVBAPREXM,"INCOMPLETE")+1
+27 KILL DTRPT
QUIT
+28 ;
GO ;
+1 NEW DVBAEXMP,DVBAP,DVBAPREXM,DVBATOT,DVBALNE,MSG
+2 SET DVBAEXMP=$SELECT($GET(DVBAPRTY)["BDD":";BDD;QS;",($GET(DVBAPRTY)["IDES"):";IDES;",($GET(DVBAPRTY)["AO"):";AO;",1:"")
+3 SET DVBABCNT=0
SET DVBALNE=""
KILL ^TMP($JOB)
+4 SET %DT="TS"
SET X="NOW"
DO ^%DT
SET DVBCNOW=Y
+5 SET PNAM=""
FOR JJ=0:0
SET PNAM=$ORDER(^DVB(396.3,"B",PNAM))
if PNAM=""
QUIT
FOR REQDA=0:0
SET REQDA=$ORDER(^DVB(396.3,"B",PNAM,REQDA))
if REQDA=""
QUIT
DO SET
+6 ;
+7 SET DVBAEXMP=$SELECT($GET(DVBAPRTY)["BDD":"BDD,QS",($GET(DVBAPRTY)["IDES"):"IDES",($GET(DVBAPRTY)["AO"):"AO",1:"ALL")
+8 ;save totals for all priorities into new array
MERGE DVBATOT=TOT
+9 FOR DVBAP=1:1:$LENGTH(DVBAEXMP,",")
Begin DoDot:1
+10 SET DVBAPREXM=$PIECE(DVBAEXMP,",",DVBAP)
+11 ;re-create TOT array for each priority of exam
+12 DO CRTOT^DVBCAMR2(DVBAPREXM,.DVBATOT,.TOT)
+13 SET TOT("AVGDAYS")=0
+14 IF TOT("COMPLETED")>0
SET TOT("AVGDAYS")=TOT("DAYS")/TOT("COMPLETED")
SET TOT("AVGDAYS")=$JUSTIFY(TOT("AVGDAYS"),5,1)
+15 DO BULLTXT^DVBCAMR1(DVBAPREXM)
+16 FOR JI=0:0
SET JI=$ORDER(^TMP($JOB,JI))
if JI=""
QUIT
SET DVBABCNT=DVBABCNT+1
SET MSG(DVBABCNT)=^TMP($JOB,JI,0)
+17 if '$DATA(XMY)
SET SBULL="N"
IF SBULL="Y"
DO SEND
+18 ;another report to run
if (DVBAP'=$LENGTH(DVBAEXMP,","))
Begin DoDot:2
+19 ;insert line breaks / horizontal line break
+20 SET DVBABCNT=DVBABCNT+1
SET MSG(DVBABCNT)=""
+21 FOR JI=1:1:70
SET $PIECE(DVBALNE,"-",JI)="-"
+22 SET DVBABCNT=DVBABCNT+1
SET MSG(DVBABCNT)=DVBALNE
+23 SET DVBABCNT=DVBABCNT+1
SET MSG(DVBABCNT)=""
End DoDot:2
End DoDot:1
+24 ;
EXIT KILL BDATE,%DT,DVBABCNT,C,DTCAN,DTREL,DTREQ,DTRQCMP,DTSCHEDC,DTTRANS
+1 KILL DVBCNOW,DVBCPCTM,EDATE,FA,FB,JI,JJ,L,PNAM,PRIO,REQDA,RONUM,RQSTAT
+2 KILL SBULL,TOT,X,X1,X2,XMDUZ,XMMG,XMY,Y,YY,DVBDIV,DVBAPRTY
+3 QUIT
+4 ;
BULL SET XMDUZ=$PIECE(^VA(200,DUZ,0),U)
SET XMMG=$SELECT($DATA(^VA(200,DUZ,0)):$PIECE(^(0),U,1),1:"")
SET XMY(DUZ)=""
+1 QUIT
+2 ;
SEND ;send 2507 AMIS report in bulletin
+1 NEW DVBAXMY
MERGE DVBAXMY=XMY
+2 SET XMSUB="RO AMIS 290 Report "_$SELECT((($GET(DVBAPREXM)]"")&($GET(DVBAPREXM)'="ALL")):"("_$GET(DVBAPREXM)_" Exam Priority) ",1:"")_"- "
+3 SET Y=BDATE
XECUTE ^DD("DD")
SET XMSUB=XMSUB_Y
SET Y=EDATE
XECUTE ^DD("DD")
SET XMSUB=XMSUB_" to "_Y
SET XMTEXT="^TMP($J,"
+4 DO ^XMD
KILL XMTEXT,XMSUB,^TMP($JOB)
+5 SET DVBABCNT=DVBABCNT+1
SET MSG(DVBABCNT)=""
+6 SET DVBABCNT=DVBABCNT+1
SET MSG(DVBABCNT)=">>> Mail message transmitted. <<<"
+7 ;restore address list for subsequent bulletins
MERGE XMY=DVBAXMY
+8 QUIT
+9 ;
