DG17202 ;BHM/RGY,ALS-Create new request for patient demographic change ;FEB 20, 1998
;;5.3;Registration;**172**;Aug 13, 1993
ADD(FILE) ;
NEW DIC,D0,DIE,DA,X,DLAYGO,DR,RGOK,EVN,DINUM
F EVN=+$P(^XTMP("DGTMP",FILE,0),"^",3)+1:1 L +^XTMP("DGTMP",FILE,EVN):0 I $T S RGOK=0 D L -^XTMP("DGTMP",FILE,EVN) Q:RGOK
.I $D(^XTMP("DGTMP",FILE,EVN)) Q
.S DINUM=EVN,DIC="^XTMP(""DGTMP"","_FILE_",",DIC(0)="L",DLAYGO=FILE,X=EVN K DD,D0 D FILE^DICN K DIC,DLAYGO,D0
.S RGOK=1
.Q
Q EVN
ADDR(FILE,NAME) ;
NEW DIC,D0,DIE,DA,X,DLAYGO,DR,RGOK,EVN,DINUM
F EVN=+$P(^DIC(FILE,0),"^",3)+1:1 L +^DIC(FILE,EVN):0 I $T S RGOK=0 D L -^DIC(FILE,EVN) Q:RGOK
.I $D(^DIC(FILE,EVN)) Q
.S DINUM=EVN,DIC="^DIC("_FILE_",",DIC(0)="L",DLAYGO=FILE,X=NAME K DD,D0 D FILE^DICN K DIC,DLAYGO,D0
.S RGOK=1
.Q
Q EVN
CONV ;Start conversion process
NEW TASK
I '$$CHK() Q
I '$$CHK2() Q
L +^XTMP("DGTMP",390.1,"ASTOP"):1 E Q
F TASK=0:0 S TASK=$O(^XTMP("DGTMP",390.1,TASK)) Q:'TASK I $P(^XTMP("DGTMP",390.1,TASK,0),"^",9)="" D TASK(TASK) I $G(^XTMP("DGTMP",390.1,"ASTOP"))="YES" D SEND G Q1
D SEND,JOBKILL
Q1 Q
SEND ;
L -^XTMP("DGTMP",390.1,"ASTOP")
D BROAD^DG17204
Q
TASK(TASK) ;Convert a file (task)
NEW GLOB,ENTRY,NODE,OV,PIECE,N0,NV,TYPE,COUNT,FIELD
S N0=$G(^XTMP("DGTMP",390.1,TASK,0)) I N0="" Q
S COUNT=0,GLOB="^"_$P(N0,"^",4),NODE=$P(N0,"^",5),FIELD=$P(N0,"^",3),PIECE=$P(N0,"^",6),TYPE=$P(N0,"^",7)
I $P(^XTMP("DGTMP",390.1,TASK,0),"^",9)]"" Q
I '$$CHK1(TYPE) D NOW^%DTC S $P(^XTMP("DGTMP",390.1,TASK,0),"^",9)=% K % Q
F ENTRY=$P(N0,"^",8):0 S ENTRY=$O(@(GLOB_ENTRY_")")) Q:'ENTRY D I $G(^XTMP("DGTMP",390.1,"ASTOP"))="YES" G OUT
.S OV=$P($G(@(GLOB_ENTRY_","_NODE_")")),"^",PIECE)
.S NV=$$GETNV(TYPE,OV)
.I NV'=-1,NV'=OV D
..S DIE=GLOB,DA=ENTRY,DR=FIELD_"////^S X="""_$S(NV="":"@",1:NV)_"""" D ^DIE
..I NV'="" S X=$P(^XTMP("DGTMP",390.2,$O(^XTMP("DGTMP",390.2,$S(TYPE=13:"AC",1:"AD"),OV,0)),0),"^",9),$P(^(0),"^",9)=X+1
..Q
.S $P(^XTMP("DGTMP",390.1,TASK,0),"^",8)=ENTRY
.Q
S $P(^XTMP("DGTMP",390.1,TASK,0),"^",9)=$$NOW^XLFDT
OUT Q
GETNV(TYPE,VALUE) ;
NEW NV
I VALUE=0 Q ""
I VALUE="" Q -1
;IF POINTS TO A INVALID VALUE SET TO NULL
I '$D(^DIC(TYPE,VALUE,0)) Q ""
;IF POINTS TO A NEW ENTRY...IT WAS A BROKEN POINTER TO BEGIN WITH
I $P($G(^XTMP("DGTMP",390.2,+$O(^XTMP("DGTMP",390.2,$S(TYPE=13:"AC",1:"AD"),VALUE,0)),0)),"^",8)=1 Q ""
S NV=$P(^XTMP("DGTMP",390.2,$O(^XTMP("DGTMP",390.2,$S(TYPE=13:"AC",1:"AD"),VALUE,0)),0),"^",$S(TYPE=13:6,1:7))
I NV Q NV
Q VALUE
CHK() ;IS CONVERSION NECESSARY?
FOR X=0:0 S X=$O(^XTMP("DGTMP",390.2,X)) Q:'X I $P(^XTMP("DGTMP",390.2,X,0),"^",8)!'$P(^(0),"^",3) Q
Q X>0
CHK1(FILE) ;IS CONVERSION FOR A FILE NECESSARY?
FOR X=0:0 S X=$O(^XTMP("DGTMP",390.2,X)) Q:'X I $P(^XTMP("DGTMP",390.2,X,0),"^",2)=FILE I $P(^XTMP("DGTMP",390.2,X,0),"^",8)!'$P(^(0),"^",3) Q
Q X>0
CHK2() ;ARE ALL THE NONSTANDARD ENTRIES MAPPED?
FOR X=0:0 S X=$O(^XTMP("DGTMP",390.2,X)) Q:'X I '$P(^XTMP("DGTMP",390.2,X,0),"^",3),$P(^(0),"^",6)="",$P(^(0),"^",7)="" Q
Q '(X>0)
CHK3() ;DID THE CONVERSION RUN TO COMPLETION?
I '$$CHK() Q 1
FOR X=0:0 S X=$O(^XTMP("DGTMP",390.1,X)) Q:'X I '$P(^XTMP("DGTMP",390.1,X,0),"^",9) Q
Q '(X>0)
JOB ;Start background job
NEW ZTIO,ZTDTH,ZTASK,ZTRTN,ZTDESC,DIR,DIRUT
I '$$CHK() W !!,"*** Conversion is not necessary! ***",!!,"Uninstalling patch..." D JOBKILL W "...done!" Q
I '$$CHK2() W !!,"*** Not all non-standard entries have been mapped...see DG172 options ***",! Q
L +^XTMP("DGTMP",390.1,"ASTOP"):1 E W !,"*** Job appears to already be running! ***",! Q
W ! D MESS^DG17204("CONV") W !
S DIR("A")="Are you sure you want to start the conversion process"
S DIR(0)="Y",DIR("B")="NO"
D ^DIR K DIR Q:$D(DIRUT)!'Y
L -^XTMP("DGTMP",390.1,"ASTOP")
S ^XTMP("DGTMP",390.1,"ASTOP")="NO"
S ZTIO="",ZTRTN="CONV^DG17202",ZTDESC="Marital/Religion File Conversion" D ^%ZTLOAD
I $D(ZTSK) W !,"*** Task #: "_ZTSK_" ***",!
S ZTREQ="@"
K ZTSK,Y
Q
STOP ;Stop background job
NEW DIR,DIRUT
L +^XTMP("DGTMP",390.1,"ASTOP"):1 E D Q
.S DIR("A")="Are you sure you want to stop the background conversion process",DIR(0)="Y",DIR("B")="NO"
.D ^DIR K DIR Q:$D(DIRUT)!'Y
.S ^XTMP("DGTMP",390.1,"ASTOP")="YES"
.W !!,"*** Job will stop soon ***",! K Y
.Q
L -^XTMP("DGTMP",390.1,"ASTOP")
W !,"*** Conversion process is NOT running! ***",!
Q
JOBKILL ;
NEW OPT,FILE,DA,DR,DIE,IDEL,NON,PI,ITEM
FOR NON=0:0 S NON=$O(^XTMP("DGTMP",390.2,NON)) Q:'NON I '$P(^(NON,0),"^",3) D
.S DIE=$P(^(0),"^",2),DA=$S(DIE=11:$P(^(0),"^",5),1:$P(^(0),"^",4)),DR=".01///@",DIE="^DIC("_DIE_"," D ^DIE
.Q
F FILE=390.1,390.2 S DIU="^XTMP(""DGTMP"","_FILE_",",DIU(0)="DT" D EN^DIU2
K DIU
S OPT="RGPR PRE-IMP MENU" S PI=$$FIND1^DIC(19,"","OX",OPT)
I PI D FIND^DIC(19,"",.01,"M","DG172 ") S ITEM="" F S ITEM=$O(^TMP("DILIST",$J,1,ITEM)) Q:ITEM="" S IDEL=$$DELETE^XPDMENU(OPT,$P(^TMP("DILIST",$J,1,ITEM),U))
S OPT="DG172" F S OPT=$O(^DIC(19,"B",OPT)) Q:$E(OPT,1,5)'="DG172" S DIE="^DIC(19,",DA=$O(^(OPT,0)),DR=".01///@",DIDEL=19 D ^DIE K DIDEL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG17202 5107 printed Apr 09, 2024@21:51:08 Page 2
DG17202 ;BHM/RGY,ALS-Create new request for patient demographic change ;FEB 20, 1998
+1 ;;5.3;Registration;**172**;Aug 13, 1993
ADD(FILE) ;
+1 NEW DIC,D0,DIE,DA,X,DLAYGO,DR,RGOK,EVN,DINUM
+2 FOR EVN=+$PIECE(^XTMP("DGTMP",FILE,0),"^",3)+1:1
LOCK +^XTMP("DGTMP",FILE,EVN):0
IF $TEST
SET RGOK=0
Begin DoDot:1
+3 IF $DATA(^XTMP("DGTMP",FILE,EVN))
QUIT
+4 SET DINUM=EVN
SET DIC="^XTMP(""DGTMP"","_FILE_","
SET DIC(0)="L"
SET DLAYGO=FILE
SET X=EVN
KILL DD,D0
DO FILE^DICN
KILL DIC,DLAYGO,D0
+5 SET RGOK=1
+6 QUIT
End DoDot:1
LOCK -^XTMP("DGTMP",FILE,EVN)
if RGOK
QUIT
+7 QUIT EVN
ADDR(FILE,NAME) ;
+1 NEW DIC,D0,DIE,DA,X,DLAYGO,DR,RGOK,EVN,DINUM
+2 FOR EVN=+$PIECE(^DIC(FILE,0),"^",3)+1:1
LOCK +^DIC(FILE,EVN):0
IF $TEST
SET RGOK=0
Begin DoDot:1
+3 IF $DATA(^DIC(FILE,EVN))
QUIT
+4 SET DINUM=EVN
SET DIC="^DIC("_FILE_","
SET DIC(0)="L"
SET DLAYGO=FILE
SET X=NAME
KILL DD,D0
DO FILE^DICN
KILL DIC,DLAYGO,D0
+5 SET RGOK=1
+6 QUIT
End DoDot:1
LOCK -^DIC(FILE,EVN)
if RGOK
QUIT
+7 QUIT EVN
CONV ;Start conversion process
+1 NEW TASK
+2 IF '$$CHK()
QUIT
+3 IF '$$CHK2()
QUIT
+4 LOCK +^XTMP("DGTMP",390.1,"ASTOP"):1
IF '$TEST
QUIT
+5 FOR TASK=0:0
SET TASK=$ORDER(^XTMP("DGTMP",390.1,TASK))
if 'TASK
QUIT
IF $PIECE(^XTMP("DGTMP",390.1,TASK,0),"^",9)=""
DO TASK(TASK)
IF $GET(^XTMP("DGTMP",390.1,"ASTOP"))="YES"
DO SEND
GOTO Q1
+6 DO SEND
DO JOBKILL
Q1 QUIT
SEND ;
+1 LOCK -^XTMP("DGTMP",390.1,"ASTOP")
+2 DO BROAD^DG17204
+3 QUIT
TASK(TASK) ;Convert a file (task)
+1 NEW GLOB,ENTRY,NODE,OV,PIECE,N0,NV,TYPE,COUNT,FIELD
+2 SET N0=$GET(^XTMP("DGTMP",390.1,TASK,0))
IF N0=""
QUIT
+3 SET COUNT=0
SET GLOB="^"_$PIECE(N0,"^",4)
SET NODE=$PIECE(N0,"^",5)
SET FIELD=$PIECE(N0,"^",3)
SET PIECE=$PIECE(N0,"^",6)
SET TYPE=$PIECE(N0,"^",7)
+4 IF $PIECE(^XTMP("DGTMP",390.1,TASK,0),"^",9)]""
QUIT
+5 IF '$$CHK1(TYPE)
DO NOW^%DTC
SET $PIECE(^XTMP("DGTMP",390.1,TASK,0),"^",9)=%
KILL %
QUIT
+6 FOR ENTRY=$PIECE(N0,"^",8):0
SET ENTRY=$ORDER(@(GLOB_ENTRY_")"))
if 'ENTRY
QUIT
Begin DoDot:1
+7 SET OV=$PIECE($GET(@(GLOB_ENTRY_","_NODE_")")),"^",PIECE)
+8 SET NV=$$GETNV(TYPE,OV)
+9 IF NV'=-1
IF NV'=OV
Begin DoDot:2
+10 SET DIE=GLOB
SET DA=ENTRY
SET DR=FIELD_"////^S X="""_$SELECT(NV="":"@",1:NV)_""""
DO ^DIE
+11 IF NV'=""
SET X=$PIECE(^XTMP("DGTMP",390.2,$ORDER(^XTMP("DGTMP",390.2,$SELECT(TYPE=13:"AC",1:"AD"),OV,0)),0),"^",9)
SET $PIECE(^(0),"^",9)=X+1
+12 QUIT
End DoDot:2
+13 SET $PIECE(^XTMP("DGTMP",390.1,TASK,0),"^",8)=ENTRY
+14 QUIT
End DoDot:1
IF $GET(^XTMP("DGTMP",390.1,"ASTOP"))="YES"
GOTO OUT
+15 SET $PIECE(^XTMP("DGTMP",390.1,TASK,0),"^",9)=$$NOW^XLFDT
OUT QUIT
GETNV(TYPE,VALUE) ;
+1 NEW NV
+2 IF VALUE=0
QUIT ""
+3 IF VALUE=""
QUIT -1
+4 ;IF POINTS TO A INVALID VALUE SET TO NULL
+5 IF '$DATA(^DIC(TYPE,VALUE,0))
QUIT ""
+6 ;IF POINTS TO A NEW ENTRY...IT WAS A BROKEN POINTER TO BEGIN WITH
+7 IF $PIECE($GET(^XTMP("DGTMP",390.2,+$ORDER(^XTMP("DGTMP",390.2,$SELECT(TYPE=13:"AC",1:"AD"),VALUE,0)),0)),"^",8)=1
QUIT ""
+8 SET NV=$PIECE(^XTMP("DGTMP",390.2,$ORDER(^XTMP("DGTMP",390.2,$SELECT(TYPE=13:"AC",1:"AD"),VALUE,0)),0),"^",$SELECT(TYPE=13:6,1:7))
+9 IF NV
QUIT NV
+10 QUIT VALUE
CHK() ;IS CONVERSION NECESSARY?
+1 FOR X=0:0
SET X=$ORDER(^XTMP("DGTMP",390.2,X))
if 'X
QUIT
IF $PIECE(^XTMP("DGTMP",390.2,X,0),"^",8)!'$PIECE(^(0),"^",3)
QUIT
+2 QUIT X>0
CHK1(FILE) ;IS CONVERSION FOR A FILE NECESSARY?
+1 FOR X=0:0
SET X=$ORDER(^XTMP("DGTMP",390.2,X))
if 'X
QUIT
IF $PIECE(^XTMP("DGTMP",390.2,X,0),"^",2)=FILE
IF $PIECE(^XTMP("DGTMP",390.2,X,0),"^",8)!'$PIECE(^(0),"^",3)
QUIT
+2 QUIT X>0
CHK2() ;ARE ALL THE NONSTANDARD ENTRIES MAPPED?
+1 FOR X=0:0
SET X=$ORDER(^XTMP("DGTMP",390.2,X))
if 'X
QUIT
IF '$PIECE(^XTMP("DGTMP",390.2,X,0),"^",3)
IF $PIECE(^(0),"^",6)=""
IF $PIECE(^(0),"^",7)=""
QUIT
+2 QUIT '(X>0)
CHK3() ;DID THE CONVERSION RUN TO COMPLETION?
+1 IF '$$CHK()
QUIT 1
+2 FOR X=0:0
SET X=$ORDER(^XTMP("DGTMP",390.1,X))
if 'X
QUIT
IF '$PIECE(^XTMP("DGTMP",390.1,X,0),"^",9)
QUIT
+3 QUIT '(X>0)
JOB ;Start background job
+1 NEW ZTIO,ZTDTH,ZTASK,ZTRTN,ZTDESC,DIR,DIRUT
+2 IF '$$CHK()
WRITE !!,"*** Conversion is not necessary! ***",!!,"Uninstalling patch..."
DO JOBKILL
WRITE "...done!"
QUIT
+3 IF '$$CHK2()
WRITE !!,"*** Not all non-standard entries have been mapped...see DG172 options ***",!
QUIT
+4 LOCK +^XTMP("DGTMP",390.1,"ASTOP"):1
IF '$TEST
WRITE !,"*** Job appears to already be running! ***",!
QUIT
+5 WRITE !
DO MESS^DG17204("CONV")
WRITE !
+6 SET DIR("A")="Are you sure you want to start the conversion process"
+7 SET DIR(0)="Y"
SET DIR("B")="NO"
+8 DO ^DIR
KILL DIR
if $DATA(DIRUT)!'Y
QUIT
+9 LOCK -^XTMP("DGTMP",390.1,"ASTOP")
+10 SET ^XTMP("DGTMP",390.1,"ASTOP")="NO"
+11 SET ZTIO=""
SET ZTRTN="CONV^DG17202"
SET ZTDESC="Marital/Religion File Conversion"
DO ^%ZTLOAD
+12 IF $DATA(ZTSK)
WRITE !,"*** Task #: "_ZTSK_" ***",!
+13 SET ZTREQ="@"
+14 KILL ZTSK,Y
+15 QUIT
STOP ;Stop background job
+1 NEW DIR,DIRUT
+2 LOCK +^XTMP("DGTMP",390.1,"ASTOP"):1
IF '$TEST
Begin DoDot:1
+3 SET DIR("A")="Are you sure you want to stop the background conversion process"
SET DIR(0)="Y"
SET DIR("B")="NO"
+4 DO ^DIR
KILL DIR
if $DATA(DIRUT)!'Y
QUIT
+5 SET ^XTMP("DGTMP",390.1,"ASTOP")="YES"
+6 WRITE !!,"*** Job will stop soon ***",!
KILL Y
+7 QUIT
End DoDot:1
QUIT
+8 LOCK -^XTMP("DGTMP",390.1,"ASTOP")
+9 WRITE !,"*** Conversion process is NOT running! ***",!
+10 QUIT
JOBKILL ;
+1 NEW OPT,FILE,DA,DR,DIE,IDEL,NON,PI,ITEM
+2 FOR NON=0:0
SET NON=$ORDER(^XTMP("DGTMP",390.2,NON))
if 'NON
QUIT
IF '$PIECE(^(NON,0),"^",3)
Begin DoDot:1
+3 SET DIE=$PIECE(^(0),"^",2)
SET DA=$SELECT(DIE=11:$PIECE(^(0),"^",5),1:$PIECE(^(0),"^",4))
SET DR=".01///@"
SET DIE="^DIC("_DIE_","
DO ^DIE
+4 QUIT
End DoDot:1
+5 FOR FILE=390.1,390.2
SET DIU="^XTMP(""DGTMP"","_FILE_","
SET DIU(0)="DT"
DO EN^DIU2
+6 KILL DIU
+7 SET OPT="RGPR PRE-IMP MENU"
SET PI=$$FIND1^DIC(19,"","OX",OPT)
+8 IF PI
DO FIND^DIC(19,"",.01,"M","DG172 ")
SET ITEM=""
FOR
SET ITEM=$ORDER(^TMP("DILIST",$JOB,1,ITEM))
if ITEM=""
QUIT
SET IDEL=$$DELETE^XPDMENU(OPT,$PIECE(^TMP("DILIST",$JOB,1,ITEM),U))
+9 SET OPT="DG172"
FOR
SET OPT=$ORDER(^DIC(19,"B",OPT))
if $EXTRACT(OPT,1,5)'="DG172"
QUIT
SET DIE="^DIC(19,"
SET DA=$ORDER(^(OPT,0))
SET DR=".01///@"
SET DIDEL=19
DO ^DIE
KILL DIDEL
+10 QUIT
