DG53P897 ;BAY/JAT - Patient File Updat; 6/7/04 7:13pm ; 9/9/14 8:15am
;;5.3;Registration;**897**;Aug 13,1993;Build 10
Q
;
CLEANUP ;This entry point will do the update.
;
N DGENSKIP
S DGENSKIP=0
W !,"This is a one-time update of the Patient File."
W !,"It will correct Race & Ethnicity records."
N X1,X2
K ^XTMP("DG53P897",$J)
S X1=DT,X2=90 D C^%DTC
S ^XTMP("DG53P897",$J,0)=X_"^"_DT_"^Patient File update"
I $$DEVICE() D ENTER
Q
;
REPORT ;This entry point was provided for testing, so that before
;patient records are updated the site can have a list of
;the DFN's that would be affected.
;
;Use this entry point to report on what the update would do.
;No changes will be made to the database.
;
N DGENSKIP
S DGENSKIP=1
W !,"This is a preliminary report by DFN of the Patient file"
W !,"records which would be affected by the update."
N X1,X2
K ^XTMP("DG53P897",$J)
S X1=DT,X2=90 D C^%DTC
S ^XTMP("DG53P897",$J,0)=X_"^"_DT_"^Patient File update"
I $$DEVICE() D ENTER
Q
;
ENTER ;
;
D UPDATE(DGENSKIP)
D:(DGENSKIP) ^%ZISC
I $D(ZTQUEUED) S ZTREQ="@"
Q
DEVICE() ;
;Description: allows the user to select a device.
;
;Output:
; Function Value - Returns 0 if the user decides not to print or to
; queue the report, 1 otherwise.
;
N OK,IOP,POP,%ZIS
S OK=1
S %ZIS="MQ"
D ^%ZIS
S:POP OK=0
D:OK&$D(IO("Q"))
.N ZTRTN,ZTDESC,ZTSKM,ZTREQ,ZTSTOP
.S ZTRTN="ENTER^DG53P897",ZTDESC=$S(DGENSKIP:"Report",1:"Update")_" of Patient Records"
.S ZTSAVE("DGENSKIP")=""
.D ^%ZTLOAD
.W !,$S($D(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
.D HOME^%ZIS
.S OK=0
Q OK
;
UPDATE(DGENSKIP) ;
;This will update patient records --
;
;Input: If DGENSKIP=1, the records will not be updated,
;just reported.
;
N DFN,COUNT,DGMULT,DGSAVE,DGDUPE,DGETHN,DGDATA,DGRACE,DGETHNIC,DGFDA,X,DINUM,DIC,DA,DGTEST
S (COUNT,DFN)=0
F S DFN=$O(^DPT(DFN)) Q:'DFN D
.; merged record
.I $D(^DPT(DFN,-9)) Q
.; in process of being merged
.I $P($G(^DPT(DFN,0)),U)["MERGING INTO" Q
.I '$D(^DPT(DFN,0)) Q
.I $P(^DPT(DFN,0),U)="" Q
.; look for duplicates
.S (DGMULT,DGSAVE,DGDUPE)=0
.F S DGMULT=$O(^DPT(DFN,.02,DGMULT)) Q:'DGMULT D
..I DGSAVE=0 S DGSAVE=$P($G(^DPT(DFN,.02,DGMULT,0)),U) Q
..I DGSAVE=$P($G(^DPT(DFN,.02,DGMULT,0)),U) S DGDUPE=1 D UPDR S DGDUPE=0
.S (DGMULT,DGSAVE,DGETHN)=0
.F S DGMULT=$O(^DPT(DFN,.06,DGMULT)) Q:'DGMULT D
..I DGSAVE=0 S DGSAVE=$P($G(^DPT(DFN,.06,DGMULT,0)),U) Q
..I DGSAVE=$P($G(^DPT(DFN,.06,DGMULT,0)),U) S DGETHN=1 D UPDR S DGETHN=0
.;look for no dinums
.S (DGMULT,DGRACE,DGETHNIC)=0
.F S DGMULT=$O(^DPT(DFN,.02,DGMULT)) Q:'DGMULT D
..S DGDATA=$G(^DPT(DFN,.02,DGMULT,0))
..S DGRACE=$P(DGDATA,U)
..I DGMULT'=DGRACE D UPDR
.S (DGMULT,DGRACE,DGETHNIC)=0
.F S DGMULT=$O(^DPT(DFN,.06,DGMULT)) Q:'DGMULT D
..S DGDATA=$G(^DPT(DFN,.06,DGMULT,0))
..S DGETHNIC=$P(DGDATA,U)
..I DGMULT'=DGETHNIC D UPDR
;
D PRINT
Q
;
UPDR ;
I '$D(^XTMP("DG53P897",$J,DFN)) S COUNT=COUNT+1
S DGTEXT=""
I $D(^XTMP("DG53P897",$J,DFN)) S DGTEXT=$G(^XTMP("DG53P897",$J,DFN))
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
I 'DGENSKIP D
.I DGDUPE D
..S DGFDA(2.02,DGMULT_","_DFN_",",.01)="@"
..D FILE^DIE(,"DGFDA",)
.I DGETHN D
..S DGFDA(2.06,DGMULT_","_DFN_",",.01)="@"
..D FILE^DIE(,"DGFDA",)
.I DGRACE D
..S DGFDA(2.02,DGMULT_","_DFN_",",.01)="@"
..D FILE^DIE(,"DGFDA",)
..S (X,DINUM)=DGRACE,DIC="^DPT(DFN,.02,",DA(1)=DFN,DIC(0)="L"
..K DO D FILE^DICN
.I DGETHNIC D
..S DGFDA(2.06,DGMULT_","_DFN_",",.01)="@"
..D FILE^DIE(,"DGFDA",)
..S (X,DINUM)=DGETHNIC,DIC="^DPT(DFN,.06,",DA(1)=DFN,DIC(0)="L"
..K DO D FILE^DICN
Q
PRINT ;
U IO
N DGDDT,DGQUIT,DGPG
S DGDDT=$$FMTE^XLFDT($$NOW^XLFDT,"D")
S (DGQUIT,DGPG)=0
D HEAD
I '$G(COUNT) D Q
.W !!!,?20,"*** No records to report ***"
W !!,"*** COUNT OF BAD PATIENT RECORDS"_$S(DGENSKIP:"",1:" UPDATED")_": ",COUNT," ***",!!
S DFN=0
F S DFN=$O(^XTMP("DG53P897",$J,DFN)) Q:'DFN D Q:DGQUIT
.I $Y>(IOSL-4) D HEAD
.W ?2,DFN,?15,$G(^XTMP("DG53P897",$J,DFN)),!
;
I DGQUIT W:$D(ZTQUEUED) !!,"Report stopped at user's request" Q
I $G(DGPG)>0,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1
I $D(ZTQUEUED) S ZTREQ="@"
Q
;
HEAD ;
I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DGQUIT)=1 Q
I $G(DGPG)>0,$E(IOST)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 DGQUIT=1
Q:DGQUIT
S DGPG=$G(DGPG)+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,!
W !
W !,?2,"DFN",?15,"Action to be taken",!
S $P(X,"-",81)="" W X,!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53P897 4798 printed Sep 23, 2025@20:16:10 Page 2
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
+2 QUIT
+3 ;
CLEANUP ;This entry point will do the update.
+1 ;
+2 NEW DGENSKIP
+3 SET DGENSKIP=0
+4 WRITE !,"This is a one-time update of the Patient File."
+5 WRITE !,"It will correct Race & Ethnicity records."
+6 NEW X1,X2
+7 KILL ^XTMP("DG53P897",$JOB)
+8 SET X1=DT
SET X2=90
DO C^%DTC
+9 SET ^XTMP("DG53P897",$JOB,0)=X_"^"_DT_"^Patient File update"
+10 IF $$DEVICE()
DO ENTER
+11 QUIT
+12 ;
REPORT ;This entry point was provided for testing, so that before
+1 ;patient records are updated the site can have a list of
+2 ;the DFN's that would be affected.
+3 ;
+4 ;Use this entry point to report on what the update would do.
+5 ;No changes will be made to the database.
+6 ;
+7 NEW DGENSKIP
+8 SET DGENSKIP=1
+9 WRITE !,"This is a preliminary report by DFN of the Patient file"
+10 WRITE !,"records which would be affected by the update."
+11 NEW X1,X2
+12 KILL ^XTMP("DG53P897",$JOB)
+13 SET X1=DT
SET X2=90
DO C^%DTC
+14 SET ^XTMP("DG53P897",$JOB,0)=X_"^"_DT_"^Patient File update"
+15 IF $$DEVICE()
DO ENTER
+16 QUIT
+17 ;
ENTER ;
+1 ;
+2 DO UPDATE(DGENSKIP)
+3 if (DGENSKIP)
DO ^%ZISC
+4 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 QUIT
DEVICE() ;
+1 ;Description: allows the user to select a device.
+2 ;
+3 ;Output:
+4 ; Function Value - Returns 0 if the user decides not to print or to
+5 ; queue the report, 1 otherwise.
+6 ;
+7 NEW OK,IOP,POP,%ZIS
+8 SET OK=1
+9 SET %ZIS="MQ"
+10 DO ^%ZIS
+11 if POP
SET OK=0
+12 if OK&$DATA(IO("Q"))
Begin DoDot:1
+13 NEW ZTRTN,ZTDESC,ZTSKM,ZTREQ,ZTSTOP
+14 SET ZTRTN="ENTER^DG53P897"
SET ZTDESC=$SELECT(DGENSKIP:"Report",1:"Update")_" of Patient Records"
+15 SET ZTSAVE("DGENSKIP")=""
+16 DO ^%ZTLOAD
+17 WRITE !,$SELECT($DATA(ZTSK):"REQUEST QUEUED TASK="_ZTSK,1:"REQUEST CANCELLED")
+18 DO HOME^%ZIS
+19 SET OK=0
End DoDot:1
+20 QUIT OK
+21 ;
UPDATE(DGENSKIP) ;
+1 ;This will update patient records --
+2 ;
+3 ;Input: If DGENSKIP=1, the records will not be updated,
+4 ;just reported.
+5 ;
+6 NEW DFN,COUNT,DGMULT,DGSAVE,DGDUPE,DGETHN,DGDATA,DGRACE,DGETHNIC,DGFDA,X,DINUM,DIC,DA,DGTEST
+7 SET (COUNT,DFN)=0
+8 FOR
SET DFN=$ORDER(^DPT(DFN))
if 'DFN
QUIT
Begin DoDot:1
+9 ; merged record
+10 IF $DATA(^DPT(DFN,-9))
QUIT
+11 ; in process of being merged
+12 IF $PIECE($GET(^DPT(DFN,0)),U)["MERGING INTO"
QUIT
+13 IF '$DATA(^DPT(DFN,0))
QUIT
+14 IF $PIECE(^DPT(DFN,0),U)=""
QUIT
+15 ; look for duplicates
+16 SET (DGMULT,DGSAVE,DGDUPE)=0
+17 FOR
SET DGMULT=$ORDER(^DPT(DFN,.02,DGMULT))
if 'DGMULT
QUIT
Begin DoDot:2
+18 IF DGSAVE=0
SET DGSAVE=$PIECE($GET(^DPT(DFN,.02,DGMULT,0)),U)
QUIT
+19 IF DGSAVE=$PIECE($GET(^DPT(DFN,.02,DGMULT,0)),U)
SET DGDUPE=1
DO UPDR
SET DGDUPE=0
End DoDot:2
+20 SET (DGMULT,DGSAVE,DGETHN)=0
+21 FOR
SET DGMULT=$ORDER(^DPT(DFN,.06,DGMULT))
if 'DGMULT
QUIT
Begin DoDot:2
+22 IF DGSAVE=0
SET DGSAVE=$PIECE($GET(^DPT(DFN,.06,DGMULT,0)),U)
QUIT
+23 IF DGSAVE=$PIECE($GET(^DPT(DFN,.06,DGMULT,0)),U)
SET DGETHN=1
DO UPDR
SET DGETHN=0
End DoDot:2
+24 ;look for no dinums
+25 SET (DGMULT,DGRACE,DGETHNIC)=0
+26 FOR
SET DGMULT=$ORDER(^DPT(DFN,.02,DGMULT))
if 'DGMULT
QUIT
Begin DoDot:2
+27 SET DGDATA=$GET(^DPT(DFN,.02,DGMULT,0))
+28 SET DGRACE=$PIECE(DGDATA,U)
+29 IF DGMULT'=DGRACE
DO UPDR
End DoDot:2
+30 SET (DGMULT,DGRACE,DGETHNIC)=0
+31 FOR
SET DGMULT=$ORDER(^DPT(DFN,.06,DGMULT))
if 'DGMULT
QUIT
Begin DoDot:2
+32 SET DGDATA=$GET(^DPT(DFN,.06,DGMULT,0))
+33 SET DGETHNIC=$PIECE(DGDATA,U)
+34 IF DGMULT'=DGETHNIC
DO UPDR
End DoDot:2
End DoDot:1
+35 ;
+36 DO PRINT
+37 QUIT
+38 ;
UPDR ;
+1 IF '$DATA(^XTMP("DG53P897",$JOB,DFN))
SET COUNT=COUNT+1
+2 SET DGTEXT=""
+3 IF $DATA(^XTMP("DG53P897",$JOB,DFN))
SET DGTEXT=$GET(^XTMP("DG53P897",$JOB,DFN))
+4 SET ^XTMP("DG53P897",$JOB,DFN)=$SELECT(DGDUPE:"dupe race",DGETHN:"dupe ethnic",DGRACE:"race entry not dinumed",DGETHNIC:"ethnicity entry not dinumed",1:"unknown")_"^"_DGTEXT
+5 IF 'DGENSKIP
Begin DoDot:1
+6 IF DGDUPE
Begin DoDot:2
+7 SET DGFDA(2.02,DGMULT_","_DFN_",",.01)="@"
+8 DO FILE^DIE(,"DGFDA",)
End DoDot:2
+9 IF DGETHN
Begin DoDot:2
+10 SET DGFDA(2.06,DGMULT_","_DFN_",",.01)="@"
+11 DO FILE^DIE(,"DGFDA",)
End DoDot:2
+12 IF DGRACE
Begin DoDot:2
+13 SET DGFDA(2.02,DGMULT_","_DFN_",",.01)="@"
+14 DO FILE^DIE(,"DGFDA",)
+15 SET (X,DINUM)=DGRACE
SET DIC="^DPT(DFN,.02,"
SET DA(1)=DFN
SET DIC(0)="L"
+16 KILL DO
DO FILE^DICN
End DoDot:2
+17 IF DGETHNIC
Begin DoDot:2
+18 SET DGFDA(2.06,DGMULT_","_DFN_",",.01)="@"
+19 DO FILE^DIE(,"DGFDA",)
+20 SET (X,DINUM)=DGETHNIC
SET DIC="^DPT(DFN,.06,"
SET DA(1)=DFN
SET DIC(0)="L"
+21 KILL DO
DO FILE^DICN
End DoDot:2
End DoDot:1
+22 QUIT
PRINT ;
+1 USE IO
+2 NEW DGDDT,DGQUIT,DGPG
+3 SET DGDDT=$$FMTE^XLFDT($$NOW^XLFDT,"D")
+4 SET (DGQUIT,DGPG)=0
+5 DO HEAD
+6 IF '$GET(COUNT)
Begin DoDot:1
+7 WRITE !!!,?20,"*** No records to report ***"
End DoDot:1
QUIT
+8 WRITE !!,"*** COUNT OF BAD PATIENT RECORDS"_$SELECT(DGENSKIP:"",1:" UPDATED")_": ",COUNT," ***",!!
+9 SET DFN=0
+10 FOR
SET DFN=$ORDER(^XTMP("DG53P897",$JOB,DFN))
if 'DFN
QUIT
Begin DoDot:1
+11 IF $Y>(IOSL-4)
DO HEAD
+12 WRITE ?2,DFN,?15,$GET(^XTMP("DG53P897",$JOB,DFN)),!
End DoDot:1
if DGQUIT
QUIT
+13 ;
+14 IF DGQUIT
if $DATA(ZTQUEUED)
WRITE !!,"Report stopped at user's request"
QUIT
+15 IF $GET(DGPG)>0
IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
if +Y=0
SET DGQUIT=1
+16 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+17 QUIT
+18 ;
HEAD ;
+1 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (ZTSTOP,DGQUIT)=1
QUIT
+2 IF $GET(DGPG)>0
IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
if +Y=0
SET DGQUIT=1
+3 if DGQUIT
QUIT
+4 SET DGPG=$GET(DGPG)+1
+5 WRITE @IOF,!,DGDDT,?15,"DG*5.3*897 Patient File Update Utility",?70,"Page:",$JUSTIFY(DGPG,5),!
KILL X
SET $PIECE(X,"-",81)=""
WRITE X,!
+6 WRITE !
+7 WRITE !,?2,"DFN",?15,"Action to be taken",!
+8 SET $PIECE(X,"-",81)=""
WRITE X,!
+9 QUIT
