SDYRENR ;ALB/ABR - PATIENT FILE ENROLL CLINIC CLEANUP ; SEP 28 1995
;;5.3;Scheduling;**32**;Aug 13, 1993
EN ;
N ZTDESC,ZTRTN,ZTIO,ZTQUEUED,ZTSK,I,X
W !!,"<<CLEAN-UP OF INCOMPLETE ENROLLMENT CLINICS IN PATIENT FILE>>",!
I '$G(DUZ)!'$D(DTIME)!'$D(U) W !!,*7,">> USER NOT DEFINED. CANNOT CONTINUE" Q
F I=1:1 S X=$P($T(TEXT+I),";;",2) Q:X="QUIT" W !,X
QUE S ZTRTN="CLN^SDYRENR",ZTDESC="PATIENT FILE ENROLLMENT CLINIC CLEAN-UP",ZTIO=""
D ^%ZTLOAD
W !!,$S($D(ZTSK):">>>Task "_ZTSK_" has been queued.",1:">>> UNABLE TO QUEUE THIS JOB.")
Q
CLN ;entry point from Queue
N SDI,SDJ,SDK,SDSTART
S SDI=0,SDK=0,SDSTART=$$HTE^XLFDT($H)
F S SDI=$O(^DPT(SDI)) Q:'SDI D
.S SDJ=0
.F S SDJ=$O(^DPT(SDI,"DE",SDJ)),SDK=SDK+1 Q:'SDJ D W:'(SDK#500)&'$D(ZTQUEUED) "."
..Q:$P($G(^DPT(SDI,"DE",SDJ,0)),U,2)]"" I '$O(^(1,0)) D DELETE
I '$D(ZTQUEUED) W ">> DONE!",!
D TEMPLATE
D MAIL
Q
;
DELETE ; delete incomplete enrollment clinic
N DA,DIE,DR
S DIE="^DPT("_SDI_",""DE"",",DA(1)=SDI,DA=SDJ,DR=".01///@"
D ^DIE
Q
MAIL ;
N SDTEXT,DIFROM
S SDTEXT(1)="The Patient file Enrollment Clinic clean-up began on "_SDSTART
S SDTEXT(2)="and ran to completion on "_$$HTE^XLFDT($H)_"."
S SDTEXT(3)=" ",SDTEXT(4)="** Please delete the SDYR* routines at this time. **"
S XMSUB="Patient File Enrollment Clinic Clean-up Complete",XMTEXT="SDTEXT("
S XMDUZ=.5,XMY(DUZ)=""
D ^XMD
Q
TEXT ;display text
;;This routine will loop through the PATIENT file, checking to see that
;;Enrollment Clinics are properly set up.
;;
;;Any active clinics missing dates will be deleted.
;;
;;This will also delete the unused sort template SD-AMB-PROC-LIST.
;;
;;THIS CLEAN-UP WILL TAKE SOME TIME AND MUST BE QUEUED!!
;;
;;QUIT
Q
TEMPLATE ; clean-up of unused template
N DIC,DIK,DA,X,Y
S (DIC,DIK)="^DIBT(",DIC(0)="X",X="SD-AMB-PROC-LIST"
D ^DIC
I Y>0 S DA=+Y D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDYRENR 1917 printed Nov 22, 2024@18:13:39 Page 2
SDYRENR ;ALB/ABR - PATIENT FILE ENROLL CLINIC CLEANUP ; SEP 28 1995
+1 ;;5.3;Scheduling;**32**;Aug 13, 1993
EN ;
+1 NEW ZTDESC,ZTRTN,ZTIO,ZTQUEUED,ZTSK,I,X
+2 WRITE !!,"<<CLEAN-UP OF INCOMPLETE ENROLLMENT CLINICS IN PATIENT FILE>>",!
+3 IF '$GET(DUZ)!'$DATA(DTIME)!'$DATA(U)
WRITE !!,*7,">> USER NOT DEFINED. CANNOT CONTINUE"
QUIT
+4 FOR I=1:1
SET X=$PIECE($TEXT(TEXT+I),";;",2)
if X="QUIT"
QUIT
WRITE !,X
QUE SET ZTRTN="CLN^SDYRENR"
SET ZTDESC="PATIENT FILE ENROLLMENT CLINIC CLEAN-UP"
SET ZTIO=""
+1 DO ^%ZTLOAD
+2 WRITE !!,$SELECT($DATA(ZTSK):">>>Task "_ZTSK_" has been queued.",1:">>> UNABLE TO QUEUE THIS JOB.")
+3 QUIT
CLN ;entry point from Queue
+1 NEW SDI,SDJ,SDK,SDSTART
+2 SET SDI=0
SET SDK=0
SET SDSTART=$$HTE^XLFDT($HOROLOG)
+3 FOR
SET SDI=$ORDER(^DPT(SDI))
if 'SDI
QUIT
Begin DoDot:1
+4 SET SDJ=0
+5 FOR
SET SDJ=$ORDER(^DPT(SDI,"DE",SDJ))
SET SDK=SDK+1
if 'SDJ
QUIT
Begin DoDot:2
+6 if $PIECE($GET(^DPT(SDI,"DE",SDJ,0)),U,2)]""
QUIT
IF '$ORDER(^(1,0))
DO DELETE
End DoDot:2
if '(SDK#500)&'$DATA(ZTQUEUED)
WRITE "."
End DoDot:1
+7 IF '$DATA(ZTQUEUED)
WRITE ">> DONE!",!
+8 DO TEMPLATE
+9 DO MAIL
+10 QUIT
+11 ;
DELETE ; delete incomplete enrollment clinic
+1 NEW DA,DIE,DR
+2 SET DIE="^DPT("_SDI_",""DE"","
SET DA(1)=SDI
SET DA=SDJ
SET DR=".01///@"
+3 DO ^DIE
+4 QUIT
MAIL ;
+1 NEW SDTEXT,DIFROM
+2 SET SDTEXT(1)="The Patient file Enrollment Clinic clean-up began on "_SDSTART
+3 SET SDTEXT(2)="and ran to completion on "_$$HTE^XLFDT($HOROLOG)_"."
+4 SET SDTEXT(3)=" "
SET SDTEXT(4)="** Please delete the SDYR* routines at this time. **"
+5 SET XMSUB="Patient File Enrollment Clinic Clean-up Complete"
SET XMTEXT="SDTEXT("
+6 SET XMDUZ=.5
SET XMY(DUZ)=""
+7 DO ^XMD
+8 QUIT
TEXT ;display text
+1 ;;This routine will loop through the PATIENT file, checking to see that
+2 ;;Enrollment Clinics are properly set up.
+3 ;;
+4 ;;Any active clinics missing dates will be deleted.
+5 ;;
+6 ;;This will also delete the unused sort template SD-AMB-PROC-LIST.
+7 ;;
+8 ;;THIS CLEAN-UP WILL TAKE SOME TIME AND MUST BE QUEUED!!
+9 ;;
+10 ;;QUIT
+11 QUIT
TEMPLATE ; clean-up of unused template
+1 NEW DIC,DIK,DA,X,Y
+2 SET (DIC,DIK)="^DIBT("
SET DIC(0)="X"
SET X="SD-AMB-PROC-LIST"
+3 DO ^DIC
+4 IF Y>0
SET DA=+Y
DO ^DIK
+5 QUIT
