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

XDRDVAL1.m

Go to the documentation of this file.
  1. 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
  1. EN ;
  1. N MFILE,FILENAME,DIR,XDR,FILE,XDRY,FILEDIC
  1. ;
  1. D ^%ZIS Q:POP I IO'=IO(0) S XDRION=ION U IO D ^%ZISC
  1. LOOP ;
  1. S DATA=$NA(^TMP($J,"BB"))
  1. K @DATA
  1. U IO(0)
  1. S MFILE=$$FILE^XDRDPICK() Q:MFILE'>0 S FILENAME=$P(^DIC(MFILE,0),U),FILEDIC=^DIC(MFILE,0,"GL")
  1. W !!! S DIC=MFILE,DIC(0)="AEM" ;K DIR S DIR(0)="PO^"_MFILE_":AEM",DIR("A")="Select "_FILENAME
  1. D ^DIC I Y'>0 U IO D ^%ZISC Q ;D ^DIR K DIR I Y'>0 U IO D ^%ZISC Q
  1. S XDRY=Y
  1. W !," .... WORKING HARD (may take a while)...",!
  1. D EN1(MFILE,+XDRY,DATA)
  1. I $D(XDRION) S IOP=XDRION D ^%ZIS I 1
  1. E S IO=IO(0)
  1. U IO W @IOF,!!!
  1. W !!,"DFN=",+XDRY," ",$P(@(FILEDIC_(+XDRY)_",0)"),U) I MFILE=2!(MFILE=200) W " [",$P(^(0),U,9),"]"
  1. I '$D(@DATA) W !?10,"No Problems Found....",!! G LOOP
  1. D LISTPROB($NA(@DATA@(+XDRY,"VAL")))
  1. I $D(XDRION) U IO D ^%ZISC
  1. G LOOP
  1. Q
  1. ;
  1. EN1(FILE,IEN,ARRAY) ;
  1. D SETUP^XDRMERG(FILE)
  1. D DOENTRY^XDRDVAL(FILE,IEN,ARRAY)
  1. F FILEX=0:0 S FILEX=$O(^TMP($J,"XFIL",FILEX)) Q:FILEX'>0 S GLOB=^(FILEX) D
  1. . S X1=$G(^TMP($J,"XGLOB",GLOB,0,1)) Q:X1=""
  1. . I $P(X1,U,3)'="DINUM" Q
  1. . D DOENTRY^XDRDVAL(FILEX,IEN,ARRAY)
  1. . Q
  1. Q
  1. ;
  1. LISTPROB(DATA) ;
  1. S XDREXIT=0
  1. F FILE=0:0 S FILE=$O(@DATA@(FILE)) Q:FILE'>0 D Q:XDREXIT
  1. . S FILENAME=$$FILENAME(FILE),NEWHEAD=1
  1. . S IENS="" F S IENS=$O(@DATA@(FILE,IENS)) Q:IENS="" D Q:XDREXIT
  1. . . F FIELD=0:0 S FIELD=$O(@DATA@(FILE,IENS,FIELD)) Q:FIELD'>0 D Q:XDREXIT
  1. . . . S X=$G(@DATA@(FILE,IENS,FIELD,"INVALID")) Q:X=""
  1. . . . S NNOTES=0 I $D(@DATA@(FILE,IENS,FIELD,"NOTE")) D
  1. . . . . F NNOTE=0:0 S NNOTE=$O(@DATA@(FILE,IENS,FIELD,"NOTE",NNOTE)) Q:NNOTE'>0 S NNOTES=NNOTES+1
  1. . . . . Q
  1. . . . S NLINES=NNOTES+3
  1. . . . I (IOSL-$Y-4)'>NLINES D:$E(IOST)["C" Q:XDREXIT W @IOF S NEWHEAD=1
  1. . . . . N DIR,Y,X
  1. . . . . S DIR(0)="E" D ^DIR I 'Y S XDREXIT=1
  1. . . . . Q
  1. . . . W:NEWHEAD !!!,FILENAME S NEWHEAD=0
  1. . . . W !,"Field ",FIELD," [",$P(^DD(FILE,FIELD,0),U),"] IENS=",IENS
  1. . . . W !," value: ",X
  1. . . . F NNOTE=0:0 S NNOTE=$O(@DATA@(FILE,IENS,FIELD,"NOTE",NNOTE)) Q:NNOTE'>0 W !," ",^(NNOTE)
  1. . . . Q
  1. . . Q
  1. . Q
  1. Q
  1. ;
  1. FILENAME(FILE) ;
  1. N FILENAME,NFILE
  1. S FILENAME="",NFILE=FILE
  1. 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
  1. I FILE>0 S FILENAME="File "_NFILE_" ["_FILENAME_$P($G(^DIC(FILE,0)),U)_" file]"
  1. Q FILENAME
  1. ;
  1. ENPAIR(FILE,ARRAY,MERGEFLG) ; ENTRY POINT FOR CHECKING AN ARRAY OF PAIRS AT START OF MERGE
  1. N XDRMESG,FROM,TO,TOVARBL,FRVARBL,DUPIEN,DATA,NLINES,XDRFDA1
  1. ;
  1. S XDRMESG=$NA(^TMP("XDRVALMESG",$J)) K @XDRMESG
  1. S XDRVDATA=$NA(^TMP("XDRVALDATA",$J)) K @XDRVDATA
  1. I $G(MERGEFLG)>0 S XDRFDA1=$$FIND1^DIC(15.23,","_MERGEFLG_",","Q","DATA CHECKING")
  1. ;
  1. F FROM=0:0 S FROM=$O(@ARRAY@(FROM)) Q:FROM'>0 D
  1. . I $G(MERGEFLG)>0 S ^VA(15.2,MERGEFLG,3,XDRFDA1,1)=$$NOW^XLFDT()_U_U_FROM
  1. . S TO=$O(@ARRAY@(FROM,0))
  1. . ;
  1. . ; add special checks for BCMA, MPI, and Pharmacy, XT*7.3*45
  1. . ; remove MPI check for CIRN/MPI aware patch, XT*7.3*49
  1. . ; remove BCMA checks, XT*7.3*57
  1. . ;I $D(^PSB(53.79,"B",FROM)) D Q
  1. . ;. S @XDRVDATA@(FROM,"VAL",53.79,TO,.01,"INVALID")="FROM Patient has data on file for BCMA, please resolve prior to merging."
  1. . ;I $T(GETICN^MPIF001)]"",$$GETICN^MPIF001(FROM)>0 D Q
  1. . ;. S @XDRVDATA@(FROM,"VAL",2,TO,991.01,"INVALID")="The FROM patient exist in the MPI system, this Patient cannot be merged."
  1. . ;I $T(GETICN^MPIF001)]"",$$GETICN^MPIF001(TO)>0 D Q
  1. . ;. S @XDRVDATA@(FROM,"VAL",2,TO,991.01,"INVALID")="The TO patient exist in the MPI system, this Patient cannot be merged."
  1. . I $T(EN^PSJPATMR)]"",'$$EN^PSJPATMR(FROM,TO) D Q
  1. . . 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."
  1. . ;
  1. . D CHKMERG^XDRDVAL2(FILE,FROM,TO,$NA(@XDRVDATA@(FROM,"VAL"))) ; GET BACK ANY PROBLEMS
  1. . F S TO=$O(@ARRAY@(FROM,TO)) Q:TO'>0 D ; FROM CAN'T POINT TO MORE THAN ONE PLACE
  1. . . S FRVARBL=$O(@ARRAY@(FROM,TO,0)) I FRVARBL="" S FRVARBL=0
  1. . . S TOVARBL=$O(@ARRAY@(FROM,TO,FRVARBL,0)) I TOVARBL="" S TOVARBL=0
  1. . . I TOVARBL=0 S DUPIEN=+$G(@ARRAY@(FROM,TO))
  1. . . E S DUPIEN=+$G(@ARRAY@(FROM,TO,FRVARBL,TOVARBL))
  1. . . D RMOVPAIR(FROM,TO,DUPIEN,ARRAY)
  1. . . Q
  1. . Q
  1. I $D(@XDRVDATA) D ; GOT BACK PROBLEMS ON ONE OR MORE FIELDS
  1. . I $G(MERGEFLG)>0 N XDRDVALF S XDRDVALF=1 S IOP="XDRBROWSER1" D ^%ZIS
  1. . I $G(MERGEFLG)'>0,$G(XDRION)'="" S IOP=XDRION D ^%ZIS
  1. . U IO
  1. . F FROM=0:0 S FROM=$O(@XDRVDATA@(FROM)) Q:FROM'>0 D
  1. . . S TO=$O(@ARRAY@(FROM,0))
  1. . . S FRVARBL=$O(@ARRAY@(FROM,TO,0)) I FRVARBL="" S FRVARBL=0
  1. . . S TOVARBL=$O(@ARRAY@(FROM,TO,FRVARBL,0)) I TOVARBL="" S TOVARBL=0
  1. . . I TOVARBL=0 S DUPIEN=+$G(@ARRAY@(FROM,TO))
  1. . . E S DUPIEN=+$G(@ARRAY@(FROM,TO,FRVARBL,TOVARBL))
  1. . . W !!
  1. . . I DUPIEN>0 D ; HAS AN ENTRY IN FILE 15
  1. . . . N X,DIRECT,ORIGTO,ORIGFR
  1. . . . S X=^VA(15,DUPIEN,0) S DIRECT=$P(X,U,4)
  1. . . . I DIRECT=1 S ORIGFR=+X,ORIGTO=+$P(X,U,2)
  1. . . . E S ORIGFR=+$P(X,U,2),ORIGTO=+X
  1. . . . ;
  1. . . . I ORIGTO'=TO D ; THE ENTRY WAS REPOINTED TO THE CURRENT 'TO' ENTRY
  1. . . . . D PAIRID(FILE,ORIGFR,ORIGTO,DUPIEN) ; OUPUT ORIGINAL PAIR ID
  1. . . . . W !," ******** REDIRECTED TO"
  1. . . . . Q
  1. . . . Q
  1. . . ;
  1. . . D PAIROUT(FILE,FROM,TO,DUPIEN,$NA(@XDRVDATA@(FROM,"VAL"))) ; OUTPUT PAIR ID AND PROBLEMS
  1. . . ;
  1. . . D RMOVPAIR(FROM,TO,DUPIEN,ARRAY) ; REMOVE PAIR FROM MERGE - NOT FROM FILE 15
  1. . . Q
  1. . U IO D ^%ZISC
  1. . I $G(MERGEFLG)>0 D
  1. . . N XMSUB,XMTEXT
  1. . . S XMSUB="MERGE PAIRS EXCLUDED DUE TO DATA PROBLEMS"
  1. . . S XMTEXT="^TMP(""DDB"",$J,"
  1. . . D SENDMESG(XMSUB,XMTEXT)
  1. . . Q
  1. . Q
  1. Q
  1. ;
  1. SENDMESG(XMSUB,XMTEXT) ;
  1. N XMY,XDRGRP,XDRGRPN,XMDUZ,XMCHAN
  1. S XDRGRP=$$GET1^DIQ(15.1,"2,",.29,"I")
  1. S:XDRGRP>0 XDRGRPN=$$GET1^DIQ(3.8,XDRGRP,.01)
  1. S XDRGRP=$S(XDRGRP>0:"G."_XDRGRPN,1:"")
  1. S:XDRGRP'="" XMY(XDRGRP)=""
  1. S:XDRGRP="" XMY(.5)="" ;If no mail grp found, send msg to postmaster
  1. S XMDUZ=.5,XMCHAN=1
  1. D ^XMD
  1. Q
  1. ;
  1. RMOVPAIR(FROM,TO,IEN,ARRAY) ;
  1. N X,MERGE,IENS,XXX,DA,DIK
  1. S JLICNT=$G(JLICNT)+1,^TMP("XDRRMOV",JLICNT,$H,1)=FROM_U_TO_U_IEN_U_ARRAY
  1. I IEN>0 D ; ENTRY IS IN FILE 15
  1. . S IENS=IEN_","
  1. . S X=^VA(15,IEN,0),MERGE=$P(X,U,20) ; GET MERGE NUMBER
  1. . S JLICNT=$G(JLICNT)+1,^TMP("XDRRMOV",JLICNT,$H,2)=MERGE_U_X
  1. . S XXX(15,IENS,.05)=1 ; SET MERGE STATUS BACK TO READY
  1. . S XXX(15,IENS,.13)=0 ; REMOVE APPROVAL FOR MERGE
  1. . S XXX(15,IENS,.14)="@" ; AND INDICATOR OF WHO APPROVED
  1. . S XXX(15,IENS,.2)="@" ; REMOVE MERGE PROCESS
  1. . D FILE^DIE("","XXX")
  1. . ;
  1. . ;S IENS=","_MERGE_",",DA=$$FIND1^DIC(15.22,IENS,"",FROM) ; GET IEN FOR THIS ENTRY IN
  1. . F DA=0:0 S DA=$O(^VA(15.2,MERGE,2,DA)) Q:DA'>0 I $P(^(DA,0),U,3)=IEN Q
  1. . I DA>0 S DIK="^VA(15.2,"_MERGE_",2,",DA(1)=MERGE D ^DIK ; LIST OF PAIRS, AND DELETE IT
  1. ;
  1. K @ARRAY@(FROM,TO) ; AND KILL THE ACTUAL ENTRY IN ARRAY
  1. Q
  1. ;
  1. PAIROUT(FILE,FROM,TO,IEN,DATA) ;
  1. D PAIRID(FILE,FROM,TO,IEN)
  1. D LISTPROB^XDRDVAL1(DATA)
  1. Q
  1. ;
  1. PAIRID(FILE,FROM,TO,IEN) ;
  1. N FRNAME,FRSSN,TONAME,TOSSN,FILEDIC
  1. S FILEDIC=^DIC(FILE,0,"GL")
  1. S FRNAME=$P($G(@(FILEDIC_FROM_",0)")),U),FRSSN=$P($G(^(0)),U,9),FRNAME=$$STRIP(FRNAME)
  1. S TONAME=$P($G(@(FILEDIC_TO_",0)")),U),TOSSN=$P($G(^(0)),U,9),TONAME=$$STRIP(TONAME)
  1. W !,"FROM: DFN=",FROM," ",FRNAME W:FILE=2!(FILE=200) " [",FRSSN,"]" I IEN>0 W " FILE 15 IEN: ",IEN
  1. W !,"TO: DFN=",TO," ",TONAME W:FILE=2!(FILE=200) " [",TOSSN,"]"
  1. Q
  1. ;
  1. STRIP(X1) ;
  1. F Q:X1'["MERGING INTO" S X1=$P($P(X1,"(",2,10),")",1,$L(X1,")")-1)
  1. Q X1