Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XDRMERGB

XDRMERGB.m

Go to the documentation of this file. 
XDRMERGB ;SF-IRMFO.SEA/JLI - TENATIVE UPDATE POINTER NODES ;5/14/98  10:30

 ;;7.3;TOOLKIT;**23,137**;Apr 25, 1995;Build 11

 ;;

 Q

 ;

MERGEIT ; MERGE TWO ENTRIES IN FILE

 N NODE,NODE1,NODE2,NODEA,SFILE,XDRFROM,XDRTO,NODEA,VALUE,XVALUE,XDRXX,NODEB,DIK,DA,I,Y,VREF,XNN,XFILNO,IENTOSTR,DFN,XDRZZ

 N XDRAA ; DEBUG STATEMENT

 ;

 S XFILNO=+$P(@(XDRDIC_"0)"),U,2)

 S IENTOSTR=IENTO_","_XDRIENS

 S DFN=IENTO

 ;

 ; NOW MERGE DATA GOING NODE BY NODE

 ;

 S NODE=""

 F  D  Q:NODE=""

 . S NODE1=$O(@(XDRDIC_IENFROM_","""_NODE_""")"))

 . I NODE1="" S NODE="" Q  ; NOTHING MORE TO MOVE OVER

 . S NODE2=$O(@(XDRDIC_IENTO_","""_NODE_""")"))

 . I NODE2'="",NODE1]NODE2 S NODE=NODE2 Q  ; NODE ON TO, BUT NOT ON FROM - GO TO NEXT

 . S NODE=NODE1

 . I $D(@(XDRDIC_IENFROM_","""_NODE_""")"))=1 D  Q  ; SINGLE NODE, MERGE DATA

 . . I NODE2]NODE1!(NODE2="") D  Q  ;  MISSING NODE, JUST MOVE IT OVER

 . . . N XDRXX,FLD,N,J

 . . . F N=0:0 S N=$O(^DD(XFILNO,"GL",NODE,N)) Q:N'>0  S FLD=$O(^(N,0)) I $O(^DD(XFILNO,FLD,1,0))>0 D

 . . . . S X=0 F J=0:0 S J=$O(^DD(XFILNO,FLD,1,J)) Q:J'>0  I $O(^(J,0))>0 S X=1 Q

 . . . . I X>0 D

 . . . . . S XDRXX(XFILNO,IENTOSTR,FLD)=$P(@(XDRDIC_IENFROM_","""_NODE_""")"),U,N)

 . . . K XDRAA I $D(XDRTESTK),$D(XDRXX) M XDRAA=XDRXX ; DEBUT STATEMENT

 . . . K XDRZZ

 . . . I $D(XDRXX) D FILE^DIE("","XDRXX","XDRZZ")

 . . . I $D(XDRTESTK),$D(XDRZZ) S XDRTESTK=XDRTESTK+1 M ^XTMP("XDRTESTK",$$NOW^XLFDT(),XDRTESTK,"XX")=XDRAA,^("ZZ")=XDRZZ ; DEBUG STATMENT

 . . . M @(XDRDIC_IENTO_","""_NODE_""")")=@(XDRDIC_IENFROM_","""_NODE_""")")

 . . I $D(@(XDRDIC_IENTO_","""_NODE_""")"))>1 Q  ; MISMATCH SO QUIT

 . . N XDRXX,FLD

 . . S X1=@(XDRDIC_IENFROM_","""_NODE_""")")

 . . S (X2,X3)=@(XDRDIC_IENTO_","""_NODE_""")")

 . . F I=1:1 Q:X1=""  S X=$P(X1,U),X1=$P(X1,U,2,999) I X'="" D

 . . . S Y=$P(X2,U,I)

 . . . I Y=""  D

 . . . . ;S $P(X2,U,I)=X ;LLS 26-OCT-2013 replaced with conditional SET below

 . . . . S FLD=$O(^DD(XFILNO,"GL",NODE,I,0)) S JXFLD=FLD

 . . . . I (XFILNO'=2)!(FLD'=.6) S $P(X2,U,I)=X ;LLS 26-OCT-2013 - replaced set of X2 so do not move 'test patient indicator'

 . . . . I XFILNO=2,FLD=.6 Q  ;LLS 26-OCT-2013 - Do not want to move 'test patient indicator' 

 . . . . I FLD>0,$O(^DD(XFILNO,FLD,1,0))>0 S XDRXX(XFILNO,IENTOSTR,FLD)=X

 . . I X2'=X3 D

 . . . I $D(XDRXX) D

 . . . . K XDRAA I $D(XDRTESTK) M XDRAA=XDRXX ; DEBUG STATEMENT

 . . . . K XDRZZ

 . . . . N X2 D FILE^DIE("","XDRXX","XDRZZ")

 . . . . I $D(XDRTESTK),$D(XDRZZ) S XDRTESTK=XDRTESTK+1 M ^XTMP("XDRTESTK",$$NOW^XLFDT(),XDRTESTK,"XX")=XDRAA,^("ZZ")=XDRZZ ; DEBUG STATMENT

 . . . S @(XDRDIC_IENTO_","""_NODE_""")")=X2 ; SET MERGED DATA ON NODE

 . ;

 . ; THE FOLLOWING HANDLES NODES THAT HAVE MULTIPLES

 . ;

 . S XDRFROM=XDRDIC_IENFROM_","""_NODE_""","

 . S XDRTO=XDRDIC_IENTO_","""_NODE_""","

 . I NODE="DIS",XFILNO=2 D DODIS^XDRMERGA Q

 . S IENTOSTR=IENTO_","_XDRIENS

 . D DOSUBS^XDRMERGA(XDRFROM,XDRTO,IENTOSTR,IENTO)

 S XDRXX=$P(@(XDRDIC_IENFROM_",0)"),U)

 K DA N DIU S DIU(0)=1 S DIK=XDRDIC,DA=IENFROM,DFN=DA D ^DIK ; KILL OFF MERGED FROM ENTRY

 S @(XDRDIC_IENFROM_",0)")=XDRXX

 Q

 ;

SAVEMERG(FILE,IENFROM,IENTO) ;

 N IENS,XDRFILE,YYY,ZZZ,XDRFDA,FROMARG,TOARG,XDRDA,Q,Q1,IENVAL,XDRSUB

 S FROMARG=$O(@FROM@(IENFROM,IENTO,"")) Q:FROMARG=""

 S TOARG=$O(@FROM@(IENFROM,IENTO,FROMARG,""))

 S XDRDA=$$FIND1^DIC(15.4,"","Q",FROMARG)

 I XDRDA>0,$P(^XDRM(XDRDA,0),U)'=FROMARG S XDRDA=0

 I XDRDA'>0 D

 . N XDRFDA

 . S XDRFDA(15.4,"+1,",.01)=FROMARG

 . S XDRFDA(15.4,"+1,",.02)=TOARG

 . S XDRFDA(15.4,"+1,",.03)=DT

 . D UPDATE^DIE("","XDRFDA","YYY") S IENS=YYY(1)

 . S XDRDA=YYY(1)

 S XDRFILE=$P(^DIC(FILE,0),U)

 S IENS=$$FIND1^DIC(15.41,","_XDRDA_",","Q",XDRFILE)

 I IENS'>0 D

 . S IENS="+1,"_XDRDA_","

 . S XDRFDA(15.41,IENS,.01)=XDRFILE

 . I IENFROM>0 S XDRFDA(15.41,IENS,.02)=IENFROM

 . K YYY

 . D UPDATE^DIE("","XDRFDA","YYY","ZZZ") S IENS=YYY(1)

 I IENFROM>0 D

 . S XDRSUB=15.411,IENVAL=IENFROM

 . D STORMERG

 K XDRFDA

 S IENS=$$FIND1^DIC(15.42,","_XDRDA_",","Q",XDRFILE)

 I IENS'>0 D

 . S IENS="+1,"_XDRDA_","

 . S XDRFDA(15.42,IENS,.01)=XDRFILE

 . I IENTO>0 S XDRFDA(15.42,IENS,.02)=IENTO

 . K YYY,ZZZ

 . D UPDATE^DIE("","XDRFDA","YYY","ZZZ") S IENS=YYY(1)

 I IENTO>0 D

 . S XDRSUB=15.421,IENVAL=IENTO

 . D STORMERG

 Q

STORMERG ;

 K ^VA(15.4,XDRDA,$S(XDRSUB=15.411:1,1:2),IENS,1) ; REMOVE ANY PREVIOUS TRIES

 S IENS="+1,"_IENS_","_XDRDA_","

 S Q=^DIC(FILE,0,"GL")_IENVAL_")",Q1=$E(Q,1,$L(Q)-1)

 F  S Q=$Q(@Q) Q:Q'[Q1  D

 . K XDRFDA

 . S XDRFDA(XDRSUB,IENS,.01)=$E(Q,2,$L(Q))

 . I @Q'="" S XDRFDA(XDRSUB,IENS,1.01)=@Q

 . D UPDATE^DIE("","XDRFDA")

 Q

 ;

SAVEPNTR(IENFROM,IENTO,FILE,IENS,FIELD,VALUE) ;

 N XDRFDA,XDRDA,FROMARG

 S FROMARG=$O(@FROM@(IENFROM,IENTO,"")) Q:FROMARG=""

 S XDRDA=$$FIND1^DIC(15.4,"","Q",FROMARG)

 S X=FILE_";"_IENS_";"_FIELD

 S XDRFDA(15.43,"+1,"_XDRDA_",",.01)=X

 S XDRFDA(15.43,"+1,"_XDRDA_",",1.01)=VALUE

 D UPDATE^DIE("","XDRFDA")

 Q

SNDMSG(XDRFDA) ;Sends msg when merge process has completed.

 N XDRGRP,XMTEXT,XMSUB,XMDUZ,XDRNAME

 S XDRNAME=$$GET1^DIQ(15.2,XDRFDA,.01)

 S R(1,0)=XDRNAME_" merge process has completed."

 S XDRGRP=$$GET1^DIQ(15.1,"2,",.29,"I")

 S:XDRGRP>0 XDRGRPN=$$GET1^DIQ(3.8,XDRGRP,.01)

 S XDRGRP=$S(XDRGRP>0:"G."_XDRGRPN,1:"")

 S:XDRGRP'="" XMY(XDRGRP)=""

 S:XDRGRP="" XMY(.5)="" ;If no mail grp found, send msg to postmaster

 S XMTEXT="R(",XMSUB=XDRNAME_" Completed",XMDUZ=.5,XMCHAN=1

 D ^XMD

 Q

 ;

QUE ;  (Moved from XDRMERG0)

 ;

 N XDRXX,XDRYY,XDRMA,DIE,DIC,DIR,DR,ZTDTH,ZTSK

 N XDRX,XDRY,XDRFIL,XDRGLOB,X,Y,XDRNAME

 N XDRFDA,XDRIENS,XDRI,XDRJ,XDRK,DA,DIK

 ;

 S XDRFIL=$$FILE^XDRDPICK() Q:XDRFIL'>0

 I XDRFIL=2 D  Q:Y

 . N X,XDRKEY

 . S (X,XDRKEY)=0 F  S X=$O(^VA(200,DUZ,51,"B",X)) Q:X'>0!(XDRKEY)  D

 . . I $$GET1^DIQ(19.1,X,.01)="DG ELIGIBILITY" S XDRKEY=1

 . . Q

 . S Y=0 I 'XDRKEY W !!,"You should hold the 'DG ELIGIBILITY' key to run a patient file merge." S Y=1

 . Q

 S XDRDIC=^DIC(XDRFIL,0,"GL")

 S XDRGLOB=$E(XDRDIC,2,999)

 S X=""

 S XNCNT=0,XNCNT0=0

 F  S X=$O(^VA(15,"AVDUP",XDRGLOB,X)) Q:X=""  S Y=$O(^(X,0)) D

 . N YVAL S YVAL=^VA(15,Y,0)

 . I $P(YVAL,U,20)>0 Q  ; ALREADY DONE OR SCHEDULED

 . I $P(YVAL,U,3)'="V" Q  ; TAKE ONLY VERIFIED

 . I $P(YVAL,U,5)'=1 Q  ; TAKE ONLY IF MARKED READY TO MERGE

 . I $P(YVAL,U,13)>0 D

 . . I '$D(@(XDRDIC_(+YVAL)_",0)"))!'$D(@(XDRDIC_(+$P(YVAL,U,2))_",0)")) Q

 . . I $P(YVAL,U,4)'=2 S XDRX(+YVAL,+$P(YVAL,U,2))=Y ; get ien numbers from duplicate file

 . . E  S XDRX(+$P(YVAL,U,2),+YVAL)=Y ; Reverse - merge to switched

 . . S XNCNT=XNCNT+1

 W !!,XNCNT,"  Entries Ready to be included in merge"

 I $O(XDRX(0))'>0 D  Q

 . W !!?15,$C(7),"No Verified Duplicates included in merge",$C(7),!!

 ;

 K DIR S DIR(0)="Y"

 S DIR("A",1)="This process will take a **LONG** time (usually over 15 hours, and sometimes"

 S DIR("A",2)="considerably longer), but you CAN stop and restart the process when you"

 S DIR("A")="want using the options.  OK"

 D ^DIR K DIR Q:Y'>0

NAME W !! S DIR(0)="F^2:30"

 S DIR("A")="Name for Merge Process"

 S DIR("?",1)="Enter a unique name by which the MERGE PROCESS will be identified"

 S DIR("?")="This name should be 2 to 30 characters in length"

 D ^DIR

 K DIR Q:Y=U  S XDRNAME=Y

 I $$FIND1^DIC(15.2,",","Q",XDRNAME)>0 D  G NAME

 . W !!,$C(7),"The name entered has already been used.  The name must be unique.",!!

 ;

 ; CREATE PROCESS ENTRY

 ;

 S XDRXX(15.2,"+1,",.01)=XDRNAME

 S XDRXX(15.2,"+1,",.02)=XDRFIL

 D UPDATE^DIE("","XDRXX","XDRYY","XDRMA")

 S XDRFDA=$G(XDRYY(1))

 ;

 ; NOW MOVE LIST OF DUPLICATES TO BE PROCESSED INTO THIS ENTRY

 S XDRIENS="+1,"_XDRFDA_","

 F XDRI=0:0 S XDRI=$O(XDRX(XDRI)) Q:XDRI'>0  D

 . S XDRJ=$O(XDRX(XDRI,0))

 . S XDRK=XDRX(XDRI,XDRJ)

 . K XDRXX,XDRYY

 . S XDRXX(15.22,XDRIENS,.01)=XDRI ; IEN1

 . S XDRXX(15.22,XDRIENS,.02)=XDRJ ; IEN2

 . S XDRXX(15.22,XDRIENS,.03)=XDRK ; ENTRY # IN FILE 15

 . D UPDATE^DIE("","XDRXX","XDRYY","XDRMA")

 . K XDRXX,XDRYY,XDRMA

 . ;    AND MARK THEM AS IN THIS MERGE PROCESS IN FILE 15

 . S XDRXX(15,XDRK_",",.05)=3

 . S XDRXX(15,XDRK_",",.2)=XDRFDA

 . D FILE^DIE("","XDRXX")

 . ; JLI 3/12/98 - FOR SOME REASON THE .05 FIELD STILL DOESN'T SEEM TO BE GETTING SET TO 3, SO CHECK IT AND IF THAT IS THE CASE, HARDSET IT.

 . I $P(^VA(15,XDRK,0),U,5)'=3 S $P(^(0),U,5)=3

 ;

 K DR S DR=".03;.04///S;" ; GET DESIRED START TIME AND MARK PROCESS AS SCHEDULED

 S DIE="^VA(15.2,"

 S DA=XDRFDA

 D ^DIE

 S ZTDTH=$P(^VA(15.2,XDRFDA,0),U,3) ; TAKE DESIRED TIME

 I ZTDTH>0 D  Q:$G(ZTSK)>0  ;         AND SET UP TASK

 . S ZTRTN="DQ^XDRMERG0",ZTDESC="MERGE PROCESS "_XDRNAME

 . S ZTIO="NULL",ZTSAVE("XDRFDA")=""

 . D ^%ZTLOAD

 . I $G(ZTSK)>0 D

 . . K DR S DR=".08///"_ZTSK_";",DIE="^VA(15.2,",DA=XDRFDA D ^DIE

 . . W !!,"Merge process '",$P(^VA(15.2,XDRFDA,0),U),"' for Verified Duplicates in File ",XDRFIL," scheduled",!,"as task ",ZTSK,".",!

 ;

 ;  TASK INFO, TIME, ETC. NOT COMPLETE - SO REVERSE IT

 ;

 F XDRI=0:0 S XDRI=$O(XDRX(XDRI)) Q:XDRI'>0  D

 . S XDRJ=$O(XDRX(XDRI,0))

 . S XDRK=XDRX(XDRI,XDRJ)

 . K XDRXX,XDRYY

 . S XDRXX(15,XDRK_",",.2)="@" ; UNMARK ENTRY IN FILE 15

 . S XDRXX(15,XDRK_",",.05)=1

 . D UPDATE^DIE("","XDRXX")

 S DA=XDRFDA

 S DIK="^VA(15.2,"

 D ^DIK

 W !!,$C(7),"The Merge Process has been aborted, no changes made."

 Q

 ;