DVBCNTSC ;ALB ISC/THM-REQUESTS NOT SCHEDULED IN THREE DAYS ; 9/28/91 8:13 AM
;;2.7;AMIE;**2,19,193**;Apr 10, 1995;Build 84
;;
D HOME^%ZIS S (PG,TOTAL)=0
S Y=DT X ^DD("DD") S DVBCDT(0)=Y D NOW^%DTC S DVBCNOW=% K %
G EN
;
PRINT S DTA=^DVB(396.3,DA,0),DFN=$P(DTA,U,1),DTRPT=$P(DTA,U,5)
;AJF; Request Status Conversion
S RQSTAT=$$RSTAT^DVBCUTL8($P(DTA,U,18)),REQCA=$P(DTA,U,19) Q:(RQSTAT["X"!(REQCA'="")) ;cancelled requests
S Y=DTRPT X ^DD("DD") S DTRPT2=Y,RO=$P(DTA,U,3),RO=$S($D(^DIC(4,+RO,0)):$P(^(0),U,1),1:"Unknown RO"),DTSCH=$P(DTA,U,6),Y=DTSCH X ^DD("DD") S DTSCH2=Y K DTA
S DAYS=0 I DTSCH="" S X1=DVBCNOW,X2=DTRPT D ^%DTC Q:X'>3 S DAYS=X
I DTSCH]"" S X1=DTSCH,X2=DTRPT D ^%DTC Q:X'>3 S DAYS=X
W PNAM,?33,^TMP($J,RQDT,PNAM,DA),?45,DTRPT2,?69,DTSCH2,?93,RO,?119,DAYS,! S TOTAL=TOTAL+1 I $Y>55 D HDR
Q
;
EN W @IOF,"2507 Exams Not Scheduled Within Three Days",!!!
S %DT(0)=-DT,%DT="AE",%DT("A")="Enter STARTING DATE REPORTED TO MAS: " D ^%DT G:Y<0 EXIT S SDATE2=Y,SDATE=Y-.5
S %DT("A")=" and ENDING DATE REPORTED TO MAS: " D ^%DT G:Y<0 EXIT S EDATE2=Y,EDATE=Y+.2359
K %DT S HD="2507 Requests Not Scheduled in Three Days at "_$$SITE^DVBCUTL4,HD2="From " S Y=$E(SDATE2,1,7) X ^DD("DD") S HD2=HD2_Y S Y=$E(EDATE2,1,7) X ^DD("DD") S HD2=HD2_" to "_Y
;
DEV W !! S %ZIS="AEQ" D ^%ZIS G:POP EXIT
I IOM<132 W *7,!!,"A right margin of 132 is required for this output!",!! G DEV
I $D(IO("Q")) S ZTIO=ION,ZTRTN="GO^DVBCNTSC",ZTDESC="2507 exams not scheduled in 3 days" F I="TOTAL","PG","SDATE*","EDATE*","HD*","DVBC*" S ZTSAVE(I)=""
I D ^%ZTLOAD W:$D(ZTSK) *7,!!,"Request queued.",!! G EXIT
;
GO K ^TMP($J) ;S X1=SDATE,X2=-7 D C^%DTC S SDATE=X ;allow for last month since using date reported
U IO D HDR F RQDT=SDATE:0 S RQDT=$O(^DVB(396.3,"C",RQDT)) Q:RQDT=""!(RQDT>EDATE) F DA=0:0 S DA=$O(^DVB(396.3,"C",RQDT,DA)) Q:DA="" S X=$P(^DVB(396.3,DA,0),U,5) I X'<SDATE,X'>EDATE D GO1
S PNAM="" F RQDT=0:0 S RQDT=$O(^TMP($J,RQDT)) Q:RQDT="" F ZI=0:0 S PNAM=$O(^TMP($J,RQDT,PNAM)) Q:PNAM="" F DA=0:0 S DA=$O(^TMP($J,RQDT,PNAM,DA)) Q:DA="" D PRINT
W !!,"Total requests: ",TOTAL,!!
;
EXIT D:$D(ZTQUEUED) KILL^%ZTLOAD K DTRPT,DTRPT2,REQCA G KILL^DVBCUTIL
;
GO1 ;request can be included only if at least one exam wasn't transferred out
S TFIND=0,COUNT=0
F XI=0:0 S XI=$O(^DVB(396.4,"C",DA,XI)) Q:XI="" D
.S COUNT=COUNT+1
.I $D(^DVB(396.4,XI,"TRAN")) S TFIND=TFIND+1
;if TFIND=COUNT then all exams are transferred, so do not consider for report
I TFIND<COUNT D
.S DFN=$P(^DVB(396.3,DA,0),U,1)
.S NAME=$S($D(^DPT(DFN,0)):$P(^(0),U,1),1:"patient file record missing")
.S DVBCSSN=$S($D(^DPT(DFN,0)):$P(^(0),U,9),1:"")
.S ^TMP($J,$E(RQDT,1,7),NAME,DA)=DVBCSSN K DVBCSSN,DFN,NAME
Q
;
HDR S PG=PG+1 I (IOST?1"C-".E)!(PG>1) W @IOF
W DVBCDT(0),?(IOM-$L(HD)\2),HD,?(IOM-9),"Page: ",PG,!?(IOM-$L(HD2)\2),HD2,!!!
W "Veteran name",?33,"SSN",?45,"Date reported-MAS",?69,"Date scheduled",?93,"Requested by",?119,"Days",!
F LINE=1:1:IOM W "-"
W !! Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCNTSC 3020 printed Oct 16, 2024@17:45:56 Page 2
DVBCNTSC ;ALB ISC/THM-REQUESTS NOT SCHEDULED IN THREE DAYS ; 9/28/91 8:13 AM
+1 ;;2.7;AMIE;**2,19,193**;Apr 10, 1995;Build 84
+2 ;;
+3 DO HOME^%ZIS
SET (PG,TOTAL)=0
+4 SET Y=DT
XECUTE ^DD("DD")
SET DVBCDT(0)=Y
DO NOW^%DTC
SET DVBCNOW=%
KILL %
+5 GOTO EN
+6 ;
PRINT SET DTA=^DVB(396.3,DA,0)
SET DFN=$PIECE(DTA,U,1)
SET DTRPT=$PIECE(DTA,U,5)
+1 ;AJF; Request Status Conversion
+2 ;cancelled requests
SET RQSTAT=$$RSTAT^DVBCUTL8($PIECE(DTA,U,18))
SET REQCA=$PIECE(DTA,U,19)
if (RQSTAT["X"!(REQCA'=""))
QUIT
+3 SET Y=DTRPT
XECUTE ^DD("DD")
SET DTRPT2=Y
SET RO=$PIECE(DTA,U,3)
SET RO=$SELECT($DATA(^DIC(4,+RO,0)):$PIECE(^(0),U,1),1:"Unknown RO")
SET DTSCH=$PIECE(DTA,U,6)
SET Y=DTSCH
XECUTE ^DD("DD")
SET DTSCH2=Y
KILL DTA
+4 SET DAYS=0
IF DTSCH=""
SET X1=DVBCNOW
SET X2=DTRPT
DO ^%DTC
if X'>3
QUIT
SET DAYS=X
+5 IF DTSCH]""
SET X1=DTSCH
SET X2=DTRPT
DO ^%DTC
if X'>3
QUIT
SET DAYS=X
+6 WRITE PNAM,?33,^TMP($JOB,RQDT,PNAM,DA),?45,DTRPT2,?69,DTSCH2,?93,RO,?119,DAYS,!
SET TOTAL=TOTAL+1
IF $Y>55
DO HDR
+7 QUIT
+8 ;
EN WRITE @IOF,"2507 Exams Not Scheduled Within Three Days",!!!
+1 SET %DT(0)=-DT
SET %DT="AE"
SET %DT("A")="Enter STARTING DATE REPORTED TO MAS: "
DO ^%DT
if Y<0
GOTO EXIT
SET SDATE2=Y
SET SDATE=Y-.5
+2 SET %DT("A")=" and ENDING DATE REPORTED TO MAS: "
DO ^%DT
if Y<0
GOTO EXIT
SET EDATE2=Y
SET EDATE=Y+.2359
+3 KILL %DT
SET HD="2507 Requests Not Scheduled in Three Days at "_$$SITE^DVBCUTL4
SET HD2="From "
SET Y=$EXTRACT(SDATE2,1,7)
XECUTE ^DD("DD")
SET HD2=HD2_Y
SET Y=$EXTRACT(EDATE2,1,7)
XECUTE ^DD("DD")
SET HD2=HD2_" to "_Y
+4 ;
DEV WRITE !!
SET %ZIS="AEQ"
DO ^%ZIS
if POP
GOTO EXIT
+1 IF IOM<132
WRITE *7,!!,"A right margin of 132 is required for this output!",!!
GOTO DEV
+2 IF $DATA(IO("Q"))
SET ZTIO=ION
SET ZTRTN="GO^DVBCNTSC"
SET ZTDESC="2507 exams not scheduled in 3 days"
FOR I="TOTAL","PG","SDATE*","EDATE*","HD*","DVBC*"
SET ZTSAVE(I)=""
+3 IF $TEST
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE *7,!!,"Request queued.",!!
GOTO EXIT
+4 ;
GO ;S X1=SDATE,X2=-7 D C^%DTC S SDATE=X ;allow for last month since using date reported
KILL ^TMP($JOB)
+1 USE IO
DO HDR
FOR RQDT=SDATE:0
SET RQDT=$ORDER(^DVB(396.3,"C",RQDT))
if RQDT=""!(RQDT>EDATE)
QUIT
FOR DA=0:0
SET DA=$ORDER(^DVB(396.3,"C",RQDT,DA))
if DA=""
QUIT
SET X=$PIECE(^DVB(396.3,DA,0),U,5)
IF X'<SDATE
IF X'>EDATE
DO GO1
+2 SET PNAM=""
FOR RQDT=0:0
SET RQDT=$ORDER(^TMP($JOB,RQDT))
if RQDT=""
QUIT
FOR ZI=0:0
SET PNAM=$ORDER(^TMP($JOB,RQDT,PNAM))
if PNAM=""
QUIT
FOR DA=0:0
SET DA=$ORDER(^TMP($JOB,RQDT,PNAM,DA))
if DA=""
QUIT
DO PRINT
+3 WRITE !!,"Total requests: ",TOTAL,!!
+4 ;
EXIT if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
KILL DTRPT,DTRPT2,REQCA
GOTO KILL^DVBCUTIL
+1 ;
GO1 ;request can be included only if at least one exam wasn't transferred out
+1 SET TFIND=0
SET COUNT=0
+2 FOR XI=0:0
SET XI=$ORDER(^DVB(396.4,"C",DA,XI))
if XI=""
QUIT
Begin DoDot:1
+3 SET COUNT=COUNT+1
+4 IF $DATA(^DVB(396.4,XI,"TRAN"))
SET TFIND=TFIND+1
End DoDot:1
+5 ;if TFIND=COUNT then all exams are transferred, so do not consider for report
+6 IF TFIND<COUNT
Begin DoDot:1
+7 SET DFN=$PIECE(^DVB(396.3,DA,0),U,1)
+8 SET NAME=$SELECT($DATA(^DPT(DFN,0)):$PIECE(^(0),U,1),1:"patient file record missing")
+9 SET DVBCSSN=$SELECT($DATA(^DPT(DFN,0)):$PIECE(^(0),U,9),1:"")
+10 SET ^TMP($JOB,$EXTRACT(RQDT,1,7),NAME,DA)=DVBCSSN
KILL DVBCSSN,DFN,NAME
End DoDot:1
+11 QUIT
+12 ;
HDR SET PG=PG+1
IF (IOST?1"C-".E)!(PG>1)
WRITE @IOF
+1 WRITE DVBCDT(0),?(IOM-$LENGTH(HD)\2),HD,?(IOM-9),"Page: ",PG,!?(IOM-$LENGTH(HD2)\2),HD2,!!!
+2 WRITE "Veteran name",?33,"SSN",?45,"Date reported-MAS",?69,"Date scheduled",?93,"Requested by",?119,"Days",!
+3 FOR LINE=1:1:IOM
WRITE "-"
+4 WRITE !!
QUIT
