source: WorldVistAEHR/trunk/r/ENROLLMENT_APPLICATION_SYSTEM-EAS/EASXDRPT.m@ 1766

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

initial load of WorldVistAEHR

File size: 4.2 KB
Line 
1EASXDRPT ;ALB/AEG - DUP PT RELATION REPORT ;7-12-02
2 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**10**;Mar 15,2001
3 ;
4RPT ; Option Entry Point.
5 D TEXT^EASXDRUT
6 W !
7 ;
8EN1 ; Device Handler.
9 N %ZIS
10 S %ZIS="QM" D ^%ZIS
11 I POP W !!,?5,"REPORT CANCELLED!",$C(7),! G STOPIT
12 I $D(IO("Q")) D QUEIT G STOPIT
13 I '$D(IO("Q")) D Q
14 .I $E(IOST,1,2)="C-" D WAIT^DICD,START Q
15 .E D START Q
16 Q
17 ;
18START ;
19 D SETUP^EASXDRUT
20 D INIT,FIND,PURGE
21 D PRINT^EASXRPT1
22 D QUIT
23 Q
24 ;
25INIT ; Setup scratch globals and initialize processing.
26 N EASA,EASB,EASC,EASAA,EASAB,EASAC,QUO
27 S QUO=""""
28 F EASA=1,2 D
29 .F EASB=1,2 D
30 ..F EASC=1,2 D
31 ...S EASAA=$S(EASA=1:"EASXDRPT",1:"DECEASED")
32 ...S EASAB=$S(EASB=1:"CATC",1:"CATOTHER")
33 ...S EASAC=$S(EASC=1:"NOCMOR",1:"CMORE")
34 ...S ROOT(EASA,EASB,EASC)="^TMP("_QUO_EASAA_QUO_","_QUO_EASAB_QUO_","_QUO_EASAC_QUO_","_$J_")"
35 ...Q
36 ..Q
37 .Q
38 Q
39 ;
40FIND ; Search for potential dups in file #408.12
41 N EASDOD,EASMTS,EASSRC,SRC,REC12,EASPER,EASREL,EASACT,EASCNT
42 N NODE
43 S DFN=0
44 F S DFN=$O(^DGPR(408.12,"B",DFN)) Q:DFN'>0 D
45 .S EASDOD=$S($$GET1^DIQ(2,DFN_",",.351,"I")]"":2,1:1)
46 .S EASMTS=$S($P($$LST^DGMTU(DFN),U,4)="C":1,1:2)
47 .; The following call is supported via DBIA #2701
48 .S SRC=$$IFVCCI^MPIF001(DFN)
49 .S EASSRC=$S(SRC=1:2,1:1)
50 .S REC12=0
51 .F S REC12=$O(^DGPR(408.12,"B",DFN,REC12)) Q:REC12'>0 D
52 ..S NODE=$G(^DGPR(408.12,REC12,0))
53 ..S EASPER=$$GET1^DIQ(408.12,REC12_",",.03,"E")
54 ..S:EASPER']"" EASPER="NO PERSON ENTRY"
55 ..S EASREL=$$GET1^DIQ(408.12,REC12_",",.02,"E")
56 ..S:EASREL']"" EASREL="NO RELATION ENTRY"
57 ..S EASCNT=1
58 ..I $D(DUPS(DFN,EASREL,EASPER)) D
59 ...S EASCNT=$O(DUPS(DFN,EASREL,EASPER,""),-1)+1
60 ..S DUPS(DFN,EASREL,EASPER,EASCNT)=REC12
61 ..I EASREL="NO RELATION ENTRY" D Q
62 ...S @ROOT(EASDOD,EASMTS,EASSRC)@("NO RELATION",DFN,EASCNT)=REC12_U_EASPER
63 ..I EASPER="NO PERSON ENTRY" D Q
64 ...S @ROOT(EASDOD,EASMTS,EASSRC)@("NO PERSON",DFN,EASCNT)=REC12_U_EASREL
65 ..S EASACT=$$ACTIVE(REC12)
66 ..S @ROOT(EASDOD,EASMTS,EASSRC)@(DFN,EASREL,EASCNT)=REC12_U_EASPER_U_EASACT
67 .K DUPS(DFN)
68 Q
69 ;
70ACTIVE(REC12) ; Is relation entry active ?
71 N RETV,EASSUB,EASTIEN,ACTF
72 S (RETV,ACTF)="",EASSUB=0
73 F S EASSUB=$O(^DGPR(408.12,REC12,"E",EASSUB)) Q:EASSUB'>0 D Q:$L(RETV,"~")>1
74 .S ACTF=$$GET1^DIQ(408.1275,EASSUB_","_REC12_",",".02")
75 .Q:ACTF']"" RETV
76 .S EASTIEN=$$GET1^DIQ(408.1275,EASSUB_","_REC12_",",.04,"I")
77 .S EASTIEN=$S(EASTIEN>0:$$GET1^DIQ(408.31,EASTIEN_",",.019,"I"),1:"")
78 .S EASTIEN=$S(EASTIEN>0:$$GET1^DIQ(408.33,EASTIEN_",",.01,"E"),1:"")
79 .S RETV=ACTF_"~"_EASTIEN_"~"_EASSUB
80 Q RETV
81 ;
82PURGE ; Purge non-duplicate from temp globals.
83 N AA,AB,AC
84 F AA=1,2 F AB=1,2 F AC=1,2 D MORE
85 Q
86 ;
87MORE ; Purge of non-dups continued.
88 N DFN,REL,LSTNUM,CNT,NODE2,CNT2
89 S (LNAME,DFN)=0
90 F S DFN=$O(@ROOT(AA,AB,AC)@(DFN)) Q:DFN'>0 D
91 .S REL=""
92 .F S REL=$O(@ROOT(AA,AB,AC)@(DFN,REL)) Q:REL']"" D
93 ..S LSTNUM=$O(@ROOT(AA,AB,AC)@(DFN,REL,""),-1)
94 ..I $D(@ROOT(AA,AB,AC)@(DFN,REL,LSTNUM,"E")) D Q
95 ...S LNAME=$S($L(REL)>LNAME:$L(REL),1:LNAME)
96 ..D NAME
97 ..I $O(@ROOT(AA,AB,AC)@(DFN,REL,""))=LSTNUM D Q
98 ...K @ROOT(AA,AB,AC)@(DFN,REL,LSTNUM)
99 ..S CNT=""
100 ..F S CNT=$O(@ROOT(AA,AB,AC)@(DFN,REL,CNT)) Q:CNT'>0 D
101 ...S NODE2=@ROOT(AA,AB,AC)@(DFN,REL,CNT)
102 ...I $P(NODE2,U,4)']"" D
103 ....K @ROOT(AA,AB,AC)@(DFN,REL,CNT)
104 ...I $P(NODE2,U,4)]"" D
105 ....S LNAME=$S($L(REL)>LNAME:$L(REL),1:LNAME)
106 ...Q
107 ..Q
108 .Q
109 Q
110 ;
111NAME ; Check names
112 N CNT,CHKNAME,CNT2
113 S CNT=""
114 F S CNT=$O(@ROOT(AA,AB,AC)@(DFN,REL,CNT)) Q:CNT'>0 D
115 .S CHKNAME=$P($G(@ROOT(AA,AB,AC)@(DFN,REL,CNT)),U,2)
116 .I CHKNAME["MERGING" D
117 ..S $P(@ROOT(AA,AB,AC)@(DFN,REL,CNT),U,4)="SHOULD BE MERGED"
118 .I $P($G(@ROOT(AA,AB,AC)@(DFN,REL,CNT)),U,4)]"" Q
119 .S CNT2=CNT
120 .F S CNT2=$O(@ROOT(AA,AB,AC)@(DFN,REL,CNT2)) Q:CNT2'>0 D
121 ..I CHKNAME'=$P($G(@ROOT(AA,AB,AC)@(DFN,REL,CNT2)),U,2) Q
122 ..S $P(@ROOT(AA,AB,AC)@(DFN,REL,CNT2),U,4)="SHOULD BE MERGED"
123 ..S $P(@ROOT(AA,AB,AC)@(DFN,REL,CNT),U,4)="SHOULD BE MERGED"
124 Q
125 ;
126QUIT ; Cleanup and quit.
127 N A,B,C
128 F A=1,2 D
129 .F B=1,2 D
130 ..F C=1,2 K @ROOT(A,B,C)
131 K DUPS,LNAME,POP,ROOT,ZTSK
132 K COL1,COL2,COL3,COL4,COL5,COL6,COL7,DAL,EQL,FSTP
133 Q
134STOPIT ;
135 Q
136QUEIT ; Que task
137 N ZTDESC,ZTRTN,ZTSAVE
138 S ZTDESC="EAS DUPLICATE PT REL REPORT",ZTRTN="START^EASXDRPT"
139 S ZTSAVE("*")=""
140 W !
141 D ^%ZTLOAD
142 I $G(ZTSK)>0 W !!,">>> Task Number #"_$G(ZTSK)_" queued. <<<",! H .5
143 D HOME^%ZIS
144 Q
Note: See TracBrowser for help on using the repository browser.