XLFNP176 ;SFISC/MKO-FIX NEW PERSON NAMES ;3:16 PM 27 Oct 2000 [ 04/02/2003 8:29 AM ]
;;8.0;KERNEL;**1007**;APR 1, 2003
;;8.0;KERNEL;**176**;Jul 10, 1995
LIST ;; M D^ D D S^ PH D^ R N^ D P M^ D O^ P A^ N P^ C R N A^ L P N
Q
;
FIX N XUFIX,DIRUT
D INTRO Q:$D(DIRUT)
S XUFIX=$$ASKFIX Q:$D(DIRUT)
D DEVSEL Q:$D(DIRUT)
U IO
;
MAIN ;Loop through the New person file; entry point for queued jobs
N XUHLIN,XUIEN,XULIST,XUNAM,XUNEW,XUPAGE,XUPC,XUPROB,XUSUF
D INIT
S XULIST=$P($T(LIST),";;",2,999)
;
S XUIEN=0 F S XUIEN=$O(^VA(200,XUIEN)) Q:'XUIEN D Q:$D(DIRUT)
. S XUNAM=$P($G(^VA(200,XUIEN,0)),U) Q:XUNAM=""
. F XUPC=1:1 S XUSUF=$P(XULIST,U,XUPC) Q:XUSUF="" D Q:$D(DIRUT)
.. Q:XUNAM'?@(".E1"""_XUSUF_"""")
.. S XUPROB=1
.. D BLDCOMP(XUNAM,XUSUF,.XUNEW)
.. D WRITE(XUIEN,XUNAM,.XUNEW) Q:$D(DIRUT)
.. D:XUFIX FILE(XUIEN,.XUNEW) Q:$D(DIRUT)
;
W:'$G(XUPROB) !,"NO PROBLEMS FOUND",!
D END
Q
;
BLDCOMP(XUNAM,XUSUF,XUNEW) ;Build new name components
K XUNEW
S XUNEW=$E(XUNAM,1,$L(XUNAM)-$L(XUSUF))
S XUSUF=$TR(XUSUF," ")
D NAMECOMP^XLFNAME(.XUNEW)
S XUNEW=XUNEW_" "_XUSUF
S XUNEW("SUFFIX")=$G(XUNEW("SUFFIX"))_$E(" ",$G(XUNEW("SUFFIX"))]"")_XUSUF
Q
;
WRITE(XUIEN,XUNAM,XUNEW) ;Write info
D W() Q:$D(DIRUT)
D W("Entry #"_XUIEN) Q:$D(DIRUT)
D W("Old Name: "_XUNAM) Q:$D(DIRUT)
D W("New Name: "_XUNEW) Q:$D(DIRUT)
I $G(XUNEW("GIVEN"))]"" D W(" Given: "_XUNEW("GIVEN"),10) Q:$D(DIRUT)
I $G(XUNEW("MIDDLE"))]"" D W("Middle: "_XUNEW("MIDDLE"),10) Q:$D(DIRUT)
I $G(XUNEW("FAMILY"))]"" D W("Family: "_XUNEW("FAMILY"),10) Q:$D(DIRUT)
I $G(XUNEW("SUFFIX"))]"" D W("Suffix: "_XUNEW("SUFFIX"),10) Q:$D(DIRUT)
Q
;
FILE(XUIEN,XUNEW) ;Correct Name
N DIERR,XUFDA,XUMSG,XUNC
;
S XUNC=$P($G(^VA(200,XUIEN,3.1)),U)
I XUNC,$D(^VA(20,XUNC,0))#2,$P(^(0),U,1,3)="200^.01^"_XUIEN_"," D
. S XUFDA(20,XUNC_",",1)=$G(XUNEW("FAMILY"))
. S XUFDA(20,XUNC_",",2)=$G(XUNEW("GIVEN"))
. S XUFDA(20,XUNC_",",3)=$G(XUNEW("MIDDLE"))
. S XUFDA(20,XUNC_",",5)=$G(XUNEW("SUFFIX"))
. D FILE^DIE("","XUFDA","XUMSG")
;
E D
. D W("** Unable to file new name **")
. D W(" There is no corresponding entry in the Name Components file.")
;
I $G(DIERR) D
. N XUI,XUOUT
. D MSG^DIALOG("AE","XUOUT","",5,"XUMSG")
. D W("** Unable to file new name **") Q:$D(DIRUT)
. F XUI=1:1:XUOUT D W(XUOUT(XUI)) Q:$D(DIRUT)
Q
;
W(XUSTR,XUTAB) ;Write XUSTR
I $Y+4>IOSL D EOP Q:$D(DIRUT)
W !?+$G(XUTAB),$G(XUSTR)
Q
;
EOP ;End-of-page prompt/check
I $E(IOST,1,2)="C-" D Q:$D(DIRUT)
. N DIR,DIROUT,DTOUT,DUOUT,X,Y
. S DIR(0)="E" W ! D ^DIR
I $D(ZTQUEUED),$$S^%ZTLOAD S (ZTSTOP,DIRUT)=1 Q
W @IOF
D HDR
Q
;
HDR ;Print header
S ($X,$Y)=0
S XUPAGE=$G(XUPAGE)+1
I XUFIX W "NEW PERSON NAMES FIXED BY FIX^XLFNP176"
E W "HOW FIX^XLFNP176 WOULD FIX NEW PERSON NAMES"
W ?(IOM-$L(XUHLIN)-$L(XUPAGE)-1),XUHLIN_XUPAGE
W !,$TR($J("",IOM-1)," ","-")
Q
;
ASKFIX() ;Ask whether to file corrected New Person name
N DIR,DIROUT,DTOUT,DUOUT,X,Y K DIRUT
S DIR(0)="SBA^R:Report Only;F:Fix Names"
S DIR("A")="Fix names or just print a Report (F/R)? "
S DIR("?",1)="Answer 'R' to print a report of names with a potential problems."
S DIR("?")="Answer 'F' to fix the names."
W ! D ^DIR
Q Y="F"
;
DEVSEL ;Select device
N %ZIS,POP K DIRUT
S %ZIS=$S($D(^%ZTSK):"Q",1:"")
W ! D ^%ZIS
I $G(POP) S DIRUT=1 Q
;
;Queue report
I $D(IO("Q")),$D(^%ZTSK) D S DIRUT=1 Q
. N ZTSK
. S ZTRTN="MAIN^XLFNP176"
. S ZTDESC="Names in New Person file with spaces within a suffix."
. S ZTSAVE("XUFIX")=""
. D ^%ZTLOAD
. I $D(ZTSK)#2 W !,"Report queued!",!,"Task number: "_$G(ZTSK),!
. E W !,"Report canceled!",!
. S IOP="HOME" D ^%ZIS
Q
;
INIT ;Setup
N %,%H,X,Y
S %H=$H D YX^%DTC
S XUHLIN=$P(Y,"@")_" "_$P($P(Y,"@",2),":",1,2)_" PAGE "
W:$E(IOST,1,2)="C-" @IOF
D HDR
Q
;
END ;Finish up
I $D(ZTQUEUED) S ZTREQ="@"
E N POP D ^%ZISC
Q
;
INTRO ;
N DIR,DIROUT,DUOUT,DTOUT,I,L,S,X,Y
W !,"Routine XLFNP176 was released with patch XU*8*176."
;
W !!,"This entry point (FIX^XLFNP176) loops through all the entries in the New"
W !,"Person file (#200) and looks for names that may have been standardized and"
W !,"parsed incorrectly by the Name Standardization Patch XU*8*134. If a name"
W !,"in the New Person file prior to the installation of Patch XU*8*134"
W !,"contained periods within its suffix, the Post-Install Conversion of that"
W !,"patch converted those periods to spaces, and didn't recognize the name"
W !,"component as a suffix. This entry point prints a report of names that may"
W !,"have the problem, and optionally corrects them."
;
W !!,"NOTE: This routine should be run only after Patches XU*8*134 and XU*8*152"
W !,"have been installed."
;
I '$$PATCH^XPDUTL("XU*8.0*134")!'$$PATCH^XPDUTL("XU*8.0*152") D Q
. W !!,$C(7)," It appears that the above two patches have NOT been installed on"
. W !," your system. Exiting ...",!
. S DIRUT=1
;
W !!," It appears that those two patches HAVE been installed in this acccount"
W ! S DIR(0)="E" D ^DIR K DIR Q:$D(DIRUT)
;
W !!,"Each New Person file Name will be checked to determine whether any"
W !,"following strings occur at the end of the Name:",!
S L=$P($T(LIST),";;",2,99)
F I=1:1:$L(L,U) S S=$P(L,U,I) W:S]"" !," '"_S_"'"
;
S DIR(0)="Y"
S DIR("A")="Do you wish to use a different list"
S DIR("B")="NO"
S DIR("?",1)=" Enter 'YES' to exit and modify line tag LIST^XLFNP162."
S DIR("?")=" Enter 'NO' to accept the above list and continue."
W ! D ^DIR K DIR Q:$D(DIRUT)
I Y D Q
. W !!," Edit the list at line tag LIST^XLFNP176.",!
. S DIRUT=1
Q
XLFNP176 ;SFISC/MKO-FIX NEW PERSON NAMES ;3:16 PM 27 Oct 2000 [ 04/02/2003 8:29 AM ]
+1 ;;8.0;KERNEL;**1007**;APR 1, 2003
+2 ;;8.0;KERNEL;**176**;Jul 10, 1995
LIST ;; M D^ D D S^ PH D^ R N^ D P M^ D O^ P A^ N P^ C R N A^ L P N
+1 QUIT
+2 ;
FIX NEW XUFIX,DIRUT
+1 DO INTRO
IF $DATA(DIRUT)
QUIT
+2 SET XUFIX=$$ASKFIX
IF $DATA(DIRUT)
QUIT
+3 DO DEVSEL
IF $DATA(DIRUT)
QUIT
+4 USE IO
+5 ;
MAIN ;Loop through the New person file; entry point for queued jobs
+1 NEW XUHLIN,XUIEN,XULIST,XUNAM,XUNEW,XUPAGE,XUPC,XUPROB,XUSUF
+2 DO INIT
+3 SET XULIST=$PIECE($TEXT(LIST),";;",2,999)
+4 ;
+5 SET XUIEN=0
FOR
SET XUIEN=$ORDER(^VA(200,XUIEN))
IF 'XUIEN
QUIT
Begin DoDot:1
+6 SET XUNAM=$PIECE($GET(^VA(200,XUIEN,0)),U)
IF XUNAM=""
QUIT
+7 FOR XUPC=1:1
SET XUSUF=$PIECE(XULIST,U,XUPC)
IF XUSUF=""
QUIT
Begin DoDot:2
+8 IF XUNAM'?@(".E1"""_XUSUF_"""")
QUIT
+9 SET XUPROB=1
+10 DO BLDCOMP(XUNAM,XUSUF,.XUNEW)
+11 DO WRITE(XUIEN,XUNAM,.XUNEW)
IF $DATA(DIRUT)
QUIT
+12 IF XUFIX
DO FILE(XUIEN,.XUNEW)
IF $DATA(DIRUT)
QUIT
End DoDot:2
IF $DATA(DIRUT)
QUIT
End DoDot:1
IF $DATA(DIRUT)
QUIT
+13 ;
+14 IF '$GET(XUPROB)
WRITE !,"NO PROBLEMS FOUND",!
+15 DO END
+16 QUIT
+17 ;
BLDCOMP(XUNAM,XUSUF,XUNEW) ;Build new name components
+1 KILL XUNEW
+2 SET XUNEW=$EXTRACT(XUNAM,1,$LENGTH(XUNAM)-$LENGTH(XUSUF))
+3 SET XUSUF=$TRANSLATE(XUSUF," ")
+4 DO NAMECOMP^XLFNAME(.XUNEW)
+5 SET XUNEW=XUNEW_" "_XUSUF
+6 SET XUNEW("SUFFIX")=$GET(XUNEW("SUFFIX"))_$EXTRACT(" ",$GET(XUNEW("SUFFIX"))]"")_XUSUF
+7 QUIT
+8 ;
WRITE(XUIEN,XUNAM,XUNEW) ;Write info
+1 DO W()
IF $DATA(DIRUT)
QUIT
+2 DO W("Entry #"_XUIEN)
IF $DATA(DIRUT)
QUIT
+3 DO W("Old Name: "_XUNAM)
IF $DATA(DIRUT)
QUIT
+4 DO W("New Name: "_XUNEW)
IF $DATA(DIRUT)
QUIT
+5 IF $GET(XUNEW("GIVEN"))]""
DO W(" Given: "_XUNEW("GIVEN"),10)
IF $DATA(DIRUT)
QUIT
+6 IF $GET(XUNEW("MIDDLE"))]""
DO W("Middle: "_XUNEW("MIDDLE"),10)
IF $DATA(DIRUT)
QUIT
+7 IF $GET(XUNEW("FAMILY"))]""
DO W("Family: "_XUNEW("FAMILY"),10)
IF $DATA(DIRUT)
QUIT
+8 IF $GET(XUNEW("SUFFIX"))]""
DO W("Suffix: "_XUNEW("SUFFIX"),10)
IF $DATA(DIRUT)
QUIT
+9 QUIT
+10 ;
FILE(XUIEN,XUNEW) ;Correct Name
+1 NEW DIERR,XUFDA,XUMSG,XUNC
+2 ;
+3 SET XUNC=$PIECE($GET(^VA(200,XUIEN,3.1)),U)
+4 IF XUNC
IF $DATA(^VA(20,XUNC,0))#2
IF $PIECE(^(0),U,1,3)="200^.01^"_XUIEN_","
Begin DoDot:1
+5 SET XUFDA(20,XUNC_",",1)=$GET(XUNEW("FAMILY"))
+6 SET XUFDA(20,XUNC_",",2)=$GET(XUNEW("GIVEN"))
+7 SET XUFDA(20,XUNC_",",3)=$GET(XUNEW("MIDDLE"))
+8 SET XUFDA(20,XUNC_",",5)=$GET(XUNEW("SUFFIX"))
+9 DO FILE^DIE("","XUFDA","XUMSG")
End DoDot:1
+10 ;
+11 IF '$TEST
Begin DoDot:1
+12 DO W("** Unable to file new name **")
+13 DO W(" There is no corresponding entry in the Name Components file.")
End DoDot:1
+14 ;
+15 IF $GET(DIERR)
Begin DoDot:1
+16 NEW XUI,XUOUT
+17 DO MSG^DIALOG("AE","XUOUT","",5,"XUMSG")
+18 DO W("** Unable to file new name **")
IF $DATA(DIRUT)
QUIT
+19 FOR XUI=1:1:XUOUT
DO W(XUOUT(XUI))
IF $DATA(DIRUT)
QUIT
End DoDot:1
+20 QUIT
+21 ;
W(XUSTR,XUTAB) ;Write XUSTR
+1 IF $Y+4>IOSL
DO EOP
IF $DATA(DIRUT)
QUIT
+2 WRITE !?+$GET(XUTAB),$GET(XUSTR)
+3 QUIT
+4 ;
EOP ;End-of-page prompt/check
+1 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+2 NEW DIR,DIROUT,DTOUT,DUOUT,X,Y
+3 SET DIR(0)="E"
WRITE !
DO ^DIR
End DoDot:1
IF $DATA(DIRUT)
QUIT
+4 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET (ZTSTOP,DIRUT)=1
QUIT
+5 WRITE @IOF
+6 DO HDR
+7 QUIT
+8 ;
HDR ;Print header
+1 SET ($X,$Y)=0
+2 SET XUPAGE=$GET(XUPAGE)+1
+3 IF XUFIX
WRITE "NEW PERSON NAMES FIXED BY FIX^XLFNP176"
+4 IF '$TEST
WRITE "HOW FIX^XLFNP176 WOULD FIX NEW PERSON NAMES"
+5 WRITE ?(IOM-$LENGTH(XUHLIN)-$LENGTH(XUPAGE)-1),XUHLIN_XUPAGE
+6 WRITE !,$TRANSLATE($JUSTIFY("",IOM-1)," ","-")
+7 QUIT
+8 ;
ASKFIX() ;Ask whether to file corrected New Person name
+1 NEW DIR,DIROUT,DTOUT,DUOUT,X,Y
KILL DIRUT
+2 SET DIR(0)="SBA^R:Report Only;F:Fix Names"
+3 SET DIR("A")="Fix names or just print a Report (F/R)? "
+4 SET DIR("?",1)="Answer 'R' to print a report of names with a potential problems."
+5 SET DIR("?")="Answer 'F' to fix the names."
+6 WRITE !
DO ^DIR
+7 QUIT Y="F"
+8 ;
DEVSEL ;Select device
+1 NEW %ZIS,POP
KILL DIRUT
+2 SET %ZIS=$SELECT($DATA(^%ZTSK):"Q",1:"")
+3 WRITE !
DO ^%ZIS
+4 IF $GET(POP)
SET DIRUT=1
QUIT
+5 ;
+6 ;Queue report
+7 IF $DATA(IO("Q"))
IF $DATA(^%ZTSK)
Begin DoDot:1
+8 NEW ZTSK
+9 SET ZTRTN="MAIN^XLFNP176"
+10 SET ZTDESC="Names in New Person file with spaces within a suffix."
+11 SET ZTSAVE("XUFIX")=""
+12 DO ^%ZTLOAD
+13 IF $DATA(ZTSK)#2
WRITE !,"Report queued!",!,"Task number: "_$GET(ZTSK),!
+14 IF '$TEST
WRITE !,"Report canceled!",!
+15 SET IOP="HOME"
DO ^%ZIS
End DoDot:1
SET DIRUT=1
QUIT
+16 QUIT
+17 ;
INIT ;Setup
+1 NEW %,%H,X,Y
+2 SET %H=$HOROLOG
DO YX^%DTC
+3 SET XUHLIN=$PIECE(Y,"@")_" "_$PIECE($PIECE(Y,"@",2),":",1,2)_" PAGE "
+4 IF $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+5 DO HDR
+6 QUIT
+7 ;
END ;Finish up
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 IF '$TEST
NEW POP
DO ^%ZISC
+3 QUIT
+4 ;
INTRO ;
+1 NEW DIR,DIROUT,DUOUT,DTOUT,I,L,S,X,Y
+2 WRITE !,"Routine XLFNP176 was released with patch XU*8*176."
+3 ;
+4 WRITE !!,"This entry point (FIX^XLFNP176) loops through all the entries in the New"
+5 WRITE !,"Person file (#200) and looks for names that may have been standardized and"
+6 WRITE !,"parsed incorrectly by the Name Standardization Patch XU*8*134. If a name"
+7 WRITE !,"in the New Person file prior to the installation of Patch XU*8*134"
+8 WRITE !,"contained periods within its suffix, the Post-Install Conversion of that"
+9 WRITE !,"patch converted those periods to spaces, and didn't recognize the name"
+10 WRITE !,"component as a suffix. This entry point prints a report of names that may"
+11 WRITE !,"have the problem, and optionally corrects them."
+12 ;
+13 WRITE !!,"NOTE: This routine should be run only after Patches XU*8*134 and XU*8*152"
+14 WRITE !,"have been installed."
+15 ;
+16 IF '$$PATCH^XPDUTL("XU*8.0*134")!'$$PATCH^XPDUTL("XU*8.0*152")
Begin DoDot:1
+17 WRITE !!,$CHAR(7)," It appears that the above two patches have NOT been installed on"
+18 WRITE !," your system. Exiting ...",!
+19 SET DIRUT=1
End DoDot:1
QUIT
+20 ;
+21 WRITE !!," It appears that those two patches HAVE been installed in this acccount"
+22 WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT
+23 ;
+24 WRITE !!,"Each New Person file Name will be checked to determine whether any"
+25 WRITE !,"following strings occur at the end of the Name:",!
+26 SET L=$PIECE($TEXT(LIST),";;",2,99)
+27 FOR I=1:1:$LENGTH(L,U)
SET S=$PIECE(L,U,I)
IF S]""
WRITE !," '"_S_"'"
+28 ;
+29 SET DIR(0)="Y"
+30 SET DIR("A")="Do you wish to use a different list"
+31 SET DIR("B")="NO"
+32 SET DIR("?",1)=" Enter 'YES' to exit and modify line tag LIST^XLFNP162."
+33 SET DIR("?")=" Enter 'NO' to accept the above list and continue."
+34 WRITE !
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
QUIT
+35 IF Y
Begin DoDot:1
+36 WRITE !!," Edit the list at line tag LIST^XLFNP176.",!
+37 SET DIRUT=1
End DoDot:1
QUIT
+38 QUIT
