XUINPCH2 ;ISF/RWF - Post INIT for Person class file v2.; 3/10/03 1:40pm
;;8.0;KERNEL;**106,159,282**;Jul 10, 1995
Q
PREXXX ;This is the pre-init
;Remove data from USC(8932.1)
S ^USC="" K ^USC(8932.1)
Q
;
POST G AUTO
AUTO ;Loop through and repoint the ones we can.
N VA200,PC,R1,R2
D BMES^XPDUTL("Now repointing entries with direct mappings.")
D PINIT ;Build list
F VA200=.9:0 S VA200=$O(^VA(200,VA200)) Q:VA200'>0 D
. S PC=$O(^VA(200,VA200,"USC1","A"),-1) Q:PC'>0
. S R1=^VA(200,VA200,"USC1",PC,0) Q:$P(R1,U,3)>0
. S R1=+R1,R2=$G(^TMP($J,R1)) Q:R2=""
. D REPOINT(VA200,PC,R1,R2)
. Q
Q
;
MANUAL ;Find person class entries need to ask about
N DA,PC,R1,R2,VA200,DUOUT,LAST,XXX
W !,"Now to re-map person class entries."
D AINIT
S DIR(0)="S^C:Continue;R:Recheck all",DIR("A")="Where do you want to start",DIR("B")="C"
D ^DIR Q:$D(DIRUT)
S LAST=.9 S:Y["C" LAST=$G(^XTMP("A4A7","LAST"),.9)
F VA200=LAST:0 S VA200=$O(^VA(200,VA200)) Q:VA200'>0 I $$LOCK(VA200,1) D D LOCK(VA200,0)
. S PC=$O(^VA(200,VA200,"USC1","A"),-1) Q:PC'>0
. S R1=^VA(200,VA200,"USC1",PC,0) Q:$P(R1,U,3)>0
. I $P($$ACTIVE^XUSER(VA200),"^",2)="TERMINATED" D Q
. . K XXX
. . S XXX(200.05,PC_","_VA200_",",3)=DT
. . D UPDATE^DIE("","XXX")
. . W !,"Terminated User ("_$P(^VA(200,VA200,0),"^")_") has been automatically processed."
. . Q
. S R1=+R1,R2=$G(^TMP($J,R1)) Q:R2=""
. S R2=$$ASK(R1,R2) I R2>0 D REPOINT(VA200,PC,R1,R2),MARK(VA200)
. S:$D(DUOUT) VA200=9E10
. Q
W !,$S($D(DUOUT):"Come back soon to finish up.",1:"That's the end."),!
Q
ASK(OLD,OFFER) ;Ask what to point to.
N DIR,DIC,NEW K DUOUT
AK W !!,"User "_$P(^VA(200,VA200,0),U)," has the following person class:",!
D SHOW(OLD)
W !,"This has been discontinued. Please select a new entry.",!
W $P(OFFER,"A, ",2,9)
S DIC="^USC(8932.1,",DIC(0)="AEMQ" D ^DIC S NEW=+Y
I NEW>0 W !! D SHOW(NEW) S DIR(0)="Y",DIR("A")="Is this the one you want" D ^DIR
Q:Y=1 NEW Q:$D(DUOUT)!(NEW=-1) 0
G AK
;
LOCK(DA,%) ;Lock/Unlock user
I '% L -^VA(200,DA,"USC1") Q
I % L +^VA(200,DA,"USC1"):0 I '$T Q 0
Q 1
RPOLD(DA1,DA,OLD,NEW) ;Don't use FM here. Too many protections.
N VA200,PC,R1,R2
I $P(^VA(200,DA1,"USC1",DA,0),U)'=OLD Q
K ^VA(200,DA1,"USC1","B",OLD,DA) S ^VA(200,DA1,"USC1","B",NEW,DA)=""
S $P(^VA(200,DA1,"USC1",DA,0),U,1)=NEW
Q
REPOINT(DA1,DA,OLD,NEW) ;Use FM so to fire X-ref's
N VA200,PC,RX1,RX2,DUZ
I $P(^VA(200,DA1,"USC1",DA,0),U)'=OLD Q
S RX1(200.05,"+1,"_DA1_",",.01)=NEW L ^VA(200,DA1,"USC1"):30
D UPDATE^DIE("S","RX1","RX2")
Q
;
SHOW(DA) ;
N X S X=$G(^USC(8932.1,DA,0))
W $P(X,U,1) W:$P(X,U,2)]"" !,?3,$P(X,U,2) W:$P(X,U,3)]"" !,?6,$P(X,U,3)
Q
PINIT ;Build swap array
K ^TMP($J)
F I=1:1:674 S X=$P(^USC(8932.1,I,0),U,8) I X["P" D
. S J=$P(X,"P",2),^TMP($J,I)=J
. Q
Q
AINIT ;Build swap array for the Ask user
K ^TMP($J)
F I=1:1:674 S X=$P(^USC(8932.1,I,0),U,8) I X["A" D
. S ^TMP($J,I)=X
. Q
Q
BUILD ;
D AINIT S IEN=17,DA=0,DATE=2960101
F S DA=$O(^TMP($J,DA)) Q:DA'>0 D
. S DATE=$$FMADD^XLFDT(DATE,2),ID=$O(^VA(200,IEN,"USC1",999),-1)
. S $P(^VA(200,IEN,"USC1",ID,0),U,3)=DATE,^VA(200,IEN,"USC1",(ID+1),0)=DA_U_DATE
. Q
Q
MARK(Y) ;Set checkmark
S ^XTMP("A4A7",0)=DT,^("LAST")=Y
Q
;
CLEANUP ;Cleanup after done.
;D DEL^XPDMENU("XXX") ;no line found
K ^XTMP("A4A7")
;S X="XUINPCH2" X "X ^%ZOSV(""DEL"") HALT"
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUINPCH2 3424 printed Sep 23, 2025@19:46:02 Page 2
XUINPCH2 ;ISF/RWF - Post INIT for Person class file v2.; 3/10/03 1:40pm
+1 ;;8.0;KERNEL;**106,159,282**;Jul 10, 1995
+2 QUIT
PREXXX ;This is the pre-init
+1 ;Remove data from USC(8932.1)
+2 SET ^USC=""
KILL ^USC(8932.1)
+3 QUIT
+4 ;
POST GOTO AUTO
AUTO ;Loop through and repoint the ones we can.
+1 NEW VA200,PC,R1,R2
+2 DO BMES^XPDUTL("Now repointing entries with direct mappings.")
+3 ;Build list
DO PINIT
+4 FOR VA200=.9:0
SET VA200=$ORDER(^VA(200,VA200))
if VA200'>0
QUIT
Begin DoDot:1
+5 SET PC=$ORDER(^VA(200,VA200,"USC1","A"),-1)
if PC'>0
QUIT
+6 SET R1=^VA(200,VA200,"USC1",PC,0)
if $PIECE(R1,U,3)>0
QUIT
+7 SET R1=+R1
SET R2=$GET(^TMP($JOB,R1))
if R2=""
QUIT
+8 DO REPOINT(VA200,PC,R1,R2)
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
MANUAL ;Find person class entries need to ask about
+1 NEW DA,PC,R1,R2,VA200,DUOUT,LAST,XXX
+2 WRITE !,"Now to re-map person class entries."
+3 DO AINIT
+4 SET DIR(0)="S^C:Continue;R:Recheck all"
SET DIR("A")="Where do you want to start"
SET DIR("B")="C"
+5 DO ^DIR
if $DATA(DIRUT)
QUIT
+6 SET LAST=.9
if Y["C"
SET LAST=$GET(^XTMP("A4A7","LAST"),.9)
+7 FOR VA200=LAST:0
SET VA200=$ORDER(^VA(200,VA200))
if VA200'>0
QUIT
IF $$LOCK(VA200,1)
Begin DoDot:1
+8 SET PC=$ORDER(^VA(200,VA200,"USC1","A"),-1)
if PC'>0
QUIT
+9 SET R1=^VA(200,VA200,"USC1",PC,0)
if $PIECE(R1,U,3)>0
QUIT
+10 IF $PIECE($$ACTIVE^XUSER(VA200),"^",2)="TERMINATED"
Begin DoDot:2
+11 KILL XXX
+12 SET XXX(200.05,PC_","_VA200_",",3)=DT
+13 DO UPDATE^DIE("","XXX")
+14 WRITE !,"Terminated User ("_$PIECE(^VA(200,VA200,0),"^")_") has been automatically processed."
+15 QUIT
End DoDot:2
QUIT
+16 SET R1=+R1
SET R2=$GET(^TMP($JOB,R1))
if R2=""
QUIT
+17 SET R2=$$ASK(R1,R2)
IF R2>0
DO REPOINT(VA200,PC,R1,R2)
DO MARK(VA200)
+18 if $DATA(DUOUT)
SET VA200=9E10
+19 QUIT
End DoDot:1
DO LOCK(VA200,0)
+20 WRITE !,$SELECT($DATA(DUOUT):"Come back soon to finish up.",1:"That's the end."),!
+21 QUIT
ASK(OLD,OFFER) ;Ask what to point to.
+1 NEW DIR,DIC,NEW
KILL DUOUT
AK WRITE !!,"User "_$PIECE(^VA(200,VA200,0),U)," has the following person class:",!
+1 DO SHOW(OLD)
+2 WRITE !,"This has been discontinued. Please select a new entry.",!
+3 WRITE $PIECE(OFFER,"A, ",2,9)
+4 SET DIC="^USC(8932.1,"
SET DIC(0)="AEMQ"
DO ^DIC
SET NEW=+Y
+5 IF NEW>0
WRITE !!
DO SHOW(NEW)
SET DIR(0)="Y"
SET DIR("A")="Is this the one you want"
DO ^DIR
+6 if Y=1
QUIT NEW
if $DATA(DUOUT)!(NEW=-1)
QUIT 0
+7 GOTO AK
+8 ;
LOCK(DA,%) ;Lock/Unlock user
+1 IF '%
LOCK -^VA(200,DA,"USC1")
QUIT
+2 IF %
LOCK +^VA(200,DA,"USC1"):0
IF '$TEST
QUIT 0
+3 QUIT 1
RPOLD(DA1,DA,OLD,NEW) ;Don't use FM here. Too many protections.
+1 NEW VA200,PC,R1,R2
+2 IF $PIECE(^VA(200,DA1,"USC1",DA,0),U)'=OLD
QUIT
+3 KILL ^VA(200,DA1,"USC1","B",OLD,DA)
SET ^VA(200,DA1,"USC1","B",NEW,DA)=""
+4 SET $PIECE(^VA(200,DA1,"USC1",DA,0),U,1)=NEW
+5 QUIT
REPOINT(DA1,DA,OLD,NEW) ;Use FM so to fire X-ref's
+1 NEW VA200,PC,RX1,RX2,DUZ
+2 IF $PIECE(^VA(200,DA1,"USC1",DA,0),U)'=OLD
QUIT
+3 SET RX1(200.05,"+1,"_DA1_",",.01)=NEW
LOCK ^VA(200,DA1,"USC1"):30
+4 DO UPDATE^DIE("S","RX1","RX2")
+5 QUIT
+6 ;
SHOW(DA) ;
+1 NEW X
SET X=$GET(^USC(8932.1,DA,0))
+2 WRITE $PIECE(X,U,1)
if $PIECE(X,U,2)]""
WRITE !,?3,$PIECE(X,U,2)
if $PIECE(X,U,3)]""
WRITE !,?6,$PIECE(X,U,3)
+3 QUIT
PINIT ;Build swap array
+1 KILL ^TMP($JOB)
+2 FOR I=1:1:674
SET X=$PIECE(^USC(8932.1,I,0),U,8)
IF X["P"
Begin DoDot:1
+3 SET J=$PIECE(X,"P",2)
SET ^TMP($JOB,I)=J
+4 QUIT
End DoDot:1
+5 QUIT
AINIT ;Build swap array for the Ask user
+1 KILL ^TMP($JOB)
+2 FOR I=1:1:674
SET X=$PIECE(^USC(8932.1,I,0),U,8)
IF X["A"
Begin DoDot:1
+3 SET ^TMP($JOB,I)=X
+4 QUIT
End DoDot:1
+5 QUIT
BUILD ;
+1 DO AINIT
SET IEN=17
SET DA=0
SET DATE=2960101
+2 FOR
SET DA=$ORDER(^TMP($JOB,DA))
if DA'>0
QUIT
Begin DoDot:1
+3 SET DATE=$$FMADD^XLFDT(DATE,2)
SET ID=$ORDER(^VA(200,IEN,"USC1",999),-1)
+4 SET $PIECE(^VA(200,IEN,"USC1",ID,0),U,3)=DATE
SET ^VA(200,IEN,"USC1",(ID+1),0)=DA_U_DATE
+5 QUIT
End DoDot:1
+6 QUIT
MARK(Y) ;Set checkmark
+1 SET ^XTMP("A4A7",0)=DT
SET ^("LAST")=Y
+2 QUIT
+3 ;
CLEANUP ;Cleanup after done.
+1 ;D DEL^XPDMENU("XXX") ;no line found
+2 KILL ^XTMP("A4A7")
+3 ;S X="XUINPCH2" X "X ^%ZOSV(""DEL"") HALT"
+4 ;
