source: WorldVistAEHR/trunk/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XDRDVAL1.m@ 1520

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