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

XLFNP176.m

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