source: FOIAVistA/tag/r/TOOLKIT-AWCM-XD-XIN-XPAR-XQAB-XT-XUC-XUR-ZIN-ZTED/XDRDEDT.m@ 1375

Last change on this file since 1375 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 5.3 KB
Line 
1XDRDEDT ;SF-IRMFO/REM - EDIT STATUS FIELD IN FILE 15 ;09/22/99 11:12
2 ;;7.3;TOOLKIT;**23,43**;Apr 25, 1995
3EN ;;
4 N XDRFIL,X,X1,X2,N1,N2,XDRDELET
5EN2 K DIE,DIC
6 S XDRFIL=$$FILE^XDRDPICK() Q:XDRFIL'>0 S XDRGLB=$G(^DIC(XDRFIL,0,"GL")) Q:XDRGLB=""
7 F D Q:DA'>0
8 . S DIC="^VA(15,",DIC(0)="AEQZ",DIC("S")="I $$SCRN^XDRDEDT(+Y,XDRGLB)"
9 . S DIC("A")="Select an Entry to "_$S($D(XDRDELET):"DELETE: ",1:"RESET TO POTENTIAL DUPLICATES: ")
10 . D ^DIC S DA=+Y Q:DA<0
11 . I $P(^VA(15,DA,0),U,4)<2 S X1=+^VA(15,DA,0),X2=+$P(^(0),U,2)
12 . E S X1=+$P(^VA(15,DA,0),U,2),X2=+^(0)
13 . S N1=$P(@(XDRGLB_X1_",0)"),U),N2=$P(@(XDRGLB_X2_",0)"),U)
14 . S N1=$$PEELNAM(N1),N2=$$PEELNAM(N2)
15 .W !!!," Duplicate Record File Entry ",DA," for the ",$P(^DIC(XDRFIL,0),U)," FILE"
16 . N XX D W !?10,X1,?20,N1,!?10,X2,?20,N2,!!?10,"Currently listed as ",XX,!!
17 . . N DIC,DIQ,DR,XDRQ
18 . . S DIC="^VA(15,",DIQ="XDRQ",DIQ(0)="E",DR=.03
19 . . D EN^DIQ1
20 . . S XX=$G(XDRQ(15,DA,.03,"E"))
21 . . Q
22 . 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
23 . D NAME(DA)
24 . I $D(XDRDELET) D
25 . . N DIK
26 . . S DIK="^VA(15," D ^DIK
27 . I '$D(XDRDELET) D
28 . . K DIE S DIE="^VA(15,",DR=".03///P;.04///@;.05///@;.07///@;.08///@;.1///@;.13///@;.14///@;" D ^DIE K DIE
29 . . S:$D(DUZ) $P(^VA(15,DA,0),U,12)=DUZ
30 . . K ^VA(15,DA,2)
31 . . K ^VA(15,DA,3)
32 . W !!," ",$S($D(XDRDELET):"Entry DELETED!",1:"Status RESET to POTENTIAL DUPLICATE RECORD."),!!,*7
33 . Q
34 K DA,DR,DIC,DIE
35 Q
36SCRN(DA,GLOBAL) ;Screen for verified dup. or verified not dup.
37 I $P(^(0),U,5)>1 Q 0 ; But don't take merged or merge in progress!
38 I '$D(XDRDELET),$P(^(0),U,3)="P"!($P(^(0),U,3)="O") Q 0 ; DON'T NEED TO SET BACK
39 I (U_$P($P(^(0),U),";",2))'=GLOBAL Q 0 ; Take only the specified file
40 ;I $P(^(0),U,3)="V" Q 1
41 ;I $P(^(0),U,3)="N" Q 1
42 Q 1
43 ;
44NAME(DA) ;
45 N X,X1,X2,N,N1,N2
46 S X=^VA(15,DA,0),X1=+X,X2=+$P(X,U,2),X=$P($P(X,U),";",2)
47 S N1=$P($G(@(U_X_X1_",0)")),U)
48 S N2=$P($G(@(U_X_X2_",0)")),U)
49 S N=$$PEELNAM(N1)
50 I N'=N1 S $P(@(U_X_X1_",0)"),U)=N
51 S N=$$PEELNAM(N2)
52 I N'=N2 S $P(@(U_X_X2_",0)"),U)=N
53 Q
54PEELNAM(NAME) ;
55 F Q:NAME'["MERGING INTO" S NAME=$P($P(NAME,"(",2,10),")",1,$L(NAME,")")-1)
56 Q NAME
57 ;
58DELETE ;
59 N XDRFIL,X,X1,X2,N1,N2,XDRDELET
60 S XDRDELET=1
61 D EN2
62 Q
63 ;
64LOOKUP(FILE) ; FIND PAIRS IN DUPLICATE RECORD FILE
65 N FILENAM,NAME,NAME1,NAME2,NAMEA,XDRDIC,DIR,Y,I,J,XDR1,IEN,N,X,FILID,IEN1
66 S FILENAM=$P(^DIC(FILE,0),U) I FILENAM="" G NOFILE
67 S XDRDIC=$G(^DIC(FILE,0,"GL")) I XDRDIC="" G NOFILE
68 S XDRDIC=";"_$E(XDRDIC,2,99)
69 ;
70LOOK1 K DIR S DIR("A")="Select "_FILENAM,DIR(0)="FO^2" D ^DIR K DIR ; GET PART OF A NAME
71 I X="" Q -1
72 I $D(DIRUT)!(Y="^") Q -1
73 ;
74 ; GET A LIST OF NAMES IN THE FILE STARTING WITH THE USERS INPUT AND WHICH HAVE AN IEN THAT IS
75 ; IN THE DUPLICATE RECORD FILE
76 ;
77 S NAME=$NA(^TMP($J,"XDRLIST")) K @NAME
78 D FIND^DIC(FILE,"","","",X,"","B^BS5^SSN","I $D(^VA(15,""B"",(Y_XDRDIC)))","",NAME)
79 ;
80 S NAME1=$NA(@NAME@("DILIST"))
81 ;
82 ; NOW GO THROUGH THE LIST OF MATCHING NAMES AND CHECK FOR THOSE WHICH HAVE THE DESIRED STATUS
83 ; USE THE DATA UNDER THE 2 NODE WHICH IS THE IEN
84 ;
85 F I=0:0 S I=$O(@NAME1@(2,I)) Q:I'>0 S IEN=^(I) D
86 . S XDR1=IEN_XDRDIC
87 . 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
88 . ; IF NOT AT LEAST ONE WITH THE DESIRED STATUS, THEN REMOVE IT FROM THE ARRAY
89 . I J'>0 F J=1,2,"ID" K @NAME1@(J,I)
90 . Q
91 ;
92 S J=$O(@NAME1@(2,0)) I J'>0 G NONAME
93 ;
94 S NAME2=$NA(^TMP($J,"XDRLI1")) K @NAME2
95 S N=0 F I=0:0 S I=$O(@NAME1@(1,I)) Q:I'>0 D
96 . S N=N+1
97 . 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)
98 . S @NAME2@(N)=X,@NAME2@(N,"IEN")=@NAME1@(2,I)
99 S X=$$ASK(NAME2) I X'>0 G NONAME
100 I N>1 W @NAME2@(X)
101 S IEN1=@NAME2@(X,"IEN")_XDRDIC K @NAME2,@NAME
102 S X=$$PAIR(IEN1,"FILID") I X'>0 G NONAME
103 Q X
104 ;
105PAIR(IENDIC,IDARR) ;
106 N FILE,IEN,NAME,XDRN,IEN2,XDRX1,XDRJ,XDRX
107 S NAME=$NA(^TMP($J,"XDRPAIR")) K @NAME
108 S FILE=+$P(@(U_$P(IENDIC,";",2)_"0)"),U,2),XDRN=0
109 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
110 . S XDRN=XDRN+1
111 . S XDRX=^VA(15,IEN,0)
112 . S IEN2=$P(XDRX,U) I IEN2=IENDIC S IEN2=$P(XDRX,U,2)
113 . S IEN2=+IEN2,IENS=IEN2_","
114 . S XDRX1=$$GET1^DIQ(FILE,IENS,.01)_" [iens="_IEN2_"]"
115 . F XDRJ=0:0 S XDRJ=$O(@IDARR@(XDRJ)) Q:XDRJ'>0 S XDRX1=XDRX1_" "_$$GET1^DIQ(FILE,IENS,XDRJ)
116 . S @NAME@(XDRN)=XDRX1,@NAME@(XDRN,"IEN")=IEN
117 I XDRN>1 W !!,"This entry is paired with more than one other record.",!,"Select which pair from the following list:",!
118 S XDRX=$$ASK(NAME) I XDRX>0 S XDRX=@NAME@(XDRX,"IEN")
119 K @NAME
120 Q XDRX
121 ;
122ASK(ARRAY) ;
123 N N,I,N1,NCHOICE
124 W !
125 S N=0 F I=0:0 S I=$O(@ARRAY@(I)) Q:I'>0 S N=N+1
126 I N'>1 S I=+$O(@ARRAY@(0)) W:I>0 @ARRAY@(I) Q I
127 I N>5 W "There are "_N_" choices.",!!
128 S N1=0,NCHOICE=0
129 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)
130 I 'NCHOICE,'$D(DIRUT) S NCHOICE=$$ASKEM(N1,N1)
131 Q NCHOICE
132 ;
133ASKEM(NCUR,NMAX) ;
134 N DIR,Y
135 W !! I NCUR<NMAX W !,"Choose from 1 to "_NCUR S DIR("A")="Or return to continue: ",DIR(0)="NO^1:"_NCUR
136 E S DIR("A")="Choose from 1 to "_NCUR,DIR(0)="N^1:"_NCUR
137 D ^DIR W ! I $D(DIRUT),'$D(DTOUT),'$D(DUOUT) K DIRUT
138 Q $S(Y>0:Y,1:0)
139 ;
140NOFILE ;
141 W !,"FILE ",FILE," NOT FOUND",$C(7),!!
142 Q -1
143 ;
144NONAME ;
145 W $C(7),"??"
146 G LOOK1
147 ;
Note: See TracBrowser for help on using the repository browser.