SDECCLN ;ALB/RBD - VISTA SCHEDULING CLEANUP UTILITY ;MAR 15, 2017
;;5.3;Scheduling;**658**;Aug 13, 1993;Build 23
;
Q
;
EN N X,Y
W !!,"The following Utility will allow the Closing of Re-Opened SDEC APPT REQUEST"
W !,"records which have resulted from a Cancellation in VistA of a corresponding"
W !,"SDEC APPOINTMENT."
;
EN2 K DIR S DIR(0)="SO^1:Compile List of Re-Opened REQUEST records that can be Closed;2:Commit Records to Be Closed from Compiled List"
S DIR("A")="What Would You like to Do?" D ^DIR Q:$D(DIRUT) G:Y=1 CLINICS G WRKLIST
Q
;
CLINICS K DIRUT,^TMP($J) W !!,"Please enter in, one by one, a list of Clinics to EXCLUDE from Compilation.",!
CLINIC S DIC("A")="Enter CLINIC to EXCLUDE: ",DIC="^SC(",DIC(0)="AEQMZ"
S DIC("S")="I $P(^(0),U,3)=""C"",'$G(^(""OOS""))" D ^DIC G:X="^" EN
I X="" K DIC G COMPILE
S ^TMP($J,X,$P(Y,"^",1))=""
G CLINIC
;
COMPILE ; Begin to Compile based on Clinics not Excluded
I '$D(^TMP($J)) D G:Y'=1 CLINICS
. W !!,"You did not choose any Clinics to Exclude."
. S DIR("B")="NO"
. S DIR("A")="Are you sure you want to run cleanup for ALL clinics? (Y OR N):"
. S DIR(0)="Y^AO" D ^DIR
W !!,"Compiling for all Clinics excluding the following:",!
S X="" F S X=$O(^TMP($J,X)) Q:X="" W !,X
ASKDEV W ! S SDJOBNO=$J S %ZIS="Q"
D ^%ZIS Q:POP
I $D(IO("Q")) D K POP,SDJOBNO,%ZIS G EN
. K ZTSAVE S ZTSAVE("SDJOBNO")="",ZTRTN="COMPIL2^SDECCLN"
. S ZTDESC="Compile of Open SDEC APPT REQUEST Records"
. D ^%ZTLOAD,^%ZISC K ZTDESC,ZTRTN
D COMPIL2 D ^%ZISC
K POP,SDJOBNO,%ZIS G EN
;
COMPIL2 ;
;O IO
U IO
N SDCID,SDCNT,SDCNCLDT,SDCLN,SDCLINS,SDCLINS2,SDATE,SDPT,SDSSN,X,Y
N SDIEN,SDIEN2,SDLINK,SDFND
M SDCLINS=^TMP(SDJOBNO)
L +^XTMP("SDECCLEAN"):5 I '$T D Q
. W !!,"Another user is running utility at same time as you."
. w !,"Please try again later."
S SDCNT=+$O(^XTMP("SDECCLEAN",""),-1)+1
S ^XTMP("SDECCLEAN",SDCNT,"START")=$H
S ^XTMP("SDECCLEAN",SDCNT,"DUZ")=DUZ
I '$D(^XTMP("SDECCLEAN",0)) S ^XTMP("SDECCLEAN",0)=$$FMADD^XLFDT(DT,365)
L -^XTMP("SDECCLEAN")
D HEADER
S X="" F S X=$O(SDCLINS(X)) Q:X="" D
. S ^XTMP("SDECCLEAN",SDCNT,"EXCLUDED CLINIC",X)=""
. S Y="" F S Y=$O(SDCLINS(X,Y)) Q:Y="" D
.. S SDCLINS2(Y)="" ; just store Clinic IENs to Exclude
S SDATE="" F S SDATE=$O(^SDEC(409.85,"E","O",SDATE)) Q:SDATE="" D
. S SDIEN="" F S SDIEN=$O(^SDEC(409.85,"E","O",SDATE,SDIEN)) Q:SDIEN="" D
.. S SDCLN=$$GET1^DIQ(409.85,SDIEN,8,"I") Q:SDCLN="" Q:$D(SDCLINS2(SDCLN))
.. Q:$$GET1^DIQ(409.85,SDIEN,41)="YES"
.. Q:$$GET1^DIQ(409.85,SDIEN,4,"I")'="APPT"
.. S SDPT=$$GET1^DIQ(409.85,SDIEN,.01,"I")
.. S SDFND=0,SDIEN2="" ; SDFND set if Cancellation in 409.84 Found
.. F S SDIEN2=$O(^SDEC(409.84,"CPAT",SDPT,SDIEN2)) Q:SDIEN2="" D Q:SDFND
... S SDCNCLDT=$$GET1^DIQ(409.84,SDIEN2,.12) Q:'$L(SDCNCLDT)
... S SDLINK=$$GET1^DIQ(409.84,SDIEN2,.22,"I")
... I $P(SDLINK,";",1)=SDIEN,$P(SDLINK,";",2)["SDEC(409.85," S SDFND=1
.. Q:'SDFND
.. S SDCLN=$$GET1^DIQ(409.85,SDIEN,8)
.. S SDCID=$$GET1^DIQ(409.85,SDIEN,22,"I")
.. S SDSSN=$$GET1^DIQ(2,SDPT,.09)
.. S SDPT=$$GET1^DIQ(409.85,SDIEN,.01)
.. S ^XTMP("SDECCLEAN",SDCNT,"CL",SDCLN,"PT",SDPT,"IEN",SDIEN)=SDSSN_"^"_SDCID_"^"_SDIEN2
D DSPLIST S ^XTMP("SDECCLEAN",SDCNT,"FINISH")=$H
Q
;
N SDRUNDAT S SDRUNDAT=$$HTE^XLFDT(^XTMP("SDECCLEAN",SDCNT,"START"))
W !!,?9,"*** Open SDEC APPT REQUESTs List run "_SDRUNDAT_" ***"
W !!,?43,"LAST 4",?50,"APPT REQ IEN"
W !,"CLINIC",?20,"PATIENT",?45,"SSN",?50," APPT IEN",?69,"CID DATE"
N SDASH S $P(SDASH,"=",80)="" W !,SDASH,!
Q
;
DSPLIST ; Display list of records
N SDREC
S SDCLN=""
F S SDCLN=$O(^XTMP("SDECCLEAN",SDCNT,"CL",SDCLN)) Q:SDCLN="" D
. S SDPT=""
. F S SDPT=$O(^XTMP("SDECCLEAN",SDCNT,"CL",SDCLN,"PT",SDPT)) Q:SDPT="" D
.. S SDIEN=""
.. F S SDIEN=$O(^XTMP("SDECCLEAN",SDCNT,"CL",SDCLN,"PT",SDPT,"IEN",SDIEN)) Q:SDIEN="" D
... S SDREC=$G(^XTMP("SDECCLEAN",SDCNT,"CL",SDCLN,"PT",SDPT,"IEN",SDIEN))
... Q:SDREC="" S SDSSN=$P(SDREC,"^",1),SDCID=$P(SDREC,"^",2)
... S SDIEN2=$P(SDREC,"^",3)
... W !,$E(SDCLN,1,18),?20,$E(SDPT,1,23)
... W ?45,$E(SDSSN,6,9)
... W ?50,SDIEN," ; ",SDIEN2,?69,$$FMTE^XLFDT(SDCID,5)
Q
;
WRKLIST K DIRUT N SDCOUNT,SDCNT,SDSTART,SDFINISH,SDUSER S SDCOUNT=0
S SDCNT=0 D WRKHEAD
WRKLST2 S SDCNT=$O(^XTMP("SDECCLEAN",SDCNT)) G:SDCNT="" ASKBTCH
S SDUSER=$G(^XTMP("SDECCLEAN",SDCNT,"DUZ"))
S SDSTART=$G(^XTMP("SDECCLEAN",SDCNT,"START"))
S SDFINISH=$G(^XTMP("SDECCLEAN",SDCNT,"FINISH"))
W !,SDCNT,?15,$$GET1^DIQ(200,SDUSER,.01),?30,$$HTE^XLFDT(SDSTART)
W ?55,$$HTE^XLFDT(SDFINISH) S SDCOUNT=SDCOUNT+1
I SDCOUNT#16=0 G ASKBTCH
G WRKLST2
;
WRKHEAD N SDASH W:$D(IOF) @IOF S $P(SDASH,"=",80)=""
W !!,"Open SDEC APPT REQUEST Compilation Lists to Choose From:"
W !!,"Batch #",?15,"Run User",?30,"Start Date",?55,"Finish Date",!,SDASH,!
Q
;
ASKBTCH N SDASKMES,SDRESP S SDASKMES="Enter Batch #"_$S(SDCNT'="":" or <Return> to continue",1:"")
W !!,SDASKMES,":" R SDRESP:300 I '$T W " ... Read Timeout" G EN
G:SDRESP["^" EN I SDRESP="" G:SDCNT="" EN D WRKHEAD G WRKLST2
I SDRESP'?1N.N W " ... Please enter a Batch #" G ASKBTCH
I SDRESP=0 W " ... Please enter a Batch #" G ASKBTCH
I '$D(^XTMP("SDECCLEAN",SDRESP)) W " ... Batch # not in List" G ASKBTCH
I '$D(^XTMP("SDECCLEAN",SDRESP,"FINISH")) W " ... Batch Run not Finished" G ASKBTCH
I '$D(^XTMP("SDECCLEAN",SDRESP,"CL")) W " ... Batch Run picked up No Records" G ASKBTCH
;
COMMIT W !!,"Committing Open records for Batch # ",SDRESP," to Closed..."
N SDCLN,SDPT,SDIEN,SDNUM S SDCLN="",SDNUM=0
F S SDCLN=$O(^XTMP("SDECCLEAN",SDRESP,"CL",SDCLN)) Q:SDCLN="" D
. S SDPT=""
. F S SDPT=$O(^XTMP("SDECCLEAN",SDRESP,"CL",SDCLN,"PT",SDPT)) Q:SDPT="" D
.. S SDIEN=""
.. F S SDIEN=$O(^XTMP("SDECCLEAN",SDRESP,"CL",SDCLN,"PT",SDPT,"IEN",SDIEN)) Q:SDIEN="" D
... I $$GET1^DIQ(409.85,SDIEN,23,"I")="C" Q
... S DR="23////C;19////"_DT_";20////"_DUZ_";21////ER;21.1////Y"
... S DIE="^SDEC(409.85,",DA=SDIEN D ^DIE
... S SDNUM=SDNUM+1 W:SDNUM#100=0 "."
K DA,DIE,DR
W "Done" Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECCLN 6178 printed Nov 22, 2024@18:01:50 Page 2
SDECCLN ;ALB/RBD - VISTA SCHEDULING CLEANUP UTILITY ;MAR 15, 2017
+1 ;;5.3;Scheduling;**658**;Aug 13, 1993;Build 23
+2 ;
+3 QUIT
+4 ;
EN NEW X,Y
+1 WRITE !!,"The following Utility will allow the Closing of Re-Opened SDEC APPT REQUEST"
+2 WRITE !,"records which have resulted from a Cancellation in VistA of a corresponding"
+3 WRITE !,"SDEC APPOINTMENT."
+4 ;
EN2 KILL DIR
SET DIR(0)="SO^1:Compile List of Re-Opened REQUEST records that can be Closed;2:Commit Records to Be Closed from Compiled List"
+1 SET DIR("A")="What Would You like to Do?"
DO ^DIR
if $DATA(DIRUT)
QUIT
if Y=1
GOTO CLINICS
GOTO WRKLIST
+2 QUIT
+3 ;
CLINICS KILL DIRUT,^TMP($JOB)
WRITE !!,"Please enter in, one by one, a list of Clinics to EXCLUDE from Compilation.",!
CLINIC SET DIC("A")="Enter CLINIC to EXCLUDE: "
SET DIC="^SC("
SET DIC(0)="AEQMZ"
+1 SET DIC("S")="I $P(^(0),U,3)=""C"",'$G(^(""OOS""))"
DO ^DIC
if X="^"
GOTO EN
+2 IF X=""
KILL DIC
GOTO COMPILE
+3 SET ^TMP($JOB,X,$PIECE(Y,"^",1))=""
+4 GOTO CLINIC
+5 ;
COMPILE ; Begin to Compile based on Clinics not Excluded
+1 IF '$DATA(^TMP($JOB))
Begin DoDot:1
+2 WRITE !!,"You did not choose any Clinics to Exclude."
+3 SET DIR("B")="NO"
+4 SET DIR("A")="Are you sure you want to run cleanup for ALL clinics? (Y OR N):"
+5 SET DIR(0)="Y^AO"
DO ^DIR
End DoDot:1
if Y'=1
GOTO CLINICS
+6 WRITE !!,"Compiling for all Clinics excluding the following:",!
+7 SET X=""
FOR
SET X=$ORDER(^TMP($JOB,X))
if X=""
QUIT
WRITE !,X
ASKDEV WRITE !
SET SDJOBNO=$JOB
SET %ZIS="Q"
+1 DO ^%ZIS
if POP
QUIT
+2 IF $DATA(IO("Q"))
Begin DoDot:1
+3 KILL ZTSAVE
SET ZTSAVE("SDJOBNO")=""
SET ZTRTN="COMPIL2^SDECCLN"
+4 SET ZTDESC="Compile of Open SDEC APPT REQUEST Records"
+5 DO ^%ZTLOAD
DO ^%ZISC
KILL ZTDESC,ZTRTN
End DoDot:1
KILL POP,SDJOBNO,%ZIS
GOTO EN
+6 DO COMPIL2
DO ^%ZISC
+7 KILL POP,SDJOBNO,%ZIS
GOTO EN
+8 ;
COMPIL2 ;
+1 ;O IO
+2 USE IO
+3 NEW SDCID,SDCNT,SDCNCLDT,SDCLN,SDCLINS,SDCLINS2,SDATE,SDPT,SDSSN,X,Y
+4 NEW SDIEN,SDIEN2,SDLINK,SDFND
+5 MERGE SDCLINS=^TMP(SDJOBNO)
+6 LOCK +^XTMP("SDECCLEAN"):5
IF '$TEST
Begin DoDot:1
+7 WRITE !!,"Another user is running utility at same time as you."
+8 WRITE !,"Please try again later."
End DoDot:1
QUIT
+9 SET SDCNT=+$ORDER(^XTMP("SDECCLEAN",""),-1)+1
+10 SET ^XTMP("SDECCLEAN",SDCNT,"START")=$HOROLOG
+11 SET ^XTMP("SDECCLEAN",SDCNT,"DUZ")=DUZ
+12 IF '$DATA(^XTMP("SDECCLEAN",0))
SET ^XTMP("SDECCLEAN",0)=$$FMADD^XLFDT(DT,365)
+13 LOCK -^XTMP("SDECCLEAN")
+14 DO HEADER
+15 SET X=""
FOR
SET X=$ORDER(SDCLINS(X))
if X=""
QUIT
Begin DoDot:1
+16 SET ^XTMP("SDECCLEAN",SDCNT,"EXCLUDED CLINIC",X)=""
+17 SET Y=""
FOR
SET Y=$ORDER(SDCLINS(X,Y))
if Y=""
QUIT
Begin DoDot:2
+18 ; just store Clinic IENs to Exclude
SET SDCLINS2(Y)=""
End DoDot:2
End DoDot:1
+19 SET SDATE=""
FOR
SET SDATE=$ORDER(^SDEC(409.85,"E","O",SDATE))
if SDATE=""
QUIT
Begin DoDot:1
+20 SET SDIEN=""
FOR
SET SDIEN=$ORDER(^SDEC(409.85,"E","O",SDATE,SDIEN))
if SDIEN=""
QUIT
Begin DoDot:2
+21 SET SDCLN=$$GET1^DIQ(409.85,SDIEN,8,"I")
if SDCLN=""
QUIT
if $DATA(SDCLINS2(SDCLN))
QUIT
+22 if $$GET1^DIQ(409.85,SDIEN,41)="YES"
QUIT
+23 if $$GET1^DIQ(409.85,SDIEN,4,"I")'="APPT"
QUIT
+24 SET SDPT=$$GET1^DIQ(409.85,SDIEN,.01,"I")
+25 ; SDFND set if Cancellation in 409.84 Found
SET SDFND=0
SET SDIEN2=""
+26 FOR
SET SDIEN2=$ORDER(^SDEC(409.84,"CPAT",SDPT,SDIEN2))
if SDIEN2=""
QUIT
Begin DoDot:3
+27 SET SDCNCLDT=$$GET1^DIQ(409.84,SDIEN2,.12)
if '$LENGTH(SDCNCLDT)
QUIT
+28 SET SDLINK=$$GET1^DIQ(409.84,SDIEN2,.22,"I")
+29 IF $PIECE(SDLINK,";",1)=SDIEN
IF $PIECE(SDLINK,";",2)["SDEC(409.85,"
SET SDFND=1
End DoDot:3
if SDFND
QUIT
+30 if 'SDFND
QUIT
+31 SET SDCLN=$$GET1^DIQ(409.85,SDIEN,8)
+32 SET SDCID=$$GET1^DIQ(409.85,SDIEN,22,"I")
+33 SET SDSSN=$$GET1^DIQ(2,SDPT,.09)
+34 SET SDPT=$$GET1^DIQ(409.85,SDIEN,.01)
+35 SET ^XTMP("SDECCLEAN",SDCNT,"CL",SDCLN,"PT",SDPT,"IEN",SDIEN)=SDSSN_"^"_SDCID_"^"_SDIEN2
End DoDot:2
End DoDot:1
+36 DO DSPLIST
SET ^XTMP("SDECCLEAN",SDCNT,"FINISH")=$HOROLOG
+37 QUIT
+38 ;
+1 NEW SDRUNDAT
SET SDRUNDAT=$$HTE^XLFDT(^XTMP("SDECCLEAN",SDCNT,"START"))
+2 WRITE !!,?9,"*** Open SDEC APPT REQUESTs List run "_SDRUNDAT_" ***"
+3 WRITE !!,?43,"LAST 4",?50,"APPT REQ IEN"
+4 WRITE !,"CLINIC",?20,"PATIENT",?45,"SSN",?50," APPT IEN",?69,"CID DATE"
+5 NEW SDASH
SET $PIECE(SDASH,"=",80)=""
WRITE !,SDASH,!
+6 QUIT
+7 ;
DSPLIST ; Display list of records
+1 NEW SDREC
+2 SET SDCLN=""
+3 FOR
SET SDCLN=$ORDER(^XTMP("SDECCLEAN",SDCNT,"CL",SDCLN))
if SDCLN=""
QUIT
Begin DoDot:1
+4 SET SDPT=""
+5 FOR
SET SDPT=$ORDER(^XTMP("SDECCLEAN",SDCNT,"CL",SDCLN,"PT",SDPT))
if SDPT=""
QUIT
Begin DoDot:2
+6 SET SDIEN=""
+7 FOR
SET SDIEN=$ORDER(^XTMP("SDECCLEAN",SDCNT,"CL",SDCLN,"PT",SDPT,"IEN",SDIEN))
if SDIEN=""
QUIT
Begin DoDot:3
+8 SET SDREC=$GET(^XTMP("SDECCLEAN",SDCNT,"CL",SDCLN,"PT",SDPT,"IEN",SDIEN))
+9 if SDREC=""
QUIT
SET SDSSN=$PIECE(SDREC,"^",1)
SET SDCID=$PIECE(SDREC,"^",2)
+10 SET SDIEN2=$PIECE(SDREC,"^",3)
+11 WRITE !,$EXTRACT(SDCLN,1,18),?20,$EXTRACT(SDPT,1,23)
+12 WRITE ?45,$EXTRACT(SDSSN,6,9)
+13 WRITE ?50,SDIEN," ; ",SDIEN2,?69,$$FMTE^XLFDT(SDCID,5)
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
WRKLIST KILL DIRUT
NEW SDCOUNT,SDCNT,SDSTART,SDFINISH,SDUSER
SET SDCOUNT=0
+1 SET SDCNT=0
DO WRKHEAD
WRKLST2 SET SDCNT=$ORDER(^XTMP("SDECCLEAN",SDCNT))
if SDCNT=""
GOTO ASKBTCH
+1 SET SDUSER=$GET(^XTMP("SDECCLEAN",SDCNT,"DUZ"))
+2 SET SDSTART=$GET(^XTMP("SDECCLEAN",SDCNT,"START"))
+3 SET SDFINISH=$GET(^XTMP("SDECCLEAN",SDCNT,"FINISH"))
+4 WRITE !,SDCNT,?15,$$GET1^DIQ(200,SDUSER,.01),?30,$$HTE^XLFDT(SDSTART)
+5 WRITE ?55,$$HTE^XLFDT(SDFINISH)
SET SDCOUNT=SDCOUNT+1
+6 IF SDCOUNT#16=0
GOTO ASKBTCH
+7 GOTO WRKLST2
+8 ;
WRKHEAD NEW SDASH
if $DATA(IOF)
WRITE @IOF
SET $PIECE(SDASH,"=",80)=""
+1 WRITE !!,"Open SDEC APPT REQUEST Compilation Lists to Choose From:"
+2 WRITE !!,"Batch #",?15,"Run User",?30,"Start Date",?55,"Finish Date",!,SDASH,!
+3 QUIT
+4 ;
ASKBTCH NEW SDASKMES,SDRESP
SET SDASKMES="Enter Batch #"_$SELECT(SDCNT'="":" or <Return> to continue",1:"")
+1 WRITE !!,SDASKMES,":"
READ SDRESP:300
IF '$TEST
WRITE " ... Read Timeout"
GOTO EN
+2 if SDRESP["^"
GOTO EN
IF SDRESP=""
if SDCNT=""
GOTO EN
DO WRKHEAD
GOTO WRKLST2
+3 IF SDRESP'?1N.N
WRITE " ... Please enter a Batch #"
GOTO ASKBTCH
+4 IF SDRESP=0
WRITE " ... Please enter a Batch #"
GOTO ASKBTCH
+5 IF '$DATA(^XTMP("SDECCLEAN",SDRESP))
WRITE " ... Batch # not in List"
GOTO ASKBTCH
+6 IF '$DATA(^XTMP("SDECCLEAN",SDRESP,"FINISH"))
WRITE " ... Batch Run not Finished"
GOTO ASKBTCH
+7 IF '$DATA(^XTMP("SDECCLEAN",SDRESP,"CL"))
WRITE " ... Batch Run picked up No Records"
GOTO ASKBTCH
+8 ;
COMMIT WRITE !!,"Committing Open records for Batch # ",SDRESP," to Closed..."
+1 NEW SDCLN,SDPT,SDIEN,SDNUM
SET SDCLN=""
SET SDNUM=0
+2 FOR
SET SDCLN=$ORDER(^XTMP("SDECCLEAN",SDRESP,"CL",SDCLN))
if SDCLN=""
QUIT
Begin DoDot:1
+3 SET SDPT=""
+4 FOR
SET SDPT=$ORDER(^XTMP("SDECCLEAN",SDRESP,"CL",SDCLN,"PT",SDPT))
if SDPT=""
QUIT
Begin DoDot:2
+5 SET SDIEN=""
+6 FOR
SET SDIEN=$ORDER(^XTMP("SDECCLEAN",SDRESP,"CL",SDCLN,"PT",SDPT,"IEN",SDIEN))
if SDIEN=""
QUIT
Begin DoDot:3
+7 IF $$GET1^DIQ(409.85,SDIEN,23,"I")="C"
QUIT
+8 SET DR="23////C;19////"_DT_";20////"_DUZ_";21////ER;21.1////Y"
+9 SET DIE="^SDEC(409.85,"
SET DA=SDIEN
DO ^DIE
+10 SET SDNUM=SDNUM+1
if SDNUM#100=0
WRITE "."
End DoDot:3
End DoDot:2
End DoDot:1
+11 KILL DA,DIE,DR
+12 WRITE "Done"
QUIT
+13 ;
