Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: EASXDRPT

EASXDRPT.m

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