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

DG53P897.m

Go to the documentation of this file. 
  1. DG53P897 ;BAY/JAT - Patient File Updat; 6/7/04 7:13pm ; 9/9/14 8:15am
  1.  ;;5.3;Registration;**897**;Aug 13,1993;Build 10
  1.  Q
  1.  ;
  1. CLEANUP ;This entry point will do the update.
  1.  ;
  1.  N DGENSKIP
  1.  S DGENSKIP=0
  1.  W !,"This is a one-time update of the Patient File."
  1.  W !,"It will correct Race & Ethnicity records."
  1.  N X1,X2
  1.  K ^XTMP("DG53P897",$J)
  1.  S X1=DT,X2=90 D C^%DTC
  1.  S ^XTMP("DG53P897",$J,0)=X_"^"_DT_"^Patient File update"
  1.  I $$DEVICE() D ENTER
  1.  Q
  1.  ;
  1. REPORT ;This entry point was provided for testing, so that before
  1.  ;patient records are updated the site can have a list of
  1.  ;the DFN's that would be affected.
  1.  ; 
  1.  ;Use this entry point to report on what the update would do.
  1.  ;No changes will be made to the database.
  1.  ;
  1.  N DGENSKIP
  1.  S DGENSKIP=1
  1.  W !,"This is a preliminary report by DFN of the Patient file"
  1.  W !,"records which would be affected by the update."
  1.  N X1,X2
  1.  K ^XTMP("DG53P897",$J)
  1.  S X1=DT,X2=90 D C^%DTC
  1.  S ^XTMP("DG53P897",$J,0)=X_"^"_DT_"^Patient File update"
  1.  I $$DEVICE() D ENTER
  1.  Q
  1.  ;
  1. ENTER ;
  1.  ;
  1.  D UPDATE(DGENSKIP)
  1.  D:(DGENSKIP) ^%ZISC
  1.  I $D(ZTQUEUED) S ZTREQ="@"
  1.  Q
  1. DEVICE() ;
  1.  ;Description: allows the user to select a device.
  1.  ;
  1.  ;Output:
  1.  ;  Function Value - Returns 0 if the user decides not to print or to
  1.  ;       queue the report, 1 otherwise.
  1.  ;
  1.  N OK,IOP,POP,%ZIS
  1.  S OK=1
  1.  S %ZIS="MQ"
  1.  D ^%ZIS
  1.  S:POP OK=0
  1.  D:OK&$D(IO("Q"))
  1.  .N ZTRTN,ZTDESC,ZTSKM,ZTREQ,ZTSTOP
  1.  .S ZTRTN="ENTER^DG53P897",ZTDESC=$S(DGENSKIP:"Report",1:"Update")_" of Patient Records"
  1.  .S ZTSAVE("DGENSKIP")=""
  1.  .D ^%ZTLOAD
  1.  .W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
  1.  .D HOME^%ZIS
  1.  .S OK=0
  1.  Q OK
  1.  ;
  1. UPDATE(DGENSKIP) ;
  1.  ;This will update patient records --
  1.  ;
  1.  ;Input: If DGENSKIP=1, the records will not be updated,
  1.  ;just reported.
  1.  ;
  1.  N DFN,COUNT,DGMULT,DGSAVE,DGDUPE,DGETHN,DGDATA,DGRACE,DGETHNIC,DGFDA,X,DINUM,DIC,DA,DGTEST
  1.  S (COUNT,DFN)=0
  1.  F  S DFN=$O(^DPT(DFN)) Q:'DFN  D
  1.  .; merged record
  1.  .I $D(^DPT(DFN,-9)) Q
  1.  .; in process of being merged
  1.  .I $P($G(^DPT(DFN,0)),U)["MERGING INTO" Q
  1.  .I '$D(^DPT(DFN,0)) Q
  1.  .I $P(^DPT(DFN,0),U)="" Q
  1.  .; look for duplicates
  1.  .S (DGMULT,DGSAVE,DGDUPE)=0
  1.  .F  S DGMULT=$O(^DPT(DFN,.02,DGMULT)) Q:'DGMULT  D
  1.  ..I DGSAVE=0 S DGSAVE=$P($G(^DPT(DFN,.02,DGMULT,0)),U) Q
  1.  ..I DGSAVE=$P($G(^DPT(DFN,.02,DGMULT,0)),U) S DGDUPE=1 D UPDR S DGDUPE=0
  1.  .S (DGMULT,DGSAVE,DGETHN)=0
  1.  .F  S DGMULT=$O(^DPT(DFN,.06,DGMULT)) Q:'DGMULT  D
  1.  ..I DGSAVE=0 S DGSAVE=$P($G(^DPT(DFN,.06,DGMULT,0)),U) Q
  1.  ..I DGSAVE=$P($G(^DPT(DFN,.06,DGMULT,0)),U) S DGETHN=1 D UPDR S DGETHN=0
  1.  .;look for no dinums
  1.  .S (DGMULT,DGRACE,DGETHNIC)=0
  1.  .F  S DGMULT=$O(^DPT(DFN,.02,DGMULT)) Q:'DGMULT  D
  1.  ..S DGDATA=$G(^DPT(DFN,.02,DGMULT,0))
  1.  ..S DGRACE=$P(DGDATA,U)
  1.  ..I DGMULT'=DGRACE D UPDR
  1.  .S (DGMULT,DGRACE,DGETHNIC)=0
  1.  .F  S DGMULT=$O(^DPT(DFN,.06,DGMULT)) Q:'DGMULT  D
  1.  ..S DGDATA=$G(^DPT(DFN,.06,DGMULT,0))
  1.  ..S DGETHNIC=$P(DGDATA,U)
  1.  ..I DGMULT'=DGETHNIC D UPDR
  1.  ;
  1.  D PRINT
  1.  Q
  1.  ;
  1. UPDR ;
  1.  I '$D(^XTMP("DG53P897",$J,DFN)) S COUNT=COUNT+1
  1.  S DGTEXT=""
  1.  I $D(^XTMP("DG53P897",$J,DFN)) S DGTEXT=$G(^XTMP("DG53P897",$J,DFN))
  1.  S ^XTMP("DG53P897",$J,DFN)=$S(DGDUPE:"dupe race",DGETHN:"dupe ethnic",DGRACE:"race entry not dinumed",DGETHNIC:"ethnicity entry not dinumed",1:"unknown")_"^"_DGTEXT
  1.  I 'DGENSKIP D
  1.  .I DGDUPE D
  1.  ..S DGFDA(2.02,DGMULT_","_DFN_",",.01)="@"
  1.  ..D FILE^DIE(,"DGFDA",)
  1.  .I DGETHN D
  1.  ..S DGFDA(2.06,DGMULT_","_DFN_",",.01)="@"
  1.  ..D FILE^DIE(,"DGFDA",)
  1.  .I DGRACE D
  1.  ..S DGFDA(2.02,DGMULT_","_DFN_",",.01)="@"
  1.  ..D FILE^DIE(,"DGFDA",)
  1.  ..S (X,DINUM)=DGRACE,DIC="^DPT(DFN,.02,",DA(1)=DFN,DIC(0)="L"
  1.  ..K DO D FILE^DICN
  1.  .I DGETHNIC D
  1.  ..S DGFDA(2.06,DGMULT_","_DFN_",",.01)="@"
  1.  ..D FILE^DIE(,"DGFDA",)
  1.  ..S (X,DINUM)=DGETHNIC,DIC="^DPT(DFN,.06,",DA(1)=DFN,DIC(0)="L"
  1.  ..K DO D FILE^DICN
  1.  Q
  1. PRINT ;
  1.  U IO
  1.  N DGDDT,DGQUIT,DGPG
  1.  S DGDDT=$$FMTE^XLFDT($$NOW^XLFDT,"D")
  1.  S (DGQUIT,DGPG)=0
  1.  D HEAD
  1.  I '$G(COUNT) D  Q
  1.  .W !!!,?20,"*** No records to report ***"
  1.  W !!,"*** COUNT OF BAD PATIENT RECORDS"_$S(DGENSKIP:"",1:" UPDATED")_": ",COUNT," ***",!!
  1.  S DFN=0
  1.  F  S DFN=$O(^XTMP("DG53P897",$J,DFN)) Q:'DFN  D  Q:DGQUIT
  1.  .I $Y>(IOSL-4) D HEAD
  1.  .W ?2,DFN,?15,$G(^XTMP("DG53P897",$J,DFN)),!
  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.  ;
  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*897 Patient File Update Utility",?70,"Page:",$J(DGPG,5),! K X S $P(X,"-",81)="" W X,!
  1.  W !
  1.  W !,?2,"DFN",?15,"Action to be taken",!
  1.  S $P(X,"-",81)="" W X,!
  1.  Q