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

DG53P543.m

Go to the documentation of this file. 
  1. DG53P543 ;BAY/JT - cleanup of file 20 ; 9/16/03 4:56pm
  1.  ;;5.3;Registration;**543**;Aug 13, 1993
  1.  ; patient name .01 only
  1.  ;
  1. ENV ; do environment check
  1.  S XPDABORT=""
  1.  D PROGCHK(.XPDABORT)
  1.  I XPDABORT="" K XPDABORT
  1.  Q
  1. PROGCHK(XPDABORT) ; checks for necessary programmer variables
  1.  I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D
  1.  .D MES^XPDUTL("Your programming variables are not set up properly.")
  1.  .D MES^XPDUTL("Installation aborted.")
  1.  .S XPDABORT=2
  1.  Q
  1.  ;
  1. CLEANUP N DGIEN,DGFULLNM,DGLINK,DGFND,DGDPT,DGNAME,DGZERO,DGONE,DGERR,CNT,DGMID,DGTOT,DGUPDT,DGNOLINK,DGLINK0,DGLINK1,DGCONC,DGOTHERS,DGGLOBAL,X1,X2
  1.  K ^XTMP("DG53P543")
  1.  S X1=DT,X2=90 D C^%DTC
  1.  S ^XTMP("DG53P543",0)=X_"^"_DT_"^Problems w/file 2 links w/file 20"
  1.  S (DGIEN,DGTOT,DGERR,DGUPDT,DGNOLINK,DGLINK0,DGLINK1,DGOTHERS)=0
  1.  D BMES^XPDUTL("Beginning clean-up...Reading thru entire Patient File...")
  1.  F  S DGIEN=$O(^DPT(DGIEN)) Q:'DGIEN  D
  1.  .S DGTOT=DGTOT+1
  1.  .Q:$P($G(^DPT(DGIEN,0)),U)["MERGING INTO"
  1.  .Q:$D(^DPT(DGIEN,-9))
  1.  .S DGFULLNM=$P($G(^DPT(DGIEN,0)),U)
  1.  .S DGLINK=+$P($G(^DPT(DGIEN,"NAME")),U)
  1.  .I 'DGLINK D NOLINK Q
  1.  .S DGZERO=$G(^VA(20,DGLINK,0))
  1.  .I DGZERO="" D NOZERO Q
  1.  .I $P(DGZERO,U)'=2!($P(DGZERO,U,2)'=".01")!(+$P(DGZERO,U,3)'=DGIEN) D BADZERO Q
  1.  .S DGONE=$G(^VA(20,DGLINK,1))
  1.  .I DGONE="" D NOONE Q
  1.  .;
  1.  .S DGERR=0
  1.  .; skip if "error" in family name
  1.  .I $P(DGFULLNM,",",1)["ERROR" Q
  1.  .; compare family name
  1.  .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
  1.  .; skip if no first name
  1.  .I $P(DGFULLNM,",",2)="",$P(DGONE,U,2)="" Q
  1.  .; if comma in first name, skip if everything equal
  1.  .I $P(DGONE,U,2)["," S DGCONC=$P(DGONE,U)_","_$P(DGONE,U,2) I DGCONC=DGFULLNM Q
  1.  .; compare first name
  1.  .S CNT=$L($P(DGONE,U,2))
  1.  .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
  1.  .;compare middle names and suffixes
  1.  .S DGMID=$P($P(DGFULLNM,",",2)," ",2)
  1.  .I DGMID=$P(DGONE,U,3)!(DGMID=$P(DGONE,U,5)) Q
  1.  .S DGMID=$P($P(DGFULLNM,",",2)," ",2,99)
  1.  .I $P(DGONE,U,3)'="",DGMID[$P(DGONE,U,3) Q
  1.  .I $P(DGONE,U,5)'="",DGMID[$P(DGONE,U,5) Q
  1.  .S DGERR=3
  1.  .S ^XTMP("DG53P543",DGIEN,DGLINK,DGERR)=DGFULLNM_"///"_$P(DGONE,U,1,5) S DGOTHERS=DGOTHERS+1
  1.  .Q
  1.  ;
  1.  D MES^XPDUTL("Total # of Patient File records read: "_DGTOT)
  1.  D MES^XPDUTL("Total # of Name Component file #20 records needing cleanup: "_DGUPDT)
  1.  I DGUPDT D
  1.  .D MES^XPDUTL("I will now update these records ...")
  1.  .D UPDATE
  1.  .D MES^XPDUTL("Done !")
  1.  I DGOTHERS!(DGNOLINK)!(DGLINK0)!(DGLINK1) D
  1.  .D MES^XPDUTL("I also found other records that need attention:")
  1.  .I DGOTHERS D MES^XPDUTL("  # of records needing reformatting: "_DGOTHERS)
  1.  .I DGNOLINK D MES^XPDUTL("  # of records with no link: "_DGNOLINK)
  1.  .I DGLINK0 D MES^XPDUTL("  # of records with no or bad zero node: "_DGLINK0)
  1.  .I DGLINK1 D MES^XPDUTL("  # of records with no '1' node: "_DGLINK1)
  1.  .S DGGLOBAL="^XTMP(""DG53P543"""
  1.  .D MES^XPDUTL("  For more details, please see the "_DGGLOBAL_" global")
  1.  .D MES^XPDUTL("  or print the report PRTRPT^DG53P543")
  1.  D BMES^XPDUTL("Clean-up is complete")
  1.  Q
  1.  S DGNOLINK=DGNOLINK+1
  1.  I DGFULLNM="" S ^XTMP("DG53P543",DGIEN,0)="no name on patient file" Q
  1.  I '$D(^VA(20,"C",DGFULLNM)) S ^XTMP("DG53P543",DGIEN,0)="no link to file 20" Q
  1.  S DGFND=0
  1.  F  S DGFND=$O(^VA(20,"C",DGFULLNM,DGFND)) Q:'DGFND  D
  1.  .S DGDPT=+$P($G(^VA(20,DGFND,0)),U,3)
  1.  .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
  1.  Q
  1. NOZERO ;
  1.  S DGLINK0=DGLINK0+1
  1.  S ^XTMP("DG53P543",DGIEN,DGLINK)="no zero node on file 20"
  1.  Q
  1. BADZERO ;
  1.  S DGLINK0=DGLINK0+1
  1.  S ^XTMP("DG53P543",DGIEN,DGLINK)="bad zero node on file 20"
  1.  Q
  1. NOONE ;
  1.  S DGLINK1=DGLINK1+1
  1.  S ^XTMP("DG53P543",DGIEN,DGLINK)="no '1' node on file 20"
  1.  Q
  1. UPDATE ;
  1.  Q:'$D(^XTMP("DG53P543"))
  1.  N DG20NAME,DA,DR,DIE,X
  1.  S DGIEN=0
  1.  F  S DGIEN=$O(^XTMP("DG53P543",DGIEN)) Q:'DGIEN  D
  1.  .S DGLINK=0
  1.  .F  S DGLINK=$O(^XTMP("DG53P543",DGIEN,DGLINK)) Q:'DGLINK  D
  1.  ..S DGERR=0
  1.  ..F  S DGERR=$O(^XTMP("DG53P543",DGIEN,DGLINK,DGERR)) Q:'DGERR  D
  1.  ...I DGERR'=1 Q
  1.  ...S DG20NAME=$P($G(^DPT(DGIEN,0)),U) I DG20NAME'="" D
  1.  ....S DIE="^DPT(",DA=DGIEN,DR=".01///^S X=DG20NAME" D ^DIE
  1.  ....D MES^XPDUTL("Record # "_DGIEN_" for "_$P(^DPT(DGIEN,0),U)_" has been updated")
  1.  ....K ^XTMP("DG53P543",DGIEN,DGLINK,DGERR)
  1.  ....K DG20NAME
  1.  Q
  1.  ;
  1. PRTRPT ;
  1.  I $$DEVICE() D PRINT
  1.  Q
  1. DEVICE() ; choose device and whether to queue.
  1.  N OK,IOP,POP,%ZIS,DGX
  1.  S OK=1
  1.  S %ZIS="MQ"
  1.  D ^%ZIS
  1.  S:POP OK=0
  1.  I OK,$D(IO("Q")) D
  1.  .N ZTRTN,ZTDESC,ZTSKM,ZTREQ,ZTSTOP
  1.  .S ZTRTN="PRINT^DG53P543"
  1.  .S ZTDESC="Print of XTMP global for DG53P543."
  1.  .F DGX=1:1:20 D ^%ZTLOAD Q:$G(ZTSK)
  1.  .W !,$S($D(ZTSK):"Request "_ZTSK_" queued!",1:"Request Cancelled!"),!
  1.  .D HOME^%ZIS
  1.  .S OK=0
  1.  Q OK
  1.  ;
  1. PRINT ;
  1.  U IO
  1.  N DGIEN,DGLINK,DGERR,DGQUIT,DGPG,DGDDT
  1.  S (DGQUIT,DGPG)=0
  1.  S DGDDT=$$FMTE^XLFDT($$NOW^XLFDT,"D")
  1.  D HEAD
  1.  S DGIEN=0,DGIEN=$O(^XTMP("DG53P543",DGIEN))
  1.  I DGIEN="" D  Q
  1.  .W !!!,?20,"*** No records to report ***"
  1.  ;
  1.  S DGIEN=0
  1.  F  S DGIEN=$O(^XTMP("DG53P543",DGIEN)) Q:'DGIEN  D  Q:DGQUIT
  1.  .I $D(^XTMP("DG53P543",DGIEN,0)) D 
  1.  ..I $Y>(IOSL-4) D HEAD
  1.  ..W "# ",DGIEN,?11,^XTMP("DG53P543",DGIEN,0),!
  1.  .S DGLINK=0
  1.  .F  S DGLINK=$O(^XTMP("DG53P543",DGIEN,DGLINK)) Q:'DGLINK  D
  1.  ..I $D(^XTMP("DG53P543",DGIEN,DGLINK))=1 D
  1.  ...I $Y>(IOSL-4) D HEAD
  1.  ...W "# ",DGIEN,?11,$P(^DPT(DGIEN,0),U),?40,^XTMP("DG53P543",DGIEN,DGLINK),?69,"# ",DGLINK,!
  1.  ..S DGERR=0
  1.  ..F  S DGERR=$O(^XTMP("DG53P543",DGIEN,DGLINK,DGERR)) Q:'DGERR  D
  1.  ...I $Y>(IOSL-4) D HEAD
  1.  ...W "# ",DGIEN,?11,^XTMP("DG53P543",DGIEN,DGLINK,DGERR),?69,"# ",DGLINK,!
  1.  ;
  1.  I DGQUIT W:$D(ZTQUEUED) !!,"Report stopped at user's request" Q
  1.  I $G(DGPG)>0,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1
  1.  I $D(ZTQUEUED) S ZTREQ="@"
  1.  Q
  1.  I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQUIT)=1 Q
  1.  I $G(DGPG)>0,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1
  1.  Q:DGQUIT
  1.  S DGPG=$G(DGPG)+1
  1.  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,!
  1.  W !,"File 2 IEN",?11,"Patient Name///Component Last^First^Middle^Prefix^Suffix",?69,"File 20 IEN",!
  1.  S $P(X,"-",81)="" W X,!
  1.  Q