source: FOIAVistA/tag/r/ENROLLMENT_APPLICATION_SYSTEM-EAS/EASXDRPT.m@ 628

EASXDRPT ;ALB/AEG - DUP PT RELATION REPORT ;7-12-02
 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**10**;Mar 15,2001
 ;
RPT ; Option Entry Point.
 D TEXT^EASXDRUT
 W !
 ;
EN1 ; Device Handler.
 N %ZIS
 S %ZIS="QM" D ^%ZIS
 I POP W !!,?5,"REPORT CANCELLED!",$C(7),! G STOPIT
 I $D(IO("Q")) D QUEIT G STOPIT
 I '$D(IO("Q")) D  Q
 .I $E(IOST,1,2)="C-" D WAIT^DICD,START Q
 .E  D START Q
 Q
 ;
START ;
 D SETUP^EASXDRUT
 D INIT,FIND,PURGE
 D PRINT^EASXRPT1
 D QUIT
 Q
 ;
INIT ; Setup scratch globals and initialize processing.
 N EASA,EASB,EASC,EASAA,EASAB,EASAC,QUO
 S QUO=""""
 F EASA=1,2 D
 .F EASB=1,2 D
 ..F EASC=1,2 D
 ...S EASAA=$S(EASA=1:"EASXDRPT",1:"DECEASED")
 ...S EASAB=$S(EASB=1:"CATC",1:"CATOTHER")
 ...S EASAC=$S(EASC=1:"NOCMOR",1:"CMORE")
 ...S ROOT(EASA,EASB,EASC)="^TMP("_QUO_EASAA_QUO_","_QUO_EASAB_QUO_","_QUO_EASAC_QUO_","_$J_")"
 ...Q
 ..Q
 .Q
 Q
 ;
FIND ; Search for potential dups in file #408.12
 N EASDOD,EASMTS,EASSRC,SRC,REC12,EASPER,EASREL,EASACT,EASCNT
 N NODE
 S DFN=0
 F  S DFN=$O(^DGPR(408.12,"B",DFN)) Q:DFN'>0  D
 .S EASDOD=$S($$GET1^DIQ(2,DFN_",",.351,"I")]"":2,1:1)
 .S EASMTS=$S($P($$LST^DGMTU(DFN),U,4)="C":1,1:2)
 .; The following call is supported via DBIA #2701
 .S SRC=$$IFVCCI^MPIF001(DFN)
 .S EASSRC=$S(SRC=1:2,1:1)
 .S REC12=0
 .F  S REC12=$O(^DGPR(408.12,"B",DFN,REC12)) Q:REC12'>0  D
 ..S NODE=$G(^DGPR(408.12,REC12,0))
 ..S EASPER=$$GET1^DIQ(408.12,REC12_",",.03,"E")
 ..S:EASPER']"" EASPER="NO PERSON ENTRY"
 ..S EASREL=$$GET1^DIQ(408.12,REC12_",",.02,"E")
 ..S:EASREL']"" EASREL="NO RELATION ENTRY"
 ..S EASCNT=1
 ..I $D(DUPS(DFN,EASREL,EASPER)) D
 ...S EASCNT=$O(DUPS(DFN,EASREL,EASPER,""),-1)+1
 ..S DUPS(DFN,EASREL,EASPER,EASCNT)=REC12
 ..I EASREL="NO RELATION ENTRY" D  Q
 ...S @ROOT(EASDOD,EASMTS,EASSRC)@("NO RELATION",DFN,EASCNT)=REC12_U_EASPER
 ..I EASPER="NO PERSON ENTRY" D  Q
 ...S @ROOT(EASDOD,EASMTS,EASSRC)@("NO PERSON",DFN,EASCNT)=REC12_U_EASREL
 ..S EASACT=$$ACTIVE(REC12)
 ..S @ROOT(EASDOD,EASMTS,EASSRC)@(DFN,EASREL,EASCNT)=REC12_U_EASPER_U_EASACT
 .K DUPS(DFN)
 Q
 ;
ACTIVE(REC12) ; Is relation entry active ?
 N RETV,EASSUB,EASTIEN,ACTF
 S (RETV,ACTF)="",EASSUB=0
 F  S EASSUB=$O(^DGPR(408.12,REC12,"E",EASSUB)) Q:EASSUB'>0  D  Q:$L(RETV,"~")>1
 .S ACTF=$$GET1^DIQ(408.1275,EASSUB_","_REC12_",",".02")
 .Q:ACTF']"" RETV
 .S EASTIEN=$$GET1^DIQ(408.1275,EASSUB_","_REC12_",",.04,"I")
 .S EASTIEN=$S(EASTIEN>0:$$GET1^DIQ(408.31,EASTIEN_",",.019,"I"),1:"")
 .S EASTIEN=$S(EASTIEN>0:$$GET1^DIQ(408.33,EASTIEN_",",.01,"E"),1:"")
 .S RETV=ACTF_"~"_EASTIEN_"~"_EASSUB
 Q RETV
 ;
PURGE ; Purge non-duplicate from temp globals.
 N AA,AB,AC
 F AA=1,2 F AB=1,2 F AC=1,2 D MORE
 Q
 ;
MORE ; Purge of non-dups continued.
 N DFN,REL,LSTNUM,CNT,NODE2,CNT2
 S (LNAME,DFN)=0
 F  S DFN=$O(@ROOT(AA,AB,AC)@(DFN)) Q:DFN'>0  D
 .S REL=""
 .F  S REL=$O(@ROOT(AA,AB,AC)@(DFN,REL)) Q:REL']""  D
 ..S LSTNUM=$O(@ROOT(AA,AB,AC)@(DFN,REL,""),-1)
 ..I $D(@ROOT(AA,AB,AC)@(DFN,REL,LSTNUM,"E")) D  Q
 ...S LNAME=$S($L(REL)>LNAME:$L(REL),1:LNAME)
 ..D NAME
 ..I $O(@ROOT(AA,AB,AC)@(DFN,REL,""))=LSTNUM D  Q
 ...K @ROOT(AA,AB,AC)@(DFN,REL,LSTNUM)
 ..S CNT=""
 ..F  S CNT=$O(@ROOT(AA,AB,AC)@(DFN,REL,CNT)) Q:CNT'>0  D
 ...S NODE2=@ROOT(AA,AB,AC)@(DFN,REL,CNT)
 ...I $P(NODE2,U,4)']"" D
 ....K @ROOT(AA,AB,AC)@(DFN,REL,CNT)
 ...I $P(NODE2,U,4)]"" D
 ....S LNAME=$S($L(REL)>LNAME:$L(REL),1:LNAME)
 ...Q
 ..Q
 .Q
 Q
 ;
NAME ; Check names
 N CNT,CHKNAME,CNT2
 S CNT=""
 F  S CNT=$O(@ROOT(AA,AB,AC)@(DFN,REL,CNT)) Q:CNT'>0  D
 .S CHKNAME=$P($G(@ROOT(AA,AB,AC)@(DFN,REL,CNT)),U,2)
 .I CHKNAME["MERGING" D
 ..S $P(@ROOT(AA,AB,AC)@(DFN,REL,CNT),U,4)="SHOULD BE MERGED"
 .I $P($G(@ROOT(AA,AB,AC)@(DFN,REL,CNT)),U,4)]"" Q
 .S CNT2=CNT
 .F  S CNT2=$O(@ROOT(AA,AB,AC)@(DFN,REL,CNT2)) Q:CNT2'>0  D
 ..I CHKNAME'=$P($G(@ROOT(AA,AB,AC)@(DFN,REL,CNT2)),U,2) Q
 ..S $P(@ROOT(AA,AB,AC)@(DFN,REL,CNT2),U,4)="SHOULD BE MERGED"
 ..S $P(@ROOT(AA,AB,AC)@(DFN,REL,CNT),U,4)="SHOULD BE MERGED"
 Q
 ;
QUIT ; Cleanup and quit.
 N A,B,C
 F A=1,2 D
 .F B=1,2 D
 ..F C=1,2 K @ROOT(A,B,C)
 K DUPS,LNAME,POP,ROOT,ZTSK
 K COL1,COL2,COL3,COL4,COL5,COL6,COL7,DAL,EQL,FSTP
 Q
STOPIT ;
 Q
QUEIT ; Que task
 N ZTDESC,ZTRTN,ZTSAVE
 S ZTDESC="EAS DUPLICATE PT REL REPORT",ZTRTN="START^EASXDRPT"
 S ZTSAVE("*")=""
 W !
 D ^%ZTLOAD
 I $G(ZTSK)>0 W !!,">>> Task Number #"_$G(ZTSK)_" queued. <<<",! H .5
 D HOME^%ZIS
 Q