DVBCAMI2 ;ALB/GTS-557/THM-HOSPITAL AMIS 290 ; 7/1/91 9:48 AM
;;2.7;AMIE;**149,184**;Apr 10, 1995;Build 10
;Per VHA Directive 2004-038, this routine should not be modified.
;
;** Version Changes
; 2.7 - GTS/Coded to adjust 35 day clock calc (Enhc 13)
;
DAY30 ;exam completion
N DVBADTS,DVBAPPTS,DVBACNT,DVBADTM,DVBAPT,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 (date inclusive)
S DVBAPPTS(1)=DTRPT_";"_EDATE,DVBAPPTS(4)=PNAM,DVBAPPTS(3)="R;I"
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 DVBAPT=$G(^TMP($J,"SDAMA301",PNAM,DVBADTM))
.Q:(+$P(DVBAPT,"^",10)'=1) ;quit if not C&P Appointment
.S ^TMP("DVBC",$J,9999999-DVBADTM,DVBADTM)=""
I ('$D(^TMP("DVBC",$J))) K ^TMP($J,"SDAMA301") Q
S DVBANDE=$O(^TMP("DVBC",$J,0)),DVBADTM=$O(^TMP("DVBC",$J,DVBANDE,0))
D:(DVBADTM]"")
.S X1=DVBADTM,X2=$S(DTRPT]"":DTRPT,1:DVBCNOW)
.D ^%DTC ;calculate date diff
.S:(X>DVBADTS) TOT(DVBAPREXM,"30DAYEX")=TOT(DVBAPREXM,"30DAYEX")+1
K ^TMP($J,"SDAMA301")
Q
;
GO1 ; ** TFIND=1 If any exams have not been transferred. **
K TFIND F XI=0:0 S XI=$O(^DVB(396.4,"C",REQDA,XI)) Q:XI="" I $P(^DVB(396.4,XI,0),U,4)'="T" S TFIND=1
Q
;if $D(TFIND) at least one exam to be done locally
;
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),DFN=$P(DTA,U,1),DTREQ=$P(DTA,U,2),DTRPT=$P(DTA,U,5),DTSCHEDC=$P(DTA,U,6),DTRQCMP=$P(DTA,U,7),PRIO=$P(DTA,U,10),DTTRANS=$P(DTA,U,12),OWNDOM=$P(DTA,U,22)
S DTREL=$P(DTA,U,14),RQSTAT=$P(DTA,U,18),DTCAN=$P(DTA,U,19) K DTA
S DTA=$S($D(^DVB(396.3,REQDA,4)):^(4),1:""),TROUT=$P(DTA,U,1),DTTROUT=$P(DTA,U,3),DTTRIN=$P(DTA,U,4),DTTRET=$P(DTA,U,5)
I DTCAN]"",DTCAN<DTRPT,DTRPT]"" S DTRPT=DTCAN ;cancelled last day of month
Q:DTRPT="" ;never reported to MAS
;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
I DTTRIN'<BDATE,DTTRIN'>EDATE S TOT(DVBAPREXM,"TRANSIN")=TOT(DVBAPREXM,"TRANSIN")+1 ;transfers in
I RQSTAT="CT",DTREL'<BDATE,DTREL'>EDATE S TOT(DVBAPREXM,"TRNRETTO")=TOT(DVBAPREXM,"TRNRETTO")+1 ;transfers returned to owners
I "^N^NT^P^S^T^"[RQSTAT,OWNDOM]"" S TOT(DVBAPREXM,"TRNPNDTO")=TOT(DVBAPREXM,"TRNPNDTO")+1 ;transfers pending return to others
Q:DTTRIN]"" ;** A transfer in (not counted further)
I DTREL'<BDATE,DTREL'>EDATE D DAY30
I DTTROUT'<BDATE,DTTROUT'>EDATE,TROUT="y" S TOT(DVBAPREXM,"TRANSOUT")=TOT(DVBAPREXM,"TRANSOUT")+1 ;transfers to other sites, not returns
I TROUT="",DTTRET'<BDATE,DTTRET'>EDATE S TOT(DVBAPREXM,"TRNRETFR")=TOT(DVBAPREXM,"TRNRETFR")+1 ;transfers returned from other sites
I TROUT="y",RQSTAT="P" S TOT(DVBAPREXM,"TRNPNDFR")=TOT(DVBAPREXM,"TRNPNDFR")+1 ;transfers pending return from other sites
I DTRPT'<BDATE,DTRPT'>EDATE,PRIO'="E" S TOT(DVBAPREXM,"RECEIVED")=TOT(DVBAPREXM,"RECEIVED")+1
I DTRPT'<BDATE,DTRPT'>EDATE,PRIO="E" S TOT(DVBAPREXM,"INSUFF")=TOT(DVBAPREXM,"INSUFF")+1
I DTRPT'<BDATE,DTRPT'>EDATE,RQSTAT'["X" D GO1 I $D(TFIND) 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,"^N^NT^P^S^T^"[RQSTAT S X1=EDATE,X2=DTRPT D ^%DTC,PENDCNT
I DTRPT'>EDATE,"^C^CT^R^RX^X^"[RQSTAT,(+DTREL>EDATE)!(+DTCAN>EDATE) S 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 DTCAN'<BDATE,DTCAN'>EDATE,RQSTAT["X" S TOT(DVBAPREXM,"INCOMPLETE")=TOT(DVBAPREXM,"INCOMPLETE")+1
K DTRPT Q
;
GO ;
N DVBAEXMP,DVBAP,DVBAPREXM,DVBATOT
S DVBAEXMP=$S($G(DVBAPRTY)["BDD":";BDD;QS;",($G(DVBAPRTY)["IDES"):";IDES;",($G(DVBAPRTY)["AO"):";AO;",1:"")
U IO K ^TMP($J) S PG=0,%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(DVBAPREXM,.DVBATOT,.TOT)
.S:($L(DVBAEXMP,",")>1) PREVMO=PREVMO(DVBAPREXM)
.S TOT("AVGDAYS")=0
.I TOT("COMPLETED")>0 S TOT("AVGDAYS")=TOT("DAYS")/TOT("COMPLETED"),TOT("AVGDAYS")=$J(TOT("AVGDAYS"),5,1)
.S TOT("PENDADJ")=PREVMO+TOT("RECEIVED")+TOT("INSUFF")-TOT("COMPLETED")-TOT("INCOMPLETE")
.D BULLTXT^DVBCAMI1(DVBAPREXM) D EN^DVBCAMI3((DVBAP=$L(DVBAEXMP,",")),DVBAPREXM)
Q
;
;Input : DVBACDE - Priority of Exam code to get Totals for
; : DVBATOT - Array holding total values for each specific priority
; (By Ref)
; : TOT - array to hold totals for requested priority (By Ref)
;Output: TOT array with totals for requested priority
CRTOT(DVBACDE,DVBATOT,TOT) ;create total array for specific priority exam report
N JI K TOT
F JI="3DAYSCH","30DAYEX","PENDADJ","TRANSIN","TRNRETTO","TRNPNDTO","TRANSOUT","TRNRETFR","TRNPNDFR","INSUFF" D
.S TOT(JI)=$G(DVBATOT(DVBACDE,JI))
F JI="RECEIVED","INCOMPLETE","DAYS","COMPLETED" D
.S TOT(JI)=$G(DVBATOT(DVBACDE,JI))
F JI="P90","P121","P151","P181","P365","P366" D
.S TOT(JI)=$G(DVBATOT(DVBACDE,JI))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCAMI2 6426 printed Apr 09, 2024@20:46:16 Page 2
DVBCAMI2 ;ALB/GTS-557/THM-HOSPITAL AMIS 290 ; 7/1/91 9:48 AM
+1 ;;2.7;AMIE;**149,184**;Apr 10, 1995;Build 10
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;** Version Changes
+5 ; 2.7 - GTS/Coded to adjust 35 day clock calc (Enhc 13)
+6 ;
DAY30 ;exam completion
+1 NEW DVBADTS,DVBAPPTS,DVBACNT,DVBADTM,DVBAPT,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 (date inclusive)
+6 SET DVBAPPTS(1)=DTRPT_";"_EDATE
SET DVBAPPTS(4)=PNAM
SET DVBAPPTS(3)="R;I"
+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 DVBAPT=$GET(^TMP($JOB,"SDAMA301",PNAM,DVBADTM))
+13 ;quit if not C&P Appointment
if (+$PIECE(DVBAPT,"^",10)'=1)
QUIT
+14 SET ^TMP("DVBC",$JOB,9999999-DVBADTM,DVBADTM)=""
End DoDot:1
+15 IF ('$DATA(^TMP("DVBC",$JOB)))
KILL ^TMP($JOB,"SDAMA301")
QUIT
+16 SET DVBANDE=$ORDER(^TMP("DVBC",$JOB,0))
SET DVBADTM=$ORDER(^TMP("DVBC",$JOB,DVBANDE,0))
+17 if (DVBADTM]"")
Begin DoDot:1
+18 SET X1=DVBADTM
SET X2=$SELECT(DTRPT]"":DTRPT,1:DVBCNOW)
+19 ;calculate date diff
DO ^%DTC
+20 if (X>DVBADTS)
SET TOT(DVBAPREXM,"30DAYEX")=TOT(DVBAPREXM,"30DAYEX")+1
End DoDot:1
+21 KILL ^TMP($JOB,"SDAMA301")
+22 QUIT
+23 ;
GO1 ; ** TFIND=1 If any exams have not been transferred. **
+1 KILL TFIND
FOR XI=0:0
SET XI=$ORDER(^DVB(396.4,"C",REQDA,XI))
if XI=""
QUIT
IF $PIECE(^DVB(396.4,XI,0),U,4)'="T"
SET TFIND=1
+2 QUIT
+3 ;if $D(TFIND) at least one exam to be done locally
+4 ;
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 DFN=$PIECE(DTA,U,1)
SET DTREQ=$PIECE(DTA,U,2)
SET DTRPT=$PIECE(DTA,U,5)
SET DTSCHEDC=$PIECE(DTA,U,6)
SET DTRQCMP=$PIECE(DTA,U,7)
SET PRIO=$PIECE(DTA,U,10)
SET DTTRANS=$PIECE(DTA,U,12)
SET OWNDOM=$PIECE(DTA,U,22)
+3 SET DTREL=$PIECE(DTA,U,14)
SET RQSTAT=$PIECE(DTA,U,18)
SET DTCAN=$PIECE(DTA,U,19)
KILL DTA
+4 SET DTA=$SELECT($DATA(^DVB(396.3,REQDA,4)):^(4),1:"")
SET TROUT=$PIECE(DTA,U,1)
SET DTTROUT=$PIECE(DTA,U,3)
SET DTTRIN=$PIECE(DTA,U,4)
SET DTTRET=$PIECE(DTA,U,5)
+5 ;cancelled last day of month
IF DTCAN]""
IF DTCAN<DTRPT
IF DTRPT]""
SET DTRPT=DTCAN
+6 ;never reported to MAS
if DTRPT=""
QUIT
+7 ;check for Parent Request (retrieve current/parent Priority of Exam)
+8 SET DVBAPREXM=$$CHKREQ^DVBCIRP1(REQDA)
+9 ;original report run (Exclude new priorities)
+10 if ((DVBAEXMP']"")&((";BDD;QS;IDES;AO;")[(";"_DVBAPREXM_";")))
QUIT
+11 ;report for specific priority
+12 if ((DVBAEXMP]"")&(DVBAEXMP'[(";"_DVBAPREXM_";")))
QUIT
+13 ;identifier for totals
if (DVBAEXMP']"")
SET DVBAPREXM="ALL"
+14 ;transfers in
IF DTTRIN'<BDATE
IF DTTRIN'>EDATE
SET TOT(DVBAPREXM,"TRANSIN")=TOT(DVBAPREXM,"TRANSIN")+1
+15 ;transfers returned to owners
IF RQSTAT="CT"
IF DTREL'<BDATE
IF DTREL'>EDATE
SET TOT(DVBAPREXM,"TRNRETTO")=TOT(DVBAPREXM,"TRNRETTO")+1
+16 ;transfers pending return to others
IF "^N^NT^P^S^T^"[RQSTAT
IF OWNDOM]""
SET TOT(DVBAPREXM,"TRNPNDTO")=TOT(DVBAPREXM,"TRNPNDTO")+1
+17 ;** A transfer in (not counted further)
if DTTRIN]""
QUIT
+18 IF DTREL'<BDATE
IF DTREL'>EDATE
DO DAY30
+19 ;transfers to other sites, not returns
IF DTTROUT'<BDATE
IF DTTROUT'>EDATE
IF TROUT="y"
SET TOT(DVBAPREXM,"TRANSOUT")=TOT(DVBAPREXM,"TRANSOUT")+1
+20 ;transfers returned from other sites
IF TROUT=""
IF DTTRET'<BDATE
IF DTTRET'>EDATE
SET TOT(DVBAPREXM,"TRNRETFR")=TOT(DVBAPREXM,"TRNRETFR")+1
+21 ;transfers pending return from other sites
IF TROUT="y"
IF RQSTAT="P"
SET TOT(DVBAPREXM,"TRNPNDFR")=TOT(DVBAPREXM,"TRNPNDFR")+1
+22 IF DTRPT'<BDATE
IF DTRPT'>EDATE
IF PRIO'="E"
SET TOT(DVBAPREXM,"RECEIVED")=TOT(DVBAPREXM,"RECEIVED")+1
+23 IF DTRPT'<BDATE
IF DTRPT'>EDATE
IF PRIO="E"
SET TOT(DVBAPREXM,"INSUFF")=TOT(DVBAPREXM,"INSUFF")+1
+24 IF DTRPT'<BDATE
IF DTRPT'>EDATE
IF RQSTAT'["X"
DO GO1
IF $DATA(TFIND)
SET X1=$SELECT(DTSCHEDC]"":DTSCHEDC,1:DVBCNOW)
SET X2=DTRPT
DO ^%DTC
IF X>3
SET TOT(DVBAPREXM,"3DAYSCH")=TOT(DVBAPREXM,"3DAYSCH")+1
+25 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
+26 IF DTRPT'>EDATE
IF "^N^NT^P^S^T^"[RQSTAT
SET X1=EDATE
SET X2=DTRPT
DO ^%DTC
DO PENDCNT
+27 IF DTRPT'>EDATE
IF "^C^CT^R^RX^X^"[RQSTAT
IF (+DTREL>EDATE)!(+DTCAN>EDATE)
SET X1=EDATE
SET X2=DTRPT
DO ^%DTC
DO PENDCNT
+28 IF DTREL'<BDATE&(DTREL'>EDATE)
IF RQSTAT="C"!(RQSTAT="R")
SET TOT(DVBAPREXM,"COMPLETED")=TOT(DVBAPREXM,"COMPLETED")+1
+29 IF DTCAN'<BDATE
IF DTCAN'>EDATE
IF RQSTAT["X"
SET TOT(DVBAPREXM,"INCOMPLETE")=TOT(DVBAPREXM,"INCOMPLETE")+1
+30 KILL DTRPT
QUIT
+31 ;
GO ;
+1 NEW DVBAEXMP,DVBAP,DVBAPREXM,DVBATOT
+2 SET DVBAEXMP=$SELECT($GET(DVBAPRTY)["BDD":";BDD;QS;",($GET(DVBAPRTY)["IDES"):";IDES;",($GET(DVBAPRTY)["AO"):";AO;",1:"")
+3 USE IO
KILL ^TMP($JOB)
SET PG=0
SET %DT="TS"
SET X="NOW"
DO ^%DT
SET DVBCNOW=Y
+4 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
+5 ;
+6 SET DVBAEXMP=$SELECT($GET(DVBAPRTY)["BDD":"BDD,QS",($GET(DVBAPRTY)["IDES"):"IDES",($GET(DVBAPRTY)["AO"):"AO",1:"ALL")
+7 ;save totals for all priorities into new array
MERGE DVBATOT=TOT
+8 FOR DVBAP=1:1:$LENGTH(DVBAEXMP,",")
Begin DoDot:1
+9 SET DVBAPREXM=$PIECE(DVBAEXMP,",",DVBAP)
+10 ;re-create TOT array for each priority of exam
+11 DO CRTOT(DVBAPREXM,.DVBATOT,.TOT)
+12 if ($LENGTH(DVBAEXMP,",")>1)
SET PREVMO=PREVMO(DVBAPREXM)
+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 SET TOT("PENDADJ")=PREVMO+TOT("RECEIVED")+TOT("INSUFF")-TOT("COMPLETED")-TOT("INCOMPLETE")
+16 DO BULLTXT^DVBCAMI1(DVBAPREXM)
DO EN^DVBCAMI3((DVBAP=$LENGTH(DVBAEXMP,",")),DVBAPREXM)
End DoDot:1
+17 QUIT
+18 ;
+19 ;Input : DVBACDE - Priority of Exam code to get Totals for
+20 ; : DVBATOT - Array holding total values for each specific priority
+21 ; (By Ref)
+22 ; : TOT - array to hold totals for requested priority (By Ref)
+23 ;Output: TOT array with totals for requested priority
CRTOT(DVBACDE,DVBATOT,TOT) ;create total array for specific priority exam report
+1 NEW JI
KILL TOT
+2 FOR JI="3DAYSCH","30DAYEX","PENDADJ","TRANSIN","TRNRETTO","TRNPNDTO","TRANSOUT","TRNRETFR","TRNPNDFR","INSUFF"
Begin DoDot:1
+3 SET TOT(JI)=$GET(DVBATOT(DVBACDE,JI))
End DoDot:1
+4 FOR JI="RECEIVED","INCOMPLETE","DAYS","COMPLETED"
Begin DoDot:1
+5 SET TOT(JI)=$GET(DVBATOT(DVBACDE,JI))
End DoDot:1
+6 FOR JI="P90","P121","P151","P181","P365","P366"
Begin DoDot:1
+7 SET TOT(JI)=$GET(DVBATOT(DVBACDE,JI))
End DoDot:1
+8 QUIT
