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

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

initial load of FOIAVistA 6/30/08 version
File size: 7.4 KB
Line 
1XDRDVAL1 ;SF-CIOFO/JLI - CHECK SPECIFIED ENTRY FOR PROBLEMS ;12/04/2001 14:04
2 ;;7.3;TOOLKIT;**23,45,46,49,57**;Apr 25, 1995
3EN ;
4 N MFILE,FILENAME,DIR,XDR,FILE,XDRY,FILEDIC
5 ;
6 D ^%ZIS Q:POP I IO'=IO(0) S XDRION=ION U IO D ^%ZISC
7LOOP ;
8 S DATA=$NA(^TMP($J,"BB"))
9 K @DATA
10 U IO(0)
11 S MFILE=$$FILE^XDRDPICK() Q:MFILE'>0 S FILENAME=$P(^DIC(MFILE,0),U),FILEDIC=^DIC(MFILE,0,"GL")
12 W !!! S DIC=MFILE,DIC(0)="AEM" ;K DIR S DIR(0)="PO^"_MFILE_":AEM",DIR("A")="Select "_FILENAME
13 D ^DIC I Y'>0 U IO D ^%ZISC Q ;D ^DIR K DIR I Y'>0 U IO D ^%ZISC Q
14 S XDRY=Y
15 W !," .... WORKING HARD (may take a while)...",!
16 D EN1(MFILE,+XDRY,DATA)
17 I $D(XDRION) S IOP=XDRION D ^%ZIS I 1
18 E S IO=IO(0)
19 U IO W @IOF,!!!
20 W !!,"DFN=",+XDRY," ",$P(@(FILEDIC_(+XDRY)_",0)"),U) I MFILE=2!(MFILE=200) W " [",$P(^(0),U,9),"]"
21 I '$D(@DATA) W !?10,"No Problems Found....",!! G LOOP
22 D LISTPROB($NA(@DATA@(+XDRY,"VAL")))
23 I $D(XDRION) U IO D ^%ZISC
24 G LOOP
25 Q
26 ;
27EN1(FILE,IEN,ARRAY) ;
28 D SETUP^XDRMERG(FILE)
29 D DOENTRY^XDRDVAL(FILE,IEN,ARRAY)
30 F FILEX=0:0 S FILEX=$O(^TMP($J,"XFIL",FILEX)) Q:FILEX'>0 S GLOB=^(FILEX) D
31 . S X1=$G(^TMP($J,"XGLOB",GLOB,0,1)) Q:X1=""
32 . I $P(X1,U,3)'="DINUM" Q
33 . D DOENTRY^XDRDVAL(FILEX,IEN,ARRAY)
34 . Q
35 Q
36 ;
37LISTPROB(DATA) ;
38 S XDREXIT=0
39 F FILE=0:0 S FILE=$O(@DATA@(FILE)) Q:FILE'>0 D Q:XDREXIT
40 . S FILENAME=$$FILENAME(FILE),NEWHEAD=1
41 . S IENS="" F S IENS=$O(@DATA@(FILE,IENS)) Q:IENS="" D Q:XDREXIT
42 . . F FIELD=0:0 S FIELD=$O(@DATA@(FILE,IENS,FIELD)) Q:FIELD'>0 D Q:XDREXIT
43 . . . S X=$G(@DATA@(FILE,IENS,FIELD,"INVALID")) Q:X=""
44 . . . S NNOTES=0 I $D(@DATA@(FILE,IENS,FIELD,"NOTE")) D
45 . . . . F NNOTE=0:0 S NNOTE=$O(@DATA@(FILE,IENS,FIELD,"NOTE",NNOTE)) Q:NNOTE'>0 S NNOTES=NNOTES+1
46 . . . . Q
47 . . . S NLINES=NNOTES+3
48 . . . I (IOSL-$Y-4)'>NLINES D:$E(IOST)["C" Q:XDREXIT W @IOF S NEWHEAD=1
49 . . . . N DIR,Y,X
50 . . . . S DIR(0)="E" D ^DIR I 'Y S XDREXIT=1
51 . . . . Q
52 . . . W:NEWHEAD !!!,FILENAME S NEWHEAD=0
53 . . . W !,"Field ",FIELD," [",$P(^DD(FILE,FIELD,0),U),"] IENS=",IENS
54 . . . W !," value: ",X
55 . . . F NNOTE=0:0 S NNOTE=$O(@DATA@(FILE,IENS,FIELD,"NOTE",NNOTE)) Q:NNOTE'>0 W !," ",^(NNOTE)
56 . . . Q
57 . . Q
58 . Q
59 Q
60 ;
61FILENAME(FILE) ;
62 N FILENAME,NFILE
63 S FILENAME="",NFILE=FILE
64 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
65 I FILE>0 S FILENAME="File "_NFILE_" ["_FILENAME_$P($G(^DIC(FILE,0)),U)_" file]"
66 Q FILENAME
67 ;
68ENPAIR(FILE,ARRAY,MERGEFLG) ; ENTRY POINT FOR CHECKING AN ARRAY OF PAIRS AT START OF MERGE
69 N XDRMESG,FROM,TO,TOVARBL,FRVARBL,DUPIEN,DATA,NLINES,XDRFDA1
70 ;
71 S XDRMESG=$NA(^TMP("XDRVALMESG",$J)) K @XDRMESG
72 S XDRVDATA=$NA(^TMP("XDRVALDATA",$J)) K @XDRVDATA
73 I $G(MERGEFLG)>0 S XDRFDA1=$$FIND1^DIC(15.23,","_MERGEFLG_",","Q","DATA CHECKING")
74 ;
75 F FROM=0:0 S FROM=$O(@ARRAY@(FROM)) Q:FROM'>0 D
76 . I $G(MERGEFLG)>0 S ^VA(15.2,MERGEFLG,3,XDRFDA1,1)=$$NOW^XLFDT()_U_U_FROM
77 . S TO=$O(@ARRAY@(FROM,0))
78 . ;
79 . ; add special checks for BCMA, MPI, and Pharmacy, XT*7.3*45
80 . ; remove MPI check for CIRN/MPI aware patch, XT*7.3*49
81 . ; remove BCMA checks, XT*7.3*57
82 . ;I $D(^PSB(53.79,"B",FROM)) D Q
83 . ;. S @XDRVDATA@(FROM,"VAL",53.79,TO,.01,"INVALID")="FROM Patient has data on file for BCMA, please resolve prior to merging."
84 . ;I $T(GETICN^MPIF001)]"",$$GETICN^MPIF001(FROM)>0 D Q
85 . ;. S @XDRVDATA@(FROM,"VAL",2,TO,991.01,"INVALID")="The FROM patient exist in the MPI system, this Patient cannot be merged."
86 . ;I $T(GETICN^MPIF001)]"",$$GETICN^MPIF001(TO)>0 D Q
87 . ;. S @XDRVDATA@(FROM,"VAL",2,TO,991.01,"INVALID")="The TO patient exist in the MPI system, this Patient cannot be merged."
88 . I $T(EN^PSJPATMR)]"",'$$EN^PSJPATMR(FROM,TO) D Q
89 . . 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."
90 . ;
91 . D CHKMERG^XDRDVAL2(FILE,FROM,TO,$NA(@XDRVDATA@(FROM,"VAL"))) ; GET BACK ANY PROBLEMS
92 . F S TO=$O(@ARRAY@(FROM,TO)) Q:TO'>0 D ; FROM CAN'T POINT TO MORE THAN ONE PLACE
93 . . S FRVARBL=$O(@ARRAY@(FROM,TO,0)) I FRVARBL="" S FRVARBL=0
94 . . S TOVARBL=$O(@ARRAY@(FROM,TO,FRVARBL,0)) I TOVARBL="" S TOVARBL=0
95 . . I TOVARBL=0 S DUPIEN=+$G(@ARRAY@(FROM,TO))
96 . . E S DUPIEN=+$G(@ARRAY@(FROM,TO,FRVARBL,TOVARBL))
97 . . D RMOVPAIR(FROM,TO,DUPIEN,ARRAY)
98 . . Q
99 . Q
100 I $D(@XDRVDATA) D ; GOT BACK PROBLEMS ON ONE OR MORE FIELDS
101 . I $G(MERGEFLG)>0 N XDRDVALF S XDRDVALF=1 S IOP="XDRBROWSER1" D ^%ZIS
102 . I $G(MERGEFLG)'>0,$G(XDRION)'="" S IOP=XDRION D ^%ZIS
103 . U IO
104 . F FROM=0:0 S FROM=$O(@XDRVDATA@(FROM)) Q:FROM'>0 D
105 . . S TO=$O(@ARRAY@(FROM,0))
106 . . S FRVARBL=$O(@ARRAY@(FROM,TO,0)) I FRVARBL="" S FRVARBL=0
107 . . S TOVARBL=$O(@ARRAY@(FROM,TO,FRVARBL,0)) I TOVARBL="" S TOVARBL=0
108 . . I TOVARBL=0 S DUPIEN=+$G(@ARRAY@(FROM,TO))
109 . . E S DUPIEN=+$G(@ARRAY@(FROM,TO,FRVARBL,TOVARBL))
110 . . W !!
111 . . I DUPIEN>0 D ; HAS AN ENTRY IN FILE 15
112 . . . N X,DIRECT,ORIGTO,ORIGFR
113 . . . S X=^VA(15,DUPIEN,0) S DIRECT=$P(X,U,4)
114 . . . I DIRECT=1 S ORIGFR=+X,ORIGTO=+$P(X,U,2)
115 . . . E S ORIGFR=+$P(X,U,2),ORIGTO=+X
116 . . . ;
117 . . . I ORIGTO'=TO D ; THE ENTRY WAS REPOINTED TO THE CURRENT 'TO' ENTRY
118 . . . . D PAIRID(FILE,ORIGFR,ORIGTO,DUPIEN) ; OUPUT ORIGINAL PAIR ID
119 . . . . W !," ******** REDIRECTED TO"
120 . . . . Q
121 . . . Q
122 . . ;
123 . . D PAIROUT(FILE,FROM,TO,DUPIEN,$NA(@XDRVDATA@(FROM,"VAL"))) ; OUTPUT PAIR ID AND PROBLEMS
124 . . ;
125 . . D RMOVPAIR(FROM,TO,DUPIEN,ARRAY) ; REMOVE PAIR FROM MERGE - NOT FROM FILE 15
126 . . Q
127 . U IO D ^%ZISC
128 . I $G(MERGEFLG)>0 D
129 . . N XMSUB,XMTEXT
130 . . S XMSUB="MERGE PAIRS EXCLUDED DUE TO DATA PROBLEMS"
131 . . S XMTEXT="^TMP(""DDB"",$J,"
132 . . D SENDMESG(XMSUB,XMTEXT)
133 . . Q
134 . Q
135 Q
136 ;
137SENDMESG(XMSUB,XMTEXT) ;
138 N XMY,XDRGRP,XDRGRPN,XMDUZ,XMCHAN
139 S XDRGRP=$$GET1^DIQ(15.1,"2,",.29,"I")
140 S:XDRGRP>0 XDRGRPN=$$GET1^DIQ(3.8,XDRGRP,.01)
141 S XDRGRP=$S(XDRGRP>0:"G."_XDRGRPN,1:"")
142 S:XDRGRP'="" XMY(XDRGRP)=""
143 S:XDRGRP="" XMY(.5)="" ;If no mail grp found, send msg to postmaster
144 S XMDUZ=.5,XMCHAN=1
145 D ^XMD
146 Q
147 ;
148RMOVPAIR(FROM,TO,IEN,ARRAY) ;
149 N X,MERGE,IENS,XXX,DA,DIK
150 S JLICNT=$G(JLICNT)+1,^TMP("XDRRMOV",JLICNT,$H,1)=FROM_U_TO_U_IEN_U_ARRAY
151 I IEN>0 D ; ENTRY IS IN FILE 15
152 . S IENS=IEN_","
153 . S X=^VA(15,IEN,0),MERGE=$P(X,U,20) ; GET MERGE NUMBER
154 . S JLICNT=$G(JLICNT)+1,^TMP("XDRRMOV",JLICNT,$H,2)=MERGE_U_X
155 . S XXX(15,IENS,.05)=1 ; SET MERGE STATUS BACK TO READY
156 . S XXX(15,IENS,.13)=0 ; REMOVE APPROVAL FOR MERGE
157 . S XXX(15,IENS,.14)="@" ; AND INDICATOR OF WHO APPROVED
158 . S XXX(15,IENS,.2)="@" ; REMOVE MERGE PROCESS
159 . D FILE^DIE("","XXX")
160 . ;
161 . ;S IENS=","_MERGE_",",DA=$$FIND1^DIC(15.22,IENS,"",FROM) ; GET IEN FOR THIS ENTRY IN
162 . F DA=0:0 S DA=$O(^VA(15.2,MERGE,2,DA)) Q:DA'>0 I $P(^(DA,0),U,3)=IEN Q
163 . I DA>0 S DIK="^VA(15.2,"_MERGE_",2,",DA(1)=MERGE D ^DIK ; LIST OF PAIRS, AND DELETE IT
164 ;
165 K @ARRAY@(FROM,TO) ; AND KILL THE ACTUAL ENTRY IN ARRAY
166 Q
167 ;
168PAIROUT(FILE,FROM,TO,IEN,DATA) ;
169 D PAIRID(FILE,FROM,TO,IEN)
170 D LISTPROB^XDRDVAL1(DATA)
171 Q
172 ;
173PAIRID(FILE,FROM,TO,IEN) ;
174 N FRNAME,FRSSN,TONAME,TOSSN,FILEDIC
175 S FILEDIC=^DIC(FILE,0,"GL")
176 S FRNAME=$P($G(@(FILEDIC_FROM_",0)")),U),FRSSN=$P($G(^(0)),U,9),FRNAME=$$STRIP(FRNAME)
177 S TONAME=$P($G(@(FILEDIC_TO_",0)")),U),TOSSN=$P($G(^(0)),U,9),TONAME=$$STRIP(TONAME)
178 W !,"FROM: DFN=",FROM," ",FRNAME W:FILE=2!(FILE=200) " [",FRSSN,"]" I IEN>0 W " FILE 15 IEN: ",IEN
179 W !,"TO: DFN=",TO," ",TONAME W:FILE=2!(FILE=200) " [",TOSSN,"]"
180 Q
181 ;
182STRIP(X1) ;
183 F Q:X1'["MERGING INTO" S X1=$P($P(X1,"(",2,10),")",1,$L(X1,")")-1)
184 Q X1
Note: See TracBrowser for help on using the repository browser.