XDRDQUE ;SF-IRMFO/IHS/OHPRD/JCM - START AND STOP DUPLICATE CHECKER SEARCH ;8/28/08 18:23
;;7.3;TOOLKIT;**23,47,113**;Apr 25, 1995;Build 5
;;Per VHA Directive 2004-038, this routine should not be modified.
;;
START ;
S XDRQFLG=0
;*** following commented line to be removed from Toolkit ver after 7.3
;S XDRDQUE("TASKMAN STATUS")=$P(@$Q(^%ZTSCH("STATUS","")),U,2) I XDRDQUE("TASKMAN STATUS")'="RUN" W !!,"Taskman does not seem to be running properly, Please notify your site manager.",!! G END
S XDRDQUE("TASKMAN STATUS")=$$TM^%ZTLOAD
I 'XDRDQUE("TASKMAN STATUS") W !!,"Taskman does not seem to be running properly, Please notify your site manager.",!! G END
; XT*7.3*113, variable XDRNOPT=1 makes option unavailable for the PATIENT file
N XDRNOPT S XDRNOPT=1
D FILE G:XDRQFLG END ; Asks user which file to check for dups
D CHECK^XDRU1 G:XDRQFLG END ; Checks the Duplicate Resolution file
D ASK G:XDRQFLG END ; Asks user what action and type of search
D QUEUE G:XDRQFLG END ; Queues search
I XDRDNSTA="r" D ASK3 D:'XDRQFLG QUEUE
END D EOJ ; Clean up variables
Q
;
FILE ; EP - Called by XDRDCOMP,XDRDLIST,XDRDSCOR,XDRMADD,XDRCNT
K DIC("B")
K X S:$D(XDRFL) X=XDRFL
S DIC(0)=$S($D(X):"Z",1:"QEAZ")
S:'$D(DIC("A")) DIC("A")="Select file to be checked for duplicates: "
; If XDRNOPT=1, don't allow selection of PATIENT file.(new with XT*7.3*113)
I $G(XDRNOPT)=1 D
. S DIC("S")="I Y'=2"
. W:'$D(ZTQUEUED) !,"* This option is not available for PATIENTS"
. Q
S DIC="^VA(15.1," D ^DIC K DIC,X
I Y=-1 S XDRQFLG=1 G FILEX
S XDRD(0)=Y(0),XDRD(0,0)=Y(0,0),XDRFL=$P(Y(0),U),PRIFILE=XDRFL K Y
W:'$D(ZTQUEUED) !!
FILEX Q
;
ASK ;
D DISP
D ASK1 G:XDRQFLG ASKX
I XDRDSTA="c"&($D(^VA(15.1,XDRFL,"APDTI"))) S XDRDPDTI="" W !!,"Since the Potential Duplicate Threshold has been raised",!,"I will only go through the Potential Duplicates and see if they",!,"meet the new threshold." G ASKX
D:XDRDSTA="c"&('XDRQFLG) ASK2
ASKX ;
Q
DISP ;
D DISP^XDRDSTAT
S XDRDSTA=$P(XDRD(0),U,2)
S XDRDTYPE=$P(XDRD(0),U,5)
Q
ASK1 ;
S:XDRDSTA']"" XDRDSTA="c"
S DIR(0)="Y",DIR("A")="Do You wish to "_$S(XDRDSTA="h":"CONTINUE",XDRDSTA="e":"CONTINUE",XDRDSTA="r":"HALT",1:"RUN")_" "_$S(XDRDSTA="r":"this",XDRDSTA="h":"this",XDRDSTA="e":"this",1:"a")_" search (Y/N)"
D ^DIR K DIR D OUT
I 'XDRQFLG,'Y,$S(XDRDSTA="r":0,XDRDSTA="c":0,1:1) D S Y=0
. S DIR(0)="Y",DIR("A")="Do you wish to mark this run COMPLETED (Y/N)",DIR("B")="NO" D ^DIR K DIR D OUT
. I Y,'XDRQFLG S DIE="^VA(15.1,",DA=XDRFL,DR=".02////c" D ^DIE K DA,DIE,DR
S:'Y XDRQFLG=1
K XDRDNSTA
S:'XDRQFLG XDRDNSTA=$S(XDRDSTA="h":"r",XDRDSTA="r":"h",1:"r")
Q
ASK2 ;
K XDRDTYPE
S DIR(0)="15.1,.05A",DIR("A")="Which type of Search do you wish to run ? (BASIC/NEW) "
S DIR("B")="BASIC",DIR("?")="A 'BASIC' search starts at the beginning of the file. A 'NEW' search uses a cross-reference you specify to determine which entries to test."
D ^DIR K DIR D OUT
S XDRDTYPE=$S(Y="b":"BASIC",1:"NEW")
I XDRDTYPE="BASIC" D
. N DIR S DIR(0)="Y"
. S DIR("A",1)="This process will take a **LONG** time (known to exceed 100 hours),"
. S DIR("A",2)="but you CAN stop and restart the process when you want using"
. S DIR("A")="the options OK"
. D ^DIR S:Y'>0 XDRQFLG=1
. Q
Q
;
ASK3 ;
W !
S DIR(0)="Y",DIR("A")="Do You wish to schedule a time to HALT this search (Y/N)"
D ^DIR K DIR D OUT
S:'Y XDRQFLG=1
G:XDRQFLG ASK3X
S XDRDNSTA="h"
ASK3X Q
;
QUEUE ;
S ZTRTN="XDRDMAIN",ZTIO="",ZTDESC="Duplicate "_XDRD(0,0)_" Search"
S:XDRDNSTA="h" ZTDESC="Halt "_ZTDESC
S ZTSAVE("XDRFL")="" S:$D(XDRDPDTI) ZTSAVE("XDRDPDTI")=""
S ZTSAVE("XDRDTYPE")="",ZTSAVE("XDRDNSTA")=""
D ^%ZTLOAD
S:'$D(ZTQUEUED) XDRQFLG=1
K ZTSK
QUEUEX Q
;
OUT ;
; Common point to take care of DIR,DIC, and DIE calls
I ($D(DTOUT))!($D(DUOUT))!($D(DIRUT)) K DTOUT,DUOUT,DIRUT S XDRQFLG=1
Q
EOJ ;
K X,Y,XDRFL,XDRDNSTA,XDRDSTA,XDRQFLG,XDRD,XDRDPDTI,XDRDQUE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRDQUE 3990 printed Dec 13, 2024@02:39:13 Page 2
XDRDQUE ;SF-IRMFO/IHS/OHPRD/JCM - START AND STOP DUPLICATE CHECKER SEARCH ;8/28/08 18:23
+1 ;;7.3;TOOLKIT;**23,47,113**;Apr 25, 1995;Build 5
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;;
START ;
+1 SET XDRQFLG=0
+2 ;*** following commented line to be removed from Toolkit ver after 7.3
+3 ;S XDRDQUE("TASKMAN STATUS")=$P(@$Q(^%ZTSCH("STATUS","")),U,2) I XDRDQUE("TASKMAN STATUS")'="RUN" W !!,"Taskman does not seem to be running properly, Please notify your site manager.",!! G END
+4 SET XDRDQUE("TASKMAN STATUS")=$$TM^%ZTLOAD
+5 IF 'XDRDQUE("TASKMAN STATUS")
WRITE !!,"Taskman does not seem to be running properly, Please notify your site manager.",!!
GOTO END
+6 ; XT*7.3*113, variable XDRNOPT=1 makes option unavailable for the PATIENT file
+7 NEW XDRNOPT
SET XDRNOPT=1
+8 ; Asks user which file to check for dups
DO FILE
if XDRQFLG
GOTO END
+9 ; Checks the Duplicate Resolution file
DO CHECK^XDRU1
if XDRQFLG
GOTO END
+10 ; Asks user what action and type of search
DO ASK
if XDRQFLG
GOTO END
+11 ; Queues search
DO QUEUE
if XDRQFLG
GOTO END
+12 IF XDRDNSTA="r"
DO ASK3
if 'XDRQFLG
DO QUEUE
END ; Clean up variables
DO EOJ
+1 QUIT
+2 ;
FILE ; EP - Called by XDRDCOMP,XDRDLIST,XDRDSCOR,XDRMADD,XDRCNT
+1 KILL DIC("B")
+2 KILL X
if $DATA(XDRFL)
SET X=XDRFL
+3 SET DIC(0)=$SELECT($DATA(X):"Z",1:"QEAZ")
+4 if '$DATA(DIC("A"))
SET DIC("A")="Select file to be checked for duplicates: "
+5 ; If XDRNOPT=1, don't allow selection of PATIENT file.(new with XT*7.3*113)
+6 IF $GET(XDRNOPT)=1
Begin DoDot:1
+7 SET DIC("S")="I Y'=2"
+8 if '$DATA(ZTQUEUED)
WRITE !,"* This option is not available for PATIENTS"
+9 QUIT
End DoDot:1
+10 SET DIC="^VA(15.1,"
DO ^DIC
KILL DIC,X
+11 IF Y=-1
SET XDRQFLG=1
GOTO FILEX
+12 SET XDRD(0)=Y(0)
SET XDRD(0,0)=Y(0,0)
SET XDRFL=$PIECE(Y(0),U)
SET PRIFILE=XDRFL
KILL Y
+13 if '$DATA(ZTQUEUED)
WRITE !!
FILEX QUIT
+1 ;
ASK ;
+1 DO DISP
+2 DO ASK1
if XDRQFLG
GOTO ASKX
+3 IF XDRDSTA="c"&($DATA(^VA(15.1,XDRFL,"APDTI")))
SET XDRDPDTI=""
WRITE !!,"Since the Potential Duplicate Threshold has been raised",!,"I will only go through the Potential Duplicates and see if they",!,"meet the new threshold."
GOTO ASKX
+4 if XDRDSTA="c"&('XDRQFLG)
DO ASK2
ASKX ;
+1 QUIT
DISP ;
+1 DO DISP^XDRDSTAT
+2 SET XDRDSTA=$PIECE(XDRD(0),U,2)
+3 SET XDRDTYPE=$PIECE(XDRD(0),U,5)
+4 QUIT
ASK1 ;
+1 if XDRDSTA']""
SET XDRDSTA="c"
+2 SET DIR(0)="Y"
SET DIR("A")="Do You wish to "_$SELECT(XDRDSTA="h":"CONTINUE",XDRDSTA="e":"CONTINUE",XDRDSTA="r":"HALT",1:"RUN")_" "_$SELECT(XDRDSTA="r":"this",XDRDSTA="h":"this",XDRDSTA="e":"this",1:"a")_" search (Y/N)"
+3 DO ^DIR
KILL DIR
DO OUT
+4 IF 'XDRQFLG
IF 'Y
IF $SELECT(XDRDSTA="r":0,XDRDSTA="c":0,1:1)
Begin DoDot:1
+5 SET DIR(0)="Y"
SET DIR("A")="Do you wish to mark this run COMPLETED (Y/N)"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
DO OUT
+6 IF Y
IF 'XDRQFLG
SET DIE="^VA(15.1,"
SET DA=XDRFL
SET DR=".02////c"
DO ^DIE
KILL DA,DIE,DR
End DoDot:1
SET Y=0
+7 if 'Y
SET XDRQFLG=1
+8 KILL XDRDNSTA
+9 if 'XDRQFLG
SET XDRDNSTA=$SELECT(XDRDSTA="h":"r",XDRDSTA="r":"h",1:"r")
+10 QUIT
ASK2 ;
+1 KILL XDRDTYPE
+2 SET DIR(0)="15.1,.05A"
SET DIR("A")="Which type of Search do you wish to run ? (BASIC/NEW) "
+3 SET DIR("B")="BASIC"
SET DIR("?")="A 'BASIC' search starts at the beginning of the file. A 'NEW' search uses a cross-reference you specify to determine which entries to test."
+4 DO ^DIR
KILL DIR
DO OUT
+5 SET XDRDTYPE=$SELECT(Y="b":"BASIC",1:"NEW")
+6 IF XDRDTYPE="BASIC"
Begin DoDot:1
+7 NEW DIR
SET DIR(0)="Y"
+8 SET DIR("A",1)="This process will take a **LONG** time (known to exceed 100 hours),"
+9 SET DIR("A",2)="but you CAN stop and restart the process when you want using"
+10 SET DIR("A")="the options OK"
+11 DO ^DIR
if Y'>0
SET XDRQFLG=1
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
ASK3 ;
+1 WRITE !
+2 SET DIR(0)="Y"
SET DIR("A")="Do You wish to schedule a time to HALT this search (Y/N)"
+3 DO ^DIR
KILL DIR
DO OUT
+4 if 'Y
SET XDRQFLG=1
+5 if XDRQFLG
GOTO ASK3X
+6 SET XDRDNSTA="h"
ASK3X QUIT
+1 ;
QUEUE ;
+1 SET ZTRTN="XDRDMAIN"
SET ZTIO=""
SET ZTDESC="Duplicate "_XDRD(0,0)_" Search"
+2 if XDRDNSTA="h"
SET ZTDESC="Halt "_ZTDESC
+3 SET ZTSAVE("XDRFL")=""
if $DATA(XDRDPDTI)
SET ZTSAVE("XDRDPDTI")=""
+4 SET ZTSAVE("XDRDTYPE")=""
SET ZTSAVE("XDRDNSTA")=""
+5 DO ^%ZTLOAD
+6 if '$DATA(ZTQUEUED)
SET XDRQFLG=1
+7 KILL ZTSK
QUEUEX QUIT
+1 ;
OUT ;
+1 ; Common point to take care of DIR,DIC, and DIE calls
+2 IF ($DATA(DTOUT))!($DATA(DUOUT))!($DATA(DIRUT))
KILL DTOUT,DUOUT,DIRUT
SET XDRQFLG=1
+3 QUIT
EOJ ;
+1 KILL X,Y,XDRFL,XDRDNSTA,XDRDSTA,XDRQFLG,XDRD,XDRDPDTI,XDRDQUE
+2 QUIT
