DG53P750 ;BAY/JT - Patient full name > 30 characters ; 9/16/03 4:56pm
;;5.3;Registration;**750**;Aug 13, 1993;Build 6
; update patient name .01 in file #2
;
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
;
SEARCH N DGIEN,DGTOT,DGFULLNM,DGLINK,DGZERO,DGONE,DGOTHERS,X1,X2
N DG20NAME,XUNOTRIG,FDANAME,FDAIEN,DIERR
K ^XTMP("DG53P750")
S X1=DT,X2=90 D C^%DTC
S ^XTMP("DG53P750",0)=X_"^"_DT_"^Patient full name > 30 characters"
S (DGIEN,DGTOT,DGOTHERS)=0
D BMES^XPDUTL("...Reading thru entire Patient File...")
F S DGIEN=$O(^DPT(DGIEN)) Q:'DGIEN D
.S DGTOT=DGTOT+1
.S DGFULLNM=$P($G(^DPT(DGIEN,0)),U)
.; skip merge records
.Q:DGFULLNM["MERGING INTO"
.Q:$D(^DPT(DGIEN,-9))
.Q:DGFULLNM=""
.Q:$L(DGFULLNM)<31
.; skip if word "error" in family name
.Q:$P(DGFULLNM,",",1)["ERROR"
.S DGLINK=+$P($G(^DPT(DGIEN,"NAME")),U)
.I 'DGLINK Q
.S DGZERO=$G(^VA(20,DGLINK,0))
.I DGZERO="" Q
.; make sure the patient name component record points back to the patient file record
.I $P(DGZERO,U)'=2!($P(DGZERO,U,2)'=".01")!(+$P(DGZERO,U,3)'=DGIEN) Q
.S DGONE=$G(^VA(20,DGLINK,1))
.I DGONE="" Q
.; get the name components
.S DG20NAME=$P(DGONE,U)_","
.I $P(DGONE,U,2)'="" S DG20NAME=DG20NAME_$P(DGONE,U,2)
.I $P(DGONE,U,3)'="" S DG20NAME=DG20NAME_" "_$P(DGONE,U,3)
.I $P(DGONE,U,5)'="" S DG20NAME=DG20NAME_" "_$P(DGONE,U,5)
.; reformat it so it's no more than 30 characters
.S DG20NAME=$$NAMEFMT^XLFNAME(.DG20NAME,"F","CFL30")
.S FDAIEN=DGIEN_","
.S FDANAME(2,FDAIEN,.01)=DG20NAME
.; set flag so patient name component record will not be updated
.S XUNOTRIG=1
.; update the .01 field
.D FILE^DIE("","FDANAME","DIERR")
.; store global entry so report can be prepared from it
.S ^XTMP("DG53P750",DGIEN,DGLINK)=DGFULLNM_"///"_DG20NAME
.S DGOTHERS=DGOTHERS+1
;
D MES^XPDUTL("Total # of Patient File records read: "_DGTOT)
D MES^XPDUTL("Total # of corrected patients: "_DGOTHERS)
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^DG53P750"
.S ZTDESC="Print of XTMP global for DG53P750."
.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("DG53P750",DGIEN))
I DGIEN="" D Q
.W !!!,?20,"*** No records to report ***"
;
S DGIEN=0
F S DGIEN=$O(^XTMP("DG53P750",DGIEN)) Q:'DGIEN D Q:DGQUIT
.S DGLINK=0
.F S DGLINK=$O(^XTMP("DG53P750",DGIEN,DGLINK)) Q:'DGLINK D
..I $Y>(IOSL-4) D HEAD
..W DGIEN,?11,DGLINK,?25,^XTMP("DG53P750",DGIEN,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*750 List of patients with long names",?70,"Page:",$J(DGPG,5),! K X S $P(X,"-",132)="" W X,!
W !,"File 2 IEN",?11,"File 20 IEN",?25,"Patient Name Before///Patient Name After",!
S $P(X,"-",132)="" W X,!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDG53P750 3750 printed Apr 09, 2024@21:48:47 Page 2
DG53P750 ;BAY/JT - Patient full name > 30 characters ; 9/16/03 4:56pm
+1 ;;5.3;Registration;**750**;Aug 13, 1993;Build 6
+2 ; update patient name .01 in file #2
+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 ;
SEARCH NEW DGIEN,DGTOT,DGFULLNM,DGLINK,DGZERO,DGONE,DGOTHERS,X1,X2
+1 NEW DG20NAME,XUNOTRIG,FDANAME,FDAIEN,DIERR
+2 KILL ^XTMP("DG53P750")
+3 SET X1=DT
SET X2=90
DO C^%DTC
+4 SET ^XTMP("DG53P750",0)=X_"^"_DT_"^Patient full name > 30 characters"
+5 SET (DGIEN,DGTOT,DGOTHERS)=0
+6 DO BMES^XPDUTL("...Reading thru entire Patient File...")
+7 FOR
SET DGIEN=$ORDER(^DPT(DGIEN))
if 'DGIEN
QUIT
Begin DoDot:1
+8 SET DGTOT=DGTOT+1
+9 SET DGFULLNM=$PIECE($GET(^DPT(DGIEN,0)),U)
+10 ; skip merge records
+11 if DGFULLNM["MERGING INTO"
QUIT
+12 if $DATA(^DPT(DGIEN,-9))
QUIT
+13 if DGFULLNM=""
QUIT
+14 if $LENGTH(DGFULLNM)<31
QUIT
+15 ; skip if word "error" in family name
+16 if $PIECE(DGFULLNM,",",1)["ERROR"
QUIT
+17 SET DGLINK=+$PIECE($GET(^DPT(DGIEN,"NAME")),U)
+18 IF 'DGLINK
QUIT
+19 SET DGZERO=$GET(^VA(20,DGLINK,0))
+20 IF DGZERO=""
QUIT
+21 ; make sure the patient name component record points back to the patient file record
+22 IF $PIECE(DGZERO,U)'=2!($PIECE(DGZERO,U,2)'=".01")!(+$PIECE(DGZERO,U,3)'=DGIEN)
QUIT
+23 SET DGONE=$GET(^VA(20,DGLINK,1))
+24 IF DGONE=""
QUIT
+25 ; get the name components
+26 SET DG20NAME=$PIECE(DGONE,U)_","
+27 IF $PIECE(DGONE,U,2)'=""
SET DG20NAME=DG20NAME_$PIECE(DGONE,U,2)
+28 IF $PIECE(DGONE,U,3)'=""
SET DG20NAME=DG20NAME_" "_$PIECE(DGONE,U,3)
+29 IF $PIECE(DGONE,U,5)'=""
SET DG20NAME=DG20NAME_" "_$PIECE(DGONE,U,5)
+30 ; reformat it so it's no more than 30 characters
+31 SET DG20NAME=$$NAMEFMT^XLFNAME(.DG20NAME,"F","CFL30")
+32 SET FDAIEN=DGIEN_","
+33 SET FDANAME(2,FDAIEN,.01)=DG20NAME
+34 ; set flag so patient name component record will not be updated
+35 SET XUNOTRIG=1
+36 ; update the .01 field
+37 DO FILE^DIE("","FDANAME","DIERR")
+38 ; store global entry so report can be prepared from it
+39 SET ^XTMP("DG53P750",DGIEN,DGLINK)=DGFULLNM_"///"_DG20NAME
+40 SET DGOTHERS=DGOTHERS+1
End DoDot:1
+41 ;
+42 DO MES^XPDUTL("Total # of Patient File records read: "_DGTOT)
+43 DO MES^XPDUTL("Total # of corrected patients: "_DGOTHERS)
+44 QUIT
+45 ;
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^DG53P750"
+9 SET ZTDESC="Print of XTMP global for DG53P750."
+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("DG53P750",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("DG53P750",DGIEN))
if 'DGIEN
QUIT
Begin DoDot:1
+12 SET DGLINK=0
+13 FOR
SET DGLINK=$ORDER(^XTMP("DG53P750",DGIEN,DGLINK))
if 'DGLINK
QUIT
Begin DoDot:2
+14 IF $Y>(IOSL-4)
DO HEAD
+15 WRITE DGIEN,?11,DGLINK,?25,^XTMP("DG53P750",DGIEN,DGLINK),!
End DoDot:2
End DoDot:1
if DGQUIT
QUIT
+16 ;
+17 IF DGQUIT
if $DATA(ZTQUEUED)
WRITE !!,"Report stopped at user's request"
QUIT
+18 IF $GET(DGPG)>0
IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
if +Y=0
SET DGQUIT=1
+19 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+20 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*750 List of patients with long names",?70,"Page:",$JUSTIFY(DGPG,5),!
KILL X
SET $PIECE(X,"-",132)=""
WRITE X,!
+6 WRITE !,"File 2 IEN",?11,"File 20 IEN",?25,"Patient Name Before///Patient Name After",!
+7 SET $PIECE(X,"-",132)=""
WRITE X,!
+8 QUIT
