source: WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUINPCH2.m@ 1141

Last change on this file since 1141 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.2 KB
Line 
1XUINPCH2 ;ISF/RWF - Post INIT for Person class file v2.; 3/10/03 1:40pm
2 ;;8.0;KERNEL;**106,159,282**;Jul 10, 1995
3 Q
4PREXXX ;This is the pre-init
5 ;Remove data from USC(8932.1)
6 S ^USC="" K ^USC(8932.1)
7 Q
8 ;
9POST G AUTO
10AUTO ;Loop through and repoint the ones we can.
11 N VA200,PC,R1,R2
12 D BMES^XPDUTL("Now repointing entries with direct mappings.")
13 D PINIT ;Build list
14 F VA200=.9:0 S VA200=$O(^VA(200,VA200)) Q:VA200'>0 D
15 . S PC=$O(^VA(200,VA200,"USC1","A"),-1) Q:PC'>0
16 . S R1=^VA(200,VA200,"USC1",PC,0) Q:$P(R1,U,3)>0
17 . S R1=+R1,R2=$G(^TMP($J,R1)) Q:R2=""
18 . D REPOINT(VA200,PC,R1,R2)
19 . Q
20 Q
21 ;
22MANUAL ;Find person class entries need to ask about
23 N DA,PC,R1,R2,VA200,DUOUT,LAST,XXX
24 W !,"Now to re-map person class entries."
25 D AINIT
26 S DIR(0)="S^C:Continue;R:Recheck all",DIR("A")="Where do you want to start",DIR("B")="C"
27 D ^DIR Q:$D(DIRUT)
28 S LAST=.9 S:Y["C" LAST=$G(^XTMP("A4A7","LAST"),.9)
29 F VA200=LAST:0 S VA200=$O(^VA(200,VA200)) Q:VA200'>0 I $$LOCK(VA200,1) D D LOCK(VA200,0)
30 . S PC=$O(^VA(200,VA200,"USC1","A"),-1) Q:PC'>0
31 . S R1=^VA(200,VA200,"USC1",PC,0) Q:$P(R1,U,3)>0
32 . I $P($$ACTIVE^XUSER(VA200),"^",2)="TERMINATED" D Q
33 . . K XXX
34 . . S XXX(200.05,PC_","_VA200_",",3)=DT
35 . . D UPDATE^DIE("","XXX")
36 . . W !,"Terminated User ("_$P(^VA(200,VA200,0),"^")_") has been automatically processed."
37 . . Q
38 . S R1=+R1,R2=$G(^TMP($J,R1)) Q:R2=""
39 . S R2=$$ASK(R1,R2) I R2>0 D REPOINT(VA200,PC,R1,R2),MARK(VA200)
40 . S:$D(DUOUT) VA200=9E10
41 . Q
42 W !,$S($D(DUOUT):"Come back soon to finish up.",1:"That's the end."),!
43 Q
44ASK(OLD,OFFER) ;Ask what to point to.
45 N DIR,DIC,NEW K DUOUT
46AK W !!,"User "_$P(^VA(200,VA200,0),U)," has the following person class:",!
47 D SHOW(OLD)
48 W !,"This has been discontinued. Please select a new entry.",!
49 W $P(OFFER,"A, ",2,9)
50 S DIC="^USC(8932.1,",DIC(0)="AEMQ" D ^DIC S NEW=+Y
51 I NEW>0 W !! D SHOW(NEW) S DIR(0)="Y",DIR("A")="Is this the one you want" D ^DIR
52 Q:Y=1 NEW Q:$D(DUOUT)!(NEW=-1) 0
53 G AK
54 ;
55LOCK(DA,%) ;Lock/Unlock user
56 I '% L -^VA(200,DA,"USC1") Q
57 I % L +^VA(200,DA,"USC1"):0 I '$T Q 0
58 Q 1
59RPOLD(DA1,DA,OLD,NEW) ;Don't use FM here. Too many protections.
60 N VA200,PC,R1,R2
61 I $P(^VA(200,DA1,"USC1",DA,0),U)'=OLD Q
62 K ^VA(200,DA1,"USC1","B",OLD,DA) S ^VA(200,DA1,"USC1","B",NEW,DA)=""
63 S $P(^VA(200,DA1,"USC1",DA,0),U,1)=NEW
64 Q
65REPOINT(DA1,DA,OLD,NEW) ;Use FM so to fire X-ref's
66 N VA200,PC,RX1,RX2,DUZ
67 I $P(^VA(200,DA1,"USC1",DA,0),U)'=OLD Q
68 S RX1(200.05,"+1,"_DA1_",",.01)=NEW L ^VA(200,DA1,"USC1"):30
69 D UPDATE^DIE("S","RX1","RX2")
70 Q
71 ;
72SHOW(DA) ;
73 N X S X=$G(^USC(8932.1,DA,0))
74 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)
75 Q
76PINIT ;Build swap array
77 K ^TMP($J)
78 F I=1:1:674 S X=$P(^USC(8932.1,I,0),U,8) I X["P" D
79 . S J=$P(X,"P",2),^TMP($J,I)=J
80 . Q
81 Q
82AINIT ;Build swap array for the Ask user
83 K ^TMP($J)
84 F I=1:1:674 S X=$P(^USC(8932.1,I,0),U,8) I X["A" D
85 . S ^TMP($J,I)=X
86 . Q
87 Q
88BUILD ;
89 D AINIT S IEN=17,DA=0,DATE=2960101
90 F S DA=$O(^TMP($J,DA)) Q:DA'>0 D
91 . S DATE=$$FMADD^XLFDT(DATE,2),ID=$O(^VA(200,IEN,"USC1",999),-1)
92 . S $P(^VA(200,IEN,"USC1",ID,0),U,3)=DATE,^VA(200,IEN,"USC1",(ID+1),0)=DA_U_DATE
93 . Q
94 Q
95MARK(Y) ;Set checkmark
96 S ^XTMP("A4A7",0)=DT,^("LAST")=Y
97 Q
98 ;
99CLEANUP ;Cleanup after done.
100 ;D DEL^XPDMENU("XXX") ;no line found
101 K ^XTMP("A4A7")
102 ;S X="XUINPCH2" X "X ^%ZOSV(""DEL"") HALT"
103 ;
Note: See TracBrowser for help on using the repository browser.