KIDS Distribution saved on Jul 16, 2008@13:28:46 XT*7.3*1003 **KIDS**:XT*7.3*1003^ **INSTALL NAME** XT*7.3*1003 "BLD",2608,0) XT*7.3*1003^TOOLKIT^0^3080716^n "BLD",2608,1,0) ^^1^1^3080716^ "BLD",2608,1,1,0) Contains routine changes needed by IHS Patient Merge (BPM) application. "BLD",2608,4,0) ^9.64PA^^ "BLD",2608,"KRN",0) ^9.67PA^8989.52^19 "BLD",2608,"KRN",.4,0) .4 "BLD",2608,"KRN",.401,0) .401 "BLD",2608,"KRN",.402,0) .402 "BLD",2608,"KRN",.403,0) .403 "BLD",2608,"KRN",.5,0) .5 "BLD",2608,"KRN",.84,0) .84 "BLD",2608,"KRN",3.6,0) 3.6 "BLD",2608,"KRN",3.8,0) 3.8 "BLD",2608,"KRN",9.2,0) 9.2 "BLD",2608,"KRN",9.8,0) 9.8 "BLD",2608,"KRN",9.8,"NM",0) ^9.68A^17^17 "BLD",2608,"KRN",9.8,"NM",1,0) XDRDEDT^^0^B32622398 "BLD",2608,"KRN",9.8,"NM",2,0) XDRDLIST^^0^B19677208 "BLD",2608,"KRN",9.8,"NM",3,0) XDRDPICK^^0^B78200766 "BLD",2608,"KRN",9.8,"NM",4,0) XDRDQUE^^0^B19875296 "BLD",2608,"KRN",9.8,"NM",5,0) XDRDSHOW^^0^B43283757 "BLD",2608,"KRN",9.8,"NM",6,0) XDRDVAL^^0^B30226252 "BLD",2608,"KRN",9.8,"NM",7,0) XDRMERG^^0^B78297304 "BLD",2608,"KRN",9.8,"NM",8,0) XDRMERG0^^0^B73333416 "BLD",2608,"KRN",9.8,"NM",9,0) XDRMERGA^^0^B69423089 "BLD",2608,"KRN",9.8,"NM",10,0) XDRMVFY^^0^B3436622 "BLD",2608,"KRN",9.8,"NM",11,0) XDRRMRG1^^0^B70245249 "BLD",2608,"KRN",9.8,"NM",12,0) XDRRMRG2^^0^B16759300 "BLD",2608,"KRN",9.8,"NM",13,0) XDRDVAL1^^0^B60497238 "BLD",2608,"KRN",9.8,"NM",14,0) XDRVCHEK^^0^B10053746 "BLD",2608,"KRN",9.8,"NM",15,0) XDRMERG2^^0^B68746101 "BLD",2608,"KRN",9.8,"NM",16,0) XDRDVAL2^^0^B43207170 "BLD",2608,"KRN",9.8,"NM",17,0) XDRMERG1^^0^B27749140 "BLD",2608,"KRN",9.8,"NM","B","XDRDEDT",1) "BLD",2608,"KRN",9.8,"NM","B","XDRDLIST",2) "BLD",2608,"KRN",9.8,"NM","B","XDRDPICK",3) "BLD",2608,"KRN",9.8,"NM","B","XDRDQUE",4) "BLD",2608,"KRN",9.8,"NM","B","XDRDSHOW",5) "BLD",2608,"KRN",9.8,"NM","B","XDRDVAL",6) "BLD",2608,"KRN",9.8,"NM","B","XDRDVAL1",13) "BLD",2608,"KRN",9.8,"NM","B","XDRDVAL2",16) "BLD",2608,"KRN",9.8,"NM","B","XDRMERG",7) "BLD",2608,"KRN",9.8,"NM","B","XDRMERG0",8) "BLD",2608,"KRN",9.8,"NM","B","XDRMERG1",17) "BLD",2608,"KRN",9.8,"NM","B","XDRMERG2",15) "BLD",2608,"KRN",9.8,"NM","B","XDRMERGA",9) "BLD",2608,"KRN",9.8,"NM","B","XDRMVFY",10) "BLD",2608,"KRN",9.8,"NM","B","XDRRMRG1",11) "BLD",2608,"KRN",9.8,"NM","B","XDRRMRG2",12) "BLD",2608,"KRN",9.8,"NM","B","XDRVCHEK",14) "BLD",2608,"KRN",19,0) 19 "BLD",2608,"KRN",19.1,0) 19.1 "BLD",2608,"KRN",101,0) 101 "BLD",2608,"KRN",409.61,0) 409.61 "BLD",2608,"KRN",771,0) 771 "BLD",2608,"KRN",870,0) 870 "BLD",2608,"KRN",8989.51,0) 8989.51 "BLD",2608,"KRN",8989.52,0) 8989.52 "BLD",2608,"KRN",8994,0) 8994 "BLD",2608,"KRN","B",.4,.4) "BLD",2608,"KRN","B",.401,.401) "BLD",2608,"KRN","B",.402,.402) "BLD",2608,"KRN","B",.403,.403) "BLD",2608,"KRN","B",.5,.5) "BLD",2608,"KRN","B",.84,.84) "BLD",2608,"KRN","B",3.6,3.6) "BLD",2608,"KRN","B",3.8,3.8) "BLD",2608,"KRN","B",9.2,9.2) "BLD",2608,"KRN","B",9.8,9.8) "BLD",2608,"KRN","B",19,19) "BLD",2608,"KRN","B",19.1,19.1) "BLD",2608,"KRN","B",101,101) "BLD",2608,"KRN","B",409.61,409.61) "BLD",2608,"KRN","B",771,771) "BLD",2608,"KRN","B",870,870) "BLD",2608,"KRN","B",8989.51,8989.51) "BLD",2608,"KRN","B",8989.52,8989.52) "BLD",2608,"KRN","B",8994,8994) "BLD",2608,"QUES",0) ^9.62^^ "BLD",2608,"REQB",0) ^9.611^1^1 "BLD",2608,"REQB",1,0) XT*7.3*73^2 "BLD",2608,"REQB","B","XT*7.3*73",1) "MBREQ") 0 "PKG",229,-1) 1^1 "PKG",229,0) TOOLKIT^XT^PROGRAMMERS OPTIONS, MULTI. TERM LOOKUP "PKG",229,22,0) ^9.49I^1^1 "PKG",229,22,1,0) 7.3^2950403^2960307 "PKG",229,22,1,"PAH",1,0) 1003^3080716 "PKG",229,22,1,"PAH",1,1,0) ^^1^1^3080716 "PKG",229,22,1,"PAH",1,1,1,0) Contains routine changes needed by IHS Patient Merge (BPM) application. "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") YES "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") YES "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 17 "RTN","XDRDEDT") 0^1^B32622398 "RTN","XDRDEDT",1,0) XDRDEDT ;SF-IRMFO/REM - EDIT STATUS FIELD IN FILE 15 ;09/22/99 11:12 [ 04/02/2003 8:47 AM ] "RTN","XDRDEDT",2,0) ;;7.3;TOOLKIT;**23,43,1001,1003**;Apr 03, 1995 "RTN","XDRDEDT",3,0) ;IHS/OIT/LJF 07/14/2006 PATCH 1003 make it clear to users that name is being asked for under LOOKUP "RTN","XDRDEDT",4,0) ; 02/09/2007 PATCH 1003 clean up DIR variable "RTN","XDRDEDT",5,0) EN ;; "RTN","XDRDEDT",6,0) N XDRFIL,X,X1,X2,N1,N2,XDRDELET "RTN","XDRDEDT",7,0) EN2 K DIE,DIC "RTN","XDRDEDT",8,0) S XDRFIL=$$FILE^XDRDPICK() Q:XDRFIL'>0 S XDRGLB=$G(^DIC(XDRFIL,0,"GL")) Q:XDRGLB="" "RTN","XDRDEDT",9,0) F D Q:DA'>0 "RTN","XDRDEDT",10,0) . S DIC="^VA(15,",DIC(0)="AEQZ",DIC("S")="I $$SCRN^XDRDEDT(+Y,XDRGLB)" "RTN","XDRDEDT",11,0) . S DIC("A")="Select an Entry to "_$S($D(XDRDELET):"DELETE: ",1:"RESET TO POTENTIAL DUPLICATES: ") "RTN","XDRDEDT",12,0) . D ^DIC S DA=+Y Q:DA<0 "RTN","XDRDEDT",13,0) . I $P(^VA(15,DA,0),U,4)<2 S X1=+^VA(15,DA,0),X2=+$P(^(0),U,2) "RTN","XDRDEDT",14,0) . E S X1=+$P(^VA(15,DA,0),U,2),X2=+^(0) "RTN","XDRDEDT",15,0) . S N1=$P(@(XDRGLB_X1_",0)"),U),N2=$P(@(XDRGLB_X2_",0)"),U) "RTN","XDRDEDT",16,0) . S N1=$$PEELNAM(N1),N2=$$PEELNAM(N2) "RTN","XDRDEDT",17,0) .W !!!," Duplicate Record File Entry ",DA," for the ",$P(^DIC(XDRFIL,0),U)," FILE" "RTN","XDRDEDT",18,0) . N XX D W !?10,X1,?20,N1,!?10,X2,?20,N2,!!?10,"Currently listed as ",XX,!! "RTN","XDRDEDT",19,0) . . N DIC,DIQ,DR,XDRQ "RTN","XDRDEDT",20,0) . . S DIC="^VA(15,",DIQ="XDRQ",DIQ(0)="E",DR=.03 "RTN","XDRDEDT",21,0) . . D EN^DIQ1 "RTN","XDRDEDT",22,0) . . S XX=$G(XDRQ(15,DA,.03,"E")) "RTN","XDRDEDT",23,0) . . Q "RTN","XDRDEDT",24,0) . S DIR(0)="Y",DIR("A")="Do you really want to "_$S($D(XDRDELET):"DELETE THIS DUPLICATE RECORD ENTRY",1:"RESET to POTENTIAL DUPLICATE"),DIR("B")="NO" D ^DIR Q:Y'>0 "RTN","XDRDEDT",25,0) . D NAME(DA) "RTN","XDRDEDT",26,0) . I $D(XDRDELET) D "RTN","XDRDEDT",27,0) . . N DIK "RTN","XDRDEDT",28,0) . . S DIK="^VA(15," D ^DIK "RTN","XDRDEDT",29,0) . I '$D(XDRDELET) D "RTN","XDRDEDT",30,0) . . K DIE S DIE="^VA(15,",DR=".03///P;.04///@;.05///@;.07///@;.08///@;.1///@;.13///@;.14///@;" D ^DIE K DIE "RTN","XDRDEDT",31,0) . . S:$D(DUZ) $P(^VA(15,DA,0),U,12)=DUZ "RTN","XDRDEDT",32,0) . . K ^VA(15,DA,2) "RTN","XDRDEDT",33,0) . . K ^VA(15,DA,3) "RTN","XDRDEDT",34,0) . W !!," ",$S($D(XDRDELET):"Entry DELETED!",1:"Status RESET to POTENTIAL DUPLICATE RECORD."),!!,*7 "RTN","XDRDEDT",35,0) . Q "RTN","XDRDEDT",36,0) K DA,DR,DIC,DIE "RTN","XDRDEDT",37,0) K DIR ;IHS/OIT/LJF 02/09/2007 PATCH 1003 "RTN","XDRDEDT",38,0) Q "RTN","XDRDEDT",39,0) SCRN(DA,GLOBAL) ;Screen for verified dup. or verified not dup. "RTN","XDRDEDT",40,0) I $P(^(0),U,5)>1 Q 0 ; But don't take merged or merge in progress! "RTN","XDRDEDT",41,0) I '$D(XDRDELET),$P(^(0),U,3)="P"!($P(^(0),U,3)="O") Q 0 ; DON'T NEED TO SET BACK "RTN","XDRDEDT",42,0) I (U_$P($P(^(0),U),";",2))'=GLOBAL Q 0 ; Take only the specified file "RTN","XDRDEDT",43,0) ;I $P(^(0),U,3)="V" Q 1 "RTN","XDRDEDT",44,0) ;I $P(^(0),U,3)="N" Q 1 "RTN","XDRDEDT",45,0) Q 1 "RTN","XDRDEDT",46,0) ; "RTN","XDRDEDT",47,0) NAME(DA) ; "RTN","XDRDEDT",48,0) N X,X1,X2,N,N1,N2 "RTN","XDRDEDT",49,0) S X=^VA(15,DA,0),X1=+X,X2=+$P(X,U,2),X=$P($P(X,U),";",2) "RTN","XDRDEDT",50,0) S N1=$P($G(@(U_X_X1_",0)")),U) "RTN","XDRDEDT",51,0) S N2=$P($G(@(U_X_X2_",0)")),U) "RTN","XDRDEDT",52,0) S N=$$PEELNAM(N1) "RTN","XDRDEDT",53,0) I N'=N1 S $P(@(U_X_X1_",0)"),U)=N "RTN","XDRDEDT",54,0) S N=$$PEELNAM(N2) "RTN","XDRDEDT",55,0) I N'=N2 S $P(@(U_X_X2_",0)"),U)=N "RTN","XDRDEDT",56,0) Q "RTN","XDRDEDT",57,0) PEELNAM(NAME) ; "RTN","XDRDEDT",58,0) F Q:NAME'["MERGING INTO" S NAME=$P($P(NAME,"(",2,10),")",1,$L(NAME,")")-1) "RTN","XDRDEDT",59,0) Q NAME "RTN","XDRDEDT",60,0) ; "RTN","XDRDEDT",61,0) DELETE ; "RTN","XDRDEDT",62,0) N XDRFIL,X,X1,X2,N1,N2,XDRDELET "RTN","XDRDEDT",63,0) S XDRDELET=1 "RTN","XDRDEDT",64,0) D EN2 "RTN","XDRDEDT",65,0) Q "RTN","XDRDEDT",66,0) ; "RTN","XDRDEDT",67,0) LOOKUP(FILE) ; FIND PAIRS IN DUPLICATE RECORD FILE "RTN","XDRDEDT",68,0) N FILENAM,NAME,NAME1,NAME2,NAMEA,XDRDIC,DIR,Y,I,J,XDR1,IEN,N,X,FILID,IEN1 "RTN","XDRDEDT",69,0) S FILENAM=$P(^DIC(FILE,0),U) I FILENAM="" G NOFILE "RTN","XDRDEDT",70,0) S XDRDIC=$G(^DIC(FILE,0,"GL")) I XDRDIC="" G NOFILE "RTN","XDRDEDT",71,0) S XDRDIC=";"_$E(XDRDIC,2,99) "RTN","XDRDEDT",72,0) ; "RTN","XDRDEDT",73,0) LOOK1 ;K DIR S DIR("A")="Select "_FILENAM,DIR(0)="FO^2" D ^DIR K DIR ; GET PART OF A NAME "RTN","XDRDEDT",74,0) K DIR S DIR("A")="Select "_FILENAM_" NAME",DIR(0)="FO^2",DIR("?")="Enter the first few letters of the name" D ^DIR K DIR ;IHS/OIT/LJF 07/14/2006 PATCH 1003 "RTN","XDRDEDT",75,0) I X="" Q -1 "RTN","XDRDEDT",76,0) I $D(DIRUT)!(Y="^") Q -1 "RTN","XDRDEDT",77,0) ; "RTN","XDRDEDT",78,0) ; GET A LIST OF NAMES IN THE FILE STARTING WITH THE USERS INPUT AND WHICH HAVE AN IEN THAT IS "RTN","XDRDEDT",79,0) ; IN THE DUPLICATE RECORD FILE "RTN","XDRDEDT",80,0) ; "RTN","XDRDEDT",81,0) S NAME=$NA(^TMP($J,"XDRLIST")) K @NAME "RTN","XDRDEDT",82,0) D FIND^DIC(FILE,"","","",X,"","B^BS5^SSN","I $D(^VA(15,""B"",(Y_XDRDIC)))","",NAME) "RTN","XDRDEDT",83,0) ; "RTN","XDRDEDT",84,0) S NAME1=$NA(@NAME@("DILIST")) "RTN","XDRDEDT",85,0) ; "RTN","XDRDEDT",86,0) ; NOW GO THROUGH THE LIST OF MATCHING NAMES AND CHECK FOR THOSE WHICH HAVE THE DESIRED STATUS "RTN","XDRDEDT",87,0) ; USE THE DATA UNDER THE 2 NODE WHICH IS THE IEN "RTN","XDRDEDT",88,0) ; "RTN","XDRDEDT",89,0) F I=0:0 S I=$O(@NAME1@(2,I)) Q:I'>0 S IEN=^(I) D "RTN","XDRDEDT",90,0) . S XDR1=IEN_XDRDIC "RTN","XDRDEDT",91,0) . F J=0:0 S J=$O(^VA(15,"B",XDR1,J)) Q:J'>0 I $P(^VA(15,J,0),U,3)="P" Q "RTN","XDRDEDT",92,0) . ; IF NOT AT LEAST ONE WITH THE DESIRED STATUS, THEN REMOVE IT FROM THE ARRAY "RTN","XDRDEDT",93,0) . I J'>0 F J=1,2,"ID" K @NAME1@(J,I) "RTN","XDRDEDT",94,0) . Q "RTN","XDRDEDT",95,0) ; "RTN","XDRDEDT",96,0) S J=$O(@NAME1@(2,0)) I J'>0 G NONAME "RTN","XDRDEDT",97,0) ; "RTN","XDRDEDT",98,0) S NAME2=$NA(^TMP($J,"XDRLI1")) K @NAME2 "RTN","XDRDEDT",99,0) S N=0 F I=0:0 S I=$O(@NAME1@(1,I)) Q:I'>0 D "RTN","XDRDEDT",100,0) . S N=N+1 "RTN","XDRDEDT",101,0) . S X=@NAME1@(1,I)_" [ien="_@NAME1@(2,I)_"]" F J=0:0 S J=$O(@NAME1@("ID",I,J)) Q:J'>0 S FILID(J)="" S X=X_" "_@NAME1@("ID",I,J) "RTN","XDRDEDT",102,0) . S @NAME2@(N)=X,@NAME2@(N,"IEN")=@NAME1@(2,I) "RTN","XDRDEDT",103,0) S X=$$ASK(NAME2) I X'>0 G NONAME "RTN","XDRDEDT",104,0) I N>1 W @NAME2@(X) "RTN","XDRDEDT",105,0) S IEN1=@NAME2@(X,"IEN")_XDRDIC K @NAME2,@NAME "RTN","XDRDEDT",106,0) S X=$$PAIR(IEN1,"FILID") I X'>0 G NONAME "RTN","XDRDEDT",107,0) Q X "RTN","XDRDEDT",108,0) ; "RTN","XDRDEDT",109,0) PAIR(IENDIC,IDARR) ; "RTN","XDRDEDT",110,0) N FILE,IEN,NAME,XDRN,IEN2,XDRX1,XDRJ,XDRX "RTN","XDRDEDT",111,0) S NAME=$NA(^TMP($J,"XDRPAIR")) K @NAME "RTN","XDRDEDT",112,0) S FILE=+$P(@(U_$P(IENDIC,";",2)_"0)"),U,2),XDRN=0 "RTN","XDRDEDT",113,0) F IEN=0:0 S IEN=$O(^VA(15,"B",IENDIC,IEN)) Q:IEN'>0 I $P(^VA(15,IEN,0),U,3)="P" D "RTN","XDRDEDT",114,0) . S XDRN=XDRN+1 "RTN","XDRDEDT",115,0) . S XDRX=^VA(15,IEN,0) "RTN","XDRDEDT",116,0) . S IEN2=$P(XDRX,U) I IEN2=IENDIC S IEN2=$P(XDRX,U,2) "RTN","XDRDEDT",117,0) . S IEN2=+IEN2,IENS=IEN2_"," "RTN","XDRDEDT",118,0) . S XDRX1=$$GET1^DIQ(FILE,IENS,.01)_" [iens="_IEN2_"]" "RTN","XDRDEDT",119,0) . F XDRJ=0:0 S XDRJ=$O(@IDARR@(XDRJ)) Q:XDRJ'>0 S XDRX1=XDRX1_" "_$$GET1^DIQ(FILE,IENS,XDRJ) "RTN","XDRDEDT",120,0) . S @NAME@(XDRN)=XDRX1,@NAME@(XDRN,"IEN")=IEN "RTN","XDRDEDT",121,0) I XDRN>1 W !!,"This entry is paired with more than one other record.",!,"Select which pair from the following list:",! "RTN","XDRDEDT",122,0) S XDRX=$$ASK(NAME) I XDRX>0 S XDRX=@NAME@(XDRX,"IEN") "RTN","XDRDEDT",123,0) K @NAME "RTN","XDRDEDT",124,0) Q XDRX "RTN","XDRDEDT",125,0) ; "RTN","XDRDEDT",126,0) ASK(ARRAY) ; "RTN","XDRDEDT",127,0) N N,I,N1,NCHOICE "RTN","XDRDEDT",128,0) W ! "RTN","XDRDEDT",129,0) S N=0 F I=0:0 S I=$O(@ARRAY@(I)) Q:I'>0 S N=N+1 "RTN","XDRDEDT",130,0) I N'>1 S I=+$O(@ARRAY@(0)) W:I>0 @ARRAY@(I) Q I "RTN","XDRDEDT",131,0) I N>5 W "There are "_N_" choices.",!! "RTN","XDRDEDT",132,0) S N1=0,NCHOICE=0 "RTN","XDRDEDT",133,0) F I=0:0 S I=$O(@ARRAY@(I)) Q:I'>0 S N1=N1+1 W !,N1,". ",@ARRAY@(I) I '(N1#5) S NCHOICE=$$ASKEM(N1,N) Q:NCHOICE Q:$D(DIRUT) "RTN","XDRDEDT",134,0) I 'NCHOICE,'$D(DIRUT) S NCHOICE=$$ASKEM(N1,N1) "RTN","XDRDEDT",135,0) Q NCHOICE "RTN","XDRDEDT",136,0) ; "RTN","XDRDEDT",137,0) ASKEM(NCUR,NMAX) ; "RTN","XDRDEDT",138,0) N DIR,Y "RTN","XDRDEDT",139,0) W !! I NCUR0:Y,1:0) "RTN","XDRDEDT",143,0) ; "RTN","XDRDEDT",144,0) NOFILE ; "RTN","XDRDEDT",145,0) W !,"FILE ",FILE," NOT FOUND",$C(7),!! "RTN","XDRDEDT",146,0) Q -1 "RTN","XDRDEDT",147,0) ; "RTN","XDRDEDT",148,0) NONAME ; "RTN","XDRDEDT",149,0) W $C(7),"??" "RTN","XDRDEDT",150,0) G LOOK1 "RTN","XDRDEDT",151,0) ; "RTN","XDRDLIST") 0^2^B19677208 "RTN","XDRDLIST",1,0) XDRDLIST ;SF-IRMFO/IHS/OHPRD/JCM - PRINT POTENTIAL AND VERIFIED DUPLICATES; [ 04/02/2003 8:47 AM ] "RTN","XDRDLIST",2,0) ;;7.3;TOOLKIT;**23,1001,1003**;Apr 03, 1995 "RTN","XDRDLIST",3,0) ;IHS/OIT/LJF 07/14/2006 PATCH 1003 changed to IHS print template to add HRCN to displays "RTN","XDRDLIST",4,0) ;; "RTN","XDRDLIST",5,0) N XDRFL,XDRFLD "RTN","XDRDLIST",6,0) START ; "RTN","XDRDLIST",7,0) S XDRQFLG=0 "RTN","XDRDLIST",8,0) ;W !!,"Choose type of list." "RTN","XDRDLIST",9,0) S DIR("?")="BRIEF prints the fields: RECORD1, RECORD2 and the IEN for each entry. CAPTIONED is FileMan's CAPTIONED format." "RTN","XDRDLIST",10,0) S DIR("A")="Choose type of list",DIR(0)="SO^1:BRIEF;2:CAPTIONED" D ^DIR K DIR G:$D(DIRUT) END "RTN","XDRDLIST",11,0) S XDRFLD=Y "RTN","XDRDLIST",12,0) I '$D(XDRFL) S DIC("A")="Select File you wish to list for: " D FILE^XDRDQUE G:XDRQFLG END "RTN","XDRDLIST",13,0) D ASK G:XDRQFLG END ; Asks which type of listing you want "RTN","XDRDLIST",14,0) D @$S(XDRDLIST("ASK")=1:"POT",XDRDLIST("ASK")=2:"NOT",XDRDLIST("ASK")=3:"VER",1:"MERGED") "RTN","XDRDLIST",15,0) G:'XDRQFLG START "RTN","XDRDLIST",16,0) END D EOJ ; End of job and cleans up variables "RTN","XDRDLIST",17,0) Q ; End of routine "RTN","XDRDLIST",18,0) ; "RTN","XDRDLIST",19,0) ASK ; "RTN","XDRDLIST",20,0) K XDRDLIST("ASK") "RTN","XDRDLIST",21,0) S XDRDLIST("GL")=$S($D(^DIC(XDRFL,0,"GL")):$P(^DIC(XDRFL,0,"GL"),U,2),1:"") "RTN","XDRDLIST",22,0) I XDRDLIST("GL")']"" S XDRQFLG=1 G ASKX "RTN","XDRDLIST",23,0) W !!,"This utility provides reports on verified and unverified potential duplicates." "RTN","XDRDLIST",24,0) WHCH S DIR("A")="report",DIR(0)="SO^1:UNVERIFIED potential duplicates;2:NOT READY TO MERGE VERIFIED duplicates;3:READY TO MERGE VERIFIED duplicates;4:MERGED VERIFIED duplicates" D ^DIR K DIR "RTN","XDRDLIST",25,0) I $D(DIRUT) S XDRQFLG=1 G ASKX "RTN","XDRDLIST",26,0) I Y=" " S XDRQFLG=1 G ASKX "RTN","XDRDLIST",27,0) S XDRDLIST("ASK")=$S(Y=1:1,Y=2:2,Y=3:3,1:4) "RTN","XDRDLIST",28,0) I XDRDLIST("ASK")=1,'$D(^VA(15,"APOT",XDRDLIST("GL"))) W !,"There are no unverified potential duplicates at this time.",$C(7) K XDRDLIST("ASK") G WHCH "RTN","XDRDLIST",29,0) I XDRDLIST("ASK")=3,'$D(^VA(15,"AMRG",XDRDLIST("GL"),1)) W !,"There are no READY TO MERGE verified duplicates at this time.",$C(7) K XDRDLIST("ASK") G WHCH "RTN","XDRDLIST",30,0) I XDRDLIST("ASK")=2,'$D(^VA(15,"AMRG",XDRDLIST("GL"),0)) W !,"There are no NOT READY TO MERGE verified duplicates at this time.",$C(7) K XDRDLIST("ASK") G WHCH "RTN","XDRDLIST",31,0) I XDRDLIST("ASK")=4,'$D(^VA(15,"AFR",XDRDLIST("GL"))) W !,"There are no MERGED VERIFIED duplicates at this time.",$C(7) K XDRDLIST("ASK") G WHCH "RTN","XDRDLIST",32,0) ; "RTN","XDRDLIST",33,0) ASKX ; "RTN","XDRDLIST",34,0) Q "RTN","XDRDLIST",35,0) ; "RTN","XDRDLIST",36,0) POT ; "RTN","XDRDLIST",37,0) S DIC="^VA(15,",L="",FLDS=$S(XDRFLD=1:"[XDR BRIEF LIST]",1:"[CAPTIONED]") "RTN","XDRDLIST",38,0) I $$GET^XPAR("PKG","BPM USE IHS LOGIC") S FLDS=$S(XDRFLD=1:"[BPM BRIEF LIST]",1:"[CAPTIONED]") ;IHS/OIT LJF 07/14/2006 PATCH 1003 "RTN","XDRDLIST",39,0) S BY="[XDR POTENTIAL DUPLICATE LIST]" "RTN","XDRDLIST",40,0) S DIS(0)="I $P($P(^VA(15,D0,0),U),"";"",2)=XDRDLIST(""GL"")" "RTN","XDRDLIST",41,0) S DHD="Unverified Potential Duplicates" "RTN","XDRDLIST",42,0) D EN1^DIP K DIC,DIS,DHD,L,FLDS,BY "RTN","XDRDLIST",43,0) Q "RTN","XDRDLIST",44,0) ; "RTN","XDRDLIST",45,0) VER ; "RTN","XDRDLIST",46,0) S DIC="^VA(15,",L="",FLDS=$S(XDRFLD=1:"[XDR BRIEF LIST]",1:"[CAPTIONED]") "RTN","XDRDLIST",47,0) I $$GET^XPAR("PKG","BPM USE IHS LOGIC") S FLDS=$S(XDRFLD=1:"[BPM BRIEF LIST]",1:"[CAPTIONED]") ;IHS/OIT/LJF 07/14/2006 PATCH 1003 "RTN","XDRDLIST",48,0) ;S DIC="^VA(15,",L="",FLDS="[CAPTIONED]" "RTN","XDRDLIST",49,0) S BY="[XDR READY TO MERGE LIST]" "RTN","XDRDLIST",50,0) S DIS(0)="I $P($P(^VA(15,D0,0),U),"";"",2)=XDRDLIST(""GL"")" "RTN","XDRDLIST",51,0) S DHD="Verified Duplicates Ready to Merge" "RTN","XDRDLIST",52,0) D EN1^DIP K DIC,DIS,DHD,L,FLDS,BY "RTN","XDRDLIST",53,0) Q "RTN","XDRDLIST",54,0) ; "RTN","XDRDLIST",55,0) NOT ; "RTN","XDRDLIST",56,0) S DIC="^VA(15,",L="",FLDS=$S(XDRFLD=1:"[XDR BRIEF LIST]",1:"[CAPTIONED]") "RTN","XDRDLIST",57,0) I $$GET^XPAR("PKG","BPM USE IHS LOGIC") S FLDS=$S(XDRFLD=1:"[BPM BRIEF LIST]",1:"[CAPTIONED]") ;IHS/OIT/LJF 07/14/2006 PATCH 1003 "RTN","XDRDLIST",58,0) ;S DIC="^VA(15,",L="",FLDS="[CAPTIONED]" "RTN","XDRDLIST",59,0) S BY="[XDR NOT READY TO MERGE LIST]" "RTN","XDRDLIST",60,0) S DIS(0)="I $P($P(^VA(15,D0,0),U),"";"",2)=XDRDLIST(""GL"")" "RTN","XDRDLIST",61,0) S DHD="Verified Duplicates Not Ready to Merge" "RTN","XDRDLIST",62,0) D EN1^DIP K DIC,DIS,DHD,L,FLDS,BY "RTN","XDRDLIST",63,0) Q "RTN","XDRDLIST",64,0) MERGED ; "RTN","XDRDLIST",65,0) S DIC="^VA(15,",L="",FLDS=$S(XDRFLD=1:"[XDR BRIEF LIST]",1:"[XDR MERGED LIST]") "RTN","XDRDLIST",66,0) I $$GET^XPAR("PKG","BPM USE IHS LOGIC") S FLDS=$S(XDRFLD=1:"[BPM BRIEF LIST]",1:"[XDR MERGED LIST]") ;IHS/OIT/LJF 07/14/2006 PATCH 1003 "RTN","XDRDLIST",67,0) ;S DIC="^VA(15,",L="",FLDS="[XDR MERGED LIST]" "RTN","XDRDLIST",68,0) S BY="[XDR MERGED LIST]" "RTN","XDRDLIST",69,0) S DIS(0)="I $P($P(^VA(15,D0,0),U),"";"",2)=XDRDLIST(""GL"")" "RTN","XDRDLIST",70,0) S DHD="Verified Duplicates that are Merged" "RTN","XDRDLIST",71,0) D EN1^DIP K DIC,DIS,DHD,L,FLDS,BY "RTN","XDRDLIST",72,0) Q "RTN","XDRDLIST",73,0) EOJ ; "RTN","XDRDLIST",74,0) K XDRDLIST,DIRUT,X,Y,DTOUT,DUOUT,XDRD,XDRFL,XDRQFLG "RTN","XDRDLIST",75,0) Q "RTN","XDRDPICK") 0^3^B78200766 "RTN","XDRDPICK",1,0) XDRDPICK ;SF-IRMFO.SEA/JLI - SELECT A PAIR OF POTENTIAL DUPLICATES AND VIEW ;07/27/2000 09:56 [ 04/02/2003 8:47 AM ] "RTN","XDRDPICK",2,0) ;;7.3;TOOLKIT;**23,47,1001,1003**;Apr 03, 1995 "RTN","XDRDPICK",3,0) ;IHS/OIT/LJF 11/03/2006 PATCH 1003 if no potential duplicates, don't ask to choose from 1-0 "RTN","XDRDPICK",4,0) ;; "RTN","XDRDPICK",5,0) EN ; "RTN","XDRDPICK",6,0) N XDRFL,CMORS1,CMORS2,D0,DA,DIC,DIE,DIR,ICNT,ICNT1,JCNT,LCNT,NCNT,PNCT,TMPGLA,TMPGLB,XDRDA,XDRFILN,XDRGLB,Y,PRIFILE "RTN","XDRDPICK",7,0) ; D EN^XDRVCHEK "RTN","XDRDPICK",8,0) S XDRFL=$$FILE() Q:XDRFL'>0 S PRIFILE=XDRFL,XDRGLB=$P(^DIC(XDRFL,0,"GL"),U,2),XDRFILN=$P(^DIC(XDRFL,0),U) "RTN","XDRDPICK",9,0) LOOP ; "RTN","XDRDPICK",10,0) W !!!,"At the following prompt select a POTENTIAL DUPLICATE ENTRY. If a selection" "RTN","XDRDPICK",11,0) W !,"is not made, you will be given a chance to select from a list if you" "RTN","XDRDPICK",12,0) W !,"want to. Otherwise, you will be returned to the menu system." "RTN","XDRDPICK",13,0) W ! "RTN","XDRDPICK",14,0) S Y=$$LOOKUP^XDRDEDT(XDRFL) "RTN","XDRDPICK",15,0) S XDRDA=+Y I Y>0 D SHOW G LOOP "RTN","XDRDPICK",16,0) S DIR(0)="Y" "RTN","XDRDPICK",17,0) S DIR("A")="Do you want to select from a list of potential duplicates" "RTN","XDRDPICK",18,0) S DIR("B")="YES" "RTN","XDRDPICK",19,0) D ^DIR K DIR Q:Y'>0 "RTN","XDRDPICK",20,0) S TMPGLB=$NA(^TMP("XDRDPICK",$J)),TMPGLA=$NA(^TMP("XDRDPICA",$J)) "RTN","XDRDPICK",21,0) K @TMPGLB,@TMPGLA "RTN","XDRDPICK",22,0) D ASK "RTN","XDRDPICK",23,0) I XDRDA>0 G LOOP "RTN","XDRDPICK",24,0) K PCNT "RTN","XDRDPICK",25,0) Q "RTN","XDRDPICK",26,0) ; "RTN","XDRDPICK",27,0) GETLIST ; "RTN","XDRDPICK",28,0) I XDRGLB="DPT(",$O(^DPT("ACMORS",0))>0 D CMORS Q "RTN","XDRDPICK",29,0) N FLG "RTN","XDRDPICK",30,0) F ICNT=ICNT:0 S ICNT=$O(^VA(15,ICNT)) Q:ICNT'>0 S X=^(ICNT,0) D Q:'(NCNT#4)&(NCNT>0)&FLG "RTN","XDRDPICK",31,0) . S FLG=1 ;This flag is when NCNT is set from previous call and STATUS is not "P" the first time- - so loop will not quit with (NCNT#4) "RTN","XDRDPICK",32,0) . I $P(X,U,3)'="P" S:PCNT=NCNT FLG=0 Q "RTN","XDRDPICK",33,0) . I $P($P(X,U),";",2)'=XDRGLB Q "RTN","XDRDPICK",34,0) . S NCNT=NCNT+1,X1=+$P(X,U),X2=+$P(X,U,2) "RTN","XDRDPICK",35,0) . I '($D(@(U_XDRGLB_X1_",0)"))#2)!'($D(@(U_XDRGLB_X2_",0)"))#2) S NCNT=NCNT-1 Q "RTN","XDRDPICK",36,0) . S @TMPGLB@(NCNT)=ICNT_U_X1_U_X2 "RTN","XDRDPICK",37,0) . S @TMPGLB@(NCNT,1)=@(U_XDRGLB_X1_",0)") "RTN","XDRDPICK",38,0) . S @TMPGLB@(NCNT,2)=@(U_XDRGLB_X2_",0)") "RTN","XDRDPICK",39,0) Q "RTN","XDRDPICK",40,0) ; "RTN","XDRDPICK",41,0) ASK ; "RTN","XDRDPICK",42,0) S NCNT=0,ICNT=0,ICNT1=0,JCNT=0,XDRDA=0,PCNT=0 "RTN","XDRDPICK",43,0) F D D CHEK Q:XDRDA'=0 Q:JCNT'>0 "RTN","XDRDPICK",44,0) . D GETLIST "RTN","XDRDPICK",45,0) . S PCNT=NCNT "RTN","XDRDPICK",46,0) . F JCNT=JCNT:0 S JCNT=$O(@TMPGLB@(JCNT)) Q:JCNT'>0 D Q:'(JCNT#4) "RTN","XDRDPICK",47,0) . . W !!!,$J(JCNT,5),". ",@TMPGLB@(JCNT,1) "RTN","XDRDPICK",48,0) . . W !,?8,@TMPGLB@(JCNT,2) "RTN","XDRDPICK",49,0) I XDRDA>0 S XDRDA=+@TMPGLB@(XDRDA) D SHOW "RTN","XDRDPICK",50,0) Q "RTN","XDRDPICK",51,0) ; "RTN","XDRDPICK",52,0) CHEK ; "RTN","XDRDPICK",53,0) ;IHS/OIT/LJF PATCH 1003 11/03/2006 don't ask if none from which to select "RTN","XDRDPICK",54,0) NEW DIR I NCNT=0 W !!," No potential duplicates found" D PAUSE^BPMU Q "RTN","XDRDPICK",55,0) ; "RTN","XDRDPICK",56,0) W ! "RTN","XDRDPICK",57,0) I JCNT'>0 S DIR(0)="N" "RTN","XDRDPICK",58,0) E S DIR(0)="NO",DIR("A",1)="Enter Return to continue listing or" "RTN","XDRDPICK",59,0) S DIR("A")="Select the desired entry by number" "RTN","XDRDPICK",60,0) S DIR(0)=DIR(0)_"^1:"_NCNT "RTN","XDRDPICK",61,0) D ^DIR K DIR "RTN","XDRDPICK",62,0) I Y>0 S XDRDA=+Y "RTN","XDRDPICK",63,0) I $D(DUOUT)!$D(DTOUT) S XDRDA=-1 K DTOUT,DUOUT "RTN","XDRDPICK",64,0) K DIRUT "RTN","XDRDPICK",65,0) Q "RTN","XDRDPICK",66,0) ; "RTN","XDRDPICK",67,0) SHOW ; "RTN","XDRDPICK",68,0) ;L +^VA(15,+XDRDA,0):30 I '$T G BUSY "RTN","XDRDPICK",69,0) ;I $P(^VA(15,+XDRDA,0),U,3)'="P" L -^VA(15,+XDRDA,0) G BUSY ; NOT AVAILABLE "RTN","XDRDPICK",70,0) ;N XDRXX S XDRXX(15,(+XDRDA)_",",.03)="X" "RTN","XDRDPICK",71,0) ;D FILE^DIE("","XDRXX") "RTN","XDRDPICK",72,0) ;L -^VA(15,+XDRDA,0) "RTN","XDRDPICK",73,0) I '$D(XDRGLB) N XDRGLB S XDRGLB=$P($P(^VA(15,XDRDA,0),U),";",2) "RTN","XDRDPICK",74,0) I $D(@(XDRGLB_(+^VA(15,XDRDA,0))_",-9)"))!$D(@(XDRGLB_(+$P(^VA(15,XDRDA,0),U,2))_",-9)")) W !,$C(7),"One of these entries has already been merged. Pick another pair.",!! D RESET(XDRDA) Q "RTN","XDRDPICK",75,0) S XQAID="" "RTN","XDRDPICK",76,0) S X=^VA(15,+XDRDA,0) "RTN","XDRDPICK",77,0) S X1=+X,X2=+$P(X,U,2) "RTN","XDRDPICK",78,0) I $$COUNT^XDRRMRG2(XDRFL,X1,X2)>1 S X1=X2,X2=+X "RTN","XDRDPICK",79,0) S XQADATA=XDRDA_U_X1_";"_X2_U_"PRIMARY"_U_XDRFL "RTN","XDRDPICK",80,0) D ^XDRRMRG1 "RTN","XDRDPICK",81,0) S DA=$$FIND1^DIC(15.02,","_XDRDA_",","X","PRIMARY") "RTN","XDRDPICK",82,0) I DA>0 D "RTN","XDRDPICK",83,0) . S X=$P(^VA(15,XDRDA,0),U,3) "RTN","XDRDPICK",84,0) . I X="N"!(X="V") Q "RTN","XDRDPICK",85,0) . S X=^VA(15,XDRDA,2,DA,0) "RTN","XDRDPICK",86,0) . I $P(X,U,2)="V" D "RTN","XDRDPICK",87,0) . . S DR=".03///X;.1///"_DT_";" "RTN","XDRDPICK",88,0) . . S DIE="^VA(15,",DA=XDRDA D ^DIE K DIE,DR "RTN","XDRDPICK",89,0) . . D SETUP^XDRRMRG1(XDRDA) "RTN","XDRDPICK",90,0) . . D CHEKVER^XDRRMRG1 "RTN","XDRDPICK",91,0) Q "RTN","XDRDPICK",92,0) ; "RTN","XDRDPICK",93,0) BUSY ; "RTN","XDRDPICK",94,0) W !!,$C(7),"Record is being processed by someone else.",!! "RTN","XDRDPICK",95,0) Q "RTN","XDRDPICK",96,0) ; "RTN","XDRDPICK",97,0) FILE() ; "RTN","XDRDPICK",98,0) N X "RTN","XDRDPICK",99,0) S X=0 "RTN","XDRDPICK",100,0) F I=0:0 S I=$O(^VA(15.1,I)) Q:I'>0 S X=X+1,X(I)="" "RTN","XDRDPICK",101,0) I X=1 Q $O(X("")) "RTN","XDRDPICK",102,0) K DIC S DIC=15.1,DIC(0)="AEQM",DIC("A")="Which FILE are the potential duplicates in (e.g., PATIENT)? ",DIC("B")="PATIENT" D ^DIC K DIC "RTN","XDRDPICK",103,0) Q +Y "RTN","XDRDPICK",104,0) ; "RTN","XDRDPICK",105,0) CMORS ; RETURN DATA RANKED BY CMORS (HIGH VALUES FIRST) "RTN","XDRDPICK",106,0) I '$D(^VA(15,"ACMORS")) D SETCMOR "RTN","XDRDPICK",107,0) I $G(^VA(15,"ACMORS",0))'>0 D SETCMOR "RTN","XDRDPICK",108,0) I $G(^VA(15,"ACMORS",0))>0,$$FMDIFF^XLFDT(DT,^(0))>7 D ASKCMOR "RTN","XDRDPICK",109,0) I ICNT1>0 S ICNT=ICNT-1 "RTN","XDRDPICK",110,0) S LCNT=0 "RTN","XDRDPICK",111,0) F ICNT=ICNT:0 S ICNT=$O(^VA(15,"ACMORS",ICNT)) Q:ICNT'>0 D Q:('(NCNT#4))&(LCNT>0) "RTN","XDRDPICK",112,0) . F ICNT1=+ICNT1:0 S ICNT1=$O(^VA(15,"ACMORS",ICNT,ICNT1)) Q:ICNT1'>0 D Q:('(NCNT#4))&(LCNT>0) "RTN","XDRDPICK",113,0) . . S X=$G(^VA(15,ICNT1,0)) Q:X="" Q:$P(X,U,3)'="P" S X1=+X,X2=+$P(X,U,2) "RTN","XDRDPICK",114,0) . . I $D(@TMPGLA@(X1,X2)) Q "RTN","XDRDPICK",115,0) . . S @TMPGLA@(X1,X2)="" "RTN","XDRDPICK",116,0) . . S NCNT=NCNT+1,LCNT=LCNT+1 "RTN","XDRDPICK",117,0) . . S @TMPGLB@(NCNT)=ICNT1_U_X1_U_X2 "RTN","XDRDPICK",118,0) . . S CMORS1=$P($G(^DPT(X1,"MPI")),U,6),CMORS2=$P($G(^DPT(X2,"MPI")),U,6) "RTN","XDRDPICK",119,0) . . S @TMPGLB@(NCNT,1)=@(U_XDRGLB_X1_",0)")_" (CMOR SCORE = "_$S(CMORS1="":"NULL",1:CMORS1)_")" "RTN","XDRDPICK",120,0) . . S @TMPGLB@(NCNT,2)=@(U_XDRGLB_X2_",0)")_" (CMOR SCORE = "_$S(CMORS2="":"NULL",1:CMORS2)_")" "RTN","XDRDPICK",121,0) Q "RTN","XDRDPICK",122,0) ; "RTN","XDRDPICK",123,0) SETCMOR ; "RTN","XDRDPICK",124,0) N I,X,X1,X2,SCOR "RTN","XDRDPICK",125,0) K ^VA(15,"ACMORS") "RTN","XDRDPICK",126,0) F I=0:0 S I=$O(^VA(15,I)) Q:I'>0 S X=^(I,0) D "RTN","XDRDPICK",127,0) . I $P(X,U,3)'="P" Q "RTN","XDRDPICK",128,0) . I $P($P(X,U),";",2)'="DPT(" Q "RTN","XDRDPICK",129,0) . S X1=+X,X2=+$P(X,U,2) "RTN","XDRDPICK",130,0) . S SCOR=$P($G(^DPT(X1,"MPI")),U,6) I SCOR'>0 S SCOR=0 "RTN","XDRDPICK",131,0) . S ^VA(15,"ACMORS",(9999999-SCOR),I)="" "RTN","XDRDPICK",132,0) . S SCOR=$P($G(^DPT(X2,"MPI")),U,6) I SCOR'>0 S SCOR=0 "RTN","XDRDPICK",133,0) . S ^VA(15,"ACMORS",(9999999-SCOR),I)="" "RTN","XDRDPICK",134,0) S ^VA(15,"ACMORS",0)=DT "RTN","XDRDPICK",135,0) Q "RTN","XDRDPICK",136,0) ; "RTN","XDRDPICK",137,0) ASKCMOR ; "RTN","XDRDPICK",138,0) N DIR "RTN","XDRDPICK",139,0) S DIR(0)="Y",DIR("A")="The CMOR scores for activity haven't been checked recently. Do you want to update these (It might take a couple of minutes)" "RTN","XDRDPICK",140,0) S DIR("B")="YES" "RTN","XDRDPICK",141,0) D ^DIR I Y>0 D SETCMOR "RTN","XDRDPICK",142,0) Q "RTN","XDRDPICK",143,0) ; "RTN","XDRDPICK",144,0) SET1 ; HANDLES SETTING OF X-REF ON CMOR SCORES FOR POTENTIAL DUPLICATES "RTN","XDRDPICK",145,0) I X'="P" Q "RTN","XDRDPICK",146,0) N XDRXVAL,XDRXVAL1 "RTN","XDRDPICK",147,0) S XDRXVAL=^VA(15,D0,0) "RTN","XDRDPICK",148,0) I $P($P(XDRXVAL,U),";",2)'="DPT(" Q "RTN","XDRDPICK",149,0) S XDRXVAL1=$P($G(^DPT(+XDRXVAL,"MPI")),U,6) I XDRXVAL1="" S XDRXVAL1=-1 "RTN","XDRDPICK",150,0) S ^VA(15,"ACMORS",(9999999-XDRXVAL1),D0)="" "RTN","XDRDPICK",151,0) S XDRXVAL1=$P($G(^DPT(+$P(XDRXVAL,U,2),"MPI")),U,6) I XDRXVAL1="" S XDRXVAL1=-1 "RTN","XDRDPICK",152,0) S ^VA(15,"ACMORS",(9999999-XDRXVAL1),D0)="" "RTN","XDRDPICK",153,0) Q "RTN","XDRDPICK",154,0) ; "RTN","XDRDPICK",155,0) KILL1 ; HANDLES KILLING OF X-REF ON CMOR SCORES FOR POTENTIAL DUPLICATES "RTN","XDRDPICK",156,0) I X'="P" Q "RTN","XDRDPICK",157,0) N XDRXVAL,XDRXVAL1 "RTN","XDRDPICK",158,0) S XDRXVAL=^VA(15,D0,0) "RTN","XDRDPICK",159,0) I $P($P(XDRXVAL,U),";",2)'="DPT(" Q "RTN","XDRDPICK",160,0) S XDRXVAL1=+$P($G(^DPT(+XDRXVAL,"MPI")),U,6) I XDRXVAL1="" S XDRXVAL1=-1 "RTN","XDRDPICK",161,0) K ^VA(15,"ACMORS",(9999999-XDRXVAL1),D0) "RTN","XDRDPICK",162,0) S XDRXVAL1=+$P($G(^DPT(+$P(XDRXVAL,U,2),"MPI")),U,6) I XDRXVAL1="" S XDRXVAL1=-1 "RTN","XDRDPICK",163,0) K ^VA(15,"ACMORS",(9999999-XDRXVAL1),D0) "RTN","XDRDPICK",164,0) Q "RTN","XDRDPICK",165,0) ; "RTN","XDRDPICK",166,0) OTHERS ; CHECKS AND MARKS OTHER PAIRS SO ONLY ONE CAN BE PROCESSED AT A TIME "RTN","XDRDPICK",167,0) Q ; NOT USED CURRENTLY "RTN","XDRDPICK",168,0) ; "RTN","XDRDPICK",169,0) ; P CLEAR ALL RELATED "RTN","XDRDPICK",170,0) ; "RTN","XDRDPICK",171,0) ; X MARK ALL RELATED "RTN","XDRDPICK",172,0) ; "RTN","XDRDPICK",173,0) ; V CLEAR TO "RTN","XDRDPICK",174,0) ; "RTN","XDRDPICK",175,0) ; O NOTHING "RTN","XDRDPICK",176,0) ; "RTN","XDRDPICK",177,0) ; R MARK ALL RELATED "RTN","XDRDPICK",178,0) ; "RTN","XDRDPICK",179,0) ; MERGED CLEAR TO REALIGN FROM "RTN","XDRDPICK",180,0) I X="O" Q "RTN","XDRDPICK",181,0) N OLDDA,OLDX S OLDDA=DA,OLDX=X N DA,X "RTN","XDRDPICK",182,0) N XDRENTR,IENVAL,XDRPAIR,DONE,XDR0,STATUS,DIREC "RTN","XDRDPICK",183,0) I $D(XDROTHER) Q "RTN","XDRDPICK",184,0) N XDROTHER S XDROTHER=1 "RTN","XDRDPICK",185,0) I OLDX="P"!(OLDX="N") D Q "RTN","XDRDPICK",186,0) . F XDRENTR=$P(^VA(15,OLDDA,0),U),$P(^VA(15,OLDDA,0),U,2) F IENVAL=0:0 S IENVAL=$O(^VA(15,"B",XDRENTR,IENVAL)) Q:IENVAL'>0 I IENVAL'=OLDDA,$P(^VA(15,IENVAL,0),U,3)="O" D "RTN","XDRDPICK",187,0) . . ; Have to check on whether the other member of the pair in process as well. "RTN","XDRDPICK",188,0) . . S XDRPAIR=$P(^VA(15,IENVAL,0),U) IF XDRPAIR=XDRENTR S XDRPAIR=$P(^(0),U,2) "RTN","XDRDPICK",189,0) . . S DONE=0 F IENPAIR=0:0 S IENPAIR=$O(^VA(15,"B",XDRPAIR,IENPAIR)) Q:IENPAIR'>0 I IENPAIR'=IENVAL D Q:DONE "RTN","XDRDPICK",190,0) . . . S XDR0=^VA(15,IENPAIR,0) "RTN","XDRDPICK",191,0) . . . S STATUS=$P(XDR0,U,3) "RTN","XDRDPICK",192,0) . . . I STATUS="X"!(STATUS="R") S DONE=1 Q "RTN","XDRDPICK",193,0) . . . I STATUS="V" D Q:DONE "RTN","XDRDPICK",194,0) . . . . S DIREC=$P(XDR0,U,4) "RTN","XDRDPICK",195,0) . . . . I $P(XDR0,U,DIREC)=XDRPAIR S DONE=1 Q ; IT IS THE 'FROM' ENTRY "RTN","XDRDPICK",196,0) . . . . Q "RTN","XDRDPICK",197,0) . . . Q "RTN","XDRDPICK",198,0) . . D RESET(IENVAL) "RTN","XDRDPICK",199,0) . . Q "RTN","XDRDPICK",200,0) . Q "RTN","XDRDPICK",201,0) I OLDX="X"!(OLDX="R") D Q "RTN","XDRDPICK",202,0) . F XDRENTR=$P(^VA(15,OLDDA,0),U),$P(^VA(15,OLDDA,0),U,2) F IENVAL=0:0 S IENVAL=$O(^VA(15,"B",XDRENTR,IENVAL)) Q:IENVAL'>0 I IENVAL'=OLDDA,$P(^VA(15,IENVAL,0),U,3)="P" D "RTN","XDRDPICK",203,0) . . N XDRXX S XDRXX(15,IENVAL_",",.03)="O" "RTN","XDRDPICK",204,0) . . D FILE^DIE("","XDRXX") "RTN","XDRDPICK",205,0) . Q "RTN","XDRDPICK",206,0) I OLDX="V"&$D(XDRDADJX) D Q ; IF MERGED (XDRDADJX IS SET IN XDRDAJD AND IS RUN BY A CROSS-REFERENCE FOR MERGE STATUS SET TO 'MERGED') "RTN","XDRDPICK",207,0) . F XDRENTR=$P(^VA(15,OLDDA,0),U),$P(^VA(15,OLDDA,0),U,2) D "RTN","XDRDPICK",208,0) . . S DIREC=$P(^VA(15,OLDDA,0),U,4) "RTN","XDRDPICK",209,0) . . F IENVAL=0:0 S IENVAL=$O(^VA(15,"B",XDRENTR,IENVAL)) Q:IENVAL'>0 I IENVAL'=OLDDA,$P(^VA(15,IENVAL,0),U,3)="O" D "RTN","XDRDPICK",210,0) . . . ; Have to check on whether the other member of the pair in process as well. "RTN","XDRDPICK",211,0) . . . S XDRPAIR=$P(^VA(15,IENVAL,0),U) IF XDRPAIR=XDRENTR S XDRPAIR=$P(^(0),U,2) "RTN","XDRDPICK",212,0) . . . S DONE=0 F IENPAIR=0:0 S IENPAIR=$O(^VA(15,"B",XDRPAIR,IENPAIR)) Q:IENPAIR'>0 I IENPAIR'=IENVAL D Q:DONE "RTN","XDRDPICK",213,0) . . . . S XDR0=^VA(15,IENPAIR,0) "RTN","XDRDPICK",214,0) . . . . S STATUS=$P(XDR0,U,3) "RTN","XDRDPICK",215,0) . . . . I STATUS="X"!(STATUS="R") S DONE=1 Q "RTN","XDRDPICK",216,0) . . . . I STATUS="V" D Q:DONE "RTN","XDRDPICK",217,0) . . . . . S DIREC=$P(XDR0,U,4) "RTN","XDRDPICK",218,0) . . . . . I $P(XDR0,U,DIREC)=XDRPAIR S DONE=1 Q ; IT IS THE 'FROM' ENTRY "RTN","XDRDPICK",219,0) . . . . . Q "RTN","XDRDPICK",220,0) . . . . Q "RTN","XDRDPICK",221,0) . . . D RESET(IENVAL) ; RESET TO "P" "RTN","XDRDPICK",222,0) . . . Q "RTN","XDRDPICK",223,0) . . Q "RTN","XDRDPICK",224,0) . Q "RTN","XDRDPICK",225,0) Q "RTN","XDRDPICK",226,0) ; "RTN","XDRDPICK",227,0) RESET(DA) ; "RTN","XDRDPICK",228,0) N XDRXX,IENS,X "RTN","XDRDPICK",229,0) I $P(^VA(15,DA,0),U,5)>1 Q "RTN","XDRDPICK",230,0) D NAME^XDRDEDT(DA) "RTN","XDRDPICK",231,0) S X=^VA(15,DA,0) "RTN","XDRDPICK",232,0) S IENS=DA_"," "RTN","XDRDPICK",233,0) S XDRXX(15,IENS,.03)="P" "RTN","XDRDPICK",234,0) I $P(X,U,4)'="" S XDRXX(15,IENS,.04)="@" "RTN","XDRDPICK",235,0) I $P(X,U,5)'="" S XDRXX(15,IENS,.05)="@" "RTN","XDRDPICK",236,0) I $P(X,U,7)'="" S XDRXX(15,IENS,.07)="@" "RTN","XDRDPICK",237,0) I $P(X,U,8)'="" S XDRXX(15,IENS,.08)="@" "RTN","XDRDPICK",238,0) I $P(X,U,10)'="" S XDRXX(15,IENS,.1)="@" "RTN","XDRDPICK",239,0) I $P(X,U,13)'="" S XDRXX(15,IENS,.13)="@" "RTN","XDRDPICK",240,0) I $P(X,U,14)'="" S XDRXX(15,IENS,.14)="@" "RTN","XDRDPICK",241,0) D FILE^DIE("","XDRXX") "RTN","XDRDPICK",242,0) S:$D(DUZ) $P(^VA(15,DA,0),U,12)=DUZ "RTN","XDRDPICK",243,0) K ^VA(15,DA,2) "RTN","XDRDPICK",244,0) K ^VA(15,DA,3) "RTN","XDRDPICK",245,0) Q "RTN","XDRDQUE") 0^4^B19875296 "RTN","XDRDQUE",1,0) XDRDQUE ;SF-IRMFO/IHS/OHPRD/JCM - START AND STOP DUPLICATE CHECKER SEARCH ;08/03/2000 07:29 [ 04/02/2003 8:47 AM ] "RTN","XDRDQUE",2,0) ;;7.3;TOOLKIT;**23,47,1001,1003**;Apr 03, 1995 "RTN","XDRDQUE",3,0) ;IHS/OIT/LJF 07/13/2006 PATCH 1003 don't ask user for file if only one is defined "RTN","XDRDQUE",4,0) ;; "RTN","XDRDQUE",5,0) START ; "RTN","XDRDQUE",6,0) S XDRQFLG=0 "RTN","XDRDQUE",7,0) ;*** following commented line to be removed from Toolkit ver after 7.3 "RTN","XDRDQUE",8,0) ;S XDRDQUE("TASKMAN STATUS")=$P(@$Q(^%ZTSCH("STATUS","")),U,2) I XDRDQUE("TASKMAN STATUS")'="RUN" W !!,"Taskman does not seem to be running properly, Please notify your site manager.",!! G END "RTN","XDRDQUE",9,0) S XDRDQUE("TASKMAN STATUS")=$$TM^%ZTLOAD "RTN","XDRDQUE",10,0) I 'XDRDQUE("TASKMAN STATUS") W !!,"Taskman does not seem to be running properly, Please notify your site manager.",!! G END "RTN","XDRDQUE",11,0) D FILE G:XDRQFLG END ; Asks user which file to check for dups "RTN","XDRDQUE",12,0) D CHECK^XDRU1 G:XDRQFLG END ; Checks the Duplicate Resolution file "RTN","XDRDQUE",13,0) D ASK G:XDRQFLG END ; Asks user what action and type of search "RTN","XDRDQUE",14,0) D QUEUE G:XDRQFLG END ; Queues search "RTN","XDRDQUE",15,0) I XDRDNSTA="r" D ASK3 D:'XDRQFLG QUEUE "RTN","XDRDQUE",16,0) END D EOJ ; Clean up variables "RTN","XDRDQUE",17,0) Q "RTN","XDRDQUE",18,0) ; "RTN","XDRDQUE",19,0) FILE ; EP - Called by XDRDCOMP,XDRDLIST,XDRDSCOR,XDRMADD,XDRCNT "RTN","XDRDQUE",20,0) K DIC("B") "RTN","XDRDQUE",21,0) K X S:$D(XDRFL) X=XDRFL "RTN","XDRDQUE",22,0) ; "RTN","XDRDQUE",23,0) ;IHS/OIT/LJF 07/13/2006 PATCH 1003 if only one file defined, don't ask just set it "RTN","XDRDQUE",24,0) I $O(^VA(15.1,0)),'$O(^VA(15.1,+$O(^VA(15.1,0)))) S X=$O(^VA(15.1,0)) "RTN","XDRDQUE",25,0) ; "RTN","XDRDQUE",26,0) S DIC(0)=$S($D(X):"Z",1:"QEAZ") "RTN","XDRDQUE",27,0) S:'$D(DIC("A")) DIC("A")="Select file to be checked for duplicates: " "RTN","XDRDQUE",28,0) S DIC="^VA(15.1," D ^DIC K DIC,X "RTN","XDRDQUE",29,0) I Y=-1 S XDRQFLG=1 G FILEX "RTN","XDRDQUE",30,0) S XDRD(0)=Y(0),XDRD(0,0)=Y(0,0),XDRFL=$P(Y(0),U),PRIFILE=XDRFL K Y "RTN","XDRDQUE",31,0) W:'$D(ZTQUEUED) !! "RTN","XDRDQUE",32,0) FILEX Q "RTN","XDRDQUE",33,0) ; "RTN","XDRDQUE",34,0) ASK ; "RTN","XDRDQUE",35,0) D DISP "RTN","XDRDQUE",36,0) D ASK1 G:XDRQFLG ASKX "RTN","XDRDQUE",37,0) I XDRDSTA="c"&($D(^VA(15.1,XDRFL,"APDTI"))) S XDRDPDTI="" W !!,"Since the Potential Duplicate Threshold has been raised",!,"I will only go through the Potential Duplicates and see if they",!,"meet the new threshold." G ASKX "RTN","XDRDQUE",38,0) D:XDRDSTA="c"&('XDRQFLG) ASK2 "RTN","XDRDQUE",39,0) ASKX ; "RTN","XDRDQUE",40,0) Q "RTN","XDRDQUE",41,0) DISP ; "RTN","XDRDQUE",42,0) D DISP^XDRDSTAT "RTN","XDRDQUE",43,0) S XDRDSTA=$P(XDRD(0),U,2) "RTN","XDRDQUE",44,0) S XDRDTYPE=$P(XDRD(0),U,5) "RTN","XDRDQUE",45,0) Q "RTN","XDRDQUE",46,0) ASK1 ; "RTN","XDRDQUE",47,0) S:XDRDSTA']"" XDRDSTA="c" "RTN","XDRDQUE",48,0) S DIR(0)="Y",DIR("A")="Do You wish to "_$S(XDRDSTA="h":"CONTINUE",XDRDSTA="e":"CONTINUE",XDRDSTA="r":"HALT",1:"RUN")_" "_$S(XDRDSTA="r":"this",XDRDSTA="h":"this",XDRDSTA="e":"this",1:"a")_" search (Y/N)" "RTN","XDRDQUE",49,0) D ^DIR K DIR D OUT "RTN","XDRDQUE",50,0) I 'XDRQFLG,'Y,$S(XDRDSTA="r":0,XDRDSTA="c":0,1:1) D S Y=0 "RTN","XDRDQUE",51,0) . S DIR(0)="Y",DIR("A")="Do you wish to mark this run COMPLETED (Y/N)",DIR("B")="NO" D ^DIR K DIR D OUT "RTN","XDRDQUE",52,0) . I Y,'XDRQFLG S DIE="^VA(15.1,",DA=XDRFL,DR=".02////c" D ^DIE K DA,DIE,DR "RTN","XDRDQUE",53,0) S:'Y XDRQFLG=1 "RTN","XDRDQUE",54,0) K XDRDNSTA "RTN","XDRDQUE",55,0) S:'XDRQFLG XDRDNSTA=$S(XDRDSTA="h":"r",XDRDSTA="r":"h",1:"r") "RTN","XDRDQUE",56,0) Q "RTN","XDRDQUE",57,0) ASK2 ; "RTN","XDRDQUE",58,0) K XDRDTYPE "RTN","XDRDQUE",59,0) S DIR(0)="15.1,.05A",DIR("A")="Which type of Search do you wish to run ? (BASIC/NEW) " "RTN","XDRDQUE",60,0) S DIR("B")="BASIC",DIR("?")="A 'BASIC' search starts at the beginning of the file. A 'NEW' search uses a cross-reference you specify to determine which entries to test." "RTN","XDRDQUE",61,0) D ^DIR K DIR D OUT "RTN","XDRDQUE",62,0) S XDRDTYPE=$S(Y="b":"BASIC",1:"NEW") "RTN","XDRDQUE",63,0) I XDRDTYPE="BASIC" D "RTN","XDRDQUE",64,0) . N DIR S DIR(0)="Y" "RTN","XDRDQUE",65,0) . S DIR("A",1)="This process will take a **LONG** time (known to exceed 100 hours)," "RTN","XDRDQUE",66,0) . S DIR("A",2)="but you CAN stop and restart the process when you want using" "RTN","XDRDQUE",67,0) . S DIR("A")="the options OK" "RTN","XDRDQUE",68,0) . D ^DIR S:Y'>0 XDRQFLG=1 "RTN","XDRDQUE",69,0) . Q "RTN","XDRDQUE",70,0) Q "RTN","XDRDQUE",71,0) ; "RTN","XDRDQUE",72,0) ASK3 ; "RTN","XDRDQUE",73,0) W ! "RTN","XDRDQUE",74,0) S DIR(0)="Y",DIR("A")="Do You wish to schedule a time to HALT this search (Y/N)" "RTN","XDRDQUE",75,0) D ^DIR K DIR D OUT "RTN","XDRDQUE",76,0) S:'Y XDRQFLG=1 "RTN","XDRDQUE",77,0) G:XDRQFLG ASK3X "RTN","XDRDQUE",78,0) S XDRDNSTA="h" "RTN","XDRDQUE",79,0) ASK3X Q "RTN","XDRDQUE",80,0) ; "RTN","XDRDQUE",81,0) QUEUE ; "RTN","XDRDQUE",82,0) S ZTRTN="XDRDMAIN",ZTIO="",ZTDESC="Duplicate "_XDRD(0,0)_" Search" "RTN","XDRDQUE",83,0) S:XDRDNSTA="h" ZTDESC="Halt "_ZTDESC "RTN","XDRDQUE",84,0) S ZTSAVE("XDRFL")="" S:$D(XDRDPDTI) ZTSAVE("XDRDPDTI")="" "RTN","XDRDQUE",85,0) S ZTSAVE("XDRDTYPE")="",ZTSAVE("XDRDNSTA")="" "RTN","XDRDQUE",86,0) D ^%ZTLOAD "RTN","XDRDQUE",87,0) S:'$D(ZTQUEUED) XDRQFLG=1 "RTN","XDRDQUE",88,0) K ZTSK "RTN","XDRDQUE",89,0) QUEUEX Q "RTN","XDRDQUE",90,0) ; "RTN","XDRDQUE",91,0) OUT ; "RTN","XDRDQUE",92,0) ; Common point to take care of DIR,DIC, and DIE calls "RTN","XDRDQUE",93,0) I ($D(DTOUT))!($D(DUOUT))!($D(DIRUT)) K DTOUT,DUOUT,DIRUT S XDRQFLG=1 "RTN","XDRDQUE",94,0) Q "RTN","XDRDQUE",95,0) EOJ ; "RTN","XDRDQUE",96,0) K X,Y,XDRFL,XDRDNSTA,XDRDSTA,XDRQFLG,XDRD,XDRDPDTI,XDRDQUE "RTN","XDRDQUE",97,0) Q "RTN","XDRDSHOW") 0^5^B43283757 "RTN","XDRDSHOW",1,0) XDRDSHOW ;SF-IRMFO.SEA/JLI - DISPLAY DATA IN FIELDS, GET OVERWRITES ;02/11/2004 08:56 "RTN","XDRDSHOW",2,0) ;;7.3;TOOLKIT;**23,49,78,1001,1003**;Apr 25, 1995 "RTN","XDRDSHOW",3,0) ;IHS/OIT/LJF 07/14/2006 PATCH 1003 check for RGV routine to prevent NOROUTINE error "RTN","XDRDSHOW",4,0) ; 07/28/2006 PATCH 1003 allow review of fields that point to file 200 "RTN","XDRDSHOW",5,0) ; display if field marked for overwrite "RTN","XDRDSHOW",6,0) ; 01/18/2007 PATCH 1003 added display of package for ancillary checks "RTN","XDRDSHOW",7,0) ;; "RTN","XDRDSHOW",8,0) SHOW(FILE,REC1,REC2,FLDS,REVIEW) ; "RTN","XDRDSHOW",9,0) N FILDIC,MULT,DDVAL,NAMIEN1,NAMIEN2,NAMREC1,NAMREC2,FIRSTIME,MPIMB "RTN","XDRDSHOW",10,0) S FILDIC=$G(^DIC(FILE,0,"GL")) Q:FILDIC="" "RTN","XDRDSHOW",11,0) S REVIEW=+$G(REVIEW) "RTN","XDRDSHOW",12,0) S FILREC1=FILDIC_"REC1)" "RTN","XDRDSHOW",13,0) S FILREC2=FILDIC_"REC2)" "RTN","XDRDSHOW",14,0) S NAMREC1=$P($G(@FILREC1@(0)),U) I NAMREC1="" Q "RTN","XDRDSHOW",15,0) S NAMREC2=$P($G(@FILREC2@(0)),U) I NAMREC2="" Q "RTN","XDRDSHOW",16,0) I FILE=63 D "RTN","XDRDSHOW",17,0) . S NAMIEN1=+$P(@FILREC1@(0),U,3),NAMIEN2=+$P(@FILREC2@(0),U,3) "RTN","XDRDSHOW",18,0) . S NAMREC1=$P(^DPT(NAMIEN1,0),U),NAMREC2=$P(^DPT(NAMIEN2,0),U) "RTN","XDRDSHOW",19,0) I $P(^DD(FILE,.01,0),U,2)["P" D "RTN","XDRDSHOW",20,0) . N XFIL "RTN","XDRDSHOW",21,0) . S XFIL=+$P($P($G(^DD(FILE,.01,0)),U,2),"P",2) Q:XFIL'>0 "RTN","XDRDSHOW",22,0) . S XFIL=$G(^DIC(XFIL,0,"GL")) Q:XFIL="" "RTN","XDRDSHOW",23,0) . S NAMREC1=$P(@(XFIL_NAMREC1_",0)"),U) "RTN","XDRDSHOW",24,0) . S NAMREC2=$P(@(XFIL_NAMREC2_",0)"),U) "RTN","XDRDSHOW",25,0) ; "RTN","XDRDSHOW",26,0) ; recalc CMOR scores "RTN","XDRDSHOW",27,0) I FILE=2,$D(^DD(FILE,991.06)) D "RTN","XDRDSHOW",28,0) . I '$L($T(CALC^RGVCCMR2)) Q ;IHS/OIT/LJF 07/14/2006 PATCH 1003 check for existence of RGVCCMS2 routine "RTN","XDRDSHOW",29,0) . N RGDFN S RGDFN=REC1 D CALC^RGVCCMR2 "RTN","XDRDSHOW",30,0) . N RGDFN S RGDFN=REC2 D CALC^RGVCCMR2 "RTN","XDRDSHOW",31,0) . Q "RTN","XDRDSHOW",32,0) ; "RTN","XDRDSHOW",33,0) ; check for multiple birth indicator in MPI "RTN","XDRDSHOW",34,0) S FIRSTIME=1 "RTN","XDRDSHOW",35,0) I FILE=2 D "RTN","XDRDSHOW",36,0) . I $G(^DPT(REC1,"MPIMB"))="Y"!($G(^DPT(REC2,"MPIMB"))="Y") S MPIMB=1 "RTN","XDRDSHOW",37,0) . E S MPIMB=0 "RTN","XDRDSHOW",38,0) ; "RTN","XDRDSHOW",39,0) D HEADER "RTN","XDRDSHOW",40,0) LOOP ; "RTN","XDRDSHOW",41,0) S FLD=0 "RTN","XDRDSHOW",42,0) F FLD=0:0 S FLD=$O(^DD(FILE,FLD)) Q:FLD'>0 D I NLIN<6 D PAGE Q:$D(DIRUT) D HEADER "RTN","XDRDSHOW",43,0) . I FILE=63,$P($G(^DD(FILE,FLD,0)),U)="NAME" Q ;scrn patient file data. From Lab "RTN","XDRDSHOW",44,0) . ; "RTN","XDRDSHOW",45,0) . ;IHS/OIT/LJF 07/28/2006 PATCH 1003 okay to allow ptrs to New Person file "RTN","XDRDSHOW",46,0) . ;I FILE'=2,$P($G(^DD(FILE,FLD,0)),U,2)["P2" Q ;From DINUM pointers. "RTN","XDRDSHOW",47,0) . I FILE'=2,$P($G(^DD(FILE,FLD,0)),U,2)["P2",$P($G(^DD(FILE,FLD,0)),U,2)'["P200" Q "RTN","XDRDSHOW",48,0) . ; "RTN","XDRDSHOW",49,0) . S DDVAL=$G(^DD(FILE,FLD,0)) "RTN","XDRDSHOW",50,0) . S NODE=$P($P(DDVAL,U,4),";") "RTN","XDRDSHOW",51,0) . S PIECE=$P($P(DDVAL,U,4),";",2) "RTN","XDRDSHOW",52,0) . I PIECE=0 S MULT(FLD)="" "RTN","XDRDSHOW",53,0) . I PIECE>0 D "RTN","XDRDSHOW",54,0) . . S X1=$P($G(@FILREC1@(NODE)),U,PIECE),X1=$$TYPE(X1,$P(DDVAL,U,2),DDVAL,REC1) "RTN","XDRDSHOW",55,0) . . S X2=$P($G(@FILREC2@(NODE)),U,PIECE),X2=$$TYPE(X2,$P(DDVAL,U,2),DDVAL,REC2) "RTN","XDRDSHOW",56,0) . . I X1'=""!(X2'="") D "RTN","XDRDSHOW",57,0) . . . S X0=" " "RTN","XDRDSHOW",58,0) . . . S XN=$P(DDVAL,U) "RTN","XDRDSHOW",59,0) . . . S XDRA=0 "RTN","XDRDSHOW",60,0) . . . I X1'=""&(X2'=""),X1'=X2 S X0=$S($D(FLDS(FLD)):"||||",1:"****"),NDIFFS=NDIFFS+1,DIFFS(NDIFFS)=FLD,XDRA=1 I REVIEW S NLIN=NLIN-1 "RTN","XDRDSHOW",61,0) . . . ; "RTN","XDRDSHOW",62,0) . . . ;IHS/OIT/LJF 07/28/2006 PATCH 1003 show if field already marked for overwrite "RTN","XDRDSHOW",63,0) . . . I X1'=""&(X2'=""),X1'=X2,$$GET^XPAR("PKG","BPM USE IHS LOGIC") S X0=$S($D(FLDS(FLD)):"||||",$D(^VA(15,+$G(XDRDA),3,+$G(XDRFILE),1,FLD)):"||||",1:"****") "RTN","XDRDSHOW",64,0) . . . ; "RTN","XDRDSHOW",65,0) . . . I 'REVIEW!XDRA D "RTN","XDRDSHOW",66,0) . . . . W ! S NLIN=NLIN-1 "RTN","XDRDSHOW",67,0) . . . . F Q:XN=""&(X1="")&(X2="") D "RTN","XDRDSHOW",68,0) . . . . . W !,X0," ",$E(XN,1,20),?30,$E(X1,1,20),?55,$E(X2,1,20) "RTN","XDRDSHOW",69,0) . . . . . S NLIN=NLIN-1 "RTN","XDRDSHOW",70,0) . . . . . S X0=" ",XN=$E(XN,21,$L(XN)) "RTN","XDRDSHOW",71,0) . . . . . S X1=$E(X1,21,$L(X1)) "RTN","XDRDSHOW",72,0) . . . . . S X2=$E(X2,21,$L(X2)) "RTN","XDRDSHOW",73,0) MULT I '$D(DIRUT) D "RTN","XDRDSHOW",74,0) . I $G(NDIFFS)>0 D PAGE Q:$D(DIRUT) D HEADER "RTN","XDRDSHOW",75,0) . I $D(MULT) D "RTN","XDRDSHOW",76,0) . . F FLD=0:0 S FLD=$O(MULT(FLD)) Q:FLD'>0 D I NLIN<6 D PAGE Q:$D(DIRUT) D HEADER "RTN","XDRDSHOW",77,0) . . . S DDVAL=^DD(FILE,FLD,0) "RTN","XDRDSHOW",78,0) . . . S NAME=$P(DDVAL,U) "RTN","XDRDSHOW",79,0) . . . S NODE=$P($P(DDVAL,U,4),";") "RTN","XDRDSHOW",80,0) . . . S NOD1=$NA(@FILREC1@(NODE)) "RTN","XDRDSHOW",81,0) . . . S NOD2=$NA(@FILREC2@(NODE)) "RTN","XDRDSHOW",82,0) . . . S N1=0,N2=0 "RTN","XDRDSHOW",83,0) . . . F I=0:0 S I=$O(@NOD1@(I)) Q:I'>0 S N1=N1+1 "RTN","XDRDSHOW",84,0) . . . F I=0:0 S I=$O(@NOD2@(I)) Q:I'>0 S N2=N2+1 "RTN","XDRDSHOW",85,0) . . . I N1'=0!(N2'=0) D "RTN","XDRDSHOW",86,0) . . . . S N1=$S(N1>1:N1_" entries",N1>0:N1_" entry",1:"---") "RTN","XDRDSHOW",87,0) . . . . S N2=$S(N2>1:N2_" entries",N2>0:N2_" entry",1:"---") "RTN","XDRDSHOW",88,0) . . . . W !!,$E(NAME,1,25),?30,N1,?55,N2 "RTN","XDRDSHOW",89,0) . . . . S NLIN=NLIN-2 "RTN","XDRDSHOW",90,0) Q "RTN","XDRDSHOW",91,0) PAGE ; "RTN","XDRDSHOW",92,0) I IOST'["C-"!$D(ZTQUEUED) Q "RTN","XDRDSHOW",93,0) W ! "RTN","XDRDSHOW",94,0) I '$D(DIFFS)!'REVIEW S DIR(0)="E" D ^DIR K DIR "RTN","XDRDSHOW",95,0) I $D(DIFFS)&REVIEW D "RTN","XDRDSHOW",96,0) . S DIR(0)="LO^1:"_NDIFFS,DIR("A")="OVERWRITE data for selected fields" "RTN","XDRDSHOW",97,0) . F I=1:1:NDIFFS W !,I," ",$P(^DD(FILE,DIFFS(I),0),U) "RTN","XDRDSHOW",98,0) . W ! D ^DIR K DIR "RTN","XDRDSHOW",99,0) . I X="",$D(DIRUT) K DIRUT "RTN","XDRDSHOW",100,0) . S I="" F S I=$O(Y(I)) Q:I="" S Y=Y(I) K Y(I) D "RTN","XDRDSHOW",101,0) . . F Q:Y="," Q:Y="" S X=$D(FLDS(DIFFS(+Y))) K:X=1 FLDS(DIFFS(+Y)) S:X=0 FLDS(DIFFS(+Y))="" S Y=$P(Y,",",2,999) "RTN","XDRDSHOW",102,0) Q "RTN","XDRDSHOW",103,0) ; "RTN","XDRDSHOW",104,0) HEADER ; "RTN","XDRDSHOW",105,0) N REC1MB,REC2MB "RTN","XDRDSHOW",106,0) I '$G(FIRSTIME),$D(IOF) W @IOF "RTN","XDRDSHOW",107,0) I $G(FIRSTIME),$G(MPIMB) D WARNING "RTN","XDRDSHOW",108,0) S FIRSTIME=0 "RTN","XDRDSHOW",109,0) K DIFFS S NDIFFS=0 "RTN","XDRDSHOW",110,0) S NLIN=IOSL-4 "RTN","XDRDSHOW",111,0) I $D(MPIMB) S NLIN=NLIN-4,MPIMB=0 "RTN","XDRDSHOW",112,0) I '$D(PACKAGE) S PACKAGE="PRIMARY" "RTN","XDRDSHOW",113,0) ; "RTN","XDRDSHOW",114,0) ;IHS/OIT/LJF 01/18/2007 PATCH 1003 display Package "RTN","XDRDSHOW",115,0) I PACKAGE'="PRIMARY" W !,"RPMS Application: ",PACKAGE "RTN","XDRDSHOW",116,0) ; "RTN","XDRDSHOW",117,0) ;REM - modified next two lines to include IENs in review display "RTN","XDRDSHOW",118,0) W !,?30,$S(PACKAGE="PRIMARY":"RECORD1 [#"_REC1_"]",PACKAGE="LABORATORY":"MERGE FROM [#"_NAMIEN1_"]",1:"MERGE FROM [#"_REC1_"]") "RTN","XDRDSHOW",119,0) W ?55,$S(PACKAGE="PRIMARY":"RECORD2 [#"_REC2_"]",PACKAGE="LABORATORY":"MERGE TO [#"_NAMIEN2_"]",1:"MERGE TO [#"_REC2_"]") "RTN","XDRDSHOW",120,0) ;I FILE=63 W !?38,"[#"_NAMIEN1_"]",?55,"[#"_NAMIEN2_"]" "RTN","XDRDSHOW",121,0) W !,?30,$E(NAMREC1,1,20),?55,$E(NAMREC2,1,20) "RTN","XDRDSHOW",122,0) S NLIN=NLIN-2 "RTN","XDRDSHOW",123,0) I $E(NAMREC1,21,40)'=""!($E(NAMREC2,21,40)'="") D "RTN","XDRDSHOW",124,0) . W !,?30,$E(NAMREC1,21,40),?55,$E(NAMREC2,21,40) "RTN","XDRDSHOW",125,0) . S NLIN=NLIN-1 "RTN","XDRDSHOW",126,0) ; "RTN","XDRDSHOW",127,0) ; add CMOR scores to header "RTN","XDRDSHOW",128,0) I $D(^DD(FILE,991.06)) D "RTN","XDRDSHOW",129,0) . W !,?30,"CMOR SCORE = "_$S($P($G(^DPT(REC1,"MPI")),U,6):$P(^DPT(REC1,"MPI"),U,6),1:"NULL"),?55,"CMOR SCORE = "_$S($P($G(^DPT(REC2,"MPI")),U,6):$P(^DPT(REC2,"MPI"),U,6),1:"NULL") "RTN","XDRDSHOW",130,0) . S NLIN=NLIN-1 "RTN","XDRDSHOW",131,0) ; "RTN","XDRDSHOW",132,0) ; add MULTIBLE BIRTH indicator to header "RTN","XDRDSHOW",133,0) S (REC1MB,REC2MB)=0 "RTN","XDRDSHOW",134,0) I $G(^DPT(REC1,"MPIMB"))="Y" S REC1MB=1 "RTN","XDRDSHOW",135,0) I $G(^DPT(REC2,"MPIMB"))="Y" S REC2MB=1 "RTN","XDRDSHOW",136,0) I REC1MB!REC2MB D "RTN","XDRDSHOW",137,0) . W !,?30,$S(REC1MB:"**MULTIPLE BIRTH**",1:""),?55,$S(REC2MB:"**MULTIPLE BIRTH**",1:"") "RTN","XDRDSHOW",138,0) . S NLIN=NLIN-1 "RTN","XDRDSHOW",139,0) ; "RTN","XDRDSHOW",140,0) W !,"----------------------------------------------------------------------------" "RTN","XDRDSHOW",141,0) S NLIN=NLIN-1 "RTN","XDRDSHOW",142,0) Q "RTN","XDRDSHOW",143,0) ; "RTN","XDRDSHOW",144,0) POINT(VAL,FILE) ; "RTN","XDRDSHOW",145,0) N X,Y "RTN","XDRDSHOW",146,0) I +VAL'=VAL Q "BAD POINTER VALUE IN FILE" "RTN","XDRDSHOW",147,0) S Y=$G(^DIC(FILE,0,"GL")) Q:Y="" "" "RTN","XDRDSHOW",148,0) S Y=Y_VAL_",0)" "RTN","XDRDSHOW",149,0) S Y=$P($G(@Y),U) I Y'=""&($P(^DD(FILE,.01,0),U,2)["P") S Y=$$POINT(Y,+$P($P(^DD(FILE,.01,0),U,2),"P",2)) "RTN","XDRDSHOW",150,0) S:Y="" Y="** Missing Entry in File "_FILE_"." ;REM - 9/6/96 When a pointer node is missing. "RTN","XDRDSHOW",151,0) Q Y "RTN","XDRDSHOW",152,0) TYPE(VAL,TYPE,DDNODE0,REC) ; "RTN","XDRDSHOW",153,0) I TYPE["O",$D(^DD(FILE,FLD,2)) S Y=VAL,D0=REC X ^DD(FILE,FLD,2) S VAL=Y Q VAL "RTN","XDRDSHOW",154,0) I TYPE["F",VAL'="" S VAL=""""_VAL_"""" Q VAL "RTN","XDRDSHOW",155,0) I TYPE["P",VAL>0 S VAL=$$POINT(VAL,+$P(TYPE,"P",2)) Q VAL "RTN","XDRDSHOW",156,0) I TYPE["D",VAL>0 D Q VAL "RTN","XDRDSHOW",157,0) . S VAL=$TR($$FMTE^XLFDT(VAL,2),"@"," ") "RTN","XDRDSHOW",158,0) I TYPE["S" D Q VAL "RTN","XDRDSHOW",159,0) . N X S X=";"_$P(DDNODE0,U,3) "RTN","XDRDSHOW",160,0) . S X=$P($P(X,(";"_VAL_":"),2),";") "RTN","XDRDSHOW",161,0) . I X'="" S VAL=X "RTN","XDRDSHOW",162,0) Q VAL "RTN","XDRDSHOW",163,0) ; "RTN","XDRDSHOW",164,0) WARNING ; "RTN","XDRDSHOW",165,0) W !,?2,"*** WARNING!!! One or both of these records indicated MULTIPLE BIRTH. ***",!,?2,"Use caution to ensure that these records are truly duplicates and not",!,?2,"siblings before proceeding.",! "RTN","XDRDSHOW",166,0) Q "RTN","XDRDVAL") 0^6^B30226252 "RTN","XDRDVAL",1,0) XDRDVAL ;CIOFO-SF.SEA/JLI - Check validity of data elements ;10/02/2000 08:00 [ 04/02/2003 8:47 AM ] "RTN","XDRDVAL",2,0) ;;7.3;TOOLKIT;**23,32,51,1001,1003**;Apr 03, 1995 "RTN","XDRDVAL",3,0) ;IHS/OIT/LJF 11/30/2006 PATCH 1003 skipped check of DW Audit file "RTN","XDRDVAL",4,0) ;; "RTN","XDRDVAL",5,0) Q "RTN","XDRDVAL",6,0) ; "RTN","XDRDVAL",7,0) DOENTRY(FILE,IEN,OUTROOT,HELP) ; ENTRY POINT TO PROCESS A SINGLE ENTRY "RTN","XDRDVAL",8,0) ;N DATAROOT,MESGROOT,TEMPROOT,IENS,FIELD,X "RTN","XDRDVAL",9,0) N ZTQUEUED ;S ZTQUEUED=1 "RTN","XDRDVAL",10,0) S DATAROOT=$NA(^TMP($J,"XDRDVAL","DATA")) "RTN","XDRDVAL",11,0) S MESGROOT=$NA(^TMP($J,"XDRDVAL","MESG")) "RTN","XDRDVAL",12,0) S TEMPROOT=$NA(^TMP($J,"XDRDVAL","TEMP")) "RTN","XDRDVAL",13,0) K @DATAROOT,@MESGROOT,@TEMPROOT "RTN","XDRDVAL",14,0) D DOGETS "RTN","XDRDVAL",15,0) I $D(@TEMPROOT) D VALIDATE(TEMPROOT,$NA(@MESGROOT@(IEN,"VAL"))) "RTN","XDRDVAL",16,0) M @OUTROOT@(IEN)=@MESGROOT@(IEN) "RTN","XDRDVAL",17,0) Q "RTN","XDRDVAL",18,0) DOGETS ; "RTN","XDRDVAL",19,0) D GETS^DIQ(FILE,IEN,"**","EIN",DATAROOT,MESGROOT) "RTN","XDRDVAL",20,0) ;I $D(@MESGROOT@("DIERR"))>1 M @OUTROOT@(FILE,IEN,"GET","DIERR")=@MESGROOT@("DIERR") "RTN","XDRDVAL",21,0) K @MESGROOT "RTN","XDRDVAL",22,0) F FILE=0:0 S FILE=$O(@DATAROOT@(FILE)) Q:FILE'>0 D "RTN","XDRDVAL",23,0) . ; "RTN","XDRDVAL",24,0) . I $$GET^XPAR("PKG","BPM USE IHS LOGIC"),(FILE=9000003.3) Q ;DW Audit has special processing;IHS/OIT/LJF 11/30/2006 PATCH 1003 "RTN","XDRDVAL",25,0) . ; "RTN","XDRDVAL",26,0) . S IENS="" F S IENS=$O(@DATAROOT@(FILE,IENS)) Q:IENS="" D "RTN","XDRDVAL",27,0) . . F FIELD=0:0 S FIELD=$O(@DATAROOT@(FILE,IENS,FIELD)) Q:FIELD'>0 D "RTN","XDRDVAL",28,0) . . . I FILE=70.03,FIELD=.01 Q ; RADIOLOGY LOGIC REQUIRES USER INPUT "RTN","XDRDVAL",29,0) . . . I $O(@DATAROOT@(FILE,IENS,FIELD,""))>0 K @DATAROOT@(FILE,IENS,FIELD) Q ; WORD PROCESSING FIELDS - SKIP "RTN","XDRDVAL",30,0) . . . S Y=$G(@DATAROOT@(FILE,IENS,FIELD,"I")) I Y="" Q ; SKIP COMPUTED FIELDS "RTN","XDRDVAL",31,0) . . . S X=$G(@DATAROOT@(FILE,IENS,FIELD,"E")) "RTN","XDRDVAL",32,0) . . . S @TEMPROOT@(FILE,IENS,FIELD)=$S(X=Y:X,1:X_U_Y) "RTN","XDRDVAL",33,0) . . . Q "RTN","XDRDVAL",34,0) . . Q "RTN","XDRDVAL",35,0) . Q "RTN","XDRDVAL",36,0) Q "RTN","XDRDVAL",37,0) ; "RTN","XDRDVAL",38,0) VALIDATE(DATA,MESG) ; VALIDATE DATA IN 'DATA' RETURN ERRORS IN 'MESG' "RTN","XDRDVAL",39,0) ;N FILE,FIELD,RESULT,VAL,IENS,I,XDRDVALF,TOPFILE,FIRSTLVL "RTN","XDRDVAL",40,0) S XDRDVALF=1 "RTN","XDRDVAL",41,0) F FILE=0:0 S FILE=$O(@DATA@(FILE)) Q:FILE'>0 D "RTN","XDRDVAL",42,0) . S TOPFILE=($G(^DD(FILE,0,"UP"))'>0),FIRSTLVL=0 "RTN","XDRDVAL",43,0) . I 'TOPFILE S I=$G(^DD(FILE,0,"UP")) I $G(^DD(I,0,"UP"))'>0 S FIRSTLVL=1 "RTN","XDRDVAL",44,0) . S IENS="" F S IENS=$O(@DATA@(FILE,IENS)) Q:IENS="" D "RTN","XDRDVAL",45,0) . . F FIELD=0:0 S FIELD=$O(@DATA@(FILE,IENS,FIELD)) Q:FIELD'>0 D "RTN","XDRDVAL",46,0) . . . S (X,VAL)=$P(@DATA@(FILE,IENS,FIELD),U) "RTN","XDRDVAL",47,0) . . . S YVAL=$S(@DATA@(FILE,IENS,FIELD)[U:$P(@DATA@(FILE,IENS,FIELD),U,2),1:X) "RTN","XDRDVAL",48,0) . . . I 'TOPFILE,(FIRSTLVL&(FIELD'=.01))!'FIRSTLVL Q "RTN","XDRDVAL",49,0) . . . I FILE=2.101,FIELD=.01 Q ; DISPOSITON DATE/TIME HAS SPCL PROCESSING "RTN","XDRDVAL",50,0) . . . I FILE=2,FIELD=63 Q ; LAB POINTER HAS SPCL PROCESSING "RTN","XDRDVAL",51,0) . . . I FILE=2,FIELD=.09 Q ; SSN WILL BE ENTERED AS INTERNAL VALUE "RTN","XDRDVAL",52,0) . . . I FILE=2,$P(^DD(FILE,FIELD,0),U,5,99)["DGLOCK2" Q ;no NOK "RTN","XDRDVAL",53,0) . . . I FILE=354,FIELD=.03 Q ; COPAY EXEMPT STATUS DATE -- BAD "RTN","XDRDVAL",54,0) . . . D CHKVALID(MESG,FILE,IENS,FIELD,VAL,YVAL) "RTN","XDRDVAL",55,0) . . . Q "RTN","XDRDVAL",56,0) . . Q "RTN","XDRDVAL",57,0) . Q "RTN","XDRDVAL",58,0) Q "RTN","XDRDVAL",59,0) ; "RTN","XDRDVAL",60,0) CHKVALID(MESG,FILE,IENS,FIELD,EXTVAL,INTVAL,HELP) ; "RTN","XDRDVAL",61,0) ; "RTN","XDRDVAL",62,0) Q:FIELD=.001 "RTN","XDRDVAL",63,0) I $$NEWERR^%ZTER() N $ETRAP,$ESTACK S $ETRAP="D ERR^XDRDVAL" "RTN","XDRDVAL",64,0) E S X="ERR^XDRDVAL",@^%ZOSF("TRAP") "RTN","XDRDVAL",65,0) S IOP="XDRBROWSER1" D ^%ZIS Q:POP U IO "RTN","XDRDVAL",66,0) S XMESG=$NA(^TMP("XDRDVAL-M")) K @XMESG "RTN","XDRDVAL",67,0) S ^TMP($J,"LAST","FILE")=FILE,^("IENS")=IENS,^("FIELD")=FIELD,^("X")=EXTVAL,^("Y")=INTVAL "RTN","XDRDVAL",68,0) S Y1=EXTVAL D "RTN","XDRDVAL",69,0) . S RESULT="^" "RTN","XDRDVAL",70,0) . I $P(^DD(FILE,FIELD,0),U,2)["S" S Y1=INTVAL "RTN","XDRDVAL",71,0) . I $P(^DD(FILE,FIELD,0),U,2)["V" D "RTN","XDRDVAL",72,0) . . N Z S Z=$P(INTVAL,";",2) Q:Z="" "RTN","XDRDVAL",73,0) . . S Z=$P($G(@("^"_Z_"0)")),U,1) "RTN","XDRDVAL",74,0) . . S Y1=Z_".`"_$P(INTVAL,";") "RTN","XDRDVAL",75,0) . . Q "RTN","XDRDVAL",76,0) . N DA,D0,DIC,DIE "RTN","XDRDVAL",77,0) . D MAKEGLO(FILE,IENS,.DIC,.DA) Q:DA'>0 "RTN","XDRDVAL",78,0) . S D0=$P(IENS,",",$L(IENS,",")-1),DIE=DIC,DIC(0)="" "RTN","XDRDVAL",79,0) . S EXCODE=$P(^DD(FILE,FIELD,0),U,5,999) "RTN","XDRDVAL",80,0) . I $P(^DD(FILE,FIELD,0),U,2)["P" S Y1=$S(FILE=2.001:"",1:"`")_INTVAL,Y=INTVAL S Z=U_$P(^(0),U,3),DIC=Z I $D(@(Z_INTVAL_",0)")) S RESULT="" Q "RTN","XDRDVAL",81,0) . S X=Y1,FILEA=FILE X EXCODE I $D(X) S RESULT="" "RTN","XDRDVAL",82,0) . Q "RTN","XDRDVAL",83,0) I $G(RESULT)="^",$G(HELP)["E" M @MESG@(FILE,IENS,FIELD)=^TMP("XDRDVAL-M") "RTN","XDRDVAL",84,0) K @XMESG "RTN","XDRDVAL",85,0) I RESULT="",FIELD=.01 D CHKNM ; CHECK FOR ,0,"NM", PROBLEM "RTN","XDRDVAL",86,0) I $G(RESULT)="^" S @MESG@(FILE,IENS,FIELD,"INVALID")=INTVAL_$S(INTVAL'=EXTVAL:U_EXTVAL,1:"") "RTN","XDRDVAL",87,0) U IO D ^%ZISC K ^TMP("DDB",$J,1) "RTN","XDRDVAL",88,0) F I=2:1 Q:'$D(^TMP("DDB",$J,I)) S ^(I-1)=^TMP("DDB",$J,I) K ^(I) "RTN","XDRDVAL",89,0) I $D(^TMP("DDB",$J)) M @MESG@(FILE,IENS,FIELD,"NOTE")=^TMP("DDB",$J) "RTN","XDRDVAL",90,0) Q "RTN","XDRDVAL",91,0) ; "RTN","XDRDVAL",92,0) MAKEGLO(FILENUM,IENS,GLOB,DASTR) ; "RTN","XDRDVAL",93,0) N I,ERRFLG,DAVAL,J,FILE,FLD,NODE "RTN","XDRDVAL",94,0) S GLOB="",ERRFLG=0 K DASTR "RTN","XDRDVAL",95,0) F I=1:1 S FILE=FILENUM,DAVAL(I)=+IENS Q:$D(^DIC(FILE,0,"GL")) D Q:ERRFLG "RTN","XDRDVAL",96,0) . S FILENUM=$G(^DD(FILE,0,"UP")) I FILENUM="" S ERRFLG=1 Q "RTN","XDRDVAL",97,0) . S FLD=$O(^DD(FILENUM,"SB",FILE,0)) I FLD'>0 S ERRFLG=1 Q "RTN","XDRDVAL",98,0) . S NODE=$P($P($G(^DD(FILENUM,FLD,0)),U,4),";") I NODE="" S ERRFLG=1 Q "RTN","XDRDVAL",99,0) . S GLOB=""""_NODE_""","_$S(GLOB="":"",1:DAVAL(I)_",")_GLOB "RTN","XDRDVAL",100,0) . S IENS=$P(IENS,",",2,99) "RTN","XDRDVAL",101,0) . Q "RTN","XDRDVAL",102,0) I ERRFLG S DASTR=-1,GLOB="" Q "RTN","XDRDVAL",103,0) S GLOB=^DIC(FILE,0,"GL")_$S(GLOB="":"",1:DAVAL(I)_",")_GLOB "RTN","XDRDVAL",104,0) F J=2:1:I S DASTR(J-1)=DAVAL(J) "RTN","XDRDVAL",105,0) S DASTR=DAVAL(1) "RTN","XDRDVAL",106,0) Q "RTN","XDRDVAL",107,0) ; "RTN","XDRDVAL",108,0) CHKNM ; CHECK FOR PROBLEM WITH NM NODE OF SUBFILE NOT BEING CORRECT "RTN","XDRDVAL",109,0) N UFILE,UNAME,UFLD "RTN","XDRDVAL",110,0) S UFILE=$G(^DD(FILE,0,"UP")) I UFILE'>0 Q "RTN","XDRDVAL",111,0) S UFLD=$O(^DD(UFILE,"SB",FILE,"")) Q:UFLD'>0 "RTN","XDRDVAL",112,0) S UNAME=$P(^DD(UFILE,UFLD,0),U) "RTN","XDRDVAL",113,0) I $O(^DD(FILE,0,"NM",""))'=UNAME D "RTN","XDRDVAL",114,0) . S RESULT="^" "RTN","XDRDVAL",115,0) . W !,"First entry in ^DD("_FILE_",0,""NM"", does not match field name "_UNAME_" in file "_UFILE_". This will be rejected by UPDATE^DIE." "RTN","XDRDVAL",116,0) Q "RTN","XDRDVAL",117,0) ; "RTN","XDRDVAL",118,0) ERR ; On an error mark status as error, and save the error message "RTN","XDRDVAL",119,0) ; "RTN","XDRDVAL",120,0) K X S RESULT="^" "RTN","XDRDVAL",121,0) S $ECODE="" "RTN","XDRDVAL",122,0) S ^TMP("DDB",$J,2)=$ZE "RTN","XDRDVAL",123,0) Q "RTN","XDRDVAL",124,0) ; "RTN","XDRDVAL",125,0) OPEN ; "RTN","XDRDVAL",126,0) S DDBRZIS=1,DDBDMSG="" "RTN","XDRDVAL",127,0) I '$D(XDRDVALF) U IO(0) W !,"...ONE MOMENT..." U IO "RTN","XDRDVAL",128,0) Q "RTN","XDRDVAL",129,0) ; "RTN","XDRDVAL",130,0) CLOSE ; "RTN","XDRDVAL",131,0) S DDBRZIS=$G(DDBRZIS,1) "RTN","XDRDVAL",132,0) N C,CHAR,DDBROS,EOF,X "RTN","XDRDVAL",133,0) K ^TMP("DDB",$J) "RTN","XDRDVAL",134,0) S DDBROS=^%ZOSF("OS"),EOF="EOF-End Of File" "RTN","XDRDVAL",135,0) S CHAR="" F I=1:1:31 S CHAR=CHAR_$C(I) "RTN","XDRDVAL",136,0) U IO W !,EOF,! "RTN","XDRDVAL",137,0) S DDBRZIS("REWIND")=$$REWIND^%ZIS(IO,IOT,IOPAR) "RTN","XDRDVAL",138,0) I 'DDBRZIS("REWIND") S DDBRZIS=0 U IO(0) W $C(7),!!?5,"<< UNABLE TO REWIND FILE>>",! H 3 Q "RTN","XDRDVAL",139,0) U IO "RTN","XDRDVAL",140,0) S C=0 "RTN","XDRDVAL",141,0) F R X:1 Q:X="EOF-End Of File" D "RTN","XDRDVAL",142,0) .S X=$TR(X,CHAR) "RTN","XDRDVAL",143,0) .S:X']"" X=" " "RTN","XDRDVAL",144,0) .S C=C+1,^TMP("DDB",$J,C)=$E(X,1,255) Q "RTN","XDRDVAL",145,0) .Q "RTN","XDRDVAL",146,0) Q "RTN","XDRDVAL",147,0) Q "RTN","XDRDVAL1") 0^13^B60497238 "RTN","XDRDVAL1",1,0) XDRDVAL1 ;SF-CIOFO/JLI - CHECK SPECIFIED ENTRY FOR PROBLEMS ;12/04/2001 14:04 [ 12/18/2003 4:54 PM ] "RTN","XDRDVAL1",2,0) ;;7.3;TOOLKIT;**23,45,46,49,57,1002,1003**;Apr 03, 1995 "RTN","XDRDVAL1",3,0) ;IHS/OIT/LJF 12/30/2006 PATCH 1003 allow selection of inactive patients "RTN","XDRDVAL1",4,0) EN ; "RTN","XDRDVAL1",5,0) N MFILE,FILENAME,DIR,XDR,FILE,XDRY,FILEDIC "RTN","XDRDVAL1",6,0) ; "RTN","XDRDVAL1",7,0) D ^%ZIS Q:POP I IO'=IO(0) S XDRION=ION U IO D ^%ZISC "RTN","XDRDVAL1",8,0) LOOP ; "RTN","XDRDVAL1",9,0) S DATA=$NA(^TMP($J,"BB")) "RTN","XDRDVAL1",10,0) K @DATA "RTN","XDRDVAL1",11,0) U IO(0) "RTN","XDRDVAL1",12,0) S MFILE=$$FILE^XDRDPICK() Q:MFILE'>0 S FILENAME=$P(^DIC(MFILE,0),U),FILEDIC=^DIC(MFILE,0,"GL") "RTN","XDRDVAL1",13,0) W !!! S DIC=MFILE,DIC(0)="AEM" ;K DIR S DIR(0)="PO^"_MFILE_":AEM",DIR("A")="Select "_FILENAME "RTN","XDRDVAL1",14,0) ; "RTN","XDRDVAL1",15,0) NEW AUPNLK S AUPNLK("ALL")=1 ;IHS/OIT/LJF 12/29/2006 allow lookup of inactive patients "RTN","XDRDVAL1",16,0) ; "RTN","XDRDVAL1",17,0) D ^DIC I Y'>0 U IO D ^%ZISC Q ;D ^DIR K DIR I Y'>0 U IO D ^%ZISC Q "RTN","XDRDVAL1",18,0) S XDRY=Y "RTN","XDRDVAL1",19,0) W !," .... WORKING HARD (may take a while)...",! "RTN","XDRDVAL1",20,0) D EN1(MFILE,+XDRY,DATA) "RTN","XDRDVAL1",21,0) I $D(XDRION) S IOP=XDRION D ^%ZIS I 1 "RTN","XDRDVAL1",22,0) E S IO=IO(0) "RTN","XDRDVAL1",23,0) U IO W @IOF,!!! "RTN","XDRDVAL1",24,0) W !!,"DFN=",+XDRY," ",$P(@(FILEDIC_(+XDRY)_",0)"),U) I MFILE=2!(MFILE=200) W " [",$P(^(0),U,9),"]" "RTN","XDRDVAL1",25,0) I '$D(@DATA) W !?10,"No Problems Found....",!! G LOOP "RTN","XDRDVAL1",26,0) D LISTPROB($NA(@DATA@(+XDRY,"VAL"))) "RTN","XDRDVAL1",27,0) I $D(XDRION) U IO D ^%ZISC "RTN","XDRDVAL1",28,0) G LOOP "RTN","XDRDVAL1",29,0) Q "RTN","XDRDVAL1",30,0) ; "RTN","XDRDVAL1",31,0) EN1(FILE,IEN,ARRAY) ; "RTN","XDRDVAL1",32,0) D SETUP^XDRMERG(FILE) "RTN","XDRDVAL1",33,0) D DOENTRY^XDRDVAL(FILE,IEN,ARRAY) "RTN","XDRDVAL1",34,0) F FILEX=0:0 S FILEX=$O(^TMP($J,"XFIL",FILEX)) Q:FILEX'>0 S GLOB=^(FILEX) D "RTN","XDRDVAL1",35,0) . S X1=$G(^TMP($J,"XGLOB",GLOB,0,1)) Q:X1="" "RTN","XDRDVAL1",36,0) . I $P(X1,U,3)'="DINUM" Q "RTN","XDRDVAL1",37,0) . D DOENTRY^XDRDVAL(FILEX,IEN,ARRAY) "RTN","XDRDVAL1",38,0) . Q "RTN","XDRDVAL1",39,0) Q "RTN","XDRDVAL1",40,0) ; "RTN","XDRDVAL1",41,0) LISTPROB(DATA) ; "RTN","XDRDVAL1",42,0) S XDREXIT=0 "RTN","XDRDVAL1",43,0) F FILE=0:0 S FILE=$O(@DATA@(FILE)) Q:FILE'>0 D Q:XDREXIT "RTN","XDRDVAL1",44,0) . S FILENAME=$$FILENAME(FILE),NEWHEAD=1 "RTN","XDRDVAL1",45,0) . S IENS="" F S IENS=$O(@DATA@(FILE,IENS)) Q:IENS="" D Q:XDREXIT "RTN","XDRDVAL1",46,0) . . F FIELD=0:0 S FIELD=$O(@DATA@(FILE,IENS,FIELD)) Q:FIELD'>0 D Q:XDREXIT "RTN","XDRDVAL1",47,0) . . . S X=$G(@DATA@(FILE,IENS,FIELD,"INVALID")) Q:X="" "RTN","XDRDVAL1",48,0) . . . S NNOTES=0 I $D(@DATA@(FILE,IENS,FIELD,"NOTE")) D "RTN","XDRDVAL1",49,0) . . . . F NNOTE=0:0 S NNOTE=$O(@DATA@(FILE,IENS,FIELD,"NOTE",NNOTE)) Q:NNOTE'>0 S NNOTES=NNOTES+1 "RTN","XDRDVAL1",50,0) . . . . Q "RTN","XDRDVAL1",51,0) . . . S NLINES=NNOTES+3 "RTN","XDRDVAL1",52,0) . . . I (IOSL-$Y-4)'>NLINES D:$E(IOST)["C" Q:XDREXIT W @IOF S NEWHEAD=1 "RTN","XDRDVAL1",53,0) . . . . N DIR,Y,X "RTN","XDRDVAL1",54,0) . . . . S DIR(0)="E" D ^DIR I 'Y S XDREXIT=1 "RTN","XDRDVAL1",55,0) . . . . Q "RTN","XDRDVAL1",56,0) . . . W:NEWHEAD !!!,FILENAME S NEWHEAD=0 "RTN","XDRDVAL1",57,0) . . . W !,"Field ",FIELD," [",$P(^DD(FILE,FIELD,0),U),"] IENS=",IENS "RTN","XDRDVAL1",58,0) . . . W !," value: ",X "RTN","XDRDVAL1",59,0) . . . F NNOTE=0:0 S NNOTE=$O(@DATA@(FILE,IENS,FIELD,"NOTE",NNOTE)) Q:NNOTE'>0 W !," ",^(NNOTE) "RTN","XDRDVAL1",60,0) . . . Q "RTN","XDRDVAL1",61,0) . . Q "RTN","XDRDVAL1",62,0) . Q "RTN","XDRDVAL1",63,0) Q "RTN","XDRDVAL1",64,0) ; "RTN","XDRDVAL1",65,0) FILENAME(FILE) ; "RTN","XDRDVAL1",66,0) N FILENAME,NFILE "RTN","XDRDVAL1",67,0) S FILENAME="",NFILE=FILE "RTN","XDRDVAL1",68,0) 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 "RTN","XDRDVAL1",69,0) I FILE>0 S FILENAME="File "_NFILE_" ["_FILENAME_$P($G(^DIC(FILE,0)),U)_" file]" "RTN","XDRDVAL1",70,0) Q FILENAME "RTN","XDRDVAL1",71,0) ; "RTN","XDRDVAL1",72,0) ENPAIR(FILE,ARRAY,MERGEFLG) ; ENTRY POINT FOR CHECKING AN ARRAY OF PAIRS AT START OF MERGE "RTN","XDRDVAL1",73,0) N XDRMESG,FROM,TO,TOVARBL,FRVARBL,DUPIEN,DATA,NLINES,XDRFDA1 "RTN","XDRDVAL1",74,0) ; "RTN","XDRDVAL1",75,0) S XDRMESG=$NA(^TMP("XDRVALMESG",$J)) K @XDRMESG "RTN","XDRDVAL1",76,0) S XDRVDATA=$NA(^TMP("XDRVALDATA",$J)) K @XDRVDATA "RTN","XDRDVAL1",77,0) I $G(MERGEFLG)>0 S XDRFDA1=$$FIND1^DIC(15.23,","_MERGEFLG_",","Q","DATA CHECKING") "RTN","XDRDVAL1",78,0) ; "RTN","XDRDVAL1",79,0) F FROM=0:0 S FROM=$O(@ARRAY@(FROM)) Q:FROM'>0 D "RTN","XDRDVAL1",80,0) . I $G(MERGEFLG)>0 S ^VA(15.2,MERGEFLG,3,XDRFDA1,1)=$$NOW^XLFDT()_U_U_FROM "RTN","XDRDVAL1",81,0) . S TO=$O(@ARRAY@(FROM,0)) "RTN","XDRDVAL1",82,0) . ; "RTN","XDRDVAL1",83,0) . ; add special checks for BCMA, MPI, and Pharmacy, XT*7.3*45 "RTN","XDRDVAL1",84,0) . ; remove MPI check for CIRN/MPI aware patch, XT*7.3*49 "RTN","XDRDVAL1",85,0) . ; remove BCMA checks, XT*7.3*57 "RTN","XDRDVAL1",86,0) . ;I $D(^PSB(53.79,"B",FROM)) D Q "RTN","XDRDVAL1",87,0) . ;. S @XDRVDATA@(FROM,"VAL",53.79,TO,.01,"INVALID")="FROM Patient has data on file for BCMA, please resolve prior to merging." "RTN","XDRDVAL1",88,0) . ;I $T(GETICN^MPIF001)]"",$$GETICN^MPIF001(FROM)>0 D Q "RTN","XDRDVAL1",89,0) . ;. S @XDRVDATA@(FROM,"VAL",2,TO,991.01,"INVALID")="The FROM patient exist in the MPI system, this Patient cannot be merged." "RTN","XDRDVAL1",90,0) . ;I $T(GETICN^MPIF001)]"",$$GETICN^MPIF001(TO)>0 D Q "RTN","XDRDVAL1",91,0) . ;. S @XDRVDATA@(FROM,"VAL",2,TO,991.01,"INVALID")="The TO patient exist in the MPI system, this Patient cannot be merged." "RTN","XDRDVAL1",92,0) . I $T(EN^PSJPATMR)]"",'$$EN^PSJPATMR(FROM,TO) D Q "RTN","XDRDVAL1",93,0) . . 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." "RTN","XDRDVAL1",94,0) . ; "RTN","XDRDVAL1",95,0) . D CHKMERG^XDRDVAL2(FILE,FROM,TO,$NA(@XDRVDATA@(FROM,"VAL"))) ; GET BACK ANY PROBLEMS "RTN","XDRDVAL1",96,0) . F S TO=$O(@ARRAY@(FROM,TO)) Q:TO'>0 D ; FROM CAN'T POINT TO MORE THAN ONE PLACE "RTN","XDRDVAL1",97,0) . . S FRVARBL=$O(@ARRAY@(FROM,TO,0)) I FRVARBL="" S FRVARBL=0 "RTN","XDRDVAL1",98,0) . . S TOVARBL=$O(@ARRAY@(FROM,TO,FRVARBL,0)) I TOVARBL="" S TOVARBL=0 "RTN","XDRDVAL1",99,0) . . I TOVARBL=0 S DUPIEN=+$G(@ARRAY@(FROM,TO)) "RTN","XDRDVAL1",100,0) . . E S DUPIEN=+$G(@ARRAY@(FROM,TO,FRVARBL,TOVARBL)) "RTN","XDRDVAL1",101,0) . . D RMOVPAIR(FROM,TO,DUPIEN,ARRAY) "RTN","XDRDVAL1",102,0) . . Q "RTN","XDRDVAL1",103,0) . Q "RTN","XDRDVAL1",104,0) I $D(@XDRVDATA) D ; GOT BACK PROBLEMS ON ONE OR MORE FIELDS "RTN","XDRDVAL1",105,0) . I $G(MERGEFLG)>0 N XDRDVALF S XDRDVALF=1 S IOP="XDRBROWSER1" D ^%ZIS "RTN","XDRDVAL1",106,0) . I $G(MERGEFLG)'>0,$G(XDRION)'="" S IOP=XDRION D ^%ZIS "RTN","XDRDVAL1",107,0) . U IO "RTN","XDRDVAL1",108,0) . F FROM=0:0 S FROM=$O(@XDRVDATA@(FROM)) Q:FROM'>0 D "RTN","XDRDVAL1",109,0) . . S TO=$O(@ARRAY@(FROM,0)) "RTN","XDRDVAL1",110,0) . . S FRVARBL=$O(@ARRAY@(FROM,TO,0)) I FRVARBL="" S FRVARBL=0 "RTN","XDRDVAL1",111,0) . . S TOVARBL=$O(@ARRAY@(FROM,TO,FRVARBL,0)) I TOVARBL="" S TOVARBL=0 "RTN","XDRDVAL1",112,0) . . I TOVARBL=0 S DUPIEN=+$G(@ARRAY@(FROM,TO)) "RTN","XDRDVAL1",113,0) . . E S DUPIEN=+$G(@ARRAY@(FROM,TO,FRVARBL,TOVARBL)) "RTN","XDRDVAL1",114,0) . . W !! "RTN","XDRDVAL1",115,0) . . I DUPIEN>0 D ; HAS AN ENTRY IN FILE 15 "RTN","XDRDVAL1",116,0) . . . N X,DIRECT,ORIGTO,ORIGFR "RTN","XDRDVAL1",117,0) . . . S X=^VA(15,DUPIEN,0) S DIRECT=$P(X,U,4) "RTN","XDRDVAL1",118,0) . . . I DIRECT=1 S ORIGFR=+X,ORIGTO=+$P(X,U,2) "RTN","XDRDVAL1",119,0) . . . E S ORIGFR=+$P(X,U,2),ORIGTO=+X "RTN","XDRDVAL1",120,0) . . . ; "RTN","XDRDVAL1",121,0) . . . I ORIGTO'=TO D ; THE ENTRY WAS REPOINTED TO THE CURRENT 'TO' ENTRY "RTN","XDRDVAL1",122,0) . . . . D PAIRID(FILE,ORIGFR,ORIGTO,DUPIEN) ; OUPUT ORIGINAL PAIR ID "RTN","XDRDVAL1",123,0) . . . . W !," ******** REDIRECTED TO" "RTN","XDRDVAL1",124,0) . . . . Q "RTN","XDRDVAL1",125,0) . . . Q "RTN","XDRDVAL1",126,0) . . ; "RTN","XDRDVAL1",127,0) . . D PAIROUT(FILE,FROM,TO,DUPIEN,$NA(@XDRVDATA@(FROM,"VAL"))) ; OUTPUT PAIR ID AND PROBLEMS "RTN","XDRDVAL1",128,0) . . ; "RTN","XDRDVAL1",129,0) . . D RMOVPAIR(FROM,TO,DUPIEN,ARRAY) ; REMOVE PAIR FROM MERGE - NOT FROM FILE 15 "RTN","XDRDVAL1",130,0) . . Q "RTN","XDRDVAL1",131,0) . U IO D ^%ZISC "RTN","XDRDVAL1",132,0) . I $G(MERGEFLG)>0 D "RTN","XDRDVAL1",133,0) . . N XMSUB,XMTEXT "RTN","XDRDVAL1",134,0) . . S XMSUB="MERGE PAIRS EXCLUDED DUE TO DATA PROBLEMS" "RTN","XDRDVAL1",135,0) . . S XMTEXT="^TMP(""DDB"",$J," "RTN","XDRDVAL1",136,0) . . D SENDMESG(XMSUB,XMTEXT) "RTN","XDRDVAL1",137,0) . . Q "RTN","XDRDVAL1",138,0) . Q "RTN","XDRDVAL1",139,0) Q "RTN","XDRDVAL1",140,0) ; "RTN","XDRDVAL1",141,0) SENDMESG(XMSUB,XMTEXT) ; "RTN","XDRDVAL1",142,0) N XMY,XDRGRP,XDRGRPN,XMDUZ,XMCHAN "RTN","XDRDVAL1",143,0) S XDRGRP=$$GET1^DIQ(15.1,"2,",.29,"I") "RTN","XDRDVAL1",144,0) S:XDRGRP>0 XDRGRPN=$$GET1^DIQ(3.8,XDRGRP,.01) "RTN","XDRDVAL1",145,0) S XDRGRP=$S(XDRGRP>0:"G."_XDRGRPN,1:"") "RTN","XDRDVAL1",146,0) S:XDRGRP'="" XMY(XDRGRP)="" "RTN","XDRDVAL1",147,0) S:XDRGRP="" XMY(.5)="" ;If no mail grp found, send msg to postmaster "RTN","XDRDVAL1",148,0) S XMDUZ=.5,XMCHAN=1 "RTN","XDRDVAL1",149,0) D ^XMD "RTN","XDRDVAL1",150,0) Q "RTN","XDRDVAL1",151,0) ; "RTN","XDRDVAL1",152,0) RMOVPAIR(FROM,TO,IEN,ARRAY) ; "RTN","XDRDVAL1",153,0) N X,MERGE,IENS,XXX,DA,DIK "RTN","XDRDVAL1",154,0) S JLICNT=$G(JLICNT)+1,^TMP("XDRRMOV",JLICNT,$H,1)=FROM_U_TO_U_IEN_U_ARRAY "RTN","XDRDVAL1",155,0) I IEN>0 D ; ENTRY IS IN FILE 15 "RTN","XDRDVAL1",156,0) . S IENS=IEN_"," "RTN","XDRDVAL1",157,0) . S X=^VA(15,IEN,0),MERGE=$P(X,U,20) ; GET MERGE NUMBER "RTN","XDRDVAL1",158,0) . S JLICNT=$G(JLICNT)+1,^TMP("XDRRMOV",JLICNT,$H,2)=MERGE_U_X "RTN","XDRDVAL1",159,0) . S XXX(15,IENS,.05)=1 ; SET MERGE STATUS BACK TO READY "RTN","XDRDVAL1",160,0) . S XXX(15,IENS,.13)=0 ; REMOVE APPROVAL FOR MERGE "RTN","XDRDVAL1",161,0) . S XXX(15,IENS,.14)="@" ; AND INDICATOR OF WHO APPROVED "RTN","XDRDVAL1",162,0) . S XXX(15,IENS,.2)="@" ; REMOVE MERGE PROCESS "RTN","XDRDVAL1",163,0) . D FILE^DIE("","XXX") "RTN","XDRDVAL1",164,0) . ; "RTN","XDRDVAL1",165,0) . ;S IENS=","_MERGE_",",DA=$$FIND1^DIC(15.22,IENS,"",FROM) ; GET IEN FOR THIS ENTRY IN "RTN","XDRDVAL1",166,0) . F DA=0:0 S DA=$O(^VA(15.2,MERGE,2,DA)) Q:DA'>0 I $P(^(DA,0),U,3)=IEN Q "RTN","XDRDVAL1",167,0) . I DA>0 S DIK="^VA(15.2,"_MERGE_",2,",DA(1)=MERGE D ^DIK ; LIST OF PAIRS, AND DELETE IT "RTN","XDRDVAL1",168,0) ; "RTN","XDRDVAL1",169,0) K @ARRAY@(FROM,TO) ; AND KILL THE ACTUAL ENTRY IN ARRAY "RTN","XDRDVAL1",170,0) Q "RTN","XDRDVAL1",171,0) ; "RTN","XDRDVAL1",172,0) PAIROUT(FILE,FROM,TO,IEN,DATA) ; "RTN","XDRDVAL1",173,0) D PAIRID(FILE,FROM,TO,IEN) "RTN","XDRDVAL1",174,0) D LISTPROB^XDRDVAL1(DATA) "RTN","XDRDVAL1",175,0) Q "RTN","XDRDVAL1",176,0) ; "RTN","XDRDVAL1",177,0) PAIRID(FILE,FROM,TO,IEN) ; "RTN","XDRDVAL1",178,0) N FRNAME,FRSSN,TONAME,TOSSN,FILEDIC "RTN","XDRDVAL1",179,0) S FILEDIC=^DIC(FILE,0,"GL") "RTN","XDRDVAL1",180,0) S FRNAME=$P($G(@(FILEDIC_FROM_",0)")),U),FRSSN=$P($G(^(0)),U,9),FRNAME=$$STRIP(FRNAME) "RTN","XDRDVAL1",181,0) S TONAME=$P($G(@(FILEDIC_TO_",0)")),U),TOSSN=$P($G(^(0)),U,9),TONAME=$$STRIP(TONAME) "RTN","XDRDVAL1",182,0) W !,"FROM: DFN=",FROM," ",FRNAME W:FILE=2!(FILE=200) " [",FRSSN,"]" I IEN>0 W " FILE 15 IEN: ",IEN "RTN","XDRDVAL1",183,0) W !,"TO: DFN=",TO," ",TONAME W:FILE=2!(FILE=200) " [",TOSSN,"]" "RTN","XDRDVAL1",184,0) Q "RTN","XDRDVAL1",185,0) ; "RTN","XDRDVAL1",186,0) STRIP(X1) ; "RTN","XDRDVAL1",187,0) F Q:X1'["MERGING INTO" S X1=$P($P(X1,"(",2,10),")",1,$L(X1,")")-1) "RTN","XDRDVAL1",188,0) Q X1 "RTN","XDRDVAL2") 0^16^B43207170 "RTN","XDRDVAL2",1,0) XDRDVAL2 ;SF-IRMFO.SEA/JLI - IDENTIFY FIELDS THAT NEED CHECKING FOR MERGE ;02/07/2000 09:55 [ 12/18/2003 5:03 PM ] "RTN","XDRDVAL2",2,0) ;;7.3;TOOLKIT;**23,34,36,42,45,77,1002,1003**;Apr 25, 1995 "RTN","XDRDVAL2",3,0) ;IHS/OIT/LJF 04/26/2007 PATCH 1003 bypass data checks on indian vs. tribe quantum "RTN","XDRDVAL2",4,0) ; (if checked separately, they might not pass input transform) "RTN","XDRDVAL2",5,0) ;; "RTN","XDRDVAL2",6,0) Q "RTN","XDRDVAL2",7,0) ; "RTN","XDRDVAL2",8,0) CHKMERG(FILENUM,IENFROM,IENTO,ARRAY) ; "RTN","XDRDVAL2",9,0) N XDRDVALF "RTN","XDRDVAL2",10,0) S XDRDVALF=1 "RTN","XDRDVAL2",11,0) S FILE=FILENUM D SETUP^XDRMERG(2) "RTN","XDRDVAL2",12,0) D CHKFMERG(FILE,IENFROM,IENTO,ARRAY) "RTN","XDRDVAL2",13,0) S XGLOB="" F S XGLOB=$O(^TMP($J,"XGLOB",XGLOB)) Q:XGLOB="" D "RTN","XDRDVAL2",14,0) . I $P($G(^TMP($J,"XGLOB",XGLOB,0,1)),U,3)="DINUM" S F=$P(^(1),U) D CHKFMERG(F,IENFROM,IENTO,ARRAY) "RTN","XDRDVAL2",15,0) Q "RTN","XDRDVAL2",16,0) ; "RTN","XDRDVAL2",17,0) CHKFMERG(XFILNO,IENFROM,IENTO,LOCATION) ; CHECK VALIDITY FOR MERGE OF TWO ENTRIES IN FILE "RTN","XDRDVAL2",18,0) N F,FILE,FILENUM,XGLOB,NODE,NODE1,NODE2,NODEA,SFILE,XDRFROM,XDRTO,NODEA,VALUE,XVALUE,XDRXX,NODEB,DIK,DA,I,Y,VREF,XNN,IENTOSTR,DFN,XDRZZ "RTN","XDRDVAL2",19,0) N XDRAA ; DEBUG STATEMENT "RTN","XDRDVAL2",20,0) ; "RTN","XDRDVAL2",21,0) S XDRDIC=$G(^DIC(XFILNO,0,"GL")) Q:XDRDIC="" "RTN","XDRDVAL2",22,0) S IENTOSTR=IENTO_"," "RTN","XDRDVAL2",23,0) S DFN=IENTO "RTN","XDRDVAL2",24,0) ; "RTN","XDRDVAL2",25,0) ; CHECK FOR BROKEN LR NODES IF PATIENT FILE "RTN","XDRDVAL2",26,0) ; "RTN","XDRDVAL2",27,0) ; FOLLOWING LINE MODIFIED TO INCLUDE IDENTIFIED PROBLEMS IN OUTPUT - JLI 03/23/99 "RTN","XDRDVAL2",28,0) I XFILNO=2 F I=IENFROM,IENTO S J=$G(^DPT(I,"LR")) I J>0,($P(^LR(J,0),U,2)'=2)!($P(^LR(J,0),U,3)'=I) S @LOCATION@(2,(I_","),63,"INVALID")="Broken ""LR"" node pointers for PATIENT file and LAB DATA FILE - DFN="_I_" LRFN="_J "RTN","XDRDVAL2",29,0) ; "RTN","XDRDVAL2",30,0) ; NOW MERGE DATA GOING NODE BY NODE "RTN","XDRDVAL2",31,0) ; "RTN","XDRDVAL2",32,0) S NODE="" "RTN","XDRDVAL2",33,0) F D Q:NODE="" "RTN","XDRDVAL2",34,0) . S NODE1=$O(@(XDRDIC_IENFROM_","""_NODE_""")")) "RTN","XDRDVAL2",35,0) . I NODE1="" S NODE="" Q ; NOTHING MORE TO MOVE OVER "RTN","XDRDVAL2",36,0) . S NODE2=$O(@(XDRDIC_IENTO_","""_NODE_""")")) "RTN","XDRDVAL2",37,0) . I NODE2'="",NODE1]NODE2 S NODE=NODE2 Q ; NODE ON TO, BUT NOT ON FROM - GO TO NEXT "RTN","XDRDVAL2",38,0) . S NODE=NODE1 "RTN","XDRDVAL2",39,0) . I $D(@(XDRDIC_IENFROM_","""_NODE_""")"))=1 D Q ; SINGLE NODE, MERGE DATA "RTN","XDRDVAL2",40,0) . . I NODE2]NODE1!(NODE2="") D Q ; MISSING NODE, JUST MOVE IT OVER "RTN","XDRDVAL2",41,0) . . . N XDRXX,FLD,N,J "RTN","XDRDVAL2",42,0) . . . 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 "RTN","XDRDVAL2",43,0) . . . . 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 "RTN","XDRDVAL2",44,0) . . . . I X>0 D "RTN","XDRDVAL2",45,0) . . . . . S XDRXX(XFILNO,IENTOSTR,FLD)=$$GETEXT(XDRDIC,IENFROM,XFILNO,FLD) "RTN","XDRDVAL2",46,0) . . . I $D(XDRXX) D CHEKFDA("XDRXX",LOCATION) "RTN","XDRDVAL2",47,0) . . I $D(@(XDRDIC_IENTO_","""_NODE_""")"))>1 Q ; MISMATCH SKIP "RTN","XDRDVAL2",48,0) . . N XDRXX,FLD "RTN","XDRDVAL2",49,0) . . S X1=@(XDRDIC_IENFROM_","""_NODE_""")") "RTN","XDRDVAL2",50,0) . . S (X2,X3)=@(XDRDIC_IENTO_","""_NODE_""")") "RTN","XDRDVAL2",51,0) . . F XDRI=1:1 Q:X1="" S X=$P(X1,U),X1=$P(X1,U,2,999) I X'="" D "RTN","XDRDVAL2",52,0) . . . S Y=$P(X2,U,XDRI) "RTN","XDRDVAL2",53,0) . . . I Y="" D "RTN","XDRDVAL2",54,0) . . . . S $P(X2,U,XDRI)=X "RTN","XDRDVAL2",55,0) . . . . S FLD=$O(^DD(XFILNO,"GL",NODE,XDRI,0)) S JXFLD=FLD "RTN","XDRDVAL2",56,0) . . . . I FLD>0,$O(^DD(XFILNO,FLD,1,0))>0 S XDRXX(XFILNO,IENTOSTR,FLD)=$$GETEXT(XDRDIC,IENFROM,XFILNO,FLD) "RTN","XDRDVAL2",57,0) . . I X2'=X3 D "RTN","XDRDVAL2",58,0) . . . I $D(XDRXX) D "RTN","XDRDVAL2",59,0) . . . . N X2 D CHEKFDA("XDRXX",LOCATION) "RTN","XDRDVAL2",60,0) . ; "RTN","XDRDVAL2",61,0) . ; THE FOLLOWING HANDLES NODES THAT HAVE MULTIPLES "RTN","XDRDVAL2",62,0) . ; "RTN","XDRDVAL2",63,0) . S XDRFROM=XDRDIC_IENFROM_","""_NODE_"""," "RTN","XDRDVAL2",64,0) . S XDRTO=XDRDIC_IENTO_","""_NODE_"""," "RTN","XDRDVAL2",65,0) . I NODE="DIS",XFILNO=2 Q "RTN","XDRDVAL2",66,0) . S IENTOSTR=IENTO_"," "RTN","XDRDVAL2",67,0) . D CHKSUBS(XDRFROM,XDRTO,IENTOSTR,IENTO) "RTN","XDRDVAL2",68,0) Q "RTN","XDRDVAL2",69,0) ; "RTN","XDRDVAL2",70,0) CHKSUBS(XDRFROM,XDRTO,IENTOSTR,XDRDASEQ) ; "RTN","XDRDVAL2",71,0) N NODEA,SFILE,VALUE,XVALUE,XDRXX,XDRYY,YVALUE,XENTOSTR "RTN","XDRDVAL2",72,0) N XDRAA,XDRZZ ; DEBUG STATEMENT "RTN","XDRDVAL2",73,0) S SFILE=+$P($G(@(XDRFROM_"0)")),U,2) "RTN","XDRDVAL2",74,0) I SFILE'>0 Q ; NO FILE NUMBER, NOT FILE MANAGER COMPATIBLE "RTN","XDRDVAL2",75,0) I $P($G(^DD(SFILE,.01,0)),U,2)["W" Q ; HANDLE WORD PROCESSING FIELDS "RTN","XDRDVAL2",76,0) F NODEA=0:0 S NODEA=$O(@(XDRFROM_NODEA_")")) Q:NODEA'>0 D "RTN","XDRDVAL2",77,0) . S VALUE=$P($G(@(XDRFROM_NODEA_",0)")),U) ; GET .01 VALUE "RTN","XDRDVAL2",78,0) . N XDRDT S XDRDT=^DD(SFILE,.01,0) "RTN","XDRDVAL2",79,0) . I $P(XDRDT,U,2)["D" S XDRDT=$P(XDRDT,U,5,999),XDRDINUM=$S(XDRDT["DINUM":1,1:0) I XDRDINUM S XDRDT=0 D DINUMDAT Q:XDRDT ; HANDLE DINUMED DATES BY SIMPLY MOVING THEM "RTN","XDRDVAL2",80,0) . S YVALUE=0,XVALUE=0 I $D(^DD(SFILE,.001,0)) S YVALUE=NODEA I $D(@(XDRTO_NODEA_")")) S XVALUE=YVALUE "RTN","XDRDVAL2",81,0) . I XVALUE=0,$P(^DD(SFILE,.01,0),U,5,99)["DINUM",$D(@(XDRTO_NODEA_")")) S XVALUE=NODEA "RTN","XDRDVAL2",82,0) . I XVALUE=0 S XVALUE=+$$FIND1^DIC(SFILE,(","_IENTOSTR),"Q",VALUE) ; FIND CURRENT ENTRY NUMBER, IF PRESENT "RTN","XDRDVAL2",83,0) . I XVALUE>0 D Q ; SUBFILE EXISTS IN IENTO, CHECK FOR LOWER SUBFILES "RTN","XDRDVAL2",84,0) . . N X,X1,NODE,NEWFROM,NEWTO,NEWTOIEN "RTN","XDRDVAL2",85,0) . . S NODE="" "RTN","XDRDVAL2",86,0) . . F S NODE=$O(@(XDRFROM_NODEA_","""_NODE_""")")) Q:NODE="" D "RTN","XDRDVAL2",87,0) . . . I $D(@(XDRFROM_NODEA_","""_NODE_""")"))'>1 Q "RTN","XDRDVAL2",88,0) . . . S NEWFROM=XDRFROM_NODEA_","""_NODE_"""," "RTN","XDRDVAL2",89,0) . . . S NEWTO=XDRTO_XVALUE_","""_NODE_"""," "RTN","XDRDVAL2",90,0) . . . S NEWTOIEN=XVALUE_","_IENTOSTR "RTN","XDRDVAL2",91,0) . . . D CHKSUBS(NEWFROM,NEWTO,NEWTOIEN,(XVALUE_U_XDRDASEQ)) "RTN","XDRDVAL2",92,0) . K XDRYY I YVALUE>0 S XDRYY(1)=YVALUE "RTN","XDRDVAL2",93,0) . S XENTOSTR="+1,"_IENTOSTR "RTN","XDRDVAL2",94,0) . S XDRFILTY=$P($G(^DD(SFILE,.01,0)),U,2) "RTN","XDRDVAL2",95,0) . ;I XDRFILTY["P",SFILE'=2.011 S VALUE="`"_VALUE "RTN","XDRDVAL2",96,0) . ;I XDRFILTY["V" D "RTN","XDRDVAL2",97,0) . ;. N Y S Y=$P(VALUE,";",2) Q:Y="" "RTN","XDRDVAL2",98,0) . ;. S Y=$P($G(@("^"_Y_"0)")),U) Q:Y="" "RTN","XDRDVAL2",99,0) . ;. S VALUE=Y_".`"_(+VALUE) "RTN","XDRDVAL2",100,0) . ;. Q "RTN","XDRDVAL2",101,0) . I (XDRFILTY["P")!(XDRFILTY["V")!(XDRFILTY["D") Q ; HANDLE AS INTERNAL VALUES ; JLI 9-1-99 "RTN","XDRDVAL2",102,0) . I SFILE=2.011 Q ; SPECIAL HANDLING ; JLI 9-1-99 "RTN","XDRDVAL2",103,0) . S XDRXX(SFILE,XENTOSTR,.01)=$$GETEXT(XDRFROM,NODEA,SFILE,.01) "RTN","XDRDVAL2",104,0) . D CHEKFDA("XDRXX",LOCATION) "RTN","XDRDVAL2",105,0) . F XDRID=0:0 S XDRID=$O(^DD(SFILE,0,"ID",XDRID)) Q:XDRID'>0 D "RTN","XDRDVAL2",106,0) . . Q:$P(^DD(SFILE,XDRID,0),U,2)'["R" "RTN","XDRDVAL2",107,0) . . S VALUE=$$GETEXT(XDRFROM,NODEA,SFILE,XDRID) "RTN","XDRDVAL2",108,0) . . I VALUE="" W !,"PROBLEM WITH IDENTIFIER FILE=",SFILE," IENSTR=",XENTOSTR," FIELD=",XDRID "RTN","XDRDVAL2",109,0) Q "RTN","XDRDVAL2",110,0) ; "RTN","XDRDVAL2",111,0) GETEXT(DICA,DA,FILNUM,FIELD,TYPE) ; GET EXTERNAL VALUE FOR .01 FIELD "RTN","XDRDVAL2",112,0) N DIC,DIQ,DR,XDRQ,TEMP "RTN","XDRDVAL2",113,0) I $G(FIELD)="" S FIELD=.01 "RTN","XDRDVAL2",114,0) I $G(TYPE)="" S TYPE="E" "RTN","XDRDVAL2",115,0) S DIC=DICA,DIC("P")=FILNUM,DR=FIELD,DIQ="XDRQ",DIQ(0)="I" "RTN","XDRDVAL2",116,0) D EN^DIQ1 "RTN","XDRDVAL2",117,0) S TEMP=$G(XDRQ(FILNUM,DA,FIELD,"I")) I TEMP="" Q "" "RTN","XDRDVAL2",118,0) S DIC=DICA,DIC("P")=FILNUM,DR=FIELD,DIQ="XDRQ",DIQ(0)="E" K XDRQ "RTN","XDRDVAL2",119,0) D EN^DIQ1 "RTN","XDRDVAL2",120,0) Q TEMP_U_$G(XDRQ(FILNUM,DA,FIELD,"E")) "RTN","XDRDVAL2",121,0) Q $G(XDRQ(FILNUM,DA,FIELD,TYPE)) "RTN","XDRDVAL2",122,0) ; "RTN","XDRDVAL2",123,0) DINUMDAT ; PROCESS ENTRIES WITH SAMPLE DATE/TIMES WITH SECONDS, NEEDS DINUM "RTN","XDRDVAL2",124,0) I $D(@(XDRTO_NODEA_")")) Q "RTN","XDRDVAL2",125,0) S XDRDT=1 "RTN","XDRDVAL2",126,0) Q "RTN","XDRDVAL2",127,0) ; "RTN","XDRDVAL2",128,0) CHEKFDA(FDA,LOCATION) ; "RTN","XDRDVAL2",129,0) N FILE,IENS,FIELD,VAL,VALEXT "RTN","XDRDVAL2",130,0) F FILE=0:0 S FILE=$O(@FDA@(FILE)) Q:FILE'>0 D "RTN","XDRDVAL2",131,0) . S IENS="" F S IENS=$O(@FDA@(FILE,IENS)) Q:IENS="" D "RTN","XDRDVAL2",132,0) . . F FIELD=0:0 S FIELD=$O(@FDA@(FILE,IENS,FIELD)) Q:FIELD'>0 D "RTN","XDRDVAL2",133,0) . . . S VAL=@FDA@(FILE,IENS,FIELD),VALEXT=$P(VAL,U,2),VAL=$P(VAL,U) I VAL="" Q "RTN","XDRDVAL2",134,0) . . . I FILE=2,FIELD=.09 Q ; SSN NUMBER IS ENTERED AS INTERNAL "RTN","XDRDVAL2",135,0) . . . I FILE=2,$P(^DD(FILE,FIELD,0),U,5,99)["DGLOCK2" Q ; no NOK check "RTN","XDRDVAL2",136,0) . . . I FILE=70.03,FIELD=.01 Q ; TIES UP EVERYTHING... ; JLI 9-1-99 "RTN","XDRDVAL2",137,0) . . . I FILE=354,FIELD=.03!(FIELD=.05) Q ; THIS ONE IS TOUGH, DON'T WORRY ABOUT IT "RTN","XDRDVAL2",138,0) . . . I FILE=2,FIELD=63 Q ; LAB DATA POINTER HAS SPECIAL PROCESSING "RTN","XDRDVAL2",139,0) . . . I FILE=161,FIELD=.5 Q ; FB has special processing, JDS XT*7.3*77, 8/5/03 "RTN","XDRDVAL2",140,0) . . . ; "RTN","XDRDVAL2",141,0) . . . ;Bypass checks on indian vs. tribe quantum ;IHS/OIT/LJF 04/26/2007 PATCH 1003 "RTN","XDRDVAL2",142,0) . . . I FILE=9000001,FIELD=1110 Q "RTN","XDRDVAL2",143,0) . . . I FILE=9000001,FIELD=1109 Q "RTN","XDRDVAL2",144,0) . . . ; "RTN","XDRDVAL2",145,0) . . . S MESGROOT=$NA(^TMP($J,"MESG")) K @MESGROOT "RTN","XDRDVAL2",146,0) . . . D CHKVALID^XDRDVAL(MESGROOT,FILE,IENS,FIELD,VALEXT,VAL) "RTN","XDRDVAL2",147,0) . . . I $D(@MESGROOT) M @LOCATION=@MESGROOT K @MESGROOT "RTN","XDRDVAL2",148,0) . . . Q "RTN","XDRDVAL2",149,0) . . Q "RTN","XDRDVAL2",150,0) . Q "RTN","XDRDVAL2",151,0) Q "RTN","XDRMERG") 0^7^B78297304 "RTN","XDRMERG",1,0) XDRMERG ;SF-IRMFO.SEA/JLI - TENATIVE UPDATE POINTER NODES ;04/26/2001 08:17 [ 12/18/2003 5:02 PM ] "RTN","XDRMERG",2,0) ;;7.3;TOOLKIT;**23,34,38,44,45,49,54,73,1002,1003**;Apr 03, 1995 "RTN","XDRMERG",3,0) ;IHS/OIT/LJF 11/30/2006 PATCH 1003 added call to IHS subroutine for end of merge steps "RTN","XDRMERG",4,0) ;; "RTN","XDRMERG",5,0) Q "RTN","XDRMERG",6,0) ; "RTN","XDRMERG",7,0) ; FILE is the file NUMBER of the file in which the pointed to fields "RTN","XDRMERG",8,0) ; are being merged (e.g., 2 or 200) "RTN","XDRMERG",9,0) ; FROM is a root under which paired arrays of FROM and TO ien values "RTN","XDRMERG",10,0) ; may be found. If internal entry number 275 were being merged "RTN","XDRMERG",11,0) ; merged into ien 75, and the array name to be used was XX, "RTN","XDRMERG",12,0) ; the data would be stored as ARRYNAME(FROMIEN,TOIEN) OR "RTN","XDRMERG",13,0) ; XX(275,75). The call would be "RTN","XDRMERG",14,0) ; "RTN","XDRMERG",15,0) ; D ENTRY^XDRMERG(2,"XX") "RTN","XDRMERG",16,0) ; "RTN","XDRMERG",17,0) ; Any number of pairs may be in the From/To array, and the higher "RTN","XDRMERG",18,0) ; this number, the more efficient the conversion will be. "RTN","XDRMERG",19,0) ; "RTN","XDRMERG",20,0) EN(FILE,FROM) ; "RTN","XDRMERG",21,0) D RESTART(FILE,FROM) "RTN","XDRMERG",22,0) Q "RTN","XDRMERG",23,0) ; "RTN","XDRMERG",24,0) ; The restart entry point permits the user to specify locations for "RTN","XDRMERG",25,0) ; continuation of a previously interrupted merge process. The "RTN","XDRMERG",26,0) ; first two arguments are as indicated above for the EN entry point. "RTN","XDRMERG",27,0) ; The next three arguments are optional, and should only be set for "RTN","XDRMERG",28,0) ; a restart of a merge which was interrupted in progress. Even "RTN","XDRMERG",29,0) ; then these values could be omitted with minimal impact on the "RTN","XDRMERG",30,0) ; first two phases of the merge operation. "RTN","XDRMERG",31,0) ; "RTN","XDRMERG",32,0) ; XDRTYPE is an indicator of the phase of the merge process "RTN","XDRMERG",33,0) ; "RTN","XDRMERG",34,0) ; SFILE indicates the pointer file number from which processing "RTN","XDRMERG",35,0) ; should be continued. "RTN","XDRMERG",36,0) ; "RTN","XDRMERG",37,0) ; SENTRY indicates the internal entry number within SFILE from which "RTN","XDRMERG",38,0) ; processing should be continued "RTN","XDRMERG",39,0) ; "RTN","XDRMERG",40,0) RESTART(FILE,FROM,XDRTYPE,SFILE,SENTRY) ; "RTN","XDRMERG",41,0) ; "RTN","XDRMERG",42,0) N XBASIS,CURRTYPE,CURRFIL,XBASE,X,XDRXT,XDRH1,XDRH2,XDRH3,XTYPE "RTN","XDRMERG",43,0) N XDRFGLOB,VAFCA08,XDRDVALF,XDRFILE,DIQUIET,RGRSICN "RTN","XDRMERG",44,0) S VAFCA08=1,XDRDVALF=1,DIQUIET=1,RGRSICN=1 "RTN","XDRMERG",45,0) ; "RTN","XDRMERG",46,0) S XDRFGLOB=$G(^DIC(FILE,0,"GL")) Q:XDRFGLOB="" "RTN","XDRMERG",47,0) ; "RTN","XDRMERG",48,0) I $G(XDRTYPE)<2 D CHKFROM^XDRMERG2(FROM,FILE) ; check for self-pointers, circular, etc. "RTN","XDRMERG",49,0) ; "RTN","XDRMERG",50,0) S XDRGID=$O(@FROM@("")) I XDRGID="" Q "RTN","XDRMERG",51,0) S XDRGID=FILE_U_XDRGID_U_$O(@FROM@(XDRGID,"")) "RTN","XDRMERG",52,0) S ^XTMP("XDRSTAT",0)=$$FMADD^XLFDT(DT,30)_U_DT "RTN","XDRMERG",53,0) S ^XTMP("XDRSTAT",XDRGID,"START",$J)=$$NOW^XLFDT() "RTN","XDRMERG",54,0) ; "RTN","XDRMERG",55,0) I $G(XDRTYPE)<2 D "RTN","XDRMERG",56,0) . S XDRTYPE=1 "RTN","XDRMERG",57,0) . D DOMAIN^XDRMERG2(FILE,FROM) "RTN","XDRMERG",58,0) . S XDRTYPE=2 "RTN","XDRMERG",59,0) I $D(ZTSTOP) Q "RTN","XDRMERG",60,0) ; "RTN","XDRMERG",61,0) LOOP ; "RTN","XDRMERG",62,0) I $G(SFILE)="" S SFILE=0 "RTN","XDRMERG",63,0) I $G(SENTRY)="" S SENTRY=0 "RTN","XDRMERG",64,0) S CURRTYPE=XDRTYPE "RTN","XDRMERG",65,0) ; "RTN","XDRMERG",66,0) D SETUP(XDRTYPE) ; identify files and fields to be processed "RTN","XDRMERG",67,0) ; "RTN","XDRMERG",68,0) F CURRFIL=SFILE-.0000001:0 Q:$D(ZTSTOP) S CURRFIL=$O(^TMP($J,"XFIL",CURRFIL)) Q:CURRFIL'>0 D "RTN","XDRMERG",69,0) . I CURRFIL=1 Q "RTN","XDRMERG",70,0) . I CURRFIL=15!(CURRFIL=15.4) Q "RTN","XDRMERG",71,0) . I FILE=63,CURRFIL=2 Q "RTN","XDRMERG",72,0) . ; "RTN","XDRMERG",73,0) . I $D(XDRTHRED)>1,'$D(XDRTHRED(CURRFIL)) Q "RTN","XDRMERG",74,0) . ; "RTN","XDRMERG",75,0) . ; "RTN","XDRMERG",76,0) . S XBASIS=^TMP($J,"XFIL",CURRFIL) "RTN","XDRMERG",77,0) . I '$D(^TMP($J,"XGLOB",XBASIS)) D I X'[XBASIS Q "RTN","XDRMERG",78,0) . . S X=$O(^TMP($J,"XGLOB",XBASIS)) "RTN","XDRMERG",79,0) . S XDRXT=$$NOW^XLFDT() "RTN","XDRMERG",80,0) . I $D(XDRFDA) D I 1 "RTN","XDRMERG",81,0) . . S ^VA(15.2,XDRFDA,3,XDRFDA1,1)=XDRXT_U_CURRTYPE_U_CURRFIL_U "RTN","XDRMERG",82,0) . E D "RTN","XDRMERG",83,0) . . S ^XTMP("XDRSTAT",XDRGID,"TIME",$J)=XDRXT_U_CURRTYPE_U_CURRFIL_U "RTN","XDRMERG",84,0) . S XDRH1=XDRXT "RTN","XDRMERG",85,0) . S ^XTMP("XDRSTAT",XDRGID,"FIL",XDRTYPE,CURRFIL)=XDRH1 "RTN","XDRMERG",86,0) . S XTYPE=$$TYPE^XDRMERG1(XBASIS),XBAS=XBASIS D Q:$D(ZTSTOP) "RTN","XDRMERG",87,0) . . I XDRTYPE=2 D Q "RTN","XDRMERG",88,0) LOOP2 . . . I XTYPE="DINUM" D DINUM^XDRMERG2(XBAS,XBAS,"") "RTN","XDRMERG",89,0) . . . I XTYPE'="" D XREFS^XDRMERG2(XBAS,XBAS,"") ; LET DINUM IN TO CHECK FOR ANY OTHER XREFS UNDER XBAS "RTN","XDRMERG",90,0) . . . S XBAS=$O(^TMP($J,"XGLOB",XBAS)) I XBAS[XBASIS S XTYPE=$$TYPE^XDRMERG1(XBAS) G LOOP2 "RTN","XDRMERG",91,0) . . . Q "RTN","XDRMERG",92,0) . . D CHASE^XDRMERG1(XBASIS,XBASIS,"") "RTN","XDRMERG",93,0) . S XDRH2=$$NOW^XLFDT() "RTN","XDRMERG",94,0) . S XDRH3=$$FMDIFF^XLFDT(XDRH2,XDRH1,2) "RTN","XDRMERG",95,0) . S ^XTMP("XDRSTAT",XDRGID,"FIL",XDRTYPE,CURRFIL)=XDRH1_U_XDRH2_U_XDRH3 "RTN","XDRMERG",96,0) ; "RTN","XDRMERG",97,0) ; hook to stop special xref clean-up after phase II "RTN","XDRMERG",98,0) I $D(XDRFDA),$P(^VA(15.2,XDRFDA,0),U)="FIX XREF PROCESS" Q "RTN","XDRMERG",99,0) I '$D(ZTSTOP),XDRTYPE=2 D G LOOP ; NOW DO THE ONES WE HAVE TO HUNT "RTN","XDRMERG",100,0) . S XDRTYPE=3 "RTN","XDRMERG",101,0) . S (SFILE,SENTRY)=0 "RTN","XDRMERG",102,0) . K XDRTHRD "RTN","XDRMERG",103,0) . N I,MAXTHRED,THREADS S MAXTHRED=$P($G(^VA(15.1,FILE,1)),U),THREADS=$P($G(^(1)),U,2) S:'$D(XDRFDA) MAXTHRED=1 Q:MAXTHRED'>1 D SETUP(XDRTYPE) "RTN","XDRMERG",104,0) . F I=1:1:MAXTHRED S XDRTHRD=$P(THREADS,";",I) Q:XDRTHRD'>0 D "RTN","XDRMERG",105,0) . . S XDRTHRD(I,XDRTHRD)="" K ^TMP($J,"XFIL",XDRTHRD) "RTN","XDRMERG",106,0) . S XDRTHRD=0 F S I=$S(I'0 S XDRTHRD(I,XDRTHRD)="" K ^TMP($J,"XFIL",XDRTHRD) "RTN","XDRMERG",107,0) . F XDRTHRD=2:1:MAXTHRED,1 D "RTN","XDRMERG",108,0) . . K XDRTHRED M XDRTHRED=XDRTHRD(XDRTHRD) S XDRTHRED=XDRTHRD "RTN","XDRMERG",109,0) . . I XDRTHRD=1 D Q "RTN","XDRMERG",110,0) . . . F XDRTHRED=0:0 S XDRTHRED=$O(XDRTHRED(XDRTHRED)) Q:XDRTHRED'>0 S ^VA(15.2,XDRFDA,3,XDRFDA1,2,XDRTHRED,0)=XDRTHRED "RTN","XDRMERG",111,0) . . S ZTRTN="DQTHREAD^XDRMERG0",ZTIO="",ZTDTH=$$NOW^XLFDT() "RTN","XDRMERG",112,0) . . S ZTDESC="MERGE THREAD FOR "_XDRTHRD,ZTSAVE("XDRFDA")="" "RTN","XDRMERG",113,0) . . S ZTSAVE("XDRTHRED")="",ZTSAVE("XDRTHRED(")="",ZTSAVE("XDRFILE")=FILE "RTN","XDRMERG",114,0) . . D ^%ZTLOAD "RTN","XDRMERG",115,0) . S XDRTHRED="" "RTN","XDRMERG",116,0) ; "RTN","XDRMERG",117,0) I $D(ZTSTOP) S ^XTMP("XDRSTAT",XDRGID,"HALT",$J)=$$NOW^XLFDT() "RTN","XDRMERG",118,0) E I '$D(XDRFDA) D "RTN","XDRMERG",119,0) . D CLOSEIT "RTN","XDRMERG",120,0) . S ^XTMP("XDRSTAT",XDRGID,"DONE",$J)=$$NOW^XLFDT() "RTN","XDRMERG",121,0) Q "RTN","XDRMERG",122,0) CLOSEIT ; "RTN","XDRMERG",123,0) I $D(XDRXFLG) Q ; DON'T CLOSE IF JUST CHECKING "RTN","XDRMERG",124,0) S:'$D(FILE) FILE=XDRFILE "RTN","XDRMERG",125,0) S:'$D(FROM) FROM=$NA(^TMP("XDRFROM",$J)) ;FROM="XDRZZZ" "RTN","XDRMERG",126,0) D SETUP(2) "RTN","XDRMERG",127,0) S I="" F S I=$O(^TMP($J,"XGLOB",I)) Q:I="" D "RTN","XDRMERG",128,0) . I I'["DA,",$P($G(^TMP($J,"XGLOB",I,0,1)),U,3)="DINUM" D "RTN","XDRMERG",129,0) . . F XDRFR=0:0 S XDRFR=$O(@FROM@(XDRFR)) Q:XDRFR'>0 D "RTN","XDRMERG",130,0) . . . ; "RTN","XDRMERG",131,0) . . . ;IHS/OIT/LJF 11/30/2006 PATCH 1003 added call to IHS subroutine "RTN","XDRMERG",132,0) . . . S BPMTO=$O(@FROM@(XDRFR,0)) "RTN","XDRMERG",133,0) . . . K @(I_XDRFR_")") ;original VA code "RTN","XDRMERG",134,0) . . . I $$GET^XPAR("PKG","BPM USE IHS LOGIC") D ENDMRG^BPMMRG(XDRFR,BPMTO,I) "RTN","XDRMERG",135,0) . . . K BPMTO "RTN","XDRMERG",136,0) ; "RTN","XDRMERG",137,0) I FILE'=2 D "RTN","XDRMERG",138,0) . S I=^DIC(FILE,0,"GL") "RTN","XDRMERG",139,0) . F XDRFR=0:0 S XDRFR=$O(@FROM@(XDRFR)) Q:XDRFR'>0 D "RTN","XDRMERG",140,0) . . K @(I_XDRFR_")") "RTN","XDRMERG",141,0) Q "RTN","XDRMERG",142,0) ; "RTN","XDRMERG",143,0) SETUP(XDRTYPE) ; XDRTYPE=3 DOES NON-.01 FIELDS (AND .01 WITH NO DINUM OR X-REF) "RTN","XDRMERG",144,0) N PFILE,PUFILE,PXFILE,PGLOB,PUFLD,PFLD,PNODE,PUNODE,NODE,PIECE,XREF,XGLOB,N,I,XREFFLAG,CHECK,STANDARD "RTN","XDRMERG",145,0) ; "RTN","XDRMERG",146,0) K ^TMP($J,"XGLO"),^TMP($J,"XGLOB"),^TMP($J,"XFIL") "RTN","XDRMERG",147,0) N XDRDINUM S XDRDINUM(FILE)="" "RTN","XDRMERG",148,0) N FILE "RTN","XDRMERG",149,0) S FILE="" "RTN","XDRMERG",150,0) F S FILE=$O(XDRDINUM(FILE)) Q:FILE="" D "RTN","XDRMERG",151,0) . F PFILE=0:0 S PFILE=$O(^DD(FILE,0,"PT",PFILE)) Q:PFILE'>0 D "RTN","XDRMERG",152,0) . . ; skip Imaging files "RTN","XDRMERG",153,0) . . Q:PFILE=2006.55 "RTN","XDRMERG",154,0) . . Q:PFILE=2006.552 "RTN","XDRMERG",155,0) . . S PUFILE=PFILE,N=0 "RTN","XDRMERG",156,0) . . F Q:$D(^DIC(PUFILE,0,"GL")) D Q:PXFILE="" "RTN","XDRMERG",157,0) . . . S PXFILE=$G(^DD(PUFILE,0,"UP")) I PXFILE="" Q "RTN","XDRMERG",158,0) . . . S PUFLD=$O(^DD(PXFILE,"SB",PUFILE,0)) I PUFLD'>0 S PXFILE="" Q "RTN","XDRMERG",159,0) . . . S PUNODE=$P($P(^DD(PXFILE,PUFLD,0),U,4),";") "RTN","XDRMERG",160,0) . . . I PUNODE'=+PUNODE S PUNODE=""""_PUNODE_"""" "RTN","XDRMERG",161,0) . . . S N=N+1 "RTN","XDRMERG",162,0) . . . S PNODE(N)=PUNODE "RTN","XDRMERG",163,0) . . . S PUFILE=PXFILE "RTN","XDRMERG",164,0) . . I '$D(^DIC(PUFILE,0,"GL")) Q "RTN","XDRMERG",165,0) . . K PGLOB "RTN","XDRMERG",166,0) . . S PGLOB(0)=^DIC(PUFILE,0,"GL") "RTN","XDRMERG",167,0) . . S ^TMP($J,"XFIL",PUFILE)=PGLOB(0) "RTN","XDRMERG",168,0) . . S XGLOB=PGLOB(0) "RTN","XDRMERG",169,0) . . F I=1:1 Q:N=0 D "RTN","XDRMERG",170,0) . . . S PGLOB(I)=PGLOB(I-1)_"DA,"_PNODE(N)_"," "RTN","XDRMERG",171,0) . . . S N=N-1 "RTN","XDRMERG",172,0) . . . S ^TMP($J,"XGLO",PGLOB(I))="" "RTN","XDRMERG",173,0) . . . S XGLOB=PGLOB(I) "RTN","XDRMERG",174,0) . . F PFLD=0:0 S PFLD=$O(^DD(FILE,0,"PT",PFILE,PFLD)) Q:PFLD'>0 D "RTN","XDRMERG",175,0) . . . I '$D(^DD(PFILE,PFLD,0)) Q "RTN","XDRMERG",176,0) . . . I $P(^DD(PFILE,PFLD,0),U,2)'["V",$P(^(0),U,3)'=$E(^DIC(FILE,0,"GL"),2,200),PFILE'=53.51 Q ; MAKE SURE POINTER IS 'REALLY' POINTING TO FILE (E.G., FIELD 400 IN FILE 60) "RTN","XDRMERG",177,0) . . . S NODE=$P($G(^DD(PFILE,PFLD,0)),U,4) "RTN","XDRMERG",178,0) . . . I NODE="" Q "RTN","XDRMERG",179,0) . . . S PIECE=$P(NODE,";",2) "RTN","XDRMERG",180,0) . . . S NODE=$P(NODE,";") "RTN","XDRMERG",181,0) . . . I NODE'=+NODE S NODE=""""_NODE_"""" "RTN","XDRMERG",182,0) . . . S XREF="" "RTN","XDRMERG",183,0) . . . I PFLD=.01,$D(^DIC(PFILE,0)) D ; MODIFIED 03/24/99 - JLI USE DINUM ONLY AT TOP OF FILE "RTN","XDRMERG",184,0) . . . . I ^DD(PFILE,PFLD,0)["DINUM" D "RTN","XDRMERG",185,0) . . . . . S XREF="DINUM" "RTN","XDRMERG",186,0) . . . . . S XDRDINUM(PFILE)="" "RTN","XDRMERG",187,0) . . . ; "RTN","XDRMERG",188,0) . . . ; the following section of code was modified to identify any pointer value reachable with "RTN","XDRMERG",189,0) . . . ; a cross-reference whether top level or in a subfile. The x-reference is checked for "RTN","XDRMERG",190,0) . . . ; the expected value for at least ten entries before being considered valid "RTN","XDRMERG",191,0) . . . ; 03/24/99 - JLI "RTN","XDRMERG",192,0) . . . ; "RTN","XDRMERG",193,0) . . . I XREF="" D "RTN","XDRMERG",194,0) . . . . N J,K,L,X1,NMAX,GLOBPCS,YGLOB,KN,KI,NCNT "RTN","XDRMERG",195,0) . . . . S NMAX=$L(XGLOB,"DA,") F J=1:1:NMAX S GLOBPCS(J)=$P(XGLOB,"DA,",J) "RTN","XDRMERG",196,0) . . . . F J=0:0 Q:XREF'="" S J=$O(^DD(PFILE,PFLD,1,J)) Q:J'>0 D "RTN","XDRMERG",197,0) . . . . . S X1=$P($G(^DD(PFILE,PFLD,1,J,0)),U,2) "RTN","XDRMERG",198,0) . . . . . Q:X1="" "RTN","XDRMERG",199,0) . . . . . I X1'=+X1 S X1=""""_X1_"""" "RTN","XDRMERG",200,0) . . . . . S K="" F KN=1:1 S K=$O(@(GLOBPCS(1)_X1_","_$S(K'=+K:""""_K_"""",1:K)_")")) Q:K=""!(XREF'="") D S:KN>10&(XREF="") XREF=X1_U_J I KN>10 Q ; global value used as naked global on next line "RTN","XDRMERG",201,0) . . . . . . S YGLOB=GLOBPCS(1),L=K,NCNT=0 F KI=1:1:NMAX S L=$O(^(L,"")) Q:L'>0!(L'=+L) S NCNT=NCNT+1,YGLOB=YGLOB_L_","_$S(NCNT0:PFILE_U_PFLD,1:"") "RTN","XDRMERG",211,0) . . . ; END OF CHANGES 03/24/99 - JLI "RTN","XDRMERG",212,0) Q "RTN","XDRMERG0") 0^8^B73333416 "RTN","XDRMERG0",1,0) XDRMERG0 ;SF-IRMFO.SEA/JLI - START OF NON-INTERACTIVE BATCH MERGE ;04/28/2005 12:11 "RTN","XDRMERG0",2,0) ;;7.3;TOOLKIT;**23,36,43,49,83,95,1001,1003**;Apr 25, 1995 "RTN","XDRMERG0",3,0) ;IHS/PAO/AEF 11/02/2006 PATCH 1003 added check to prevent UNDEF error "RTN","XDRMERG0",4,0) ;IHS/OIT/LJF 11/15/2006 PATCH 1003 added check that Package file is clean "RTN","XDRMERG0",5,0) ; 11/30/2006 PATCH 1003 add call to delete DW Audit entry for FROM patients "RTN","XDRMERG0",6,0) ;; "RTN","XDRMERG0",7,0) ; Covered Under DBIA's (#2710, #2796, #3765) "RTN","XDRMERG0",8,0) ; "RTN","XDRMERG0",9,0) Q "RTN","XDRMERG0",10,0) QUE ; This is the entry point for queueing a merge process "RTN","XDRMERG0",11,0) ; "RTN","XDRMERG0",12,0) D EN^XDRVCHEK ; update verified and/or ready to merge statuses if necessary "RTN","XDRMERG0",13,0) ; "RTN","XDRMERG0",14,0) G QUE^XDRMERGB ; CODE MOVED TO KEEP DOWN SIZE OF ROUTINE "RTN","XDRMERG0",15,0) ; "RTN","XDRMERG0",16,0) DQ ; This is the entry point for actually processing the merge task "RTN","XDRMERG0",17,0) ; Either as the initial entry or on restart. "RTN","XDRMERG0",18,0) ; "RTN","XDRMERG0",19,0) N XDRZZZ,XDRFILE,XDRPACK,XDRPACKN,XDRSFILE,XDRFDA1,XDRPACKN "RTN","XDRMERG0",20,0) N XDRROU,XDRCODE,XDRGLOB,XDRDVALF,DIQUIET,RGRSICN,XDRTIME "RTN","XDRMERG0",21,0) S XDRDVALF=1,XDRZZZ=$NA(^TMP("XDRFROM",$J)) K @XDRZZZ "RTN","XDRMERG0",22,0) S DIQUIET=1,RGRSICN=1 "RTN","XDRMERG0",23,0) ; "RTN","XDRMERG0",24,0) I $$NEWERR^%ZTER() N $ETRAP,$ESTACK S $ETRAP="D ERR^XDRMERG0" "RTN","XDRMERG0",25,0) E S X="ERR^XDRMERG0",@^%ZOSF("TRAP") "RTN","XDRMERG0",26,0) S XDRGLOB=^DIC($P(^VA(15.2,XDRFDA,0),U,2),0,"GL"),XDRGLOB=";"_$E(XDRGLOB,2,$L(XDRGLOB)),XDRTIME=$P(^VA(15.1,$P(^VA(15.2,XDRFDA,0),U,2),1),U,3) "RTN","XDRMERG0",27,0) F I=0:0 S I=$O(^VA(15.2,XDRFDA,2,I)) Q:I'>0 S X=^(I,0) D "RTN","XDRMERG0",28,0) . S @XDRZZZ@(+X,$P(X,U,2),((+X)_XDRGLOB),$P(X,U,2)_XDRGLOB)=$P(X,U,3) ; REVISED WITH 4 SUBSCRIPTS TO SAVE MERGE IMAGE IN FM STRUCTURED FILE "RTN","XDRMERG0",29,0) . ; "RTN","XDRMERG0",30,0) . ; THE FOLLOWING LINES OF CODE ADDED TO TAKE CARE OF RESTARTS IN WHICH THE LABORATORY POINTERS ARE IN AN INTERMEDIATE STATE PRIOR TO COMPLETION - JLI 03-22-99 "RTN","XDRMERG0",31,0) . ; DURING THE MERGE PROCESS THE ^LR( ENTRY IS SET TO SIMPLY THE LRIEN VALUE AND A -9 NODE ADDED, "RTN","XDRMERG0",32,0) . ; AT THE END OF LAB MERGE PROCESSING, THE FROM PATIENT ENTRY HAS ITS LR VALUE SET TO THE LRIEN FOR THE TO ENTRY "RTN","XDRMERG0",33,0) . ; WHICH IS PRESENT UNTIL THE PATIENT ENTRIES ARE MERGED. IF THE MERGE IS STOPPED PRIOR TO THE LABORATORY "RTN","XDRMERG0",34,0) . ; PROCESSING BEING MARKED COMPLETE, ON RE-ENTRY INTO THE LAB PROCESSING PAIRS WITH THE FROM ENTRY LAB DATA LEFT "RTN","XDRMERG0",35,0) . ; IN EITHER OF THE ABOVE STATES ARE EXCLUDED FROM THE MERGE. "RTN","XDRMERG0",36,0) . ; THE FOLLOWING CODE RESTORES THE CORRECT LRIEN POINTER AND LR(LRIEN,0) NODE FOR THE FROM VALUES "RTN","XDRMERG0",37,0) . ; "RTN","XDRMERG0",38,0) . I XDRGLOB=";DPT(",$D(^DPT(+X,"LR")) D "RTN","XDRMERG0",39,0) . . N TO,LR,FROMVAR S TO=$P(X,U,2),LR=^DPT(+X,"LR"),LR=$G(^LR(LR,0)) I $P(LR,U,2)=2,$P(LR,U,3)=+X Q "RTN","XDRMERG0",40,0) . . I ($P(LR,U,2)=""&($P(LR,U,3)=""))!($P(LR,U,2)=2&($P(LR,U,3)=TO)) D "RTN","XDRMERG0",41,0) . . . N DA F DA=0:0 S DA=$O(^XDRM("B",((+X)_XDRGLOB),DA)) Q:DA'>0 S LR=^XDRM(DA,1,1,0) I LR["LAB DATA" S LR=$P(LR,U,2) I LR>0 S ^DPT(+X,"LR")=LR,^LR(LR,0)=LR_U_"2"_U_(+X) K ^LR(LR,-9) Q "RTN","XDRMERG0",42,0) . ; END OF CODE ADDITION FOR LAB POINTER PROBLEM "RTN","XDRMERG0",43,0) ; "RTN","XDRMERG0",44,0) ; DO DATA CHECKING BEFORE STARTING MERGE "RTN","XDRMERG0",45,0) ; "RTN","XDRMERG0",46,0) I $P(^VA(15.2,XDRFDA,0),U,4)="S" S $P(^(0),U,3,4)=$$NOW^XLFDT()_U_"A" "RTN","XDRMERG0",47,0) S XDRPRE=1 D "RTN","XDRMERG0",48,0) . S XDRFDA1=$$ADDSPECL("DATA CHECKING") "RTN","XDRMERG0",49,0) . I $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C" Q "RTN","XDRMERG0",50,0) . S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,9)=$$NOW^XLFDT()_"^A^^^^" "RTN","XDRMERG0",51,0) . ; "RTN","XDRMERG0",52,0) . ;IHS/OIT/LJF 11/30/2006 PATCH 1003 add call to delete DW Audit entry for FROM patients "RTN","XDRMERG0",53,0) . I $$GET^XPAR("PKG","BPM USE IHS LOGIC"),$L($T(DWAUD^BPMMRG)) D DWAUD^BPMMRG(XDRZZZ) "RTN","XDRMERG0",54,0) . ; "RTN","XDRMERG0",55,0) . D ENPAIR^XDRDVAL1($P(^VA(15.2,XDRFDA,0),U,2),XDRZZZ,XDRFDA) ; CHECK FOR DATA VALIDITY PROBLEMS, REMOVE ANY PAIRS THAT HAVE PROBLEMS "RTN","XDRMERG0",56,0) . D CHKFROM^XDRMERG2(XDRZZZ,$P(^VA(15.2,XDRFDA,0),U,2)) "RTN","XDRMERG0",57,0) . I '$D(@XDRZZZ) D "RTN","XDRMERG0",58,0) . . D SETCOMPL ; MARK DATA CHECKING COMPLETE "RTN","XDRMERG0",59,0) . . S XDRFDA1=$$ADDSPECL("NO PAIRS LEFT") D SETCOMPL "RTN","XDRMERG0",60,0) . . S XDRFDA1=$$ADDSPECL("**STOPPED**") "RTN","XDRMERG0",61,0) . . K XDRPRE ; AND MAKE IT CLOSE WHOLE PROCESS "RTN","XDRMERG0",62,0) . D SETCOMPL "RTN","XDRMERG0",63,0) . Q "RTN","XDRMERG0",64,0) ; "RTN","XDRMERG0",65,0) I '$D(@XDRZZZ) Q "RTN","XDRMERG0",66,0) S XDRFILE=$P(^VA(15.2,XDRFDA,0),U,2) Q:XDRFILE'>0 "RTN","XDRMERG0",67,0) I $P(^VA(15.2,XDRFDA,0),U,4)="S" S $P(^(0),U,3,4)=$$NOW^XLFDT()_U_"A" "RTN","XDRMERG0",68,0) E S I=$P(^VA(15.2,XDRFDA,0),U,7),$P(^(0),U,4,7)="A"_U_$$NOW^XLFDT()_U_U_(I+1) "RTN","XDRMERG0",69,0) ; "RTN","XDRMERG0",70,0) ; PROCESS ANY SPECIAL HANDLING INDICATED FOR PACKAGES "RTN","XDRMERG0",71,0) ; "RTN","XDRMERG0",72,0) ;IHS/OIT/LJF 11/15/2006 PATCH 1003 Added check that Package file is clean "RTN","XDRMERG0",73,0) I $$GET^XPAR("PKG","BPM USE IHS LOGIC"),$L($T(PKG^BPMMRG)) D PKG^BPMMRG "RTN","XDRMERG0",74,0) ; "RTN","XDRMERG0",75,0) F XDRPACK=0:0 S XDRPACK=$O(^DIC(9.4,XDRPACK)) Q:XDRPACK'>0 D Q:'$D(@XDRZZZ) "RTN","XDRMERG0",76,0) . F XDRSFILE=0:0 S XDRSFILE=$O(^DIC(9.4,XDRPACK,20,XDRSFILE)) Q:XDRSFILE'>0 D Q:'$D(@XDRZZZ) "RTN","XDRMERG0",77,0) . . I $P(^DIC(9.4,XDRPACK,20,XDRSFILE,0),U)=XDRFILE D "RTN","XDRMERG0",78,0) . . . S X=^DIC(9.4,XDRPACK,20,XDRSFILE,0) "RTN","XDRMERG0",79,0) . . . S XDRPACKN=$P(^DIC(9.4,XDRPACK,0),U) "RTN","XDRMERG0",80,0) . . . S XDRROU=$P(X,U,2,3) "RTN","XDRMERG0",81,0) . . . S XDRCODE=$G(^DIC(9.4,XDRPACK,20,XDRSFILE,1)) "RTN","XDRMERG0",82,0) . . . S XDRFDA1=$$ADDSPECL(XDRPACKN) "RTN","XDRMERG0",83,0) . . . I $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C" Q "RTN","XDRMERG0",84,0) . . . S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,9)=$$NOW^XLFDT()_"^A^^^^"_ZTSK_U_XDRROU "RTN","XDRMERG0",85,0) . . . D DQ1 "RTN","XDRMERG0",86,0) . . . I '$D(@XDRZZZ) D "RTN","XDRMERG0",87,0) . . . . S XDRFDA1=$$ADDSPECL("NO PAIRS LEFT") D SETCOMPL "RTN","XDRMERG0",88,0) . . . . S XDRFDA1=$$ADDSPECL("**STOPPED**") "RTN","XDRMERG0",89,0) . . . . K XDRPRE ; AND MAKE IT CLOSE WHOLE PROCESS "RTN","XDRMERG0",90,0) K XDRPRE "RTN","XDRMERG0",91,0) ; "RTN","XDRMERG0",92,0) ; Mark completed and quit if no pairs are left "RTN","XDRMERG0",93,0) ; "RTN","XDRMERG0",94,0) I '$D(@XDRZZZ) S $P(^VA(15.2,XDRFDA,0),U,4)="C",$P(^VA(15.2,XDRFDA,0),U,6)=$$NOW^XLFDT() Q "RTN","XDRMERG0",95,0) ; "RTN","XDRMERG0",96,0) ; NOW PROCESS THE MAIN FILE AND ITS DEPENDENCIES "RTN","XDRMERG0",97,0) ; "RTN","XDRMERG0",98,0) I '$D(ZTSTOP) D "RTN","XDRMERG0",99,0) . S XDRFDA1=$$ADDSPECL($P(^DIC(XDRFILE,0),U)_" FILE") "RTN","XDRMERG0",100,0) . I $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C" Q "RTN","XDRMERG0",101,0) . S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,7)=$$NOW^XLFDT()_U_"A^^^^"_$G(ZTSK) "RTN","XDRMERG0",102,0) . S $P(^VA(15.2,XDRFDA,3,XDRFDA1,1),U)=$$NOW^XLFDT() "RTN","XDRMERG0",103,0) . S X=^VA(15.2,XDRFDA,3,XDRFDA1,1) "RTN","XDRMERG0",104,0) . S XDRCSTAT=$P(X,U,2),XDRCFIL=$P(X,U,3),XDRCENT=$P(X,U,4) "RTN","XDRMERG0",105,0) . ; "RTN","XDRMERG0",106,0) . I XDRCSTAT'="" Q "RTN","XDRMERG0",107,0) . I $D(ZTSTOP) S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="H" "RTN","XDRMERG0",108,0) ; "RTN","XDRMERG0",109,0) I '$D(ZTSTOP) D "RTN","XDRMERG0",110,0) . S XDRFDA2=XDRFDA1 "RTN","XDRMERG0",111,0) . F S XDRFDA1=$O(^VA(15.2,XDRFDA,3,XDRFDA1)) Q:XDRFDA1'>0 D "RTN","XDRMERG0",112,0) . . S ZTRTN="RETHREAD^XDRMERG0",ZTIO="",ZTDESC="MERGE THREAD" "RTN","XDRMERG0",113,0) . . S ZTSAVE("XDRFDA")="",ZTSAVE("XDRFDA1")="",ZTDTH=$$NOW^XLFDT() "RTN","XDRMERG0",114,0) . . D ^%ZTLOAD "RTN","XDRMERG0",115,0) . I $P(^VA(15.2,XDRFDA,3,XDRFDA2,0),U,3)="C" Q "RTN","XDRMERG0",116,0) . S XDRFDA1=XDRFDA2 K XDRTHRED F I=0:0 S I=$O(^VA(15.2,XDRFDA,3,XDRFDA1,2,I)) Q:I'>0 S J=^(I,0) S XDRTHRED(J)="" "RTN","XDRMERG0",117,0) . S ^VA(15.2,XDRFDA,1)=$$NOW^XLFDT() "RTN","XDRMERG0",118,0) . D RESTART^XDRMERG(XDRFILE,$NA(^TMP("XDRFROM",$J)),XDRCSTAT,XDRCFIL,XDRCENT) "RTN","XDRMERG0",119,0) ; "RTN","XDRMERG0",120,0) I $D(ZTSTOP) S $P(^VA(15.2,XDRFDA,0),U,4)="H" "RTN","XDRMERG0",121,0) E D SETCOMPL "RTN","XDRMERG0",122,0) Q "RTN","XDRMERG0",123,0) ; "RTN","XDRMERG0",124,0) DQTHREAD ; START POINT FOR EXTRA THREADS "RTN","XDRMERG0",125,0) N XDRNAME,XDRFDA1,I,X,XDRZZZ,XDRTIME "RTN","XDRMERG0",126,0) S XDRZZZ=$NA(^TMP("XDRFROM",$J)) K @XDRZZZ "RTN","XDRMERG0",127,0) ; "RTN","XDRMERG0",128,0) S XDRFILE=$P($G(^VA(15.2,XDRFDA,0)),U,2) Q:XDRFILE'>0 "RTN","XDRMERG0",129,0) S XDRTIME=$P(^VA(15.1,$P(^VA(15.2,XDRFDA,0),U,2),1),U,3) "RTN","XDRMERG0",130,0) S XDRNAME=" THREAD "_XDRTHRED "RTN","XDRMERG0",131,0) S XDRFDA1=$$ADDSPECL(XDRNAME) "RTN","XDRMERG0",132,0) I $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C" Q "RTN","XDRMERG0",133,0) S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,7)=$$NOW^XLFDT()_U_"A^^^^"_$G(ZTSK) "RTN","XDRMERG0",134,0) S XDRGLOB=^DIC($P(^VA(15.2,XDRFDA,0),U,2),0,"GL"),XDRGLOB=";"_$E(XDRGLOB,2,$L(XDRGLOB)) "RTN","XDRMERG0",135,0) F I=0:0 S I=$O(^VA(15.2,XDRFDA,2,I)) Q:I'>0 S X=^(I,0) D "RTN","XDRMERG0",136,0) . ; S @XDRZZZ@(+X,+$P(X,U,2))=$P(X,U,3) ; ORIGINAL VERSION WITH 2 SUBSCRIPTS "RTN","XDRMERG0",137,0) . S @XDRZZZ@(+X,$P(X,U,2),((+X)_XDRGLOB),$P(X,U,2)_XDRGLOB)=$P(X,U,3) ; REVISED WITH 4 SUBSCRIPTS TO SAVE MERGE IMAGE IN FM STRUCTURED FILE "RTN","XDRMERG0",138,0) F I=0:0 S I=$O(XDRTHRED(I)) Q:I'>0 D "RTN","XDRMERG0",139,0) . S ^VA(15.2,XDRFDA,3,XDRFDA1,2,I,0)=I "RTN","XDRMERG0",140,0) S X=$G(^VA(15.2,XDRFDA,3,XDRFDA1,1)) "RTN","XDRMERG0",141,0) S XDRCFIL=+$P(X,U,3),XDRCENT=+$P(X,U,4) "RTN","XDRMERG0",142,0) D RESTART^XDRMERG(XDRFILE,$NA(^TMP("XDRFROM",$J)),3,XDRCFIL,XDRCENT) "RTN","XDRMERG0",143,0) I $D(ZTSTOP) S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="H" "RTN","XDRMERG0",144,0) E D SETCOMPL "RTN","XDRMERG0",145,0) Q "RTN","XDRMERG0",146,0) ; "RTN","XDRMERG0",147,0) RETHREAD ; RESTART THREADS "RTN","XDRMERG0",148,0) N I "RTN","XDRMERG0",149,0) K XDRTHRED "RTN","XDRMERG0",150,0) F I=0:0 S I=$O(^VA(15.2,XDRFDA,3,XDRFDA1,2,I)) Q:I'>0 S J=^(I,0),XDRTHRED(J)="" "RTN","XDRMERG0",151,0) S XDRTHRED=$P($P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U)," THREAD ",2) "RTN","XDRMERG0",152,0) D DQTHREAD "RTN","XDRMERG0",153,0) Q "RTN","XDRMERG0",154,0) ; "RTN","XDRMERG0",155,0) DQ1 ; HANDLE MERGE OF SPECIAL FILES "RTN","XDRMERG0",156,0) N X,XDRROU "RTN","XDRMERG0",157,0) S X=$G(^VA(15.2,XDRFDA,3,XDRFDA1,0)) "RTN","XDRMERG0",158,0) I $P(X,U,3)="C" Q "RTN","XDRMERG0",159,0) S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,2,7)=$$NOW^XLFDT()_U_"A^^^^"_$G(ZTSK) "RTN","XDRMERG0",160,0) S $P(^VA(15.2,XDRFDA,3,XDRFDA1,1),U)=$$NOW^XLFDT() "RTN","XDRMERG0",161,0) S X=^VA(15.2,XDRFDA,3,XDRFDA1,1) "RTN","XDRMERG0",162,0) S XDRCSTAT=$P(X,U,2),XDRCFIL=$P(X,U,3),XDRCENT=$P(X,U,4) "RTN","XDRMERG0",163,0) S XDRROU=$P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,8,9) Q:XDRROU="" "RTN","XDRMERG0",164,0) Q:XDRROU="^" ;IHS/PAO/AEF 11/02/2006 PATCH 1003 LINE ADDED TO PREVENT DQ1+10^XDRMERG0 error when XDRROU="^" "RTN","XDRMERG0",165,0) I $P(XDRROU,U)="" S XDRROU="EN"_XDRROU "RTN","XDRMERG0",166,0) D @(XDRROU_"(XDRZZZ)") "RTN","XDRMERG0",167,0) I $D(ZTSTOP) S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="H" "RTN","XDRMERG0",168,0) E D SETCOMPL "RTN","XDRMERG0",169,0) Q "RTN","XDRMERG0",170,0) ; "RTN","XDRMERG0",171,0) SETCOMPL ; Indicate that a component of the process was completed "RTN","XDRMERG0",172,0) ; "RTN","XDRMERG0",173,0) S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,5)=$$NOW^XLFDT() "RTN","XDRMERG0",174,0) S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="C" "RTN","XDRMERG0",175,0) K ^VA(15.2,XDRFDA,3,XDRFDA1,1) "RTN","XDRMERG0",176,0) S J=1 F I=0:0 S I=$O(^VA(15.2,XDRFDA,3,I)) Q:I'>0 I $P(^(I,0),U,3)'="C" S J=0 Q "RTN","XDRMERG0",177,0) I J=1,+$G(XDRPRE)=0 D ; All threads have completed "RTN","XDRMERG0",178,0) . S $P(^VA(15.2,XDRFDA,0),U,6)=$$NOW^XLFDT() "RTN","XDRMERG0",179,0) . S $P(^VA(15.2,XDRFDA,0),U,4)="C" "RTN","XDRMERG0",180,0) . F XDRXX=0:0 S XDRXX=$O(@XDRZZZ@(XDRXX)) Q:XDRXX'>0 D "RTN","XDRMERG0",181,0) . . S XDRYY=$O(@XDRZZZ@(XDRXX,0)),XDRY1=$O(@XDRZZZ@(XDRXX,XDRYY,"")),XDRY2=$O(@XDRZZZ@(XDRXX,XDRYY,XDRY1,"")) "RTN","XDRMERG0",182,0) . . S XDRK=@XDRZZZ@(XDRXX,XDRYY,XDRY1,XDRY2) "RTN","XDRMERG0",183,0) . . N XDRAA S XDRAA(15,(XDRK_","),.05)=2 "RTN","XDRMERG0",184,0) . . D UPDATE^DIE("","XDRAA") "RTN","XDRMERG0",185,0) . . ; "RTN","XDRMERG0",186,0) . . ; recalc CMOR scores on newly merged TO record "RTN","XDRMERG0",187,0) . . I XDRY2[";DPT(",$T(CALC^RGVCCMR2)]"" D "RTN","XDRMERG0",188,0) . . . N RGDFN S RGDFN=XDRYY D CALC^RGVCCMR2 "RTN","XDRMERG0",189,0) . . . ; create an A31 message for newly merged TO record "RTN","XDRMERG0",190,0) . . . S ERR=$$A31^MPIFA31B(XDRYY) "RTN","XDRMERG0",191,0) . . . I +ERR<0 D START^RGHLLOG(),EXC^RGHLLOG(208,"Error returned while building A31 after merge (DFN="_XDRYY_") ERROR="_$P(ERR,"^",2),XDRYY),STOP^RGHLLOG() "RTN","XDRMERG0",192,0) . S (FILE,XDRFILE)=$P(^VA(15.2,XDRFDA,0),U,2) "RTN","XDRMERG0",193,0) . S FROM=$NA(^TMP("XDRFROM",$J)) "RTN","XDRMERG0",194,0) . D CLOSEIT^XDRMERG "RTN","XDRMERG0",195,0) . D SNDMSG^XDRMERGB(XDRFDA) "RTN","XDRMERG0",196,0) Q "RTN","XDRMERG0",197,0) ; "RTN","XDRMERG0",198,0) ADDSPECL(PACKAGE) ; Add a package identifier to merge process "RTN","XDRMERG0",199,0) ; if already present, simply return the internal entry number "RTN","XDRMERG0",200,0) ; (it would be present if re-starting) "RTN","XDRMERG0",201,0) ; "RTN","XDRMERG0",202,0) N Y,XDRZZ,XDRXX "RTN","XDRMERG0",203,0) S Y=$$FIND1^DIC(15.23,","_XDRFDA_",","Q",PACKAGE) "RTN","XDRMERG0",204,0) I Y'>0 D "RTN","XDRMERG0",205,0) . S XDRZZ(15.23,"+1,"_XDRFDA_",",.01)=PACKAGE "RTN","XDRMERG0",206,0) . D UPDATE^DIE("","XDRZZ","XDRXX") "RTN","XDRMERG0",207,0) . S Y=XDRXX(1) "RTN","XDRMERG0",208,0) Q +Y "RTN","XDRMERG0",209,0) ; "RTN","XDRMERG0",210,0) ; "RTN","XDRMERG0",211,0) ERR ; On an error mark status as error, and save the error message "RTN","XDRMERG0",212,0) ; "RTN","XDRMERG0",213,0) S XDRZE=$ZE "RTN","XDRMERG0",214,0) D ^%ZTER "RTN","XDRMERG0",215,0) I $D(XDRFDA),$D(XDRFDA1) D "RTN","XDRMERG0",216,0) . S $P(^VA(15.2,XDRFDA,3,XDRFDA1,0),U,3)="E",^(2)=XDRZE "RTN","XDRMERG0",217,0) G UNWIND^%ZTER "RTN","XDRMERG0",218,0) ; "RTN","XDRMERG1") 0^17^B27749140 "RTN","XDRMERG1",1,0) XDRMERG1 ;SF-IRMFO.SEA/JLI - TENATIVE UPDATE POINTER NODES ;06/02/2005 09:01 "RTN","XDRMERG1",2,0) ;;7.3;TOOLKIT;**23,34,38,44,47,95,1001,1003**;Apr 25, 1995 "RTN","XDRMERG1",3,0) ;;IHS/OIT/LJF 05/24/2007 PATCH 1003 No IHS changes; updated VA routine "RTN","XDRMERG1",4,0) ;; "RTN","XDRMERG1",5,0) ;; "RTN","XDRMERG1",6,0) CHASE(XVAL,RVAL,XDRIENS) ; "RTN","XDRMERG1",7,0) N XDRYT,XDRYTT,NODE,X,PC,Y,XDRTO,XDRIEN,XV,XN,XXV,XTYPE,X "RTN","XDRMERG1",8,0) N DA,XV,XXV,XDRFILE,OLDH "RTN","XDRMERG1",9,0) S OLDH=$P($H,",",2) "RTN","XDRMERG1",10,0) F DA=SENTRY:0 Q:$D(ZTSTOP) S DA=$O(@(XVAL_DA_")")) Q:DA'>0 D "RTN","XDRMERG1",11,0) . I (($P($H,",",2)-OLDH>XDRTIME)!($P($H,",",2)5 D ;60 D "RTN","XDRMERG1",18,0) . . . I $D(XDRFDA) D I 1 "RTN","XDRMERG1",19,0) . . . . S ^VA(15.2,XDRFDA,3,XDRFDA1,1)=XDRYT_U_CURRTYPE_U_CURRFIL_U_DA "RTN","XDRMERG1",20,0) . . . E D "RTN","XDRMERG1",21,0) . . . . S ^XTMP("XDRSTAT",XDRGID,"TIME",$J)=XDRYT_U_CURRTYPE_U_CURRFIL_U_DA "RTN","XDRMERG1",22,0) . . . S XDRXT=XDRYT "RTN","XDRMERG1",23,0) . I $D(^TMP($J,"XGLOB",RVAL)) D "RTN","XDRMERG1",24,0) . . S NODE="" F S NODE=$O(^TMP($J,"XGLOB",RVAL,NODE)) Q:NODE="" D "RTN","XDRMERG1",25,0) . . . S X=$G(@(XVAL_DA_","_NODE_")")) Q:X="" "RTN","XDRMERG1",26,0) . . . F PC=0:0 S PC=$O(^TMP($J,"XGLOB",RVAL,NODE,PC)) Q:PC'>0 D "RTN","XDRMERG1",27,0) . . . . S Y=$P(X,U,PC),XDRFR=Y "RTN","XDRMERG1",28,0) . . . . I Y>0,$D(XDRXFLG),$D(@FROM@(+Y))=1 S @FROM@(+Y,"R",CURRFIL)=$G(@FROM@(+Y,"R",CURRFIL))+1 Q ; USED TO DETERMINE WHICH ENTRIES AREN'T POINTED TO. "RTN","XDRMERG1",29,0) . . . . I Y>0 S XDRTO=$O(@FROM@(+Y,"")) I XDRTO>0 D "RTN","XDRMERG1",30,0) . . . . . I +Y'=Y D Q:Y'>0 "RTN","XDRMERG1",31,0) . . . . . . I $P(Y,";",2)'=$E(XDRFGLOB,2,99) S Y=0 Q "RTN","XDRMERG1",32,0) . . . . . . S XDRTO=XDRTO_";"_$E(XDRFGLOB,2,99) "RTN","XDRMERG1",33,0) . . . . . I $P(^TMP($J,"XGLOB",RVAL,NODE,PC),U,3)="DINUM" D Q "RTN","XDRMERG1",34,0) . . . . . . D DINUM^XDRMERG2(XVAL,RVAL,XDRIENS) "RTN","XDRMERG1",35,0) . . . . . I ^TMP($J,"XGLOB",RVAL,NODE,PC)>0 D Q "RTN","XDRMERG1",36,0) . . . . . . S XDRIEN=DA_","_XDRIENS "RTN","XDRMERG1",37,0) . . . . . . N DA,XDRFILE,XDRFLD,XDR "RTN","XDRMERG1",38,0) . . . . . . S XDRFILE=+^TMP($J,"XGLOB",RVAL,NODE,PC) "RTN","XDRMERG1",39,0) . . . . . . S XDRFLD=+$P(^TMP($J,"XGLOB",RVAL,NODE,PC),U,2) "RTN","XDRMERG1",40,0) . . . . . . S XDR(XDRFILE,XDRIEN,XDRFLD)=XDRTO "RTN","XDRMERG1",41,0) . . . . . . ; S ^XDRM(+XDRFR,"P",XDRFILE,XDRIEN,XDRFLD)=XDRFR ; ORIGINAL VERSION SIMPLY STORE DATA ON POINTER CHANGE "RTN","XDRMERG1",42,0) . . . . . . D SAVEPNTR^XDRMERGB(+XDRFR,+XDRTO,XDRFILE,XDRIEN,XDRFLD,XDRFR) ; REVISED TO STORE POINTER CHANGE IN FM COMPATIBLE STRUCTURE "RTN","XDRMERG1",43,0) . . . . . . D FILE^DIE("","XDR") "RTN","XDRMERG1",44,0) . . . . . S $P(@(XVAL_DA_","_NODE_")"),U,PC)=XDRTO "RTN","XDRMERG1",45,0) . . . . . S XDRFILE=+$P(@(XVAL_"0)"),U,2) "RTN","XDRMERG1",46,0) . . . . . S XDRFLD=$O(@("^DD("_XDRFILE_",""GL"","_NODE_","_PC_",0)")) "RTN","XDRMERG1",47,0) . . . . . S XDRIEN=DA_","_XDRIENS "RTN","XDRMERG1",48,0) . . . . . ; S ^XDRM(+XDRFR,"P",XDRFILE,XDRIEN,XDRFLD)=XDRFR ; ORIGINAL VERSION SIMPLY STORE DATA ON POINTER CHANGE "RTN","XDRMERG1",49,0) . . . . . D SAVEPNTR^XDRMERGB(+XDRFR,+XDRTO,XDRFILE,XDRIEN,XDRFLD,XDRFR) "RTN","XDRMERG1",50,0) . S XV=RVAL "RTN","XDRMERG1",51,0) . F S XV=$O(^TMP($J,"XGLO",XV)) Q:XV'[RVAL D "RTN","XDRMERG1",52,0) . . S XN=$P(XV,RVAL,2),XN=DA_","_$P(XN,"DA,",2) "RTN","XDRMERG1",53,0) . . S XXV=XVAL_XN "RTN","XDRMERG1",54,0) . . S XTYPE=$$TYPE(XV) "RTN","XDRMERG1",55,0) . . I XTYPE="DINUM" D DINUM^XDRMERG2(XXV,XV,DA_","_XDRIENS) Q "RTN","XDRMERG1",56,0) . . I XTYPE'="" D XREFS^XDRMERG2(XXV,XV,DA_","_XDRIENS) Q "RTN","XDRMERG1",57,0) . . D CHASE(XXV,XV,DA_","_XDRIENS) "RTN","XDRMERG1",58,0) S SENTRY=0 "RTN","XDRMERG1",59,0) Q "RTN","XDRMERG1",60,0) ; "RTN","XDRMERG1",61,0) TYPE(GLOB) ; "RTN","XDRMERG1",62,0) N I,J "RTN","XDRMERG1",63,0) S I=$O(^TMP($J,"XGLOB",GLOB,"")) Q:I="" "" "RTN","XDRMERG1",64,0) S J=$O(^TMP($J,"XGLOB",GLOB,I,"")) Q:J="" "" "RTN","XDRMERG1",65,0) Q $P(^TMP($J,"XGLOB",GLOB,I,J),U,3) "RTN","XDRMERG1",66,0) ; "RTN","XDRMERG1",67,0) XREFS ; CONTINUATION FROM XDRMERG2 DUE TO SPACE LIMITS "RTN","XDRMERG1",68,0) N IENOLD,IENNEW,IENVAL,FILEI,FLDJ,XREF,XDRXX,VREF,NMAX,GLOBPCS "RTN","XDRMERG1",69,0) N NODE,PIECE "RTN","XDRMERG1",70,0) N XDRZZ,XDRAA ; DEBUG STATEMENT "RTN","XDRMERG1",71,0) S XDRXX=$NA(^TMP($J,"XDRXX")) "RTN","XDRMERG1",72,0) K @XDRXX "RTN","XDRMERG1",73,0) S NMAX=$L(XR,"DA,") F J=1:1:NMAX S GLOBPCS(J)=$P(XR,"DA,",J) "RTN","XDRMERG1",74,0) S NODE="" F S NODE=$O(^TMP($J,"XGLOB",XR,NODE)) Q:NODE="" F PIECE=0:0 S PIECE=$O(^TMP($J,"XGLOB",XR,NODE,PIECE)) Q:PIECE'>0 S FILEI=^(PIECE) D "RTN","XDRMERG1",75,0) . S FLDJ=$P(FILEI,U,2),XREF=$P(FILEI,U,3),FILEI=+FILEI,VREF="" I $P(^DD(FILEI,FLDJ,0),U,2)["V" S VREF=";"_$E(XDRFGLOB,2,99) "RTN","XDRMERG1",76,0) . I XREF="DINUM" Q "RTN","XDRMERG1",77,0) . F IENOLD=0:0 S IENOLD=$O(@FROM@(IENOLD)) Q:IENOLD'>0 D "RTN","XDRMERG1",78,0) . . N KVALUE,YGLOB,NCNT,DAIENS,ZGLOB "RTN","XDRMERG1",79,0) . . S IENNEW=$O(@FROM@(IENOLD,"")) Q:IENNEW'>0&'$D(XDRXFLG) "RTN","XDRMERG1",80,0) . . S KVALUE=$S(VREF'="":IENOLD_VREF,1:IENOLD),ZGLOB=GLOBPCS(1)_XREF_","_""""_KVALUE_""""_")" I $D(@ZGLOB) S DAIENS="",YGLOB=GLOBPCS(1),NCNT=0 D FINDXREF(NMAX,XDRXX,ZGLOB,NCNT,DAIENS,YGLOB) "RTN","XDRMERG1",81,0) . . Q "RTN","XDRMERG1",82,0) . Q "RTN","XDRMERG1",83,0) K XDRAA,XDRZZ I $D(XDRTESTK) M XDRAA=@XDRXX ; DEBUG STATEMENT "RTN","XDRMERG1",84,0) I $D(@XDRXX) D FILE^DIE("",XDRXX) "RTN","XDRMERG1",85,0) I $D(XDRZZ),$D(XDRTESTK) S XDRTESTK=XDRTESTK+1 M ^XTMP("XDRTESTK",$$NOW^XLFDT(),XDRTESTK,"XX")=XDRAA,^("ZZ")=XDRZZ K XDRAA,XDRZZ ; DEBUG STATEMENT "RTN","XDRMERG1",86,0) Q "RTN","XDRMERG1",87,0) ; "RTN","XDRMERG1",88,0) FINDXREF(NMAX,XDRXX,ZGLOB,NCNT,DAIENS,YGLOB) ; "RTN","XDRMERG1",89,0) N LVAL,NVAL "RTN","XDRMERG1",90,0) S NVAL=NCNT+1 "RTN","XDRMERG1",91,0) I NVAL=NMAX D Q "RTN","XDRMERG1",92,0) . F LVAL=0:0 S LVAL=$O(@ZGLOB@(LVAL)) Q:LVAL'>0!(LVAL'=+LVAL) D SETXREF((YGLOB_LVAL_","),(LVAL_","_DAIENS)) "RTN","XDRMERG1",93,0) . Q "RTN","XDRMERG1",94,0) F LVAL=0:0 S LVAL=$O(@ZGLOB@(LVAL)) Q:LVAL'>0!(LVAL'=+LVAL) D FINDXREF(NMAX,XDRXX,$NA(@ZGLOB@(LVAL)),NVAL,(LVAL_","_DAIENS),(YGLOB_LVAL_","_GLOBPCS(NVAL+1))) "RTN","XDRMERG1",95,0) Q "RTN","XDRMERG1",96,0) ; "RTN","XDRMERG1",97,0) SETXREF(YGLOB,DAIENS) ; "RTN","XDRMERG1",98,0) I $E($P($G(@(YGLOB_NODE_")")),U,PIECE),1,30)'=KVALUE Q "RTN","XDRMERG1",99,0) I $D(XDRXFLG) S @FROM@(IENOLD,"R",FILEI)=$G(@FROM@(IENOLD,"R",FILEI))+1 Q ; POINTER WAS FOUND, MARK ENTRY FOR FILE "RTN","XDRMERG1",100,0) S @XDRXX@(FILEI,DAIENS,FLDJ)=IENNEW_VREF "RTN","XDRMERG1",101,0) D SAVEPNTR^XDRMERGB(+IENOLD,+IENNEW,FILEI,DAIENS,FLDJ,(IENOLD_VREF)) "RTN","XDRMERG1",102,0) Q "RTN","XDRMERG2") 0^15^B68746101 "RTN","XDRMERG2",1,0) XDRMERG2 ;SF-IRMFO.SEA/JLI - TENATIVE UPDATE POINTER NODES ; [ 04/02/2003 8:47 AM ] "RTN","XDRMERG2",2,0) ;;7.3;TOOLKIT;**23,38,40,42,46,62,1001,1003**;Apr 25, 1995 "RTN","XDRMERG2",3,0) ;IHS/OIT/LJF 02/09/2007 PATCH 1003 prevent View Merge Status from scrolling off screen "RTN","XDRMERG2",4,0) ; 03/02/2007 PATCH 1003 set 19th piece of ^DPT on FROM patient for backward "RTN","XDRMERG2",5,0) ; compatibility with PCC Mgt Reports "RTN","XDRMERG2",6,0) ;; "RTN","XDRMERG2",7,0) Q "RTN","XDRMERG2",8,0) ; "RTN","XDRMERG2",9,0) ; XDRXFLG is referenced in a few places, but not defined - it was "RTN","XDRMERG2",10,0) ; used where it was set at the time the run started to identify "RTN","XDRMERG2",11,0) ; entries which were referenced in one or more files and to "RTN","XDRMERG2",12,0) ; remove them from a list of entries which were not referenced "RTN","XDRMERG2",13,0) ; by any files within the database "RTN","XDRMERG2",14,0) ; "RTN","XDRMERG2",15,0) DINUM(XVAL,XR,XDRIENS) ; FIND AND MERGE DINUMMED POINTERS "RTN","XDRMERG2",16,0) N IENOLD,IENNEW,FILEI,FLDJ,XREF,VREF "RTN","XDRMERG2",17,0) ; "RTN","XDRMERG2",18,0) D SETVALS "RTN","XDRMERG2",19,0) F IENOLD=0:0 S IENOLD=$O(@FROM@(IENOLD)) Q:IENOLD'>0 D "RTN","XDRMERG2",20,0) . I '$D(@(XVAL_IENOLD_",0)")) Q "RTN","XDRMERG2",21,0) . I $D(XDRXFLG) S @FROM@(IENOLD,"R",FILEI)=$G(@FROM@(IENOLD,"R",FILEI))+1 Q ; POINTER WAS FOUND MARK ENTRY FOR FILE "RTN","XDRMERG2",22,0) . S IENNEW=$O(@FROM@(IENOLD,"")) Q:IENNEW'>0 "RTN","XDRMERG2",23,0) . ; N I F I=IENOLD,IENNEW M @("^XDRM(I,""M"",FILEI,I)="_XVAL_I_")") ; OLD SAVE IMAGE BY SIMPLY MERGING "RTN","XDRMERG2",24,0) . D SAVEMERG^XDRMERGB(FILEI,IENOLD,IENNEW) "RTN","XDRMERG2",25,0) . I '$D(@(XVAL_IENNEW_",0)")) D "RTN","XDRMERG2",26,0) . . N DD,DO,DIC,X,DINUM,DA "RTN","XDRMERG2",27,0) . . S DIC=XVAL,DIC(0)="L",X=IENNEW,DINUM=IENNEW D FILE^DICN Q:Y'>0 "RTN","XDRMERG2",28,0) . D OVRWRI(FILEI,IENOLD,IENNEW) "RTN","XDRMERG2",29,0) . D MERGEIT(XVAL,IENOLD,IENNEW) "RTN","XDRMERG2",30,0) . D TIMSTAMP(2,FILEI,IENOLD) "RTN","XDRMERG2",31,0) Q "RTN","XDRMERG2",32,0) MERGEIT(XDRDIC,IENFROM,IENTO) ; MERGE TWO ENTRIES IN FILE "RTN","XDRMERG2",33,0) N NODE,NODE1,NODE2,NODEA,SFILE,XDRFROM,XDRTO,NODEA,VALUE,XVALUE,XDRXX,XDRYY,NODEB,DIK,DA,I,Y,VREF,XNN,XFILNO,IENTOSTR,DFN "RTN","XDRMERG2",34,0) ; "RTN","XDRMERG2",35,0) D MERGEIT^XDRMERGB "RTN","XDRMERG2",36,0) Q "RTN","XDRMERG2",37,0) TIMSTAMP(PHASE,FILE,IEN) ; "RTN","XDRMERG2",38,0) S XDRYT=$$NOW^XLFDT() "RTN","XDRMERG2",39,0) I $$FMDIFF^XLFDT(XDRYT,+$G(XDRXT),2)>5 D "RTN","XDRMERG2",40,0) . I $D(XDRFDA) D I 1 "RTN","XDRMERG2",41,0) . . S ^VA(15.2,XDRFDA,3,XDRFDA1,1)=XDRYT_U_PHASE_U_FILE_U_IEN "RTN","XDRMERG2",42,0) . E D "RTN","XDRMERG2",43,0) . . S ^XTMP("XDRSTAT",XDRGID,"TIME",$J)=XDRYT_U_PHASE_U_FILE_U_IEN "RTN","XDRMERG2",44,0) . S XDRXT=XDRYT "RTN","XDRMERG2",45,0) Q "RTN","XDRMERG2",46,0) XREFS(XVAL,XR,XDRIENS) ; FIND POINTERS BASED ON KNOWN X-REFS FOR FILE "RTN","XDRMERG2",47,0) D XREFS^XDRMERG1 "RTN","XDRMERG2",48,0) Q "RTN","XDRMERG2",49,0) ; "RTN","XDRMERG2",50,0) SETVALS ; IDENTIFY THE LOCATIONS OF POINTERS (NODE, PIECE, AND X-REF I ANY) "RTN","XDRMERG2",51,0) S FILEI=$O(^TMP($J,"XGLOB",XR,"")),FLDJ=$O(^TMP($J,"XGLOB",XR,FILEI,"")) "RTN","XDRMERG2",52,0) S FILEI=^TMP($J,"XGLOB",XR,FILEI,FLDJ),FLDJ=+$P(FILEI,U,2) "RTN","XDRMERG2",53,0) S XREF=$P(FILEI,U,3),FILEI=+FILEI "RTN","XDRMERG2",54,0) S VREF="" I $P(^DD(FILEI,FLDJ,0),U,2)["V" S VREF=";"_$E(XDRFGLOB,2,99) "RTN","XDRMERG2",55,0) Q "RTN","XDRMERG2",56,0) ; "RTN","XDRMERG2",57,0) DOMAIN(FILE,FROM) ; MERGE ACTUAL ENTRIES IN THE FILE (THE ONES POINTED TO) "RTN","XDRMERG2",58,0) N IENFROM,IENTO,XDRVAL,XDRIENS "RTN","XDRMERG2",59,0) I '$D(XDRTESTK) S XDRTESTK=0 S ^XTMP("XDRTESTK",0)=$$FMADD^XLFDT(DT,30)_U_DT ; DEBUG STATEMENT "RTN","XDRMERG2",60,0) S XFILNO=FILE "RTN","XDRMERG2",61,0) I $D(XDRXFLG) Q "RTN","XDRMERG2",62,0) S XDRIENS="" "RTN","XDRMERG2",63,0) S XDRDIC=$G(^DIC(FILE,0,"GL")) Q:XDRDIC="" "RTN","XDRMERG2",64,0) S IENFROM=0 "RTN","XDRMERG2",65,0) F S IENFROM=$O(@FROM@(IENFROM)) Q:IENFROM'>0 D "RTN","XDRMERG2",66,0) . I '$D(@(XDRDIC_IENFROM_")")) Q "RTN","XDRMERG2",67,0) . S IENTO=$O(@FROM@(IENFROM,"")) Q:IENTO'>0 "RTN","XDRMERG2",68,0) . I $D(@(XDRDIC_IENFROM_",-9)"))!$D(@(XDRDIC_IENTO_",-9)")) Q ; ALREADY MERGED "RTN","XDRMERG2",69,0) . S XDRVAL=$P($G(@(XDRDIC_IENFROM_",0)")),U) "RTN","XDRMERG2",70,0) . S XDRVAL=$P($G(@(XDRDIC_IENFROM_",0)")),U) "RTN","XDRMERG2",71,0) . I $E(XDRVAL,1,12)="MERGING INTO" D "RTN","XDRMERG2",72,0) . . N X S X=XDRVAL "RTN","XDRMERG2",73,0) . . F Q:X'["MERGING INTO" S X=$P(X,"(",2,99),X=$E(X,1,$L(X)-1) "RTN","XDRMERG2",74,0) . . S $P(@(XDRDIC_IENFROM_",0)"),U)=X "RTN","XDRMERG2",75,0) . . S XDRVAL=X "RTN","XDRMERG2",76,0) . D GETSSN ; GET SSN FOR SELECTED MAIN FILES "RTN","XDRMERG2",77,0) . S IENTO=$O(@FROM@(IENFROM,"")) Q:IENTO'>0 S DFN=IENTO D "RTN","XDRMERG2",78,0) . . ; N I F I=IENFROM,IENTO M @("^XDRM(I,""M"",FILE,I)="_XDRDIC_I_")") ; ORIGINAL VERSION SAVE IMAGE BY SIMPLY MERGING "RTN","XDRMERG2",79,0) . . D SAVEMERG^XDRMERGB(FILE,IENFROM,IENTO) ; SAVE IMAGE IN FM COMPATIBLE STRUCTURE "RTN","XDRMERG2",80,0) . . N XDRVAL "RTN","XDRMERG2",81,0) . . D OVRWRI(XFILNO,IENFROM,IENTO) ; LOOK FOR DATA TO BE OVERWRITTEN "RTN","XDRMERG2",82,0) . . D MERGEIT(XDRDIC,IENFROM,IENTO) "RTN","XDRMERG2",83,0) . S @(XDRDIC_IENFROM_",0)")=XDRVAL "RTN","XDRMERG2",84,0) . S @(XDRDIC_IENFROM_",-9)")=IENTO "RTN","XDRMERG2",85,0) . ; "RTN","XDRMERG2",86,0) . ;IHS/OIT/LJF 03/02/2007 PATCH 1003 for backwards compatibility "RTN","XDRMERG2",87,0) . I FILE=2,$$GET^XPAR("PKG","BPM USE IHS LOGIC") S $P(@(XDRDIC_IENFROM_",0)"),U,19)=IENTO "RTN","XDRMERG2",88,0) . ; "RTN","XDRMERG2",89,0) . D SETALIAS ; SET UP ALIAS ENTRY IN SELECTED FILES "RTN","XDRMERG2",90,0) . N VALUE,XDRXX,XDRYY "RTN","XDRMERG2",91,0) . S VALUE=$$FIND1^DIC(15.3,",","Q",FILE) "RTN","XDRMERG2",92,0) . I VALUE'>0 D "RTN","XDRMERG2",93,0) . . S XDRXX(15.3,"+1,",.01)=FILE "RTN","XDRMERG2",94,0) . . K XDRYY S XDRYY(1)=FILE "RTN","XDRMERG2",95,0) . . D UPDATE^DIE("","XDRXX","XDRYY") "RTN","XDRMERG2",96,0) . K XDRXX,XDRYY "RTN","XDRMERG2",97,0) . S XDRXX(15.31,"+1,"_FILE_",",.01)=IENFROM "RTN","XDRMERG2",98,0) . S XDRXX(15.31,"+1,"_FILE_",",.02)=IENTO "RTN","XDRMERG2",99,0) . D UPDATE^DIE("","XDRXX","XDRYY","XDRMM") "RTN","XDRMERG2",100,0) . D TIMSTAMP(1,FILE,IENFROM) "RTN","XDRMERG2",101,0) Q "RTN","XDRMERG2",102,0) ; "RTN","XDRMERG2",103,0) CHKFROM(FROM,FILE) ; "RTN","XDRMERG2",104,0) D CHKFROM^XDRMERGC(FROM,FILE) "RTN","XDRMERG2",105,0) Q "RTN","XDRMERG2",106,0) ; "RTN","XDRMERG2",107,0) GETSSN ; For files 2 and 200, get SSN value for XDRFROM entry "RTN","XDRMERG2",108,0) I FILE=2 S XDRVAL("SSN")=$P(^DPT(IENFROM,0),U,9) Q "RTN","XDRMERG2",109,0) I FILE=200 S XDRVAL("SSN")=$P(^VA(200,IENFROM,1),U,9) Q "RTN","XDRMERG2",110,0) Q "RTN","XDRMERG2",111,0) ; "RTN","XDRMERG2",112,0) OVRWRI(FILE,IENFR,IENTO) ; "RTN","XDRMERG2",113,0) N XNI,XDRARR,XDRARR1,IENSF,I,XNN,IENA,IENB ; THIS WOULD BE ONLY TOP LEVEL "RTN","XDRMERG2",114,0) ; "RTN","XDRMERG2",115,0) S IENA=$O(@FROM@(IENFR,IENTO,"")) Q:IENA="" "RTN","XDRMERG2",116,0) S IENB=$O(@FROM@(IENFR,IENTO,IENA,"")) Q:IENB="" "RTN","XDRMERG2",117,0) S XNN=@FROM@(IENFR,IENTO,IENA,IENB) Q:XNN'>0 "RTN","XDRMERG2",118,0) S XNI="",IENSF=IENFR_"," "RTN","XDRMERG2",119,0) F I=0:0 S I=$O(^VA(15,XNN,3,FILE,1,I)) Q:I'>0 S XNI=XNI_^(I,0)_";" "RTN","XDRMERG2",120,0) I XNI'="" D "RTN","XDRMERG2",121,0) . D GETS^DIQ(FILE,IENSF,XNI,"I","XDRARR") "RTN","XDRMERG2",122,0) . F I=0:0 S I=$O(XDRARR(FILE,IENSF,I)) Q:I'>0 D "RTN","XDRMERG2",123,0) . . S XDRARR1(FILE,(IENTO_","),I)=XDRARR(FILE,IENSF,I,"I") "RTN","XDRMERG2",124,0) . I FILE=2!(FILE=200),$D(XDRARR1(FILE,(IENTO_","),$S(FILE=2:.09,1:9))) D "RTN","XDRMERG2",125,0) . . N IENST,XDRARR2 S IENST=IENTO_"," "RTN","XDRMERG2",126,0) . . D GETS^DIQ(FILE,IENST,$S(FILE=2:.09,1:9),"I","XDRARR2") "RTN","XDRMERG2",127,0) . . I $D(XDRARR2(FILE,IENST,$S(FILE=2:.09,1:9),"I")) D "RTN","XDRMERG2",128,0) . . . S XDRARR1(FILE,IENSF,$S(FILE=2:.09,1:9))=XDRARR2(FILE,IENST,$S(FILE=2:.09,1:9),"I") "RTN","XDRMERG2",129,0) . . . Q "RTN","XDRMERG2",130,0) . . Q "RTN","XDRMERG2",131,0) . D FILE^DIE("","XDRARR1") "RTN","XDRMERG2",132,0) Q "RTN","XDRMERG2",133,0) SETALIAS ; For selected files place data into alias field of TO entry "RTN","XDRMERG2",134,0) N XDRARR "RTN","XDRMERG2",135,0) I FILE=2 D "RTN","XDRMERG2",136,0) . S XDRARR(2.01,"+1,"_IENTO_",",.01)=XDRVAL "RTN","XDRMERG2",137,0) . S XDRARR(2.01,"+1,"_IENTO_",",1)=XDRVAL("SSN") "RTN","XDRMERG2",138,0) . D UPDATE^DIE("","XDRARR") "RTN","XDRMERG2",139,0) I FILE=200 D "RTN","XDRMERG2",140,0) . S XDRARR(200.04,"+1,"_IENTO_",",.01)=XDRVAL "RTN","XDRMERG2",141,0) . D FILE^DIE("","XDRARR") "RTN","XDRMERG2",142,0) Q "RTN","XDRMERG2",143,0) ; "RTN","XDRMERG2",144,0) CHKLOCAL ; CHECK STATUS FOR LOCAL MERGE PROCESSES (EVEN IF SOME DATA EXISTS IN MERGE PROCESS FILE) "RTN","XDRMERG2",145,0) N XJOB,X,N,XNAME,XSTAT,XDRFIL,DIRUT,CHKLOCAL "RTN","XDRMERG2",146,0) S CHKLOCAL=1,XDRFIL="^XTMP(""XDRSTAT""," "RTN","XDRMERG2",147,0) G CHK1 "RTN","XDRMERG2",148,0) ; "RTN","XDRMERG2",149,0) CHECK ; "RTN","XDRMERG2",150,0) N XJOB,X,N,M,BA,XNAME,XDRFIL,DIRUT,START,XDRFIL1,XDRFIL2 "RTN","XDRMERG2",151,0) CHK1 ; "RTN","XDRMERG2",152,0) I '$D(CHKLOCAL) S XDRFIL=$S($O(^VA(15.2,0))>0:"^VA(15.2,",1:"^XTMP(""XDRSTAT"",") "RTN","XDRMERG2",153,0) S N=0,BA="" "RTN","XDRMERG2",154,0) W @IOF "RTN","XDRMERG2",155,0) S M=":" F S M=$O(@(XDRFIL_""""_M_""")"),-1) Q:M'>0 D "RTN","XDRMERG2",156,0) . I XDRFIL["VA(15.2",$P(^VA(15.2,M,0),U,4)="S" Q "RTN","XDRMERG2",157,0) . S XDRFIL1=$S(XDRFIL["VA":$NA(@(XDRFIL_M_")")),1:$NA(^XTMP("XDRSTAT",M))) "RTN","XDRMERG2",158,0) . S N=$S($D(^TMP($J,"BDT",N)):N+1,1:N) S XNAME="",XJOB="",N=N+1 "RTN","XDRMERG2",159,0) . D ONESET(XDRFIL1,0) "RTN","XDRMERG2",160,0) . I XDRFIL["VA" D "RTN","XDRMERG2",161,0) . . F J=0:0 S J=$O(@XDRFIL1@(3,J)) Q:J'>0 D "RTN","XDRMERG2",162,0) . . . S XDRFIL2=$NA(@XDRFIL1@(3,J)) "RTN","XDRMERG2",163,0) . . . D ONESET(XDRFIL2,1) "RTN","XDRMERG2",164,0) D HEADER "RTN","XDRMERG2",165,0) F N=0:0 S N=$O(^TMP($J,"BDT",N)) Q:N'>0 D Q:$D(DIRUT) "RTN","XDRMERG2",166,0) .I (IOSL-$Y)<6 D:IOST["C-" Q:$D(DIRUT) W @IOF,! D HEADER ;REM -9/25/96 page breaks "RTN","XDRMERG2",167,0) ..W ! S DIR(0)="E" D ^DIR K DIR "RTN","XDRMERG2",168,0) . S XNAME=$P($G(^TMP($J,"BDT",N)),"~",2) "RTN","XDRMERG2",169,0) . S START=$P($G(^TMP($J,"BDT",N)),"~",3) "RTN","XDRMERG2",170,0) . S XJOB=$P($G(^TMP($J,"BDT",N)),"~",4) "RTN","XDRMERG2",171,0) . I BA'="",BA'=$P($G(START),"."),START'="" W ! "RTN","XDRMERG2",172,0) . S BA=$P($G(START),".") "RTN","XDRMERG2",173,0) . S:XNAME["THREAD" XNAME=" "_XNAME "RTN","XDRMERG2",174,0) . W !,XNAME Q:XNAME="" I $L(XNAME)>18 W ! "RTN","XDRMERG2",175,0) . S X=START D DATE8 W ?20,X," ",$P(^TMP($J,"BDT",N),"~") W:START="" ! "RTN","XDRMERG2",176,0) . S X=$P(XJOB,U) I X'="" D DATE8 W ?36,X "RTN","XDRMERG2",177,0) . I X="" D "RTN","XDRMERG2",178,0) . . S X=$P(XJOB,U,2) D DATE8 W ?36,X "RTN","XDRMERG2",179,0) . . W ?50,$P(XJOB,U,3),?55,$P(XJOB,U,4),?64," ",$P(XJOB,U,5) "RTN","XDRMERG2",180,0) . . I $P(^TMP($J,"BDT",N),"~")="E" S N=N+1 W !?5,"ERROR: ",$E($P(^TMP($J,"BDT",N),"~"),1,230),! "RTN","XDRMERG2",181,0) K ^TMP($J,"BDT") "RTN","XDRMERG2",182,0) ; "RTN","XDRMERG2",183,0) D PAUSE^BPMU ;IHS/OIT/LJF 02/09/2007 PATCH 1003 "RTN","XDRMERG2",184,0) Q "RTN","XDRMERG2",185,0) ; "RTN","XDRMERG2",186,0) HEADER ;REM -9/25/96 Write header. "RTN","XDRMERG2",187,0) W !,?55,"Current",?65,"Current" "RTN","XDRMERG2",188,0) W !,"Merge Set Start Stat Last Chk Phase File Entry",! "RTN","XDRMERG2",189,0) Q "RTN","XDRMERG2",190,0) ; "RTN","XDRMERG2",191,0) DATE8 ; "RTN","XDRMERG2",192,0) N X1 "RTN","XDRMERG2",193,0) I X="" S X=" " Q "RTN","XDRMERG2",194,0) S X1=X "RTN","XDRMERG2",195,0) S X=$E(X1,4,5)_"/"_$E(X1,6,7)_" " "RTN","XDRMERG2",196,0) S X1=$P(X1,".",2)_"000000" "RTN","XDRMERG2",197,0) S X=X_$E(X1,1,2)_":"_$E(X1,3,4) "RTN","XDRMERG2",198,0) Q "RTN","XDRMERG2",199,0) ; "RTN","XDRMERG2",200,0) ONESET(FILE,SPECIAL) ; "RTN","XDRMERG2",201,0) N JOBNUM,JVAL "RTN","XDRMERG2",202,0) I FILE'["VA" S JVAL=0 F JOBNUM=0:0 S JOBNUM=$O(@FILE@("START",JOBNUM)) Q:JOBNUM'>0 S JVAL=JVAL+1 D LOOP "RTN","XDRMERG2",203,0) I FILE'["VA" Q "RTN","XDRMERG2",204,0) LOOP S N=N+1 I $D(^TMP($J,"BDT",N)) G LOOP "RTN","XDRMERG2",205,0) I 'SPECIAL S START=$S(FILE'["VA":@FILE@("START",JOBNUM),$P(@FILE@(0),U,5)>0:$P(^(0),U,5),1:$P(^(0),U,3)) I 1 "RTN","XDRMERG2",206,0) I SPECIAL S START=$S($P(@FILE@(0),U,4)>0:$P(^(0),U,4),1:$P(^(0),U,2)) "RTN","XDRMERG2",207,0) S XNAME=$S(XDRFIL'["VA":XJOB_" J"_JVAL_" ",'SPECIAL:$P(@FILE@(0),U),1:" "_$E($P(@FILE@(0),U),1,15)) "RTN","XDRMERG2",208,0) I XDRFIL["VA" S ^TMP($J,"BDT",N)=$S('SPECIAL:$P(@FILE@(0),U,4),1:$P(@FILE@(0),U,3)) "RTN","XDRMERG2",209,0) E S ^TMP($J,"BDT",N)=$S($D(@FILE@("DONE",JOBNUM)):"C",1:"A") "RTN","XDRMERG2",210,0) I ^TMP($J,"BDT",N)="E" S ^TMP($J,"BDT",N+1)=$G(@FILE@(2)) "RTN","XDRMERG2",211,0) S XJOB=$S(XDRFIL'["VA":$G(@FILE@("DONE",JOBNUM)),'SPECIAL:$P(@FILE@(0),U,6),1:$P(@FILE@(0),U,5)) "RTN","XDRMERG2",212,0) I XJOB="" D "RTN","XDRMERG2",213,0) . S XJOB=XJOB_U_$S(XDRFIL'["VA":$G(@FILE@("TIME",JOBNUM)),1:$G(@FILE@(1))) "RTN","XDRMERG2",214,0) . I XDRFIL'["VA"!SPECIAL,^TMP($J,"BDT",N)="A",$$FMDIFF^XLFDT($$NOW^XLFDT(),$P(XJOB,U,2),2)>43000 D "RTN","XDRMERG2",215,0) . . S ^TMP($J,"BDT",N)="U" "RTN","XDRMERG2",216,0) . . I XDRFIL["VA" D "RTN","XDRMERG2",217,0) . . . S $P(@FILE@(0),U,3)="U" "RTN","XDRMERG2",218,0) . I ^TMP($J,"BDT",N)="U",XDRFIL["VA",SPECIAL,$$FMDIFF^XLFDT($$NOW^XLFDT(),$P(XJOB,U,2),2)'>43000 S ^TMP($J,"BDT",N)="A",$P(@FILE@(0),U,3)="A" "RTN","XDRMERG2",219,0) S ^TMP($J,"BDT",N)=$P(^TMP($J,"BDT",N),"~")_"~"_XNAME_"~"_START_"~"_XJOB "RTN","XDRMERG2",220,0) Q "RTN","XDRMERGA") 0^9^B69423089 "RTN","XDRMERGA",1,0) XDRMERGA ;SF-IRMFO.SEA/JLI - START OF NON-INTERACTIVE BATCH MERGE ;01/31/2000 09:14 [ 04/02/2003 8:47 AM ] "RTN","XDRMERGA",2,0) ;;7.3;TOOLKIT;**23,28,37,40,45,1001,1003**;Apr 03, 1995 "RTN","XDRMERGA",3,0) ;IHS/OIT/LJF 11/03/2006 PATCH 1003 if none found to mark, say so (communicate with user) "RTN","XDRMERGA",4,0) ; 01/19/2007 PATCH 1003 added IHS chart # to approval display "RTN","XDRMERGA",5,0) ;; "RTN","XDRMERGA",6,0) Q "RTN","XDRMERGA",7,0) APPROVE ; This is the entry point for approving a duplicate pair for merge "RTN","XDRMERGA",8,0) K DIRUT,DUOUT,DTOUT ; "RTN","XDRMERGA",9,0) D EN^XDRVCHEK ; update verified and/or ready to merge statuses if necessary "RTN","XDRMERGA",10,0) ; "RTN","XDRMERGA",11,0) N XDRXX,XDRYY,XDRMA,DIE,DIC,DIR,DR,ZTDTH,ZTSK "RTN","XDRMERGA",12,0) N XDRX,XDRY,XDRFIL,XDRGLOB,X,Y,XDRNAME "RTN","XDRMERGA",13,0) N XDRFDA,XDRIENS,XDRI,XDRJ,XDRK,DA,DIK "RTN","XDRMERGA",14,0) ; "RTN","XDRMERGA",15,0) S XDRFIL=$$FILE^XDRDPICK() Q:XDRFIL'>0 "RTN","XDRMERGA",16,0) S XDRDIC=^DIC(XDRFIL,0,"GL") "RTN","XDRMERGA",17,0) S XDRGLOB=$E(XDRDIC,2,999) "RTN","XDRMERGA",18,0) S X="" "RTN","XDRMERGA",19,0) S XNCNT=0,XNCNT0=0 "RTN","XDRMERGA",20,0) F S X=$O(^VA(15,"AVDUP",XDRGLOB,X)) Q:X="" S Y=$O(^(X,0)) D "RTN","XDRMERGA",21,0) . N YVAL S YVAL=^VA(15,Y,0) "RTN","XDRMERGA",22,0) . I $P(YVAL,U,20)>0 Q ; ALREADY DONE OR SCHEDULED "RTN","XDRMERGA",23,0) . I $P(YVAL,U,3)'="V" Q ; TAKE ONLY VERIFIED "RTN","XDRMERGA",24,0) . I $P(YVAL,U,5)'=1 Q ; TAKE ONLY IF MARKED READY TO MERGE "RTN","XDRMERGA",25,0) . I $P(YVAL,U,4)="" D Q ; MAKE SURE MERGE DIRECTION IS DEFINED "RTN","XDRMERGA",26,0) . . W !,"Entry `",Y," DOES NOT HAVE MERGE DIRECTION DEFINED - CAN'T APPROVE" "RTN","XDRMERGA",27,0) . . N XDRDICA S XDRDICA=U_$P($P(YVAL,U),";",2) "RTN","XDRMERGA",28,0) . . I '$D(@(XDRDICA_(+YVAL)_",0)"))!$D(@(XDRDICA_(+YVAL)_",-9)"))!'$D(@(XDRDICA_(+$P(YVAL,U,2))_",0)"))!$D(@(XDRDICA_(+$P(YVAL,U,2))_",-9)")) D Q "RTN","XDRMERGA",29,0) . . . D RESET^XDRDPICK(Y) "RTN","XDRMERGA",30,0) . I $P(YVAL,U,13)'>0 D "RTN","XDRMERGA",31,0) . . I $P(YVAL,U,4)'=2 S XDRY(+YVAL,+$P(YVAL,U,2))=Y "RTN","XDRMERGA",32,0) . . E S XDRY(+$P(YVAL,U,2),+YVAL)=Y "RTN","XDRMERGA",33,0) . . S XNCNT0=XNCNT0+1 "RTN","XDRMERGA",34,0) I XNCNT0>0 W !!,XNCNT0," Entries are awaiting approval for merging Return to continue..." R X:DTIME "RTN","XDRMERGA",35,0) ; "RTN","XDRMERGA",36,0) ;IHS/OIT/LJF 11/03/2006 PATCH 1003 if none found, say so "RTN","XDRMERGA",37,0) I XNCNT0=0 W !!," No Verified Duplicates waiting to be marked as Ready" D PAUSE^BPMU Q "RTN","XDRMERGA",38,0) ; "RTN","XDRMERGA",39,0) I $D(XDRY) D CHKBKUP I $D(DUOUT)!$D(DTOUT) Q "RTN","XDRMERGA",40,0) K XDRY "RTN","XDRMERGA",41,0) Q "RTN","XDRMERGA",42,0) ; "RTN","XDRMERGA",43,0) STOP ; "RTN","XDRMERGA",44,0) N XDRI,DIE,DA,DR,DIR,XDRC "RTN","XDRMERGA",45,0) S XDRC=0 F XDRI=0:0 S XDRI=$O(^VA(15.2,XDRI)) Q:XDRI'>0 I $P(^(XDRI,0),U,4)="A" D "RTN","XDRMERGA",46,0) . S XDRC=XDRC+1 "RTN","XDRMERGA",47,0) . S DIR(0)="Y",DIR("A")="Do you want to stop "_$P(^VA(15.2,XDRI,0),U) "RTN","XDRMERGA",48,0) . D ^DIR K DIR I Y'>0 Q "RTN","XDRMERGA",49,0) . S DIE="^VA(15.2,",DA=XDRI,DR=".09///1" D ^DIE "RTN","XDRMERGA",50,0) . K DIE,DR "RTN","XDRMERGA",51,0) I XDRC'>0 W !!,$C(7),"No active merge processes were found.",!! "RTN","XDRMERGA",52,0) Q "RTN","XDRMERGA",53,0) ; "RTN","XDRMERGA",54,0) CHKBKUP ; Check if backups have been generated for outstanding pairs "RTN","XDRMERGA",55,0) N I,J,X,Y,X1,X2,XNCNT,I,J,K,L,M,N,XX "RTN","XDRMERGA",56,0) K DIR "RTN","XDRMERGA",57,0) ;S DIR("A")="Do you want to check pairs awaiting backups (Y/N)" "RTN","XDRMERGA",58,0) ;S DIR("?")="Indication that a backup of the data for the entries for a duplicate pair is required prior to merging the entries. You may review entries to see if any should be marked as completed." "RTN","XDRMERGA",59,0) ;S DIR(0)="Y" D ^DIR K DIR Q:Y'>0 "RTN","XDRMERGA",60,0) S ASKNAME="ASK1" D CHECK "RTN","XDRMERGA",61,0) Q "RTN","XDRMERGA",62,0) ; "RTN","XDRMERGA",63,0) CHECK ; "RTN","XDRMERGA",64,0) W @IOF "RTN","XDRMERGA",65,0) S XNCNT=0 "RTN","XDRMERGA",66,0) F I=0:0 S I=$O(XDRY(I)) Q:I'>0 D Q:$D(DUOUT)!$D(DTOUT) "RTN","XDRMERGA",67,0) . F J=0:0 S J=$O(XDRY(I,J)) Q:J'>0 D Q:$D(DUOUT)!$D(DTOUT) "RTN","XDRMERGA",68,0) . . S X01=$G(@(XDRDIC_I_",0)")),X1=$P(X01,U),X1S=$P(X01,U,9),X1S=$E(X1S,1,3)_"-"_$E(X1S,4,5)_"-"_$E(X1S,6,15) "RTN","XDRMERGA",69,0) . . S X02=$G(@(XDRDIC_J_",0)")),X2=$P(X02,U),X2S=$P(X02,U,9),X2S=$E(X2S,1,3)_"-"_$E(X2S,4,5)_"-"_$E(X2S,6,15) "RTN","XDRMERGA",70,0) . . I X1=""!(X2="") K XDRY(I,J) Q "RTN","XDRMERGA",71,0) . . F Q:X1'["MERGING INTO" S X1=$P($P(X1,"(",2,10),")",1,$L(X1,")")-1) "RTN","XDRMERGA",72,0) . . S XNCNT=XNCNT+1,XX(XNCNT)=I_U_J "RTN","XDRMERGA",73,0) . . ; "RTN","XDRMERGA",74,0) . . ;IHS/OIT/LJF 01/19/2007 PATCH 1003 add IHS chart # to display "RTN","XDRMERGA",75,0) . . ;W !!,$J(XNCNT,3)," ",?8,X1,?42,X1S,?60,"[",I,"]" "RTN","XDRMERGA",76,0) . . ;W !,?8,X2,?42,X2S,?60,"[",J,"]" "RTN","XDRMERGA",77,0) . . W !!,$J(XNCNT,3)," ",?8,X1,?42,X1S,?60,"[",I,"]",?70,"#",$$HRCN^BPMU(I,$G(DUZ(2))) "RTN","XDRMERGA",78,0) . . W !,?8,X2,?42,X2S,?60,"[",J,"]",?70,"#",$$HRCN^BPMU(J,$G(DUZ(2))) "RTN","XDRMERGA",79,0) . . ; "RTN","XDRMERGA",80,0) . . I '(XNCNT#6) D @ASKNAME Q:$D(DUOUT)!$D(DTOUT) W @IOF "RTN","XDRMERGA",81,0) I '($D(DUOUT)!$D(DTOUT)) D @ASKNAME "RTN","XDRMERGA",82,0) Q "RTN","XDRMERGA",83,0) ; "RTN","XDRMERGA",84,0) ASK1 ; "RTN","XDRMERGA",85,0) W ! S DIR(0)="LO^1:"_XNCNT,DIR("A")="Select entries to approve them for merging" "RTN","XDRMERGA",86,0) ;W !,"TEST" "RTN","XDRMERGA",87,0) D ^DIR K DIR K DIRUT Q:$D(DUOUT)!$D(DTOUT) "RTN","XDRMERGA",88,0) S K="" F S K=$O(Y(K)) Q:K="" S Y=Y(K) K Y(K) D "RTN","XDRMERGA",89,0) . F M=1:1 S N=$P(Y,",",M) Q:N="" D "RTN","XDRMERGA",90,0) . . S N1=+XX(N),N2=$P(XX(N),U,2) "RTN","XDRMERGA",91,0) . . S (DA,XDRX(N1,N2))=XDRY(N1,N2) "RTN","XDRMERGA",92,0) . . N I,J,K,M,N,N1,N2,X1,X2,X,DIE,DR,Y "RTN","XDRMERGA",93,0) . . S DIE="^VA(15," "RTN","XDRMERGA",94,0) . . S X=DT,X=$$FMTE^XLFDT(X,"2D") "RTN","XDRMERGA",95,0) . . S X=$P($P(^VA(200,DUZ,0),U),",",2)_" "_$P($P(^(0),U),",")_" (DUZ="_DUZ_") "_X "RTN","XDRMERGA",96,0) . . S DR=".13///1;.14///"_X "RTN","XDRMERGA",97,0) . . D ^DIE "RTN","XDRMERGA",98,0) Q "RTN","XDRMERGA",99,0) ; "RTN","XDRMERGA",100,0) RESTART ; Entry point to restart non-completed merges "RTN","XDRMERGA",101,0) N NC,N S NC=0 "RTN","XDRMERGA",102,0) F XDRFDA=0:0 S XDRFDA=$O(^VA(15.2,XDRFDA)) Q:XDRFDA'>0 D "RTN","XDRMERGA",103,0) . S X=$P(^VA(15.2,XDRFDA,0),U,4) I X="C"!(X="A") S N=1 D Q:N=1 "RTN","XDRMERGA",104,0) . . F J=0:0 S J=$O(^VA(15.2,XDRFDA,3,J)) Q:J'>0 I "CA"'[$P(^(J,0),U,3) S N=0 Q "RTN","XDRMERGA",105,0) . S NC=NC+1 "RTN","XDRMERGA",106,0) . S DIR(0)="Y",DIR("A")="Do you want to RESTART merge process "_$P(^VA(15.2,XDRFDA,0),U),DIR("B")="NO" "RTN","XDRMERGA",107,0) . D ^DIR K DIR Q:Y'>0 "RTN","XDRMERGA",108,0) . S ZTRTN="DQ^XDRMERG0",ZTSAVE("XDRFDA")="",ZTIO="NULL" "RTN","XDRMERGA",109,0) . D ^%ZTLOAD I '$D(ZTSK) W !!,$C(7),"RESTART **NOT** QUEUED" Q "RTN","XDRMERGA",110,0) . S $P(^VA(15.2,XDRFDA,0),U,8,9)=ZTSK_U ; SET TASK NUMBER AND REMOVE HALT FLAG IF SET "RTN","XDRMERGA",111,0) . W !,"Restart queued as task ",ZTSK,! "RTN","XDRMERGA",112,0) I NC'>0 W !!,$C(7),"No merge processes found that needed restarting.",!! "RTN","XDRMERGA",113,0) Q "RTN","XDRMERGA",114,0) ; "RTN","XDRMERGA",115,0) ; "RTN","XDRMERGA",116,0) DOSUBS(XDRFROM,XDRTO,IENTOSTR,XDRDASEQ) ; "RTN","XDRMERGA",117,0) N NODEA,SFILE,VALUE,XVALUE,XDRXX,XDRYY,YVALUE,XENTOSTR "RTN","XDRMERGA",118,0) N XDRAA,XDRZZ ; DEBUG STATEMENT "RTN","XDRMERGA",119,0) S SFILE=+$P($G(@(XDRFROM_"0)")),U,2) "RTN","XDRMERGA",120,0) I SFILE'>0 Q ; NO FILE NUMBER, NOT FILE MANAGER COMPATIBLE "RTN","XDRMERGA",121,0) I $P($G(^DD(SFILE,.01,0)),U,2)["W" D Q ; HANDLE WORD PROCESSING FIELDS "RTN","XDRMERGA",122,0) . N XF,XT S XT=$E(XDRTO,1,$L(XDRTO)-1)_")" "RTN","XDRMERGA",123,0) . I '$D(@XT) D "RTN","XDRMERGA",124,0) . . S XF=$E(XDRFROM,1,$L(XDRFROM)-1)_")" "RTN","XDRMERGA",125,0) . . M @XT=@XF "RTN","XDRMERGA",126,0) . . Q "RTN","XDRMERGA",127,0) . Q "RTN","XDRMERGA",128,0) F NODEA=0:0 S NODEA=$O(@(XDRFROM_NODEA_")")) Q:NODEA'>0 D "RTN","XDRMERGA",129,0) . S VALUE=$P($G(@(XDRFROM_NODEA_",0)")),U) ; GET .01 VALUE "RTN","XDRMERGA",130,0) . N XDRDT S XDRDT=^DD(SFILE,.01,0) "RTN","XDRMERGA",131,0) . I $P(XDRDT,U,2)["D" S XDRDT=$P(XDRDT,U,5,999),XDRDINUM=$S(XDRDT["DINUM":1,1:0) I XDRDINUM S XDRDT=0 D DINUMDAT Q:XDRDT ; HANDLE DINUMED DATES BY SIMPLY MOVING THEM "RTN","XDRMERGA",132,0) . S YVALUE=0,XVALUE=0 I $D(^DD(SFILE,.001,0)) S YVALUE=NODEA I $D(@(XDRTO_NODEA_")")) S XVALUE=YVALUE "RTN","XDRMERGA",133,0) . I XVALUE=0,$P(^DD(SFILE,.01,0),U,5,99)["DINUM",$D(@(XDRTO_NODEA_")")) S XVALUE=NODEA "RTN","XDRMERGA",134,0) . I XVALUE=0 S XVALUE=+$$FIND1^DIC(SFILE,(","_IENTOSTR),"Q",VALUE) ; FIND CURRENT ENTRY NUMBER, IF PRESENT "RTN","XDRMERGA",135,0) . I XVALUE>0 D Q ; SUBFILE EXISTS IN IENTO, CHECK FOR LOWER SUBFILES "RTN","XDRMERGA",136,0) . . N X,X1,NODE,NEWFROM,NEWTO,NEWTOIEN "RTN","XDRMERGA",137,0) . . S NODE="" "RTN","XDRMERGA",138,0) . . F S NODE=$O(@(XDRFROM_NODEA_","""_NODE_""")")) Q:NODE="" D "RTN","XDRMERGA",139,0) . . . I $D(@(XDRFROM_NODEA_","""_NODE_""")"))'>1 Q "RTN","XDRMERGA",140,0) . . . S NEWFROM=XDRFROM_NODEA_","""_NODE_"""," "RTN","XDRMERGA",141,0) . . . S NEWTO=XDRTO_XVALUE_","""_NODE_"""," "RTN","XDRMERGA",142,0) . . . S NEWTOIEN=XVALUE_","_IENTOSTR "RTN","XDRMERGA",143,0) . . . D DOSUBS(NEWFROM,NEWTO,NEWTOIEN,(XVALUE_U_XDRDASEQ)) "RTN","XDRMERGA",144,0) . K XDRYY I YVALUE>0 S XDRYY(1)=YVALUE "RTN","XDRMERGA",145,0) . S XENTOSTR="+1,"_IENTOSTR "RTN","XDRMERGA",146,0) . S XDRFILTY=$P($G(^DD(SFILE,.01,0)),U,2) "RTN","XDRMERGA",147,0) . I XDRFILTY["P" S VALUE="`"_VALUE "RTN","XDRMERGA",148,0) . I XDRFILTY["V" D "RTN","XDRMERGA",149,0) . . N Y S Y=$P(VALUE,";",2) Q:Y="" "RTN","XDRMERGA",150,0) . . S Y=$P($G(@("^"_Y_"0)")),U) Q:Y="" "RTN","XDRMERGA",151,0) . . S VALUE=Y_".`"_(+VALUE) "RTN","XDRMERGA",152,0) . . Q "RTN","XDRMERGA",153,0) . I SFILE=70.03 S XDRFILTY="D" ;use internal data for file 70.03 "RTN","XDRMERGA",154,0) . I XDRFILTY'["P"&(XDRFILTY'["V"),XDRFILTY'["D" S VALUE=$$GETEXT(XDRFROM,NODEA,SFILE) "RTN","XDRMERGA",155,0) . S XDRXX(SFILE,XENTOSTR,.01)=VALUE "RTN","XDRMERGA",156,0) . I $O(^DD(SFILE,0,"ID",0))>0 D "RTN","XDRMERGA",157,0) . . ;CODE FOR ADDING IDENTIFIERS "RTN","XDRMERGA",158,0) . . N I,N,XDRFROM1,IENFR "RTN","XDRMERGA",159,0) . . S N=0,I=SFILE F S I=$G(^DD(I,0,"UP")) Q:I'>0 S N=N+1 "RTN","XDRMERGA",160,0) . . S XDRFROM1=$P(XDRFROM,"(",2,99),IENFR=NODEA_"," "RTN","XDRMERGA",161,0) . . F I=$L(XDRFROM1,",")-2:-2 Q:N'>0 S IENFR=IENFR_$P(XDRFROM1,",",I)_",",N=N-1 "RTN","XDRMERGA",162,0) . . ; "RTN","XDRMERGA",163,0) . . F XDRID=0:0 S XDRID=$O(^DD(SFILE,0,"ID",XDRID)) Q:XDRID'>0 D "RTN","XDRMERGA",164,0) . . . S N=$$GET1^DIQ(SFILE,IENFR,XDRID) "RTN","XDRMERGA",165,0) . . . I N'="" S XDRXX(SFILE,XENTOSTR,XDRID)=N "RTN","XDRMERGA",166,0) . . . Q "RTN","XDRMERGA",167,0) . . Q "RTN","XDRMERGA",168,0) . ; "RTN","XDRMERGA",169,0) . K XDRAA,XDRZZ I $D(XDRTESTK) M XDRAA=XDRXX ; DEBUG STATEMENT "RTN","XDRMERGA",170,0) . ; DATES THAT ARE DINUMED HAVE BEEN HANDLED ABOVE, SO CAN PASS A DATE IN AS AN INTERNAL VALUE "RTN","XDRMERGA",171,0) . D UPDATE^DIE($S(XDRFILTY["D":"",1:"E"),"XDRXX","XDRYY","XDRZZ") ; CREATE A NEW ENTRY IN IENTO FOR VALUE "RTN","XDRMERGA",172,0) . I $D(XDRZZ),$D(XDRTESTK),SFILE'=2.0361 S XDRTESTK=XDRTESTK+1 M ^XTMP("XDRTESTK",$$NOW^XLFDT(),XDRTESTK,"XX")=XDRAA,^("ZZ")=XDRZZ ; DEBUG STATEMENT "RTN","XDRMERGA",173,0) . S NODEB=$G(XDRYY(1)) I NODEB'>0 Q "RTN","XDRMERGA",174,0) . M @(XDRTO_NODEB_")")=@(XDRFROM_NODEA_")") "RTN","XDRMERGA",175,0) . S DIK=XDRTO,DA=NODEB D "RTN","XDRMERGA",176,0) . . F I=1:1 S DA(I)=$P(XDRDASEQ,U,I) I DA(I)="" K DA(I) Q "RTN","XDRMERGA",177,0) . I SFILE=55.06 N DIU S DIU(0)=1 F DIK(1)=".01^B","10^AUDS","34^AUD","64^AUDDD","7^ACR1" D EN1^DIK "RTN","XDRMERGA",178,0) . I SFILE'=55.06 N DIU S DIU(0)=1 D IX^DIK "RTN","XDRMERGA",179,0) Q "RTN","XDRMERGA",180,0) ; "RTN","XDRMERGA",181,0) GETEXT(DICA,DA,FILNUM) ; GET EXTERNAL VALUE FOR .01 FIELD "RTN","XDRMERGA",182,0) N DIC,DIQ,DR,XDRQ "RTN","XDRMERGA",183,0) S DIC=DICA,DIC("P")=FILNUM,DR=.01,DIQ="XDRQ",DIQ(0)="E" "RTN","XDRMERGA",184,0) D EN^DIQ1 "RTN","XDRMERGA",185,0) Q $G(XDRQ(FILNUM,DA,.01,"E")) "RTN","XDRMERGA",186,0) ; "RTN","XDRMERGA",187,0) DINUMDAT ; PROCESS ENTRIES WITH SAMPLE DATE/TIMES WITH SECONDS, NEEDS DINUM "RTN","XDRMERGA",188,0) N NEWVAL,NODETO "RTN","XDRMERGA",189,0) S NODETO=NODEA "RTN","XDRMERGA",190,0) I $D(@(XDRTO_NODEA_")")) Q:(SFILE'=63.04) D "RTN","XDRMERGA",191,0) . S NEWVAL=VALUE "RTN","XDRMERGA",192,0) . F Q:'$D(@(XDRTO_NODETO_")")) S NODETO=NODETO-.000001,NEWVAL=NEWVAL+.000001 "RTN","XDRMERGA",193,0) M @(XDRTO_NODETO_")")=@(XDRFROM_NODEA_")") "RTN","XDRMERGA",194,0) I $D(NEWVAL) S $P(@(XDRTO_NODETO_",0)"),U)=NEWVAL "RTN","XDRMERGA",195,0) S DIK=XDRTO,DA=NODEA D D IX^DIK "RTN","XDRMERGA",196,0) . F I=1:1 S DA(I)=$P(XDRDASEQ,U,I) I DA(I)="" K DA(I) Q "RTN","XDRMERGA",197,0) S XDRDT=1 "RTN","XDRMERGA",198,0) Q "RTN","XDRMERGA",199,0) ; "RTN","XDRMERGA",200,0) DODIS ; CODE TO HANDLE DISPOSITION ENTRIES IN PATIENT FILE "RTN","XDRMERGA",201,0) N XDRI,DA,DIK "RTN","XDRMERGA",202,0) F XDRI=0:0 S XDRI=$O(@(XDRDIC_IENFROM_",""DIS"","_XDRI_")")) Q:XDRI'>0 D "RTN","XDRMERGA",203,0) . I $D(@(XDRDIC_IENTO_",""DIS"","_XDRI_")")) Q "RTN","XDRMERGA",204,0) . M @(XDRDIC_IENTO_",""DIS"","_XDRI_")")=@(XDRDIC_IENFROM_",""DIS"","_XDRI_")") "RTN","XDRMERGA",205,0) . S DA=XDRI,DA(1)=IENTO,DIK=XDRDIC_IENTO_",""DIS""," D IX^DIK "RTN","XDRMERGA",206,0) . Q "RTN","XDRMERGA",207,0) Q "RTN","XDRMERGA",208,0) ; "RTN","XDRMVFY") 0^10^B3436622 "RTN","XDRMVFY",1,0) XDRMVFY ;SF-IRMFO/IHS/OHPRD/JCM - VERIFY POTENTIAL DUPLICATES ;10/29/93 09:58 [ 04/02/2003 8:47 AM ] "RTN","XDRMVFY",2,0) ;;7.3;TOOLKIT;**23,1001,1003**;Apr 03, 1995 "RTN","XDRMVFY",3,0) ;IHS/OHPRD/JCM 03/26/1991 Inserted DITC+4-6 "RTN","XDRMVFY",4,0) ;IHS/OIRM/DSD/AEF 11/24/2002 uncommented IHS line that VA commented out "RTN","XDRMVFY",5,0) ;IHS/OIT/LJF 11/02/2006 PATCH 1003 changed call from ^DTPDZCH to ^BPMHRCN "RTN","XDRMVFY",6,0) ; "RTN","XDRMVFY",7,0) START ; "RTN","XDRMVFY",8,0) D DITC "RTN","XDRMVFY",9,0) G:XDRQFLG END "RTN","XDRMVFY",10,0) D VERIFY "RTN","XDRMVFY",11,0) G:XDRQFLG!(XDRMSTAT="") END "RTN","XDRMVFY",12,0) D STATUS "RTN","XDRMVFY",13,0) END D EOJ "RTN","XDRMVFY",14,0) Q "RTN","XDRMVFY",15,0) ; "RTN","XDRMVFY",16,0) DITC ; "RTN","XDRMVFY",17,0) S DIT(1)=XDRMCD,DIT(2)=XDRMCD2,DFF=XDRFL,IOP=IO(0) "RTN","XDRMVFY",18,0) D EN^DITC K IOP "RTN","XDRMVFY",19,0) I $D(DUOUT)!($D(DTOUT))!($D(DIRUT)) S XDRQFLG=1 K DIRUT,DUOUT,DTOUT "RTN","XDRMVFY",20,0) ;********************************* "RTN","XDRMVFY",21,0) ;I $G(DUZ("AG"))="I",'XDRQFLG,XDRFL=2 D ^DPTDZCH ;IHS/OHPRD/JCM 3/26/91 ;THIS LINE WAS COMMENTED OUT BY THE VA, I UNCOMMENTED THE LINE IHS/OIRM/DSD/AEF/ 11/24/02 "RTN","XDRMVFY",22,0) I $$GET^XPAR("PKG","BPM USE IHS LOGIC"),$L($T(^BPMHRCN)),'XDRQFLG,XDRFL=2 D ^BPMHRCN ;IHS/OIT/LJF 11/02/2006 PATCH 1003 changed namespace "RTN","XDRMVFY",23,0) ;********************************* "RTN","XDRMVFY",24,0) Q "RTN","XDRMVFY",25,0) ; "RTN","XDRMVFY",26,0) VERIFY ; Verifies if duplicate or not. "RTN","XDRMVFY",27,0) S XDRMSTAT="" "RTN","XDRMVFY",28,0) S DIR(0)="S^V:VERIFIED DUPLICATE;N:VERIFIED, NOT A DUPLICATE;U:UNABLE TO MAKE DETERMINATION" "RTN","XDRMVFY",29,0) S DIR("A")="Verification status of potential duplicate pair" "RTN","XDRMVFY",30,0) D ^DIR K DIR "RTN","XDRMVFY",31,0) I $D(DUOUT)!($D(DTOUT)) S XDRQFLG=1 G VERIFYX "RTN","XDRMVFY",32,0) S XDRMSTAT=$S(Y="V":"V",Y="N":"N",1:"") "RTN","XDRMVFY",33,0) VERIFYX Q "RTN","XDRMVFY",34,0) ; "RTN","XDRMVFY",35,0) STATUS ; "RTN","XDRMVFY",36,0) S DIE="^VA(15,",DA=XDRMPDA,DIE("NO^")=1,DR=".03///"_XDRMSTAT "RTN","XDRMVFY",37,0) S:XDRMSTAT="V" XDRMRG=1,DR=DR_";.04//2" "RTN","XDRMVFY",38,0) D ^DIE K DIE,DR,DA "RTN","XDRMVFY",39,0) Q "RTN","XDRMVFY",40,0) ; "RTN","XDRMVFY",41,0) EOJ ; "RTN","XDRMVFY",42,0) K DIT,DFF,IOP,XDRMSTAT,DIRUT "RTN","XDRMVFY",43,0) Q "RTN","XDRMVFY",44,0) ;******************************************** "RTN","XDRMVFY",45,0) ; EN entry point added specifically for APMFVFY for MFI "RTN","XDRMVFY",46,0) EN ; "RTN","XDRMVFY",47,0) S XDRQFLG=0 "RTN","XDRMVFY",48,0) D DITC "RTN","XDRMVFY",49,0) G:XDRQFLG ENX "RTN","XDRMVFY",50,0) D VERIFY "RTN","XDRMVFY",51,0) ENX K DIT,DFF,IOP "RTN","XDRMVFY",52,0) Q "RTN","XDRRMRG1") 0^11^B70245249 "RTN","XDRRMRG1",1,0) XDRRMRG1 ;SF-IRMFO.SEA/JLI - DUP VERIFICATION FOR ANCILLARY SERVICES ;08/09/2000 11:12 [ 04/02/2003 8:47 AM ] "RTN","XDRRMRG1",2,0) ;;7.3;TOOLKIT;**23,29,46,47,49,1001,1003**;Apr 03, 1995 "RTN","XDRRMRG1",3,0) ;IHS/OIT/LJF 07/28/2006 PATCH 1003 display IHS Patient file fields (multiple lines changed or added) "RTN","XDRRMRG1",4,0) ; "RTN","XDRRMRG1",5,0) EN ; "RTN","XDRRMRG1",6,0) I '$D(XQADATA) Q "RTN","XDRRMRG1",7,0) N OVERWRIT,XDRDA,DFNFR,DFNTO,DFNFRX,DFNTOX,REVIEW,XDRGL,PRIFILE ; MODIFIED 03/28/00 "RTN","XDRRMRG1",8,0) S REVIEW=0 "RTN","XDRRMRG1",9,0) S XDRGL=$P($P($G(^VA(15,+XQADATA,0)),U),";",2) Q:XDRGL="" S XDRGL=U_XDRGL S PRIFILE=+$P(@(XDRGL_"0)"),U,2) ; MODIFIED 03/28/00 "RTN","XDRRMRG1",10,0) S XDRDA=$P(XQADATA,U) "RTN","XDRRMRG1",11,0) S DFNFR=$P(XQADATA,U,2) "RTN","XDRRMRG1",12,0) S (DFNTOX,DFNTO)=$P(DFNFR,";",2) "RTN","XDRRMRG1",13,0) S (DFNFRX,DFNFR)=$P(DFNFR,";") "RTN","XDRRMRG1",14,0) S PACKAGE=$P(XQADATA,U,3) "RTN","XDRRMRG1",15,0) S SUBFILES=$P(XQADATA,U,5) "RTN","XDRRMRG1",16,0) S SUBNAMES=$P(XQADATA,U,6) "RTN","XDRRMRG1",17,0) S XDRFILE=$P(XQADATA,U,4) "RTN","XDRRMRG1",18,0) S FILEDIC=^DIC(XDRFILE,0,"GL")_"DFN)" "RTN","XDRRMRG1",19,0) I XDRGL="^DPT(" D "RTN","XDRRMRG1",20,0) . S DFN=DFNFR D ^VADPT M DFNFR=VADM K VA,VADM "RTN","XDRRMRG1",21,0) . S DFN=DFNTO D ^VADPT M DFNTO=VADM K VA,VADM "RTN","XDRRMRG1",22,0) I XDRFILE=63 D "RTN","XDRRMRG1",23,0) . S DFNFR=$G(^DPT(DFNFR,"LR")) "RTN","XDRRMRG1",24,0) . S DFNTO=$G(^DPT(DFNTO,"LR")) "RTN","XDRRMRG1",25,0) I DFNFR'>0!(DFNTO'>0) W !,$C(7),"NO DATA TO REVIEW....",!! Q "RTN","XDRRMRG1",26,0) LDATE F XDRI=1,2 S DFN=$S(XDRI=1:DFNFR,1:DFNTO) S DFNNAM=$S(XDRI=1:"DFNFR",1:"DFNTO") D "RTN","XDRRMRG1",27,0) . S I=5 F S I=$O(@DFNNAM@(I)) Q:I="" K @DFNNAM@(I) "RTN","XDRRMRG1",28,0) . F ISUBS=1:1 S SUBSCR=$P(SUBFILES,";",ISUBS) Q:SUBSCR="" D "RTN","XDRRMRG1",29,0) . . S XX=$G(^DD(XDRFILE,SUBSCR,0)) "RTN","XDRRMRG1",30,0) . . I $P(XX,U,2)'["D" Q "RTN","XDRRMRG1",31,0) . . I $P($P(XX,U,4),";",2)'=0 Q "RTN","XDRRMRG1",32,0) . . S SUBSCR=$P($P(XX,U,4),";") "RTN","XDRRMRG1",33,0) . . N XDAT1 S XDAT1=0 "RTN","XDRRMRG1",34,0) . . I DFN>0 F I=0:0 S I=$O(@FILEDIC@(SUBSCR,I)) Q:I'>0 D "RTN","XDRRMRG1",35,0) . . . S X=$P($G(@FILEDIC@(SUBSCR,I,0)),U) "RTN","XDRRMRG1",36,0) . . . I XXDAT1 S XDAT1=X "RTN","XDRRMRG1",37,0) . . S LASTNAM="LAST "_$P(SUBNAMES,";",ISUBS) "RTN","XDRRMRG1",38,0) . . S @DFNNAM@(LASTNAM)="" "RTN","XDRRMRG1",39,0) . . I XDAT1>0 S @DFNNAM@(LASTNAM)=$$FMTE^XLFDT(XDAT1\1) "RTN","XDRRMRG1",40,0) . I @DFNNAM'="",'$D(@FILEDIC) S @DFNNAM="" "RTN","XDRRMRG1",41,0) ; "RTN","XDRRMRG1",42,0) ;IHS/OIT/LJF 07/28/2006 PATCH 1003 "RTN","XDRRMRG1",43,0) ;D SHOW "RTN","XDRRMRG1",44,0) I XDRFILE=2,$$GET^XPAR("PKG","BPM USE IHS LOGIC") D S XDRFILE=2 "RTN","XDRRMRG1",45,0) . F XDRFILE=2,9000001 D SHOW Q:$D(DIRUT) "RTN","XDRRMRG1",46,0) E D SHOW "RTN","XDRRMRG1",47,0) ; "RTN","XDRRMRG1",48,0) S:XDRFILE'=63 DFNFR=DFNFRX,DFNTO=DFNTOX ;REM - LAB is handled differently "RTN","XDRRMRG1",49,0) I IOST'["C-" Q "RTN","XDRRMRG1",50,0) D CHK "RTN","XDRRMRG1",51,0) Q "RTN","XDRRMRG1",52,0) ; "RTN","XDRRMRG1",53,0) SHOW ; "RTN","XDRRMRG1",54,0) N NAMIEN1,NAMIEN2 "RTN","XDRRMRG1",55,0) S N1=$$COUNT^XDRRMRG2(XDRFILE,DFNFRX,DFNTOX) "RTN","XDRRMRG1",56,0) W @IOF I N1>0,PACKAGE="PRIMARY" W !," RECORD"_N1_" contains fewer data elements, usually this would indicate",!," that this record would be merged INTO the other." "RTN","XDRRMRG1",57,0) ;S LABEL(1)="NAME",LABEL(2)="SSN",LABEL(3)="BIRTH DATE" "RTN","XDRRMRG1",58,0) ;S LABEL(4)="AGE",LABEL(5)="SEX",LABEL("LASTDAT")="LAST DATE" "RTN","XDRRMRG1",59,0) W !!,"Determine if these entries ARE or ARE NOT duplicates." "RTN","XDRRMRG1",60,0) W ! "RTN","XDRRMRG1",61,0) ;REM - Modified next three lines to include IENs by patient name. "RTN","XDRRMRG1",62,0) I XDRFILE=63 S NAMIEN1=$$LABIEN^XDRRMRG2(XDRFILE,DFNFR),NAMIEN2=$$LABIEN^XDRRMRG2(XDRFILE,DFNTO) "RTN","XDRRMRG1",63,0) ;W !,?20,$S(PACKAGE="PRIMARY":"RECORD1 [#"_DFNFR_"]",PACKAGE="LABORATORY":"MERGE FROM [#"_NAMIEN1_"]",1:"MERGE FROM [#"_DFNFR_"]") "RTN","XDRRMRG1",64,0) ;W ?45,$S(PACKAGE="PRIMARY":"RECORD2 [#"_DFNTO_"]",PACKAGE="LABORATORY":"MERGE TO [#"_NAMIEN2_"]",1:"MERGE TO [#"_DFNTO_"]") "RTN","XDRRMRG1",65,0) ;S I="" F S I=$O(DFNFR(I)) Q:I="" D "RTN","XDRRMRG1",66,0) ;. I DFNFR(I)=""&(DFNTO(I)="") Q "RTN","XDRRMRG1",67,0) ;. S DFNFR(I)=$S($P(DFNFR(I),U,2)'="":$P(DFNFR(I),U,2),1:$P(DFNFR(I),U)) "RTN","XDRRMRG1",68,0) ;. S DFNTO(I)=$S($P(DFNTO(I),U,2)'="":$P(DFNTO(I),U,2),1:$P(DFNTO(I),U)) "RTN","XDRRMRG1",69,0) ;. W !,$S($D(LABEL(I)):LABEL(I),1:I),?20,$E(DFNFR(I),1,20),?45,$E(DFNTO(I),1,20) "RTN","XDRRMRG1",70,0) ;. I I=1!(I=5) W ! "RTN","XDRRMRG1",71,0) ;I DFNFR=""!(DFNTO="") D "RTN","XDRRMRG1",72,0) ;. I DFNFR=""&(DFNTO="") W !!,"There is NO DATA in the "_PACKAGE_" file for either entry." Q "RTN","XDRRMRG1",73,0) ;. I DFNFR="" W !!,"There is NO DATA in the "_PACKAGE_" file for (",DFNFRX,") ",DFNFR(1)," ",DFNFR(2) "RTN","XDRRMRG1",74,0) ;. I DFNTO="" W !!,"There is NO DATA in the "_PACKAGE_" file for (",DFNTOX,") ",DFNTO(1)," ",DFNTO(2) "RTN","XDRRMRG1",75,0) ;S DIR(0)="E" D ^DIR K DIR Q:$D(DIRUT) "RTN","XDRRMRG1",76,0) ;I DFNFR=""!(DFNTO="") Q "RTN","XDRRMRG1",77,0) ;S DIT(1)=DFNFR,DIT(2)=DFNTO,IOP=IO(0),DFF=XDRFILE,DIC=XDRFILE "RTN","XDRRMRG1",78,0) D SHOW^XDRDSHOW(XDRFILE,DFNFR,DFNTO,.OVERWRIT,REVIEW) ;D EN^DITC K IOP "RTN","XDRRMRG1",79,0) Q "RTN","XDRRMRG1",80,0) ; "RTN","XDRRMRG1",81,0) CHK ; "RTN","XDRRMRG1",82,0) N DIR "RTN","XDRRMRG1",83,0) CHK1 K DIR "RTN","XDRRMRG1",84,0) ; "RTN","XDRRMRG1",85,0) S DIR(0)="S^V:VERIFIED DUPLICATE;N:VERIFIED, NOT A DUPLICATE;U:UNABLE TO DETERMINE;H:HEALTH SUMMARY;R:REVIEW DATA AGAIN;S:SELECT/REVIEW OVERWRITES",DIR("A")="Select Action",DIR("B")="HEALTH SUMMARY" "RTN","XDRRMRG1",86,0) ; "RTN","XDRRMRG1",87,0) ;IHS/OIT/LJF 07/28/2006 PATCH 1003 removed select/review overwrites (put under Verify) "RTN","XDRRMRG1",88,0) I $$GET^XPAR("PKG","BPM USE IHS LOGIC") S DIR(0)="S^V:VERIFIED DUPLICATE;N:VERIFIED, NOT A DUPLICATE;U:UNABLE TO DETERMINE;H:HEALTH SUMMARY;R:REVIEW DATA AGAIN" "RTN","XDRRMRG1",89,0) ; "RTN","XDRRMRG1",90,0) D ^DIR K DIR S XDRY=Y I $D(DIRUT) K XQAKILL Q "RTN","XDRRMRG1",91,0) ; "RTN","XDRRMRG1",92,0) ;IHS/OIT/LJF 07/28/2006 PATCH 1003 show IHS patient file fields & allow users to mark overwrites before "V" "RTN","XDRRMRG1",93,0) ;I XDRY="R" S REVIEW=0 D SHOW G CHK1 "RTN","XDRRMRG1",94,0) I XDRY="R",'$$GET^XPAR("PKG","BPM USE IHS LOGIC") S REVIEW=0 D SHOW G CHK1 "RTN","XDRRMRG1",95,0) I XDRY="R" S REVIEW=0 D G CHK1 "RTN","XDRRMRG1",96,0) . F XDRFILE=2,9000001 D SHOW Q:$D(DIRUT) "RTN","XDRRMRG1",97,0) ; "RTN","XDRRMRG1",98,0) I XDRY="S" S REVIEW=1 D SHOW G CHK1 "RTN","XDRRMRG1",99,0) I XDRY'="H" D Q "RTN","XDRRMRG1",100,0) . K XQAKILL "RTN","XDRRMRG1",101,0) . I XDRY'="^" D "RTN","XDRRMRG1",102,0) . . S XQAKILL=$S(XDRY'="U":0,1:1) "RTN","XDRRMRG1",103,0) . . S XDRDIR="" "RTN","XDRRMRG1",104,0) . . I XDRY="V",PACKAGE="PRIMARY" D "RTN","XDRRMRG1",105,0) . . . S DIR=0 F DFN=DFNFRX,DFNTOX I $D(@FILEDIC) S DIR=DIR+1 "RTN","XDRRMRG1",106,0) . . . I DIR'>1 K DIR Q ; DON'T NEED TO SELECT DIRECTION UNLESS DATA IN BOTH ENTRIES "RTN","XDRRMRG1",107,0) . . . S DIR("B")=$$COUNT^XDRRMRG2(XDRFILE,DFNFRX,DFNTOX) "RTN","XDRRMRG1",108,0) . . . S DIR("B")=$S(DIR("B")'>1:"RECORD1 INTO RECORD2",1:"RECORD2 INTO RECORD1") "RTN","XDRRMRG1",109,0) . . . I DIR("B")=0 K DIR("B") "RTN","XDRRMRG1",110,0) . . . S DIR(0)="S^1:RECORD1 INTO RECORD2;2:RECORD2 INTO RECORD1" "RTN","XDRRMRG1",111,0) . . . W !!!,?20,"RECORD1 [#"_DFNFR_"]",?45,"RECORD2 [#"_DFNTO_"]" "RTN","XDRRMRG1",112,0) . . . W !,?20,DFNFR(1),?45,DFNTO(1) "RTN","XDRRMRG1",113,0) . . . S DIR("A")="Which record (1 or 2) should be MERGED INTO the other record" "RTN","XDRRMRG1",114,0) . . . D ^DIR K DIR I Y>0 S XDRDIR=+Y "RTN","XDRRMRG1",115,0) . . . I $D(DIRUT) S XDRY="^" W !!!,$C(7),"VERIFICATION ABORTED!",! Q "RTN","XDRRMRG1",116,0) . . . I DFNFRX'=+^VA(15,XDRDA,0) S XDRDIR=$S(XDRDIR'>0:2,XDRDIR=1:2,1:1) "RTN","XDRRMRG1",117,0) . . N XDRFDA,XDRDA1 "RTN","XDRRMRG1",118,0) . . S XDRDA1=$$FIND1^DIC(15.02,","_XDRDA_",","X",PACKAGE) "RTN","XDRRMRG1",119,0) . . S XDRDA1=$S(XDRDA1>0:XDRDA1_",",1:"+1,")_XDRDA_"," "RTN","XDRRMRG1",120,0) . . S XDRFDA(15.02,XDRDA1,.01)=PACKAGE "RTN","XDRRMRG1",121,0) . . S XDRFDA(15.02,XDRDA1,.02)=XDRY "RTN","XDRRMRG1",122,0) . . S XDRFDA(15.02,XDRDA1,.03)=DUZ "RTN","XDRRMRG1",123,0) . . S XDRFDA(15.02,XDRDA1,.04)=$$NOW^XLFDT() "RTN","XDRRMRG1",124,0) . . I XDRDIR'="" S XDRFDA(15.02,XDRDA1,.05)=XDRDIR "RTN","XDRRMRG1",125,0) . . D UPDATE^DIE("S","XDRFDA") "RTN","XDRRMRG1",126,0) . . ; "RTN","XDRRMRG1",127,0) . . ;IHS/OIT/LJF 07/28/2006 PATCH 1003 line added for overwrites to 2 patient files "RTN","XDRRMRG1",128,0) . . I $$GET^XPAR("PKG","BPM USE IHS LOGIC"),$L($T(OVERWRIT^BPMVER)),XDRY="V" F XDRFILE=2,9000001 S REVIEW=1 D SHOW I $D(OVERWRIT) D OVERWRIT^BPMVER(XDRFILE,XDRDA,.OVERWRIT) K OVERWRIT "RTN","XDRRMRG1",129,0) . . ; "RTN","XDRRMRG1",130,0) . . I $D(OVERWRIT)!(XDRDIR=2&(PACKAGE'="PRIMARY")) D "RTN","XDRRMRG1",131,0) . . . N I "RTN","XDRRMRG1",132,0) . . . S XDRDA1=$$FIND1^DIC(15.03,","_XDRDA_",","X",XDRFILE) "RTN","XDRRMRG1",133,0) . . . I XDRDA1'>0 D "RTN","XDRRMRG1",134,0) . . . . S XDRDA1="+1,"_XDRDA_"," "RTN","XDRRMRG1",135,0) . . . . K XDRFDA,XDRDAX "RTN","XDRRMRG1",136,0) . . . . S XDRDAX(1)=XDRFILE "RTN","XDRRMRG1",137,0) . . . . S XDRFDA(15.03,XDRDA1,.01)=XDRFILE "RTN","XDRRMRG1",138,0) . . . . I XDRDIR=2,PACKAGE'="PRIMARY" D "RTN","XDRRMRG1",139,0) . . . . . S XDRFDA(15.03,XDRDA1,.02)=2 "RTN","XDRRMRG1",140,0) . . . . D UPDATE^DIE("S","XDRFDA","XDRDAX") "RTN","XDRRMRG1",141,0) . . . . S XDRDA1=XDRDAX(1) "RTN","XDRRMRG1",142,0) . . . S XDRDA1="+1,"_XDRDA1_","_XDRDA_"," "RTN","XDRRMRG1",143,0) . . . F I=0:0 S I=$O(OVERWRIT(I)) Q:I'>0 D "RTN","XDRRMRG1",144,0) . . . . K XDRFDA,XDRDAX "RTN","XDRRMRG1",145,0) . . . . S XDRDAX(1)=I "RTN","XDRRMRG1",146,0) . . . . S XDRFDA(15.031,XDRDA1,.01)=I "RTN","XDRRMRG1",147,0) . . . . D UPDATE^DIE("S","XDRFDA","XDRDAX") "RTN","XDRRMRG1",148,0) . I XDRY="V" D "RTN","XDRRMRG1",149,0) . . D CHEKVER "RTN","XDRRMRG1",150,0) . I XDRY="N" D "RTN","XDRRMRG1",151,0) . . S XDRAID=$G(XQAID) N XQAID,I "RTN","XDRRMRG1",152,0) . . F I=0:0 S I=$O(^VA(15.1,PRIFILE,2,I)) Q:I'>0 D ; MODIFIED 03/28/00 "RTN","XDRRMRG1",153,0) . . . S XQAID=$P(XDRAID,",",1,2)_","_I "RTN","XDRRMRG1",154,0) . . . S XQAKILL=0 "RTN","XDRRMRG1",155,0) . . . D DELETEA^XQALERT "RTN","XDRRMRG1",156,0) . . N XDRFDA "RTN","XDRRMRG1",157,0) . . S XDRFDA(15,XDRDA_",",.03)="N" "RTN","XDRRMRG1",158,0) . . S XDRFDA(15,XDRDA_",",.07)=$$NOW^XLFDT() "RTN","XDRRMRG1",159,0) . . S XDRFDA(15,XDRDA_",",.11)=DUZ "RTN","XDRRMRG1",160,0) . . D UPDATE^DIE("S","XDRFDA") "RTN","XDRRMRG1",161,0) S ABORT=0 D ASK^XDRRMRG2(.QLIST,.ABORT) ;REM -Reset ABORT to 0 "RTN","XDRRMRG1",162,0) ; "RTN","XDRRMRG1",163,0) ;For health summary, user has the option of using the Browser to view "RTN","XDRRMRG1",164,0) ;both records or use may select any other device for each record. "RTN","XDRRMRG1",165,0) ; "RTN","XDRRMRG1",166,0) I '$G(ABORT) D PRINT2^XDRRMRG2 "RTN","XDRRMRG1",167,0) D HOME^%ZIS "RTN","XDRRMRG1",168,0) G CHK1 "RTN","XDRRMRG1",169,0) Q "RTN","XDRRMRG1",170,0) ; "RTN","XDRRMRG1",171,0) CHEKVER ; "RTN","XDRRMRG1",172,0) N R "RTN","XDRRMRG1",173,0) S XVER=1 "RTN","XDRRMRG1",174,0) F I=0:0 S I=$O(^VA(15.1,PRIFILE,2,I)) Q:I'>0 D Q:'XVER ; MODIFIED 03/28/00 "RTN","XDRRMRG1",175,0) . S X1=+$P(^VA(15.1,PRIFILE,2,I,0),U,2) ; MODIFIED 03/28/00 "RTN","XDRRMRG1",176,0) . S XN=$P(^VA(15.1,PRIFILE,2,I,0),U) ; MODIFIED 03/28/00 "RTN","XDRRMRG1",177,0) . I X1>0 D "RTN","XDRRMRG1",178,0) . . F R=1,5,6,7,0 I $O(^XMB(3.8,X1,R,0))>0 Q ;REM -changed I to R in FOR loop "RTN","XDRRMRG1",179,0) . . I R'>0 S X1=0 "RTN","XDRRMRG1",180,0) . I X1'>0,$O(^VA(15.1,PRIFILE,2,I,1,0))'>0 Q ; MODIFIED 03/28/00 "RTN","XDRRMRG1",181,0) . S X1=$$FIND1^DIC(15.02,","_XDRDA_",","X",XN) "RTN","XDRRMRG1",182,0) . S XVER=$S(X1'>0:0,$P(^VA(15,XDRDA,2,X1,0),U,2)="V":1,$P(^(0),U,2)="D":1,1:0) "RTN","XDRRMRG1",183,0) I XVER D FINALVER^XDRVCHEK(XDRDA) "RTN","XDRRMRG1",184,0) Q "RTN","XDRRMRG1",185,0) ; "RTN","XDRRMRG1",186,0) SETUP(XDRDA) ; "RTN","XDRRMRG1",187,0) N XDRGRPN,XDRSSN,XDRFILE "RTN","XDRRMRG1",188,0) S X=^VA(15,XDRDA,0) "RTN","XDRRMRG1",189,0) I $P($G(^VA(15,XDRDA,2,1,0)),U,5)=2 S DFNTO=+X,DFNFR=+$P(X,U,2) "RTN","XDRRMRG1",190,0) E S DFNFR=+X,DFNTO=+$P(X,U,2) "RTN","XDRRMRG1",191,0) S XDRFILE=$P($P(X,U),";",2),XDRFILE=+$P(@(U_XDRFILE_"0)"),U,2) "RTN","XDRRMRG1",192,0) F XDRAID=0:0 S XDRAID=$O(^VA(15.1,PRIFILE,2,XDRAID)) Q:XDRAID'>0 D ; MODIFIED 03/28/00 "RTN","XDRRMRG1",193,0) . S XDRNODE=^VA(15.1,PRIFILE,2,XDRAID,0) ; MODIFIED 03/28/00 "RTN","XDRRMRG1",194,0) . S XDRNOD2=$G(^VA(15.1,PRIFILE,2,XDRAID,2)) ; MODIFIED 03/28/00 "RTN","XDRRMRG1",195,0) . S XDRNAME=$P(XDRNODE,U) "RTN","XDRRMRG1",196,0) . S XDRGRP=$P(XDRNODE,U,2) "RTN","XDRRMRG1",197,0) . S:XDRGRP>0 XDRGRPN=$$GET1^DIQ(3.8,XDRGRP,.01) ;REM -8/2/96 Get the name of mail group "RTN","XDRRMRG1",198,0) . S XDRGRP=$S(XDRGRP>0:"G."_XDRGRPN,1:"") "RTN","XDRRMRG1",199,0) . S XDRFILE=$P(XDRNODE,U,3) D Q:'$D(XDRNODE) "RTN","XDRRMRG1",200,0) . . N XDRDIC,XDRFR,XDRTO "RTN","XDRRMRG1",201,0) . . S XDRDIC=^DIC(XDRFILE,0,"GL") "RTN","XDRRMRG1",202,0) . . S XDRFR=$S(XDRFILE'=63:DFNFR,1:$G(^DPT(DFNFR,"LR"))) "RTN","XDRRMRG1",203,0) . . S XDRTO=$S(XDRFILE'=63:DFNTO,1:$G(^DPT(DFNTO,"LR"))) "RTN","XDRRMRG1",204,0) . . I XDRFR'>0!(XDRTO'>0) K XDRNODE "RTN","XDRRMRG1",205,0) . . I $D(XDRNODE),'$D(@(XDRDIC_XDRFR_",0)"))!'$D(@(XDRDIC_XDRTO_",0)")) K XDRNODE "RTN","XDRRMRG1",206,0) . . I '$D(XDRNODE) D "RTN","XDRRMRG1",207,0) . . . N XDRARR I $$FIND1^DIC(15.02,","_XDRDA_",","X",XDRNAME)>0 Q "RTN","XDRRMRG1",208,0) . . . S XDRARR(15.02,"+1,"_XDRDA_",",.01)=XDRNAME "RTN","XDRRMRG1",209,0) . . . S XDRARR(15.02,"+1,"_XDRDA_",",.02)="D" "RTN","XDRRMRG1",210,0) . . . D UPDATE^DIE("","XDRARR") "RTN","XDRRMRG1",211,0) . S XQADATA=XDRDA_U_DFNFR_";"_DFNTO_U_XDRNAME_U_XDRFILE_U_$P(XDRNOD2,U)_U_$P(XDRNOD2,U,2) "RTN","XDRRMRG1",212,0) . ;S R(1)=XDRDA_U_DFNFR_";"_DFNTO_U_XDRNAME_U_XDRFILE_U_$P(XDRNOD2,U)_U_$P(XDRNOD2,U,2) "RTN","XDRRMRG1",213,0) . D SETARY^XDRRMRG0 S XMTEXT="R(" "RTN","XDRRMRG1",214,0) . S:XDRGRP'="" XMY(XDRGRP)="" "RTN","XDRRMRG1",215,0) . F I=0:0 S I=$O(^VA(15.1,PRIFILE,2,XDRAID,1,I)) Q:I'>0 S X=^(I,0) D "RTN","XDRRMRG1",216,0) . . S XQA(X)="" "RTN","XDRRMRG1",217,0) . D SEND^XDRRMRG0 K R "RTN","XDRRMRG1",218,0) Q "RTN","XDRRMRG2") 0^12^B16759300 "RTN","XDRRMRG2",1,0) XDRRMRG2 ;SF-IRMFO/GB,JLI - GET PATIENT HEALTH SUMMARY ;06/26/98 13:35 [ 04/02/2003 8:47 AM ] "RTN","XDRRMRG2",2,0) ;;7.3;TOOLKIT;**23,29,1001,1003**;Apr 03, 1995 "RTN","XDRRMRG2",3,0) ;IHS/OIT/LJF 07/27/2006 PATCH 1003 use IHS merge type as default HS "RTN","XDRRMRG2",4,0) ; PATCH 1003 change default on using browser to NO "RTN","XDRRMRG2",5,0) ;; "RTN","XDRRMRG2",6,0) ASK(QLIST,ABORT) ; Report-specific questions "RTN","XDRRMRG2",7,0) N DIC,Y,DTOUT,DUOUT "RTN","XDRRMRG2",8,0) ; Which patient? "RTN","XDRRMRG2",9,0) ; S DIC="^SPNL(154," "RTN","XDRRMRG2",10,0) ; S DIC("S")="I $P(^(0),U,3)=""A""" ; Select only from active patients "RTN","XDRRMRG2",11,0) ; S DIC(0)="AEQM" "RTN","XDRRMRG2",12,0) ; S DIC("A")="Select SCD Patient: " "RTN","XDRRMRG2",13,0) ; S DIC("?")="Select the patient for whom you want the Health Summary" "RTN","XDRRMRG2",14,0) ; D ^DIC I $D(DTOUT)!($D(DUOUT))!(Y<0) S ABORT=1 Q "RTN","XDRRMRG2",15,0) ; S QLIST("DFN")=+Y ; IEN's are DINUM'd to the ^DPT "RTN","XDRRMRG2",16,0) K DIC "RTN","XDRRMRG2",17,0) ; Which Health Summary Type? "RTN","XDRRMRG2",18,0) S DIC="^GMT(142," "RTN","XDRRMRG2",19,0) S DIC(0)="AEQM" "RTN","XDRRMRG2",20,0) ; "RTN","XDRRMRG2",21,0) I $$GET^XPAR("PKG","BPM USE IHS LOGIC") S DIC("B")="BPM MERGE" ;IHS/OIT/LJF 07/27/2006 PATCH 1003 added default "RTN","XDRRMRG2",22,0) ; "RTN","XDRRMRG2",23,0) S DIC("A")="Select Health Summary Type Name: " "RTN","XDRRMRG2",24,0) ;S DIC("?")="Choose one, if you aren't sure, experiment!" "RTN","XDRRMRG2",25,0) D ^DIC I $D(DTOUT)!($D(DUOUT))!(Y<0) S ABORT=1 Q "RTN","XDRRMRG2",26,0) S QLIST("TYPE")=+Y "RTN","XDRRMRG2",27,0) ASKX Q "RTN","XDRRMRG2",28,0) ; "RTN","XDRRMRG2",29,0) GATHER(DFN,FDATE,TDATE,HIUSERS,QLIST) ; No need to gather "RTN","XDRRMRG2",30,0) Q "RTN","XDRRMRG2",31,0) ; "RTN","XDRRMRG2",32,0) PRINT(QLIST) ;Call to print health summary "RTN","XDRRMRG2",33,0) D ENX^GMTSDVR(QLIST("DFN"),QLIST("TYPE")) "RTN","XDRRMRG2",34,0) PRINTX Q "RTN","XDRRMRG2",35,0) ; "RTN","XDRRMRG2",36,0) PRINT2 ;Prints the record pair using the Browser of to a device. "RTN","XDRRMRG2",37,0) N XDRIOP "RTN","XDRRMRG2",38,0) W ! S DIR(0)="Y",DIR("A",1)="Would you like to use the FM Browser to" "RTN","XDRRMRG2",39,0) S DIR("A")="view the record pair" "RTN","XDRRMRG2",40,0) S DIR("B")="YES",DIR("?")="You may use FM Browser to view the record pair else you will be prompted to select a device for each record." "RTN","XDRRMRG2",41,0) ; "RTN","XDRRMRG2",42,0) ;IHS/OIT/LJF 07/27/2006 PATCH 1003 changed default to NO "RTN","XDRRMRG2",43,0) I $$GET^XPAR("PKG","BPM USE IHS LOGIC") S DIR("B")="NO" "RTN","XDRRMRG2",44,0) ; "RTN","XDRRMRG2",45,0) D ^DIR S:Y=1 XDRIOP=1 Q:$D(DIRUT) "RTN","XDRRMRG2",46,0) K ^TMP("XDRRMRG1",$J),^TMP("XDRRMRG",$J) "RTN","XDRRMRG2",47,0) ;S IOP="XDRBROWSER1" D ^%ZIS Q:POP ;Old code, delete after testing "RTN","XDRRMRG2",48,0) REC1 S:$D(XDRIOP) IOP="XDRBROWSER1" S:'$D(XDRIOP) %ZIS="QM" "RTN","XDRRMRG2",49,0) S %ZIS("A")="DEVICE FOR FIRST RECORD: " "RTN","XDRRMRG2",50,0) W ! D ^%ZIS Q:POP "RTN","XDRRMRG2",51,0) I $D(IO("Q")) D G REC2 ;Will queue to TaskMan "RTN","XDRRMRG2",52,0) . S ZTRTN="QUEUE^XDRRMRG2",ZTIO=ION,ZTDESC="XDR Health Summary for first patient." "RTN","XDRRMRG2",53,0) . S DFN=DFNFRX,TYPE=QLIST("TYPE"),ZTSAVE("DFN")="",ZTSAVE("TYPE")="" "RTN","XDRRMRG2",54,0) . D ^%ZTLOAD W:$D(ZTSK) !!,"Queued as task "_ZTSK,! "RTN","XDRRMRG2",55,0) . Q "RTN","XDRRMRG2",56,0) U IO(0) W:$D(XDRIOP) " Getting first entry ",! "RTN","XDRRMRG2",57,0) D ENX^GMTSDVR(DFNFRX,QLIST("TYPE")) "RTN","XDRRMRG2",58,0) U IO D ^%ZISC "RTN","XDRRMRG2",59,0) S ^TMP("XDRRMRG",$J,"ENTER S TO VIEW OTHER- "_$E($G(DFNFR(1)),1,30)_" "_$G(DFNFR(2))_" ("_DFNFRX_")")="^TMP(""XDRRMRG1"",$J,1)" "RTN","XDRRMRG2",60,0) M ^TMP("XDRRMRG1",$J,1)=^TMP("DDB",$J) "RTN","XDRRMRG2",61,0) ;S IOP="XDRBROWSER1" D ^%ZIS Q:POP ;old code delete after testing "RTN","XDRRMRG2",62,0) REC2 S:$D(XDRIOP) IOP="XDRBROWSER1" S:'$D(XDRIOP) %ZIS="QM" "RTN","XDRRMRG2",63,0) S %ZIS("A")="DEVICE FOR SECOND RECORD: " "RTN","XDRRMRG2",64,0) W ! D ^%ZIS Q:POP "RTN","XDRRMRG2",65,0) I $D(IO("Q")) D G PRINTX ;Will queue to TaskMan "RTN","XDRRMRG2",66,0) . S ZTRTN="QUEUE^XDRRMRG2",ZTIO=ION,ZTDESC="XDR Health Summary for second patient." "RTN","XDRRMRG2",67,0) . S DFN=DFNTOX,TYPE=QLIST("TYPE"),ZTSAVE("DFN")="",ZTSAVE("TYPE")="" "RTN","XDRRMRG2",68,0) . D ^%ZTLOAD W:$D(ZTSK) !!,"Queued as task "_ZTSK,! "RTN","XDRRMRG2",69,0) . Q "RTN","XDRRMRG2",70,0) U IO(0) W:$D(XDRIOP) " Getting second entry ",! "RTN","XDRRMRG2",71,0) D ENX^GMTSDVR(DFNTOX,QLIST("TYPE")) "RTN","XDRRMRG2",72,0) D ^%ZISC U IO(0) "RTN","XDRRMRG2",73,0) S ^TMP("XDRRMRG",$J,"ENTER S TO VIEW OTHER- "_$E($G(DFNTO(1)),1,30)_" "_$G(DFNTO(2))_" ("_DFNTOX_")")="^TMP(""XDRRMRG1"",$J,2)" "RTN","XDRRMRG2",74,0) M ^TMP("XDRRMRG1",$J,2)=^TMP("DDB",$J) "RTN","XDRRMRG2",75,0) D DOCLIST^DDBR($NA(^TMP("XDRRMRG",$J)),"R") "RTN","XDRRMRG2",76,0) K ^TMP("XDRRMRG1",$J),^TMP("XDRRMRG",$J) "RTN","XDRRMRG2",77,0) PRINT2X Q "RTN","XDRRMRG2",78,0) ; "RTN","XDRRMRG2",79,0) QUEUE ;Will process the print task for patients' health summaries. "RTN","XDRRMRG2",80,0) D ENX^GMTSDVR(DFN,TYPE) "RTN","XDRRMRG2",81,0) QUEUEX Q "RTN","XDRRMRG2",82,0) ; "RTN","XDRRMRG2",83,0) COUNT(XDRFILE,FROM,TO) ; "RTN","XDRRMRG2",84,0) N X,I,FIL1,FIL2,NOD,PIECE,X1,X2,N1,N2 "RTN","XDRRMRG2",85,0) S N1=0,N2=0 "RTN","XDRRMRG2",86,0) S FIL2=^DIC(XDRFILE,0,"GL") "RTN","XDRRMRG2",87,0) S FIL1=FIL2_"FROM)" "RTN","XDRRMRG2",88,0) S FIL2=FIL2_"TO)" "RTN","XDRRMRG2",89,0) F I=0:0 S I=$O(^DD(XDRFILE,I)) Q:I'>0 S X=^(I,0) D "RTN","XDRRMRG2",90,0) . S NOD=$P($P(X,U,4),";") "RTN","XDRRMRG2",91,0) . S PIECE=$P($P(X,U,4),";",2) "RTN","XDRRMRG2",92,0) . I PIECE>0 D "RTN","XDRRMRG2",93,0) . . S X1=$P($G(@FIL1@(NOD)),U,PIECE) "RTN","XDRRMRG2",94,0) . . S X2=$P($G(@FIL2@(NOD)),U,PIECE) "RTN","XDRRMRG2",95,0) . . I X1'="",X2="" S N1=N1+1 "RTN","XDRRMRG2",96,0) . . I X2'="",X1="" S N2=N2+1 "RTN","XDRRMRG2",97,0) COUNTX Q $S(N1>N2:2,N2>N1:1,1:0) "RTN","XDRRMRG2",98,0) ; "RTN","XDRRMRG2",99,0) LABIEN(FILE,REC) ;REM - Resolve LABs DFNFR and DFNTO. "RTN","XDRRMRG2",100,0) S NAMREC="" "RTN","XDRRMRG2",101,0) S FILDIC=$G(^DIC(FILE,0,"GL")) Q:FILDIC="" NAMREC "RTN","XDRRMRG2",102,0) S FILREC=FILDIC_"REC)" "RTN","XDRRMRG2",103,0) S NAMREC=+$P(@FILREC@(0),U,3) "RTN","XDRRMRG2",104,0) LABIENX Q NAMREC "RTN","XDRVCHEK") 0^14^B10053746 "RTN","XDRVCHEK",1,0) XDRVCHEK ;SF-IRMFO.SEA/JLI - CHECK FOR ENTRIES WHICH HAVE PASSED THE NUMBER OF DAYS REQUIRED FOR VERIFICATION ;02/24/2000 07:46 [ 04/02/2003 8:47 AM ] "RTN","XDRVCHEK",2,0) ;;7.3;TOOLKIT;**23,46,1001,1003**;Apr 25, 1995 "RTN","XDRVCHEK",3,0) ;IHS/OIT/LJF 01/26/2007 PATCH 1003 remove ancillary check "RTN","XDRVCHEK",4,0) ;; "RTN","XDRVCHEK",5,0) ;; "RTN","XDRVCHEK",6,0) EN ; "RTN","XDRVCHEK",7,0) N XDRDAYS,XDRGLB,XDRI,XDRJ,XDRK,XDRX,DIE,DA,DR,XDRDA,XDRXREF "RTN","XDRVCHEK",8,0) F XDRI=0:0 S XDRI=$O(^VA(15.1,XDRI)) Q:XDRI'>0 D "RTN","XDRVCHEK",9,0) . S XDRGLB=$P(^DIC(XDRI,0,"GL"),U,2) "RTN","XDRVCHEK",10,0) . S XDRDAYS=$P(^VA(15.1,XDRI,0),U,13) "RTN","XDRVCHEK",11,0) . F XDRXREF="AXDUP","ARDUP1" F XDRJ=0:0 S XDRJ=$O(^VA(15,XDRXREF,XDRGLB,XDRJ)) Q:XDRJ'>0 D "RTN","XDRVCHEK",12,0) . . S XDRX=$P(^VA(15,XDRJ,0),U,7) "RTN","XDRVCHEK",13,0) . . I XDRX>0,$$FMDIFF^XLFDT(DT,XDRX)'0:^VA(15,XDRDA,2,XDRFDA,0),1:"") Q:X="" "RTN","XDRVCHEK",20,0) I $P(X,U,2)'="V" Q "RTN","XDRVCHEK",21,0) S XDRFDA(15,XDRDA_",",.04)=$P(X,U,5) Q:$P(X,U,5)'>0 "RTN","XDRVCHEK",22,0) D FILE^DIE("","XDRFDA") K XDRFDA ; SET DIRECTION IN BEFORE SETTING STATUS "RTN","XDRVCHEK",23,0) S FILE=$P($P(^VA(15,XDRDA,0),U),";",2),FILE=+$P(@(U_FILE_"0)"),U,2) "RTN","XDRVCHEK",24,0) ; "RTN","XDRVCHEK",25,0) ;IHS/OIT/LJF 01/26/2007 PATCH 1003 IHS does not require ancillary checks "RTN","XDRVCHEK",26,0) ;S XDRX1="V" F XDRFDA=0:0 S XDRFDA=$O(^VA(15.1,FILE,2,XDRFDA)) Q:XDRFDA'>0 S NAME=$P(^(XDRFDA,0),U) S NAME=$$FIND1^DIC(15.02,","_XDRDA_",","X",NAME) I NAME'>0 S XDRX1="R" Q "RTN","XDRVCHEK",27,0) S XDRX1="V" I '$$GET^XPAR("PKG","BPM USE IHS LOGIC") F XDRFDA=0:0 S XDRFDA=$O(^VA(15.1,FILE,2,XDRFDA)) Q:XDRFDA'>0 S NAME=$P(^(XDRFDA,0),U) S NAME=$$FIND1^DIC(15.02,","_XDRDA_",","X",NAME) I NAME'>0 S XDRX1="R" Q "RTN","XDRVCHEK",28,0) ; "RTN","XDRVCHEK",29,0) ;S XDRX1="V" F XDRFDA=0:0 S XDRFDA=$O(^VA(15,XDRDA,2,XDRFDA)) Q:XDRFDA'>0 I $P(^(XDRFDA,0),U,2)'="V",$P(^(0),U,2)'="D" S XDRX1="R" Q "RTN","XDRVCHEK",30,0) K XDRFDA S XDRFDA(15,XDRDA_",",.03)=XDRX1 "RTN","XDRVCHEK",31,0) I XDRX1="V" D "RTN","XDRVCHEK",32,0) . S XDRFDA(15,XDRDA_",",.07)=($$NOW^XLFDT()\1) "RTN","XDRVCHEK",33,0) . S XDRFDA(15,XDRDA_",",.11)=$S(X'="":$P(X,U,3),1:DUZ) "RTN","XDRVCHEK",34,0) D FILE^DIE("","XDRFDA") "RTN","XDRVCHEK",35,0) I XDRX1'="V" Q "RTN","XDRVCHEK",36,0) NAME ; "RTN","XDRVCHEK",37,0) S X=^VA(15,XDRDA,0) "RTN","XDRVCHEK",38,0) I $P(X,U,4)=2 D "RTN","XDRVCHEK",39,0) . S XDRX1=+$P(X,U,2) "RTN","XDRVCHEK",40,0) . S XDRX2=+$P(X,U) "RTN","XDRVCHEK",41,0) E D "RTN","XDRVCHEK",42,0) . S XDRX1=+$P(X,U) "RTN","XDRVCHEK",43,0) . S XDRX2=+$P(X,U,2) "RTN","XDRVCHEK",44,0) S X=U_$P($P(X,U),";",2)_"XDRX1,0)" "RTN","XDRVCHEK",45,0) S NAME=$P(@X,U) "RTN","XDRVCHEK",46,0) F Q:NAME'["MERGING INTO" S NAME=$P($P(NAME,"(",2,10),")",1,$L(NAME,")")-1) "RTN","XDRVCHEK",47,0) S NAME="MERGING INTO `"_XDRX2_" USE THAT ENTRY ("_NAME_")" "RTN","XDRVCHEK",48,0) S $P(@X,U)=NAME "RTN","XDRVCHEK",49,0) Q "RTN","XDRVCHEK",50,0) ; "RTN","XDRVCHEK",51,0) CHKREADY ; Check whether the status with respect to merge can be changed "RTN","XDRVCHEK",52,0) ; from NOT READY to READY based on the minimum number of days prior to "RTN","XDRVCHEK",53,0) ; merging "RTN","XDRVCHEK",54,0) ; "RTN","XDRVCHEK",55,0) F XDRFILE=0:0 S XDRFILE=$O(^VA(15.1,XDRFILE)) Q:XDRFILE'>0 D "RTN","XDRVCHEK",56,0) . S XDRGLOB=$P(^DIC(XDRFILE,0,"GL"),U,2) "RTN","XDRVCHEK",57,0) . S XDRDAYS=+$P($G(^VA(15.1,XDRFILE,0)),U,14) "RTN","XDRVCHEK",58,0) . S XDRDAYS=$S(XDRDAYS>0:XDRDAYS,1:-1) "RTN","XDRVCHEK",59,0) . S XDRDATE=$$FMADD^XLFDT(DT,-XDRDAYS) "RTN","XDRVCHEK",60,0) . S XDRI="" F S XDRI=$O(^VA(15,"AVDUP",XDRGLOB,XDRI)) Q:XDRI="" D "RTN","XDRVCHEK",61,0) . . S XDRJ=$O(^VA(15,"AVDUP",XDRGLOB,XDRI,0)) "RTN","XDRVCHEK",62,0) . . S XDRJV=$G(^VA(15,XDRJ,0)) I XDRJV="" K ^VA(15,"AVDUP",XDRGLOB,XDRI,XDRJ) Q "RTN","XDRVCHEK",63,0) . . I $P(XDRJV,U,5)<2,$P(XDRJV,U,7)0 D "RTN","XDRVCHEK",69,0) . S V=$G(^VA(15,I,0)) I $P(V,U,3)'="V" Q "RTN","XDRVCHEK",70,0) . S Y=$P(V,U,4) "RTN","XDRVCHEK",71,0) . S Y=$S(Y>0:Y,1:1) "RTN","XDRVCHEK",72,0) . S X=$P(V,U,Y) "RTN","XDRVCHEK",73,0) . F J=0:0 S J=$O(^VA(15,"B",X,J)) Q:J'>0 I J'=I D "RTN","XDRVCHEK",74,0) . . S Y=$P($G(^VA(15,J,0)),U,3) "RTN","XDRVCHEK",75,0) . . I Y="P"!(Y="") D "RTN","XDRVCHEK",76,0) . . . S DA=J "RTN","XDRVCHEK",77,0) . . . N I,J,X,Y,V "RTN","XDRVCHEK",78,0) . . . S DIK="^VA(15," "RTN","XDRVCHEK",79,0) . . . D ^DIK "RTN","XDRVCHEK",80,0) Q "VER") 8.0^22.0 **END** **END**