DG53P543 ;BAY/JT - cleanup of file 20 ; 9/16/03 4:56pm
;;5.3;Registration;**543,1015**;Aug 13, 1993;Build 21
; patient name .01 only
;
ENV ; do environment check
S XPDABORT=""
D PROGCHK(.XPDABORT)
I XPDABORT="" K XPDABORT
Q
PROGCHK(XPDABORT) ; checks for necessary programmer variables
I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D
.D MES^XPDUTL("Your programming variables are not set up properly.")
.D MES^XPDUTL("Installation aborted.")
.S XPDABORT=2
Q
;
CLEANUP N DGIEN,DGFULLNM,DGLINK,DGFND,DGDPT,DGNAME,DGZERO,DGONE,DGERR,CNT,DGMID,DGTOT,DGUPDT,DGNOLINK,DGLINK0,DGLINK1,DGCONC,DGOTHERS,DGGLOBAL,X1,X2
K ^XTMP("DG53P543")
S X1=DT,X2=90 D C^%DTC
S ^XTMP("DG53P543",0)=X_"^"_DT_"^Problems w/file 2 links w/file 20"
S (DGIEN,DGTOT,DGERR,DGUPDT,DGNOLINK,DGLINK0,DGLINK1,DGOTHERS)=0
D BMES^XPDUTL("Beginning clean-up...Reading thru entire Patient File...")
F S DGIEN=$O(^DPT(DGIEN)) Q:'DGIEN D
.S DGTOT=DGTOT+1
.Q:$P($G(^DPT(DGIEN,0)),U)["MERGING INTO"
.Q:$D(^DPT(DGIEN,-9))
.S DGFULLNM=$P($G(^DPT(DGIEN,0)),U)
.S DGLINK=+$P($G(^DPT(DGIEN,"NAME")),U)
.I 'DGLINK D NOLINK Q
.S DGZERO=$G(^VA(20,DGLINK,0))
.I DGZERO="" D NOZERO Q
.I $P(DGZERO,U)'=2!($P(DGZERO,U,2)'=".01")!(+$P(DGZERO,U,3)'=DGIEN) D BADZERO Q
.S DGONE=$G(^VA(20,DGLINK,1))
.I DGONE="" D NOONE Q
.;
.S DGERR=0
.; skip if "error" in family name
.I $P(DGFULLNM,",",1)["ERROR" Q
.; compare family name
.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
.; skip if no first name
.I $P(DGFULLNM,",",2)="",$P(DGONE,U,2)="" Q
.; if comma in first name, skip if everything equal
.I $P(DGONE,U,2)["," S DGCONC=$P(DGONE,U)_","_$P(DGONE,U,2) I DGCONC=DGFULLNM Q
.; compare first name
.S CNT=$L($P(DGONE,U,2))
.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
.;compare middle names and suffixes
.S DGMID=$P($P(DGFULLNM,",",2)," ",2)
.I DGMID=$P(DGONE,U,3)!(DGMID=$P(DGONE,U,5)) Q
.S DGMID=$P($P(DGFULLNM,",",2)," ",2,99)
.I $P(DGONE,U,3)'="",DGMID[$P(DGONE,U,3) Q
.I $P(DGONE,U,5)'="",DGMID[$P(DGONE,U,5) Q
.S DGERR=3
.S ^XTMP("DG53P543",DGIEN,DGLINK,DGERR)=DGFULLNM_"///"_$P(DGONE,U,1,5) S DGOTHERS=DGOTHERS+1
.Q
;
D MES^XPDUTL("Total # of Patient File records read: "_DGTOT)
D MES^XPDUTL("Total # of Name Component file #20 records needing cleanup: "_DGUPDT)
I DGUPDT D
.D MES^XPDUTL("I will now update these records ...")
.D UPDATE
.D MES^XPDUTL("Done !")
I DGOTHERS!(DGNOLINK)!(DGLINK0)!(DGLINK1) D
.D MES^XPDUTL("I also found other records that need attention:")
.I DGOTHERS D MES^XPDUTL(" # of records needing reformatting: "_DGOTHERS)
.I DGNOLINK D MES^XPDUTL(" # of records with no link: "_DGNOLINK)
.I DGLINK0 D MES^XPDUTL(" # of records with no or bad zero node: "_DGLINK0)
.I DGLINK1 D MES^XPDUTL(" # of records with no '1' node: "_DGLINK1)
.S DGGLOBAL="^XTMP(""DG53P543"""
.D MES^XPDUTL(" For more details, please see the "_DGGLOBAL_" global")
.D MES^XPDUTL(" or print the report PRTRPT^DG53P543")
D BMES^XPDUTL("Clean-up is complete")
Q
NOLINK ;
S DGNOLINK=DGNOLINK+1
I DGFULLNM="" S ^XTMP("DG53P543",DGIEN,0)="no name on patient file" Q
I '$D(^VA(20,"C",DGFULLNM)) S ^XTMP("DG53P543",DGIEN,0)="no link to file 20" Q
S DGFND=0
F S DGFND=$O(^VA(20,"C",DGFULLNM,DGFND)) Q:'DGFND D
.S DGDPT=+$P($G(^VA(20,DGFND,0)),U,3)
.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
Q
NOZERO ;
S DGLINK0=DGLINK0+1
S ^XTMP("DG53P543",DGIEN,DGLINK)="no zero node on file 20"
Q
BADZERO ;
S DGLINK0=DGLINK0+1
S ^XTMP("DG53P543",DGIEN,DGLINK)="bad zero node on file 20"
Q
NOONE ;
S DGLINK1=DGLINK1+1
S ^XTMP("DG53P543",DGIEN,DGLINK)="no '1' node on file 20"
Q
UPDATE ;
Q:'$D(^XTMP("DG53P543"))
N DG20NAME,DA,DR,DIE,X
S DGIEN=0
F S DGIEN=$O(^XTMP("DG53P543",DGIEN)) Q:'DGIEN D
.S DGLINK=0
.F S DGLINK=$O(^XTMP("DG53P543",DGIEN,DGLINK)) Q:'DGLINK D
..S DGERR=0
..F S DGERR=$O(^XTMP("DG53P543",DGIEN,DGLINK,DGERR)) Q:'DGERR D
...I DGERR'=1 Q
...S DG20NAME=$P($G(^DPT(DGIEN,0)),U) I DG20NAME'="" D
....S DIE="^DPT(",DA=DGIEN,DR=".01///^S X=DG20NAME" D ^DIE
....D MES^XPDUTL("Record # "_DGIEN_" for "_$P(^DPT(DGIEN,0),U)_" has been updated")
....K ^XTMP("DG53P543",DGIEN,DGLINK,DGERR)
....K DG20NAME
Q
;
PRTRPT ;
I $$DEVICE() D PRINT
Q
DEVICE() ; choose device and whether to queue.
N OK,IOP,POP,%ZIS,DGX
S OK=1
S %ZIS="MQ"
D ^%ZIS
S:POP OK=0
I OK,$D(IO("Q")) D
.N ZTRTN,ZTDESC,ZTSKM,ZTREQ,ZTSTOP
.S ZTRTN="PRINT^DG53P543"
.S ZTDESC="Print of XTMP global for DG53P543."
.F DGX=1:1:20 D ^%ZTLOAD Q:$G(ZTSK)
.W !,$S($D(ZTSK):"Request "_ZTSK_" queued!",1:"Request Cancelled!"),!
.D HOME^%ZIS
.S OK=0
Q OK
;
PRINT ;
U IO
N DGIEN,DGLINK,DGERR,DGQUIT,DGPG,DGDDT
S (DGQUIT,DGPG)=0
S DGDDT=$$FMTE^XLFDT($$NOW^XLFDT,"D")
D HEAD
S DGIEN=0,DGIEN=$O(^XTMP("DG53P543",DGIEN))
I DGIEN="" D Q
.W !!!,?20,"*** No records to report ***"
;
S DGIEN=0
F S DGIEN=$O(^XTMP("DG53P543",DGIEN)) Q:'DGIEN D Q:DGQUIT
.I $D(^XTMP("DG53P543",DGIEN,0)) D
..I $Y>(IOSL-4) D HEAD
..W "# ",DGIEN,?11,^XTMP("DG53P543",DGIEN,0),!
.S DGLINK=0
.F S DGLINK=$O(^XTMP("DG53P543",DGIEN,DGLINK)) Q:'DGLINK D
..I $D(^XTMP("DG53P543",DGIEN,DGLINK))=1 D
...I $Y>(IOSL-4) D HEAD
...W "# ",DGIEN,?11,$P(^DPT(DGIEN,0),U),?40,^XTMP("DG53P543",DGIEN,DGLINK),?69,"# ",DGLINK,!
..S DGERR=0
..F S DGERR=$O(^XTMP("DG53P543",DGIEN,DGLINK,DGERR)) Q:'DGERR D
...I $Y>(IOSL-4) D HEAD
...W "# ",DGIEN,?11,^XTMP("DG53P543",DGIEN,DGLINK,DGERR),?69,"# ",DGLINK,!
;
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*543 File #20 Cleanup Utility",?70,"Page:",$J(DGPG,5),! K X S $P(X,"-",81)="" W X,!
W !,"File 2 IEN",?11,"Patient Name///Component Last^First^Middle^Prefix^Suffix",?69,"File 20 IEN",!
S $P(X,"-",81)="" W X,!
Q
DG53P543 ;BAY/JT - cleanup of file 20 ; 9/16/03 4:56pm
+1 ;;5.3;Registration;**543,1015**;Aug 13, 1993;Build 21
+2 ; patient name .01 only
+3 ;
ENV ; do environment check
+1 SET XPDABORT=""
+2 DO PROGCHK(.XPDABORT)
+3 IF XPDABORT=""
KILL XPDABORT
+4 QUIT
PROGCHK(XPDABORT) ; checks for necessary programmer variables
+1 IF '$GET(DUZ)!($GET(DUZ(0))'="@")!('$GET(DT))!($GET(U)'="^")
Begin DoDot:1
+2 DO MES^XPDUTL("Your programming variables are not set up properly.")
+3 DO MES^XPDUTL("Installation aborted.")
+4 SET XPDABORT=2
End DoDot:1
+5 QUIT
+6 ;
CLEANUP NEW DGIEN,DGFULLNM,DGLINK,DGFND,DGDPT,DGNAME,DGZERO,DGONE,DGERR,CNT,DGMID,DGTOT,DGUPDT,DGNOLINK,DGLINK0,DGLINK1,DGCONC,DGOTHERS,DGGLOBAL,X1,X2
+1 KILL ^XTMP("DG53P543")
+2 SET X1=DT
SET X2=90
DO C^%DTC
+3 SET ^XTMP("DG53P543",0)=X_"^"_DT_"^Problems w/file 2 links w/file 20"
+4 SET (DGIEN,DGTOT,DGERR,DGUPDT,DGNOLINK,DGLINK0,DGLINK1,DGOTHERS)=0
+5 DO BMES^XPDUTL("Beginning clean-up...Reading thru entire Patient File...")
+6 FOR
SET DGIEN=$ORDER(^DPT(DGIEN))
IF 'DGIEN
QUIT
Begin DoDot:1
+7 SET DGTOT=DGTOT+1
+8 IF $PIECE($GET(^DPT(DGIEN,0)),U)["MERGING INTO"
QUIT
+9 IF $DATA(^DPT(DGIEN,-9))
QUIT
+10 SET DGFULLNM=$PIECE($GET(^DPT(DGIEN,0)),U)
+11 SET DGLINK=+$PIECE($GET(^DPT(DGIEN,"NAME")),U)
+12 IF 'DGLINK
DO NOLINK
QUIT
+13 SET DGZERO=$GET(^VA(20,DGLINK,0))
+14 IF DGZERO=""
DO NOZERO
QUIT
+15 IF $PIECE(DGZERO,U)'=2!($PIECE(DGZERO,U,2)'=".01")!(+$PIECE(DGZERO,U,3)'=DGIEN)
DO BADZERO
QUIT
+16 SET DGONE=$GET(^VA(20,DGLINK,1))
+17 IF DGONE=""
DO NOONE
QUIT
+18 ;
+19 SET DGERR=0
+20 ; skip if "error" in family name
+21 IF $PIECE(DGFULLNM,",",1)["ERROR"
QUIT
+22 ; compare family name
+23 IF $PIECE(DGFULLNM,",",1)'=$PIECE(DGONE,U)
SET DGERR=1
SET ^XTMP("DG53P543",DGIEN,DGLINK,DGERR)=$PIECE(DGFULLNM,",",1)_U_$PIECE(DGONE,U)
SET DGUPDT=DGUPDT+1
QUIT
+24 ; skip if no first name
+25 IF $PIECE(DGFULLNM,",",2)=""
IF $PIECE(DGONE,U,2)=""
QUIT
+26 ; if comma in first name, skip if everything equal
+27 IF $PIECE(DGONE,U,2)[","
SET DGCONC=$PIECE(DGONE,U)_","_$PIECE(DGONE,U,2)
IF DGCONC=DGFULLNM
QUIT
+28 ; compare first name
+29 SET CNT=$LENGTH($PIECE(DGONE,U,2))
+30 IF $EXTRACT($PIECE(DGFULLNM,",",2),1,CNT)'=$PIECE(DGONE,U,2)
SET DGERR=2
SET ^XTMP("DG53P543",DGIEN,DGLINK,DGERR)=DGFULLNM_"///"_$PIECE(DGONE,U,1,5)
SET DGOTHERS=DGOTHERS+1
QUIT
+31 ;compare middle names and suffixes
+32 SET DGMID=$PIECE($PIECE(DGFULLNM,",",2)," ",2)
+33 IF DGMID=$PIECE(DGONE,U,3)!(DGMID=$PIECE(DGONE,U,5))
QUIT
+34 SET DGMID=$PIECE($PIECE(DGFULLNM,",",2)," ",2,99)
+35 IF $PIECE(DGONE,U,3)'=""
IF DGMID[$PIECE(DGONE,U,3)
QUIT
+36 IF $PIECE(DGONE,U,5)'=""
IF DGMID[$PIECE(DGONE,U,5)
QUIT
+37 SET DGERR=3
+38 SET ^XTMP("DG53P543",DGIEN,DGLINK,DGERR)=DGFULLNM_"///"_$PIECE(DGONE,U,1,5)
SET DGOTHERS=DGOTHERS+1
+39 QUIT
End DoDot:1
+40 ;
+41 DO MES^XPDUTL("Total # of Patient File records read: "_DGTOT)
+42 DO MES^XPDUTL("Total # of Name Component file #20 records needing cleanup: "_DGUPDT)
+43 IF DGUPDT
Begin DoDot:1
+44 DO MES^XPDUTL("I will now update these records ...")
+45 DO UPDATE
+46 DO MES^XPDUTL("Done !")
End DoDot:1
+47 IF DGOTHERS!(DGNOLINK)!(DGLINK0)!(DGLINK1)
Begin DoDot:1
+48 DO MES^XPDUTL("I also found other records that need attention:")
+49 IF DGOTHERS
DO MES^XPDUTL(" # of records needing reformatting: "_DGOTHERS)
+50 IF DGNOLINK
DO MES^XPDUTL(" # of records with no link: "_DGNOLINK)
+51 IF DGLINK0
DO MES^XPDUTL(" # of records with no or bad zero node: "_DGLINK0)
+52 IF DGLINK1
DO MES^XPDUTL(" # of records with no '1' node: "_DGLINK1)
+53 SET DGGLOBAL="^XTMP(""DG53P543"""
+54 DO MES^XPDUTL(" For more details, please see the "_DGGLOBAL_" global")
+55 DO MES^XPDUTL(" or print the report PRTRPT^DG53P543")
End DoDot:1
+56 DO BMES^XPDUTL("Clean-up is complete")
+57 QUIT
NOLINK ;
+1 SET DGNOLINK=DGNOLINK+1
+2 IF DGFULLNM=""
SET ^XTMP("DG53P543",DGIEN,0)="no name on patient file"
QUIT
+3 IF '$DATA(^VA(20,"C",DGFULLNM))
SET ^XTMP("DG53P543",DGIEN,0)="no link to file 20"
QUIT
+4 SET DGFND=0
+5 FOR
SET DGFND=$ORDER(^VA(20,"C",DGFULLNM,DGFND))
IF 'DGFND
QUIT
Begin DoDot:1
+6 SET DGDPT=+$PIECE($GET(^VA(20,DGFND,0)),U,3)
+7 IF DGDPT
SET DGNAME=$PIECE($GET(^DPT(DGDPT,0)),U)
IF DGNAME'=""
IF DGNAME=DGFULLNM
SET ^XTMP("DG53P543",DGIEN,0)=DGFND_" points to Patient file "_DGDPT
End DoDot:1
+8 QUIT
NOZERO ;
+1 SET DGLINK0=DGLINK0+1
+2 SET ^XTMP("DG53P543",DGIEN,DGLINK)="no zero node on file 20"
+3 QUIT
BADZERO ;
+1 SET DGLINK0=DGLINK0+1
+2 SET ^XTMP("DG53P543",DGIEN,DGLINK)="bad zero node on file 20"
+3 QUIT
NOONE ;
+1 SET DGLINK1=DGLINK1+1
+2 SET ^XTMP("DG53P543",DGIEN,DGLINK)="no '1' node on file 20"
+3 QUIT
UPDATE ;
+1 IF '$DATA(^XTMP("DG53P543"))
QUIT
+2 NEW DG20NAME,DA,DR,DIE,X
+3 SET DGIEN=0
+4 FOR
SET DGIEN=$ORDER(^XTMP("DG53P543",DGIEN))
IF 'DGIEN
QUIT
Begin DoDot:1
+5 SET DGLINK=0
+6 FOR
SET DGLINK=$ORDER(^XTMP("DG53P543",DGIEN,DGLINK))
IF 'DGLINK
QUIT
Begin DoDot:2
+7 SET DGERR=0
+8 FOR
SET DGERR=$ORDER(^XTMP("DG53P543",DGIEN,DGLINK,DGERR))
IF 'DGERR
QUIT
Begin DoDot:3
+9 IF DGERR'=1
QUIT
+10 SET DG20NAME=$PIECE($GET(^DPT(DGIEN,0)),U)
IF DG20NAME'=""
Begin DoDot:4
+11 SET DIE="^DPT("
SET DA=DGIEN
SET DR=".01///^S X=DG20NAME"
DO ^DIE
+12 DO MES^XPDUTL("Record # "_DGIEN_" for "_$PIECE(^DPT(DGIEN,0),U)_" has been updated")
+13 KILL ^XTMP("DG53P543",DGIEN,DGLINK,DGERR)
+14 KILL DG20NAME
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
PRTRPT ;
+1 IF $$DEVICE()
DO PRINT
+2 QUIT
DEVICE() ; choose device and whether to queue.
+1 NEW OK,IOP,POP,%ZIS,DGX
+2 SET OK=1
+3 SET %ZIS="MQ"
+4 DO ^%ZIS
+5 IF POP
SET OK=0
+6 IF OK
IF $DATA(IO("Q"))
Begin DoDot:1
+7 NEW ZTRTN,ZTDESC,ZTSKM,ZTREQ,ZTSTOP
+8 SET ZTRTN="PRINT^DG53P543"
+9 SET ZTDESC="Print of XTMP global for DG53P543."
+10 FOR DGX=1:1:20
DO ^%ZTLOAD
IF $GET(ZTSK)
QUIT
+11 WRITE !,$SELECT($DATA(ZTSK):"Request "_ZTSK_" queued!",1:"Request Cancelled!"),!
+12 DO HOME^%ZIS
+13 SET OK=0
End DoDot:1
+14 QUIT OK
+15 ;
PRINT ;
+1 USE IO
+2 NEW DGIEN,DGLINK,DGERR,DGQUIT,DGPG,DGDDT
+3 SET (DGQUIT,DGPG)=0
+4 SET DGDDT=$$FMTE^XLFDT($$NOW^XLFDT,"D")
+5 DO HEAD
+6 SET DGIEN=0
SET DGIEN=$ORDER(^XTMP("DG53P543",DGIEN))
+7 IF DGIEN=""
Begin DoDot:1
+8 WRITE !!!,?20,"*** No records to report ***"
End DoDot:1
QUIT
+9 ;
+10 SET DGIEN=0
+11 FOR
SET DGIEN=$ORDER(^XTMP("DG53P543",DGIEN))
IF 'DGIEN
QUIT
Begin DoDot:1
+12 IF $DATA(^XTMP("DG53P543",DGIEN,0))
Begin DoDot:2
+13 IF $Y>(IOSL-4)
DO HEAD
+14 WRITE "# ",DGIEN,?11,^XTMP("DG53P543",DGIEN,0),!
End DoDot:2
+15 SET DGLINK=0
+16 FOR
SET DGLINK=$ORDER(^XTMP("DG53P543",DGIEN,DGLINK))
IF 'DGLINK
QUIT
Begin DoDot:2
+17 IF $DATA(^XTMP("DG53P543",DGIEN,DGLINK))=1
Begin DoDot:3
+18 IF $Y>(IOSL-4)
DO HEAD
+19 WRITE "# ",DGIEN,?11,$PIECE(^DPT(DGIEN,0),U),?40,^XTMP("DG53P543",DGIEN,DGLINK),?69,"# ",DGLINK,!
End DoDot:3
+20 SET DGERR=0
+21 FOR
SET DGERR=$ORDER(^XTMP("DG53P543",DGIEN,DGLINK,DGERR))
IF 'DGERR
QUIT
Begin DoDot:3
+22 IF $Y>(IOSL-4)
DO HEAD
+23 WRITE "# ",DGIEN,?11,^XTMP("DG53P543",DGIEN,DGLINK,DGERR),?69,"# ",DGLINK,!
End DoDot:3
End DoDot:2
End DoDot:1
IF DGQUIT
QUIT
+24 ;
+25 IF DGQUIT
IF $DATA(ZTQUEUED)
WRITE !!,"Report stopped at user's request"
QUIT
+26 IF $GET(DGPG)>0
IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF +Y=0
SET DGQUIT=1
+27 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+28 QUIT
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*543 File #20 Cleanup Utility",?70,"Page:",$JUSTIFY(DGPG,5),!
KILL X
SET $PIECE(X,"-",81)=""
WRITE X,!
+6 WRITE !,"File 2 IEN",?11,"Patient Name///Component Last^First^Middle^Prefix^Suffix",?69,"File 20 IEN",!
+7 SET $PIECE(X,"-",81)=""
WRITE X,!
+8 QUIT
