XDRDVAL1 ;SF-CIOFO/JLI - CHECK SPECIFIED ENTRY FOR PROBLEMS ;12/04/2001 14:04
;;7.3;TOOLKIT;**23,45,46,49,57**;Apr 25, 1995
EN ;
N MFILE,FILENAME,DIR,XDR,FILE,XDRY,FILEDIC
;
D ^%ZIS Q:POP I IO'=IO(0) S XDRION=ION U IO D ^%ZISC
LOOP ;
S DATA=$NA(^TMP($J,"BB"))
K @DATA
U IO(0)
S MFILE=$$FILE^XDRDPICK() Q:MFILE'>0 S FILENAME=$P(^DIC(MFILE,0),U),FILEDIC=^DIC(MFILE,0,"GL")
W !!! S DIC=MFILE,DIC(0)="AEM" ;K DIR S DIR(0)="PO^"_MFILE_":AEM",DIR("A")="Select "_FILENAME
D ^DIC I Y'>0 U IO D ^%ZISC Q ;D ^DIR K DIR I Y'>0 U IO D ^%ZISC Q
S XDRY=Y
W !," .... WORKING HARD (may take a while)...",!
D EN1(MFILE,+XDRY,DATA)
I $D(XDRION) S IOP=XDRION D ^%ZIS I 1
E S IO=IO(0)
U IO W @IOF,!!!
W !!,"DFN=",+XDRY," ",$P(@(FILEDIC_(+XDRY)_",0)"),U) I MFILE=2!(MFILE=200) W " [",$P(^(0),U,9),"]"
I '$D(@DATA) W !?10,"No Problems Found....",!! G LOOP
D LISTPROB($NA(@DATA@(+XDRY,"VAL")))
I $D(XDRION) U IO D ^%ZISC
G LOOP
Q
;
EN1(FILE,IEN,ARRAY) ;
D SETUP^XDRMERG(FILE)
D DOENTRY^XDRDVAL(FILE,IEN,ARRAY)
F FILEX=0:0 S FILEX=$O(^TMP($J,"XFIL",FILEX)) Q:FILEX'>0 S GLOB=^(FILEX) D
. S X1=$G(^TMP($J,"XGLOB",GLOB,0,1)) Q:X1=""
. I $P(X1,U,3)'="DINUM" Q
. D DOENTRY^XDRDVAL(FILEX,IEN,ARRAY)
. Q
Q
;
LISTPROB(DATA) ;
S XDREXIT=0
F FILE=0:0 S FILE=$O(@DATA@(FILE)) Q:FILE'>0 D Q:XDREXIT
. S FILENAME=$$FILENAME(FILE),NEWHEAD=1
. S IENS="" F S IENS=$O(@DATA@(FILE,IENS)) Q:IENS="" D Q:XDREXIT
. . F FIELD=0:0 S FIELD=$O(@DATA@(FILE,IENS,FIELD)) Q:FIELD'>0 D Q:XDREXIT
. . . S X=$G(@DATA@(FILE,IENS,FIELD,"INVALID")) Q:X=""
. . . S NNOTES=0 I $D(@DATA@(FILE,IENS,FIELD,"NOTE")) D
. . . . F NNOTE=0:0 S NNOTE=$O(@DATA@(FILE,IENS,FIELD,"NOTE",NNOTE)) Q:NNOTE'>0 S NNOTES=NNOTES+1
. . . . Q
. . . S NLINES=NNOTES+3
. . . I (IOSL-$Y-4)'>NLINES D:$E(IOST)["C" Q:XDREXIT W @IOF S NEWHEAD=1
. . . . N DIR,Y,X
. . . . S DIR(0)="E" D ^DIR I 'Y S XDREXIT=1
. . . . Q
. . . W:NEWHEAD !!!,FILENAME S NEWHEAD=0
. . . W !,"Field ",FIELD," [",$P(^DD(FILE,FIELD,0),U),"] IENS=",IENS
. . . W !," value: ",X
. . . F NNOTE=0:0 S NNOTE=$O(@DATA@(FILE,IENS,FIELD,"NOTE",NNOTE)) Q:NNOTE'>0 W !," ",^(NNOTE)
. . . Q
. . Q
. Q
Q
;
FILENAME(FILE) ;
N FILENAME,NFILE
S FILENAME="",NFILE=FILE
F Q:$D(^DIC(FILE,0)) S FILENAME=FILENAME_$O(^DD(FILE,0,"NM",""))_" subfile of " S FILE=$G(^DD(FILE,0,"UP")) Q:FILE'>0
I FILE>0 S FILENAME="File "_NFILE_" ["_FILENAME_$P($G(^DIC(FILE,0)),U)_" file]"
Q FILENAME
;
ENPAIR(FILE,ARRAY,MERGEFLG) ; ENTRY POINT FOR CHECKING AN ARRAY OF PAIRS AT START OF MERGE
N XDRMESG,FROM,TO,TOVARBL,FRVARBL,DUPIEN,DATA,NLINES,XDRFDA1
;
S XDRMESG=$NA(^TMP("XDRVALMESG",$J)) K @XDRMESG
S XDRVDATA=$NA(^TMP("XDRVALDATA",$J)) K @XDRVDATA
I $G(MERGEFLG)>0 S XDRFDA1=$$FIND1^DIC(15.23,","_MERGEFLG_",","Q","DATA CHECKING")
;
F FROM=0:0 S FROM=$O(@ARRAY@(FROM)) Q:FROM'>0 D
. I $G(MERGEFLG)>0 S ^VA(15.2,MERGEFLG,3,XDRFDA1,1)=$$NOW^XLFDT()_U_U_FROM
. S TO=$O(@ARRAY@(FROM,0))
. ;
. ; add special checks for BCMA, MPI, and Pharmacy, XT*7.3*45
. ; remove MPI check for CIRN/MPI aware patch, XT*7.3*49
. ; remove BCMA checks, XT*7.3*57
. ;I $D(^PSB(53.79,"B",FROM)) D Q
. ;. S @XDRVDATA@(FROM,"VAL",53.79,TO,.01,"INVALID")="FROM Patient has data on file for BCMA, please resolve prior to merging."
. ;I $T(GETICN^MPIF001)]"",$$GETICN^MPIF001(FROM)>0 D Q
. ;. S @XDRVDATA@(FROM,"VAL",2,TO,991.01,"INVALID")="The FROM patient exist in the MPI system, this Patient cannot be merged."
. ;I $T(GETICN^MPIF001)]"",$$GETICN^MPIF001(TO)>0 D Q
. ;. S @XDRVDATA@(FROM,"VAL",2,TO,991.01,"INVALID")="The TO patient exist in the MPI system, this Patient cannot be merged."
. I $T(EN^PSJPATMR)]"",'$$EN^PSJPATMR(FROM,TO) D Q
. . S @XDRVDATA@(FROM,"VAL",55,TO,62,"INVALID")="FROM Patient has either active inpatient orders or orders on a current pick list. This needs to be resolved prior to merging."
. ;
. D CHKMERG^XDRDVAL2(FILE,FROM,TO,$NA(@XDRVDATA@(FROM,"VAL"))) ; GET BACK ANY PROBLEMS
. F S TO=$O(@ARRAY@(FROM,TO)) Q:TO'>0 D ; FROM CAN'T POINT TO MORE THAN ONE PLACE
. . S FRVARBL=$O(@ARRAY@(FROM,TO,0)) I FRVARBL="" S FRVARBL=0
. . S TOVARBL=$O(@ARRAY@(FROM,TO,FRVARBL,0)) I TOVARBL="" S TOVARBL=0
. . I TOVARBL=0 S DUPIEN=+$G(@ARRAY@(FROM,TO))
. . E S DUPIEN=+$G(@ARRAY@(FROM,TO,FRVARBL,TOVARBL))
. . D RMOVPAIR(FROM,TO,DUPIEN,ARRAY)
. . Q
. Q
I $D(@XDRVDATA) D ; GOT BACK PROBLEMS ON ONE OR MORE FIELDS
. I $G(MERGEFLG)>0 N XDRDVALF S XDRDVALF=1 S IOP="XDRBROWSER1" D ^%ZIS
. I $G(MERGEFLG)'>0,$G(XDRION)'="" S IOP=XDRION D ^%ZIS
. U IO
. F FROM=0:0 S FROM=$O(@XDRVDATA@(FROM)) Q:FROM'>0 D
. . S TO=$O(@ARRAY@(FROM,0))
. . S FRVARBL=$O(@ARRAY@(FROM,TO,0)) I FRVARBL="" S FRVARBL=0
. . S TOVARBL=$O(@ARRAY@(FROM,TO,FRVARBL,0)) I TOVARBL="" S TOVARBL=0
. . I TOVARBL=0 S DUPIEN=+$G(@ARRAY@(FROM,TO))
. . E S DUPIEN=+$G(@ARRAY@(FROM,TO,FRVARBL,TOVARBL))
. . W !!
. . I DUPIEN>0 D ; HAS AN ENTRY IN FILE 15
. . . N X,DIRECT,ORIGTO,ORIGFR
. . . S X=^VA(15,DUPIEN,0) S DIRECT=$P(X,U,4)
. . . I DIRECT=1 S ORIGFR=+X,ORIGTO=+$P(X,U,2)
. . . E S ORIGFR=+$P(X,U,2),ORIGTO=+X
. . . ;
. . . I ORIGTO'=TO D ; THE ENTRY WAS REPOINTED TO THE CURRENT 'TO' ENTRY
. . . . D PAIRID(FILE,ORIGFR,ORIGTO,DUPIEN) ; OUPUT ORIGINAL PAIR ID
. . . . W !," ******** REDIRECTED TO"
. . . . Q
. . . Q
. . ;
. . D PAIROUT(FILE,FROM,TO,DUPIEN,$NA(@XDRVDATA@(FROM,"VAL"))) ; OUTPUT PAIR ID AND PROBLEMS
. . ;
. . D RMOVPAIR(FROM,TO,DUPIEN,ARRAY) ; REMOVE PAIR FROM MERGE - NOT FROM FILE 15
. . Q
. U IO D ^%ZISC
. I $G(MERGEFLG)>0 D
. . N XMSUB,XMTEXT
. . S XMSUB="MERGE PAIRS EXCLUDED DUE TO DATA PROBLEMS"
. . S XMTEXT="^TMP(""DDB"",$J,"
. . D SENDMESG(XMSUB,XMTEXT)
. . Q
. Q
Q
;
SENDMESG(XMSUB,XMTEXT) ;
N XMY,XDRGRP,XDRGRPN,XMDUZ,XMCHAN
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 XMDUZ=.5,XMCHAN=1
D ^XMD
Q
;
RMOVPAIR(FROM,TO,IEN,ARRAY) ;
N X,MERGE,IENS,XXX,DA,DIK
S JLICNT=$G(JLICNT)+1,^TMP("XDRRMOV",JLICNT,$H,1)=FROM_U_TO_U_IEN_U_ARRAY
I IEN>0 D ; ENTRY IS IN FILE 15
. S IENS=IEN_","
. S X=^VA(15,IEN,0),MERGE=$P(X,U,20) ; GET MERGE NUMBER
. S JLICNT=$G(JLICNT)+1,^TMP("XDRRMOV",JLICNT,$H,2)=MERGE_U_X
. S XXX(15,IENS,.05)=1 ; SET MERGE STATUS BACK TO READY
. S XXX(15,IENS,.13)=0 ; REMOVE APPROVAL FOR MERGE
. S XXX(15,IENS,.14)="@" ; AND INDICATOR OF WHO APPROVED
. S XXX(15,IENS,.2)="@" ; REMOVE MERGE PROCESS
. D FILE^DIE("","XXX")
. ;
. ;S IENS=","_MERGE_",",DA=$$FIND1^DIC(15.22,IENS,"",FROM) ; GET IEN FOR THIS ENTRY IN
. F DA=0:0 S DA=$O(^VA(15.2,MERGE,2,DA)) Q:DA'>0 I $P(^(DA,0),U,3)=IEN Q
. I DA>0 S DIK="^VA(15.2,"_MERGE_",2,",DA(1)=MERGE D ^DIK ; LIST OF PAIRS, AND DELETE IT
;
K @ARRAY@(FROM,TO) ; AND KILL THE ACTUAL ENTRY IN ARRAY
Q
;
PAIROUT(FILE,FROM,TO,IEN,DATA) ;
D PAIRID(FILE,FROM,TO,IEN)
D LISTPROB^XDRDVAL1(DATA)
Q
;
PAIRID(FILE,FROM,TO,IEN) ;
N FRNAME,FRSSN,TONAME,TOSSN,FILEDIC
S FILEDIC=^DIC(FILE,0,"GL")
S FRNAME=$P($G(@(FILEDIC_FROM_",0)")),U),FRSSN=$P($G(^(0)),U,9),FRNAME=$$STRIP(FRNAME)
S TONAME=$P($G(@(FILEDIC_TO_",0)")),U),TOSSN=$P($G(^(0)),U,9),TONAME=$$STRIP(TONAME)
W !,"FROM: DFN=",FROM," ",FRNAME W:FILE=2!(FILE=200) " [",FRSSN,"]" I IEN>0 W " FILE 15 IEN: ",IEN
W !,"TO: DFN=",TO," ",TONAME W:FILE=2!(FILE=200) " [",TOSSN,"]"
Q
;
STRIP(X1) ;
F Q:X1'["MERGING INTO" S X1=$P($P(X1,"(",2,10),")",1,$L(X1,")")-1)
Q X1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXDRDVAL1 7711 printed Apr 09, 2024@21:44:27 Page 2
XDRDVAL1 ;SF-CIOFO/JLI - CHECK SPECIFIED ENTRY FOR PROBLEMS ;12/04/2001 14:04
+1 ;;7.3;TOOLKIT;**23,45,46,49,57**;Apr 25, 1995
EN ;
+1 NEW MFILE,FILENAME,DIR,XDR,FILE,XDRY,FILEDIC
+2 ;
+3 DO ^%ZIS
if POP
QUIT
IF IO'=IO(0)
SET XDRION=ION
USE IO
DO ^%ZISC
LOOP ;
+1 SET DATA=$NAME(^TMP($JOB,"BB"))
+2 KILL @DATA
+3 USE IO(0)
+4 SET MFILE=$$FILE^XDRDPICK()
if MFILE'>0
QUIT
SET FILENAME=$PIECE(^DIC(MFILE,0),U)
SET FILEDIC=^DIC(MFILE,0,"GL")
+5 ;K DIR S DIR(0)="PO^"_MFILE_":AEM",DIR("A")="Select "_FILENAME
WRITE !!!
SET DIC=MFILE
SET DIC(0)="AEM"
+6 ;D ^DIR K DIR I Y'>0 U IO D ^%ZISC Q
DO ^DIC
IF Y'>0
USE IO
DO ^%ZISC
QUIT
+7 SET XDRY=Y
+8 WRITE !," .... WORKING HARD (may take a while)...",!
+9 DO EN1(MFILE,+XDRY,DATA)
+10 IF $DATA(XDRION)
SET IOP=XDRION
DO ^%ZIS
IF 1
+11 IF '$TEST
SET IO=IO(0)
+12 USE IO
WRITE @IOF,!!!
+13 WRITE !!,"DFN=",+XDRY," ",$PIECE(@(FILEDIC_(+XDRY)_",0)"),U)
IF MFILE=2!(MFILE=200)
WRITE " [",$PIECE(^(0),U,9),"]"
+14 IF '$DATA(@DATA)
WRITE !?10,"No Problems Found....",!!
GOTO LOOP
+15 DO LISTPROB($NAME(@DATA@(+XDRY,"VAL")))
+16 IF $DATA(XDRION)
USE IO
DO ^%ZISC
+17 GOTO LOOP
+18 QUIT
+19 ;
EN1(FILE,IEN,ARRAY) ;
+1 DO SETUP^XDRMERG(FILE)
+2 DO DOENTRY^XDRDVAL(FILE,IEN,ARRAY)
+3 FOR FILEX=0:0
SET FILEX=$ORDER(^TMP($JOB,"XFIL",FILEX))
if FILEX'>0
QUIT
SET GLOB=^(FILEX)
Begin DoDot:1
+4 SET X1=$GET(^TMP($JOB,"XGLOB",GLOB,0,1))
if X1=""
QUIT
+5 IF $PIECE(X1,U,3)'="DINUM"
QUIT
+6 DO DOENTRY^XDRDVAL(FILEX,IEN,ARRAY)
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
LISTPROB(DATA) ;
+1 SET XDREXIT=0
+2 FOR FILE=0:0
SET FILE=$ORDER(@DATA@(FILE))
if FILE'>0
QUIT
Begin DoDot:1
+3 SET FILENAME=$$FILENAME(FILE)
SET NEWHEAD=1
+4 SET IENS=""
FOR
SET IENS=$ORDER(@DATA@(FILE,IENS))
if IENS=""
QUIT
Begin DoDot:2
+5 FOR FIELD=0:0
SET FIELD=$ORDER(@DATA@(FILE,IENS,FIELD))
if FIELD'>0
QUIT
Begin DoDot:3
+6 SET X=$GET(@DATA@(FILE,IENS,FIELD,"INVALID"))
if X=""
QUIT
+7 SET NNOTES=0
IF $DATA(@DATA@(FILE,IENS,FIELD,"NOTE"))
Begin DoDot:4
+8 FOR NNOTE=0:0
SET NNOTE=$ORDER(@DATA@(FILE,IENS,FIELD,"NOTE",NNOTE))
if NNOTE'>0
QUIT
SET NNOTES=NNOTES+1
+9 QUIT
End DoDot:4
+10 SET NLINES=NNOTES+3
+11 IF (IOSL-$Y-4)'>NLINES
if $EXTRACT(IOST)["C"
Begin DoDot:4
+12 NEW DIR,Y,X
+13 SET DIR(0)="E"
DO ^DIR
IF 'Y
SET XDREXIT=1
+14 QUIT
End DoDot:4
if XDREXIT
QUIT
WRITE @IOF
SET NEWHEAD=1
+15 if NEWHEAD
WRITE !!!,FILENAME
SET NEWHEAD=0
+16 WRITE !,"Field ",FIELD," [",$PIECE(^DD(FILE,FIELD,0),U),"] IENS=",IENS
+17 WRITE !," value: ",X
+18 FOR NNOTE=0:0
SET NNOTE=$ORDER(@DATA@(FILE,IENS,FIELD,"NOTE",NNOTE))
if NNOTE'>0
QUIT
WRITE !," ",^(NNOTE)
+19 QUIT
End DoDot:3
if XDREXIT
QUIT
+20 QUIT
End DoDot:2
if XDREXIT
QUIT
+21 QUIT
End DoDot:1
if XDREXIT
QUIT
+22 QUIT
+23 ;
FILENAME(FILE) ;
+1 NEW FILENAME,NFILE
+2 SET FILENAME=""
SET NFILE=FILE
+3 FOR
if $DATA(^DIC(FILE,0))
QUIT
SET FILENAME=FILENAME_$ORDER(^DD(FILE,0,"NM",""))_" subfile of "
SET FILE=$GET(^DD(FILE,0,"UP"))
if FILE'>0
QUIT
+4 IF FILE>0
SET FILENAME="File "_NFILE_" ["_FILENAME_$PIECE($GET(^DIC(FILE,0)),U)_" file]"
+5 QUIT FILENAME
+6 ;
ENPAIR(FILE,ARRAY,MERGEFLG) ; ENTRY POINT FOR CHECKING AN ARRAY OF PAIRS AT START OF MERGE
+1 NEW XDRMESG,FROM,TO,TOVARBL,FRVARBL,DUPIEN,DATA,NLINES,XDRFDA1
+2 ;
+3 SET XDRMESG=$NAME(^TMP("XDRVALMESG",$JOB))
KILL @XDRMESG
+4 SET XDRVDATA=$NAME(^TMP("XDRVALDATA",$JOB))
KILL @XDRVDATA
+5 IF $GET(MERGEFLG)>0
SET XDRFDA1=$$FIND1^DIC(15.23,","_MERGEFLG_",","Q","DATA CHECKING")
+6 ;
+7 FOR FROM=0:0
SET FROM=$ORDER(@ARRAY@(FROM))
if FROM'>0
QUIT
Begin DoDot:1
+8 IF $GET(MERGEFLG)>0
SET ^VA(15.2,MERGEFLG,3,XDRFDA1,1)=$$NOW^XLFDT()_U_U_FROM
+9 SET TO=$ORDER(@ARRAY@(FROM,0))
+10 ;
+11 ; add special checks for BCMA, MPI, and Pharmacy, XT*7.3*45
+12 ; remove MPI check for CIRN/MPI aware patch, XT*7.3*49
+13 ; remove BCMA checks, XT*7.3*57
+14 ;I $D(^PSB(53.79,"B",FROM)) D Q
+15 ;. S @XDRVDATA@(FROM,"VAL",53.79,TO,.01,"INVALID")="FROM Patient has data on file for BCMA, please resolve prior to merging."
+16 ;I $T(GETICN^MPIF001)]"",$$GETICN^MPIF001(FROM)>0 D Q
+17 ;. S @XDRVDATA@(FROM,"VAL",2,TO,991.01,"INVALID")="The FROM patient exist in the MPI system, this Patient cannot be merged."
+18 ;I $T(GETICN^MPIF001)]"",$$GETICN^MPIF001(TO)>0 D Q
+19 ;. S @XDRVDATA@(FROM,"VAL",2,TO,991.01,"INVALID")="The TO patient exist in the MPI system, this Patient cannot be merged."
+20 IF $TEXT(EN^PSJPATMR)]""
IF '$$EN^PSJPATMR(FROM,TO)
Begin DoDot:2
+21 SET @XDRVDATA@(FROM,"VAL",55,TO,62,"INVALID")="FROM Patient has either active inpatient orders or orders on a current pick list. This needs to be resolved prior to merging."
End DoDot:2
QUIT
+22 ;
+23 ; GET BACK ANY PROBLEMS
DO CHKMERG^XDRDVAL2(FILE,FROM,TO,$NAME(@XDRVDATA@(FROM,"VAL")))
+24 ; FROM CAN'T POINT TO MORE THAN ONE PLACE
FOR
SET TO=$ORDER(@ARRAY@(FROM,TO))
if TO'>0
QUIT
Begin DoDot:2
+25 SET FRVARBL=$ORDER(@ARRAY@(FROM,TO,0))
IF FRVARBL=""
SET FRVARBL=0
+26 SET TOVARBL=$ORDER(@ARRAY@(FROM,TO,FRVARBL,0))
IF TOVARBL=""
SET TOVARBL=0
+27 IF TOVARBL=0
SET DUPIEN=+$GET(@ARRAY@(FROM,TO))
+28 IF '$TEST
SET DUPIEN=+$GET(@ARRAY@(FROM,TO,FRVARBL,TOVARBL))
+29 DO RMOVPAIR(FROM,TO,DUPIEN,ARRAY)
+30 QUIT
End DoDot:2
+31 QUIT
End DoDot:1
+32 ; GOT BACK PROBLEMS ON ONE OR MORE FIELDS
IF $DATA(@XDRVDATA)
Begin DoDot:1
+33 IF $GET(MERGEFLG)>0
NEW XDRDVALF
SET XDRDVALF=1
SET IOP="XDRBROWSER1"
DO ^%ZIS
+34 IF $GET(MERGEFLG)'>0
IF $GET(XDRION)'=""
SET IOP=XDRION
DO ^%ZIS
+35 USE IO
+36 FOR FROM=0:0
SET FROM=$ORDER(@XDRVDATA@(FROM))
if FROM'>0
QUIT
Begin DoDot:2
+37 SET TO=$ORDER(@ARRAY@(FROM,0))
+38 SET FRVARBL=$ORDER(@ARRAY@(FROM,TO,0))
IF FRVARBL=""
SET FRVARBL=0
+39 SET TOVARBL=$ORDER(@ARRAY@(FROM,TO,FRVARBL,0))
IF TOVARBL=""
SET TOVARBL=0
+40 IF TOVARBL=0
SET DUPIEN=+$GET(@ARRAY@(FROM,TO))
+41 IF '$TEST
SET DUPIEN=+$GET(@ARRAY@(FROM,TO,FRVARBL,TOVARBL))
+42 WRITE !!
+43 ; HAS AN ENTRY IN FILE 15
IF DUPIEN>0
Begin DoDot:3
+44 NEW X,DIRECT,ORIGTO,ORIGFR
+45 SET X=^VA(15,DUPIEN,0)
SET DIRECT=$PIECE(X,U,4)
+46 IF DIRECT=1
SET ORIGFR=+X
SET ORIGTO=+$PIECE(X,U,2)
+47 IF '$TEST
SET ORIGFR=+$PIECE(X,U,2)
SET ORIGTO=+X
+48 ;
+49 ; THE ENTRY WAS REPOINTED TO THE CURRENT 'TO' ENTRY
IF ORIGTO'=TO
Begin DoDot:4
+50 ; OUPUT ORIGINAL PAIR ID
DO PAIRID(FILE,ORIGFR,ORIGTO,DUPIEN)
+51 WRITE !," ******** REDIRECTED TO"
+52 QUIT
End DoDot:4
+53 QUIT
End DoDot:3
+54 ;
+55 ; OUTPUT PAIR ID AND PROBLEMS
DO PAIROUT(FILE,FROM,TO,DUPIEN,$NAME(@XDRVDATA@(FROM,"VAL")))
+56 ;
+57 ; REMOVE PAIR FROM MERGE - NOT FROM FILE 15
DO RMOVPAIR(FROM,TO,DUPIEN,ARRAY)
+58 QUIT
End DoDot:2
+59 USE IO
DO ^%ZISC
+60 IF $GET(MERGEFLG)>0
Begin DoDot:2
+61 NEW XMSUB,XMTEXT
+62 SET XMSUB="MERGE PAIRS EXCLUDED DUE TO DATA PROBLEMS"
+63 SET XMTEXT="^TMP(""DDB"",$J,"
+64 DO SENDMESG(XMSUB,XMTEXT)
+65 QUIT
End DoDot:2
+66 QUIT
End DoDot:1
+67 QUIT
+68 ;
SENDMESG(XMSUB,XMTEXT) ;
+1 NEW XMY,XDRGRP,XDRGRPN,XMDUZ,XMCHAN
+2 SET XDRGRP=$$GET1^DIQ(15.1,"2,",.29,"I")
+3 if XDRGRP>0
SET XDRGRPN=$$GET1^DIQ(3.8,XDRGRP,.01)
+4 SET XDRGRP=$SELECT(XDRGRP>0:"G."_XDRGRPN,1:"")
+5 if XDRGRP'=""
SET XMY(XDRGRP)=""
+6 ;If no mail grp found, send msg to postmaster
if XDRGRP=""
SET XMY(.5)=""
+7 SET XMDUZ=.5
SET XMCHAN=1
+8 DO ^XMD
+9 QUIT
+10 ;
RMOVPAIR(FROM,TO,IEN,ARRAY) ;
+1 NEW X,MERGE,IENS,XXX,DA,DIK
+2 SET JLICNT=$GET(JLICNT)+1
SET ^TMP("XDRRMOV",JLICNT,$HOROLOG,1)=FROM_U_TO_U_IEN_U_ARRAY
+3 ; ENTRY IS IN FILE 15
IF IEN>0
Begin DoDot:1
+4 SET IENS=IEN_","
+5 ; GET MERGE NUMBER
SET X=^VA(15,IEN,0)
SET MERGE=$PIECE(X,U,20)
+6 SET JLICNT=$GET(JLICNT)+1
SET ^TMP("XDRRMOV",JLICNT,$HOROLOG,2)=MERGE_U_X
+7 ; SET MERGE STATUS BACK TO READY
SET XXX(15,IENS,.05)=1
+8 ; REMOVE APPROVAL FOR MERGE
SET XXX(15,IENS,.13)=0
+9 ; AND INDICATOR OF WHO APPROVED
SET XXX(15,IENS,.14)="@"
+10 ; REMOVE MERGE PROCESS
SET XXX(15,IENS,.2)="@"
+11 DO FILE^DIE("","XXX")
+12 ;
+13 ;S IENS=","_MERGE_",",DA=$$FIND1^DIC(15.22,IENS,"",FROM) ; GET IEN FOR THIS ENTRY IN
+14 FOR DA=0:0
SET DA=$ORDER(^VA(15.2,MERGE,2,DA))
if DA'>0
QUIT
IF $PIECE(^(DA,0),U,3)=IEN
QUIT
+15 ; LIST OF PAIRS, AND DELETE IT
IF DA>0
SET DIK="^VA(15.2,"_MERGE_",2,"
SET DA(1)=MERGE
DO ^DIK
End DoDot:1
+16 ;
+17 ; AND KILL THE ACTUAL ENTRY IN ARRAY
KILL @ARRAY@(FROM,TO)
+18 QUIT
+19 ;
PAIROUT(FILE,FROM,TO,IEN,DATA) ;
+1 DO PAIRID(FILE,FROM,TO,IEN)
+2 DO LISTPROB^XDRDVAL1(DATA)
+3 QUIT
+4 ;
PAIRID(FILE,FROM,TO,IEN) ;
+1 NEW FRNAME,FRSSN,TONAME,TOSSN,FILEDIC
+2 SET FILEDIC=^DIC(FILE,0,"GL")
+3 SET FRNAME=$PIECE($GET(@(FILEDIC_FROM_",0)")),U)
SET FRSSN=$PIECE($GET(^(0)),U,9)
SET FRNAME=$$STRIP(FRNAME)
+4 SET TONAME=$PIECE($GET(@(FILEDIC_TO_",0)")),U)
SET TOSSN=$PIECE($GET(^(0)),U,9)
SET TONAME=$$STRIP(TONAME)
+5 WRITE !,"FROM: DFN=",FROM," ",FRNAME
if FILE=2!(FILE=200)
WRITE " [",FRSSN,"]"
IF IEN>0
WRITE " FILE 15 IEN: ",IEN
+6 WRITE !,"TO: DFN=",TO," ",TONAME
if FILE=2!(FILE=200)
WRITE " [",TOSSN,"]"
+7 QUIT
+8 ;
STRIP(X1) ;
+1 FOR
if X1'["MERGING INTO"
QUIT
SET X1=$PIECE($PIECE(X1,"(",2,10),")",1,$LENGTH(X1,")")-1)
+2 QUIT X1
