- 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 Feb 19, 2025@00:05:47 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