source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DG53P543.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 6.1 KB
Line 
1DG53P543 ;BAY/JT - cleanup of file 20 ; 9/16/03 4:56pm
2 ;;5.3;Registration;**543**;Aug 13, 1993
3 ; patient name .01 only
4 ;
5ENV ; do environment check
6 S XPDABORT=""
7 D PROGCHK(.XPDABORT)
8 I XPDABORT="" K XPDABORT
9 Q
10PROGCHK(XPDABORT) ; checks for necessary programmer variables
11 I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D
12 .D MES^XPDUTL("Your programming variables are not set up properly.")
13 .D MES^XPDUTL("Installation aborted.")
14 .S XPDABORT=2
15 Q
16 ;
17CLEANUP N DGIEN,DGFULLNM,DGLINK,DGFND,DGDPT,DGNAME,DGZERO,DGONE,DGERR,CNT,DGMID,DGTOT,DGUPDT,DGNOLINK,DGLINK0,DGLINK1,DGCONC,DGOTHERS,DGGLOBAL,X1,X2
18 K ^XTMP("DG53P543")
19 S X1=DT,X2=90 D C^%DTC
20 S ^XTMP("DG53P543",0)=X_"^"_DT_"^Problems w/file 2 links w/file 20"
21 S (DGIEN,DGTOT,DGERR,DGUPDT,DGNOLINK,DGLINK0,DGLINK1,DGOTHERS)=0
22 D BMES^XPDUTL("Beginning clean-up...Reading thru entire Patient File...")
23 F S DGIEN=$O(^DPT(DGIEN)) Q:'DGIEN D
24 .S DGTOT=DGTOT+1
25 .Q:$P($G(^DPT(DGIEN,0)),U)["MERGING INTO"
26 .Q:$D(^DPT(DGIEN,-9))
27 .S DGFULLNM=$P($G(^DPT(DGIEN,0)),U)
28 .S DGLINK=+$P($G(^DPT(DGIEN,"NAME")),U)
29 .I 'DGLINK D NOLINK Q
30 .S DGZERO=$G(^VA(20,DGLINK,0))
31 .I DGZERO="" D NOZERO Q
32 .I $P(DGZERO,U)'=2!($P(DGZERO,U,2)'=".01")!(+$P(DGZERO,U,3)'=DGIEN) D BADZERO Q
33 .S DGONE=$G(^VA(20,DGLINK,1))
34 .I DGONE="" D NOONE Q
35 .;
36 .S DGERR=0
37 .; skip if "error" in family name
38 .I $P(DGFULLNM,",",1)["ERROR" Q
39 .; compare family name
40 .I $P(DGFULLNM,",",1)'=$P(DGONE,U) S DGERR=1 S ^XTMP("DG53P543",DGIEN,DGLINK,DGERR)=$P(DGFULLNM,",",1)_U_$P(DGONE,U) S DGUPDT=DGUPDT+1 Q
41 .; skip if no first name
42 .I $P(DGFULLNM,",",2)="",$P(DGONE,U,2)="" Q
43 .; if comma in first name, skip if everything equal
44 .I $P(DGONE,U,2)["," S DGCONC=$P(DGONE,U)_","_$P(DGONE,U,2) I DGCONC=DGFULLNM Q
45 .; compare first name
46 .S CNT=$L($P(DGONE,U,2))
47 .I $E($P(DGFULLNM,",",2),1,CNT)'=$P(DGONE,U,2) S DGERR=2 S ^XTMP("DG53P543",DGIEN,DGLINK,DGERR)=DGFULLNM_"///"_$P(DGONE,U,1,5) S DGOTHERS=DGOTHERS+1 Q
48 .;compare middle names and suffixes
49 .S DGMID=$P($P(DGFULLNM,",",2)," ",2)
50 .I DGMID=$P(DGONE,U,3)!(DGMID=$P(DGONE,U,5)) Q
51 .S DGMID=$P($P(DGFULLNM,",",2)," ",2,99)
52 .I $P(DGONE,U,3)'="",DGMID[$P(DGONE,U,3) Q
53 .I $P(DGONE,U,5)'="",DGMID[$P(DGONE,U,5) Q
54 .S DGERR=3
55 .S ^XTMP("DG53P543",DGIEN,DGLINK,DGERR)=DGFULLNM_"///"_$P(DGONE,U,1,5) S DGOTHERS=DGOTHERS+1
56 .Q
57 ;
58 D MES^XPDUTL("Total # of Patient File records read: "_DGTOT)
59 D MES^XPDUTL("Total # of Name Component file #20 records needing cleanup: "_DGUPDT)
60 I DGUPDT D
61 .D MES^XPDUTL("I will now update these records ...")
62 .D UPDATE
63 .D MES^XPDUTL("Done !")
64 I DGOTHERS!(DGNOLINK)!(DGLINK0)!(DGLINK1) D
65 .D MES^XPDUTL("I also found other records that need attention:")
66 .I DGOTHERS D MES^XPDUTL(" # of records needing reformatting: "_DGOTHERS)
67 .I DGNOLINK D MES^XPDUTL(" # of records with no link: "_DGNOLINK)
68 .I DGLINK0 D MES^XPDUTL(" # of records with no or bad zero node: "_DGLINK0)
69 .I DGLINK1 D MES^XPDUTL(" # of records with no '1' node: "_DGLINK1)
70 .S DGGLOBAL="^XTMP(""DG53P543"""
71 .D MES^XPDUTL(" For more details, please see the "_DGGLOBAL_" global")
72 .D MES^XPDUTL(" or print the report PRTRPT^DG53P543")
73 D BMES^XPDUTL("Clean-up is complete")
74 Q
75NOLINK ;
76 S DGNOLINK=DGNOLINK+1
77 I DGFULLNM="" S ^XTMP("DG53P543",DGIEN,0)="no name on patient file" Q
78 I '$D(^VA(20,"C",DGFULLNM)) S ^XTMP("DG53P543",DGIEN,0)="no link to file 20" Q
79 S DGFND=0
80 F S DGFND=$O(^VA(20,"C",DGFULLNM,DGFND)) Q:'DGFND D
81 .S DGDPT=+$P($G(^VA(20,DGFND,0)),U,3)
82 .I DGDPT S DGNAME=$P($G(^DPT(DGDPT,0)),U) I DGNAME'="",DGNAME=DGFULLNM S ^XTMP("DG53P543",DGIEN,0)=DGFND_" points to Patient file "_DGDPT
83 Q
84NOZERO ;
85 S DGLINK0=DGLINK0+1
86 S ^XTMP("DG53P543",DGIEN,DGLINK)="no zero node on file 20"
87 Q
88BADZERO ;
89 S DGLINK0=DGLINK0+1
90 S ^XTMP("DG53P543",DGIEN,DGLINK)="bad zero node on file 20"
91 Q
92NOONE ;
93 S DGLINK1=DGLINK1+1
94 S ^XTMP("DG53P543",DGIEN,DGLINK)="no '1' node on file 20"
95 Q
96UPDATE ;
97 Q:'$D(^XTMP("DG53P543"))
98 N DG20NAME,DA,DR,DIE,X
99 S DGIEN=0
100 F S DGIEN=$O(^XTMP("DG53P543",DGIEN)) Q:'DGIEN D
101 .S DGLINK=0
102 .F S DGLINK=$O(^XTMP("DG53P543",DGIEN,DGLINK)) Q:'DGLINK D
103 ..S DGERR=0
104 ..F S DGERR=$O(^XTMP("DG53P543",DGIEN,DGLINK,DGERR)) Q:'DGERR D
105 ...I DGERR'=1 Q
106 ...S DG20NAME=$P($G(^DPT(DGIEN,0)),U) I DG20NAME'="" D
107 ....S DIE="^DPT(",DA=DGIEN,DR=".01///^S X=DG20NAME" D ^DIE
108 ....D MES^XPDUTL("Record # "_DGIEN_" for "_$P(^DPT(DGIEN,0),U)_" has been updated")
109 ....K ^XTMP("DG53P543",DGIEN,DGLINK,DGERR)
110 ....K DG20NAME
111 Q
112 ;
113PRTRPT ;
114 I $$DEVICE() D PRINT
115 Q
116DEVICE() ; choose device and whether to queue.
117 N OK,IOP,POP,%ZIS,DGX
118 S OK=1
119 S %ZIS="MQ"
120 D ^%ZIS
121 S:POP OK=0
122 I OK,$D(IO("Q")) D
123 .N ZTRTN,ZTDESC,ZTSKM,ZTREQ,ZTSTOP
124 .S ZTRTN="PRINT^DG53P543"
125 .S ZTDESC="Print of XTMP global for DG53P543."
126 .F DGX=1:1:20 D ^%ZTLOAD Q:$G(ZTSK)
127 .W !,$S($D(ZTSK):"Request "_ZTSK_" queued!",1:"Request Cancelled!"),!
128 .D HOME^%ZIS
129 .S OK=0
130 Q OK
131 ;
132PRINT ;
133 U IO
134 N DGIEN,DGLINK,DGERR,DGQUIT,DGPG,DGDDT
135 S (DGQUIT,DGPG)=0
136 S DGDDT=$$FMTE^XLFDT($$NOW^XLFDT,"D")
137 D HEAD
138 S DGIEN=0,DGIEN=$O(^XTMP("DG53P543",DGIEN))
139 I DGIEN="" D Q
140 .W !!!,?20,"*** No records to report ***"
141 ;
142 S DGIEN=0
143 F S DGIEN=$O(^XTMP("DG53P543",DGIEN)) Q:'DGIEN D Q:DGQUIT
144 .I $D(^XTMP("DG53P543",DGIEN,0)) D
145 ..I $Y>(IOSL-4) D HEAD
146 ..W "# ",DGIEN,?11,^XTMP("DG53P543",DGIEN,0),!
147 .S DGLINK=0
148 .F S DGLINK=$O(^XTMP("DG53P543",DGIEN,DGLINK)) Q:'DGLINK D
149 ..I $D(^XTMP("DG53P543",DGIEN,DGLINK))=1 D
150 ...I $Y>(IOSL-4) D HEAD
151 ...W "# ",DGIEN,?11,$P(^DPT(DGIEN,0),U),?40,^XTMP("DG53P543",DGIEN,DGLINK),?69,"# ",DGLINK,!
152 ..S DGERR=0
153 ..F S DGERR=$O(^XTMP("DG53P543",DGIEN,DGLINK,DGERR)) Q:'DGERR D
154 ...I $Y>(IOSL-4) D HEAD
155 ...W "# ",DGIEN,?11,^XTMP("DG53P543",DGIEN,DGLINK,DGERR),?69,"# ",DGLINK,!
156 ;
157 I DGQUIT W:$D(ZTQUEUED) !!,"Report stopped at user's request" Q
158 I $G(DGPG)>0,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1
159 I $D(ZTQUEUED) S ZTREQ="@"
160 Q
161HEAD ;
162 I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQUIT)=1 Q
163 I $G(DGPG)>0,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1
164 Q:DGQUIT
165 S DGPG=$G(DGPG)+1
166 W @IOF,!,DGDDT,?15,"DG*5.3*543 File #20 Cleanup Utility",?70,"Page:",$J(DGPG,5),! K X S $P(X,"-",81)="" W X,!
167 W !,"File 2 IEN",?11,"Patient Name///Component Last^First^Middle^Prefix^Suffix",?69,"File 20 IEN",!
168 S $P(X,"-",81)="" W X,!
169 Q
Note: See TracBrowser for help on using the repository browser.