AUXINST ; [ 04/11/86 3:34 PM ]
W !,"AUXINST alters the ^DIC AND ^AUTTLOC globals.",!,"Therefore,..It must NOT be interrupted!!"
R !!,"Are you sure you want to continue <Y>? ",ANS I '(ANS="Y"!(ANS="")) W !,"OKIE DOKE - I QUIT!!",!,"AUXINST NOT EXECUTED!" K ANS Q
B 0 D CHGINST,ADDLOC,XCHGLOC,CHGPKG
W !,"AUXINST has completed its tasks.",!,"You may delete the ^DICBKUP and ^AUTTBKUP global at your pleasure!" B 1
Q
CHGINST ; CHANGE ENTRY NUMBERS BY 10000 IN ^DIC(4,
D BKUPINST
W !,"Beginning to change ^DIC(4,EN, to ^TEMPINST(4,EN+10000,",!,"..PLEASE WAIT!"
S ^TEMPINST(4,0)=^DIC(4,0)
S EN="" F L=0:0 S EN=$O(^DIC(4,EN)) Q:EN'=+EN S FROM="^DIC(4,"_EN_",",TO="^TEMPINST(4,"_(EN+10000)_"," D AUXGLOB
W " <DONE>",!,"Removing the ^DIC(4) global nodes!!" K ^DIC(4)
W " <DONE>",!,"Beginning to change ^TEMPINST(4, back to ^DIC(4,",!,"..PLEASE WAIT!"
S ^DIC(4,0)=^TEMPINST(4,0)
S EN=9999 F L=0:0 S EN=$O(^TEMPINST(4,EN)) Q:EN'=+EN S FROM="^TEMPINST(4,"_EN_"," S:EN=10000 EN=0 S TO="^DIC(4,"_EN_"," D AUXGLOB S:EN=0 EN=10000
W " <DONE>" K EN,L,^TEMPINST
Q
ADDLOC ; ADD IHS LOCATION NAMES TO VA INSTITUTION FILE
W !,"The ^DIC(4, global node has been altered!!",!,"Copying IHS Location names (^AUTTLOC) to VA Institution global (^DIC(4,",!,"..PLEASE WAIT!"
S EN=0 F L=0:0 S EN=$O(^AUTTLOC(EN)) Q:EN'=+EN S ^DIC(4,EN,0)=$P(^AUTTLOC(EN,0),"^",1)
W " <DONE>"
Q
XCHGLOC ; EXCHANGE LOCATION NAMES WITH ENTRY NUMBERS IN ^AUTTLOC
D BKUPLOC
W !,"Beginning to exchange the Location names with their entry numbers in ^AUTTLOC global.",!,"..PLEASE WAIT"
S X=0
F L=0:0 S X=$O(^AUTTLOC(X)) Q:'+X S $P(^(X,0),"^",1)=X
W " <DONE>" K X,L
Q
CHGPKG ; CHANGE INSTITUTION DATA IN ^DIC(9.4) PACKAGE FILE
D BKUPPKG
W !,"Beginning to change ^DIC(9.4 Alpha, Beta and Delta data values by 10000",!,"..PLEASE WAIT!"
S EN=0 F L=0:0 S EN=$O(^DIC(9.4,EN)) Q:'+EN D:$D(^(EN,9)) AB D:$D(^(10,0)) D
D D1 W " <DONE>" K EN,MV,X,FROM,TO,L,F,T,C,P,NF,NT,LX,F1,TF,TT,^DMV
Q
AB ; CHANGE ALPHA/BETA VALUES
S:$P(^DIC(9.4,EN,9),"^",1)>0 $P(^DIC(9.4,EN,9),"^",1)=$P(^DIC(9.4,EN,9),"^",1)+10000 S:$P(^DIC(9.4,EN,9),"^",2)>0 $P(^DIC(9.4,EN,9),"^",2)=$P(^DIC(9.4,EN,9),"^",2)+10000
Q
D ; CHANGE ANY VALUES IN THE DELTA FIELDS
S:$P(^DIC(9.4,EN,10,0),"^",3)>0 $P(^DIC(9.4,EN,10,0),"^",3)=$P(^DIC(9.4,EN,10,0),"^",3)+10000
S MV=0 F L=0:0 S MV=$O(^DIC(9.4,EN,10,MV)) Q:'+MV D:$D(^DIC(9.4,EN,10,MV,0)) DMV
Q
DMV ; CHANGE DELTA MULTI-VALUE FIELDS
S:^DIC(9.4,EN,10,MV,0)>0 ^DMV(9.4,EN,10,MV+10000,0)=^DIC(9.4,EN,10,MV,0)+10000 K ^DIC(9.4,EN,10,MV,0)
Q
D1 ; RESTORE ^DMV(9.4) AS ^DIC(9.4,EN,10,MV+10000,0) ENTRY
S X=0 F L=0:0 S X=$O(^DMV(X)) Q:X'=+X!(X>9.4) S FROM="^DMV(9.4,",TO="^DIC(9.4," D AUXGLOB
Q
AUXGLOB ;
S F="F",T="T",C=",",P=")",NF=$L(FROM,C)-1,NT=$L(TO,C)-1,LX=1,F1=""
S TF=FROM F L1=1:1:30 S TF=TF_F_L1_C
S TT=TO F L1=1:1:30 S TT=TT_F_L1_C
EXTR S X=F_LX,Y=$P(TF,C,1,LX+NF)_P,@X=$O(@Y)
I @X'="" D:$D(@(Y))#2 SUB S LX=LX+1,@(F_LX)="" G EXTR
S LX=LX-1 Q:LX=0 G EXTR
SUB S Z=$P(TT,C,1,LX+NT)_P,@Z=@Y
Q
BKUPINST ; SAVE ^DIC(4) FOR BACKUP
W !,"Saving ^DIC(4) as ^DICBKUP(4) for backup.",!,"..PLEASE WAIT!"
S X=3.9999 F L=0:0 S X=$O(^DIC(X)) Q:X'=+X!(X>4) S FROM="^DIC(4,",TO="^DICBKUP(4," D AUXGLOB
W " <DONE>" K X,L,FROM,TO,F,T,C,P,NF,NT,LX,F1,TF,TT
Q
BKUPPKG ; SAVE ^DIC(9.4) FOR BACKUP
W !,"Saving ^DIC(9.4) as ^DICBKUP(9.4) for backup.",!,"..PLEASE WAIT!"
S X=9.3999 F L=0:0 S X=$O(^DIC(X)) Q:X'=+X!(X>9.4) S FROM="^DIC(9.4,",TO="^DICBKUP(9.4," D AUXGLOB
W " <DONE>" K X,L,FROM,TO,F,T,C,P,NF,NT,LX,F1,TF,TT
Q
BKUPLOC ; SAVE ^AUTTLOC FOR BACKUP
W !,"Saving ^AUTTLOC, as ^AUTTBKUP for backup.",!,"..PLEASE WAIT!"
S X="" F L=0:0 S X=$O(^AUTTLOC(X)) Q:X'?1N.N S FROM="^AUTTLOC(",TO="^AUTTBKUP(" D AUXGLOB
W " <DONE>" K X,L,FROM,TO,F,T,C,P,NF,NT,LX,F1,TF,TT
Q
AUXINST ; [ 04/11/86 3:34 PM ]
+1 WRITE !,"AUXINST alters the ^DIC AND ^AUTTLOC globals.",!,"Therefore,..It must NOT be interrupted!!"
+2 READ !!,"Are you sure you want to continue <Y>? ",ANS
IF '(ANS="Y"!(ANS=""))
WRITE !,"OKIE DOKE - I QUIT!!",!,"AUXINST NOT EXECUTED!"
KILL ANS
QUIT
+3 BREAK 0
DO CHGINST
DO ADDLOC
DO XCHGLOC
DO CHGPKG
+4 WRITE !,"AUXINST has completed its tasks.",!,"You may delete the ^DICBKUP and ^AUTTBKUP global at your pleasure!"
BREAK 1
+5 QUIT
CHGINST ; CHANGE ENTRY NUMBERS BY 10000 IN ^DIC(4,
+1 DO BKUPINST
+2 WRITE !,"Beginning to change ^DIC(4,EN, to ^TEMPINST(4,EN+10000,",!,"..PLEASE WAIT!"
+3 SET ^TEMPINST(4,0)=^DIC(4,0)
+4 SET EN=""
FOR L=0:0
SET EN=$ORDER(^DIC(4,EN))
IF EN'=+EN
QUIT
SET FROM="^DIC(4,"_EN_","
SET TO="^TEMPINST(4,"_(EN+10000)_","
DO AUXGLOB
+5 WRITE " <DONE>",!,"Removing the ^DIC(4) global nodes!!"
KILL ^DIC(4)
+6 WRITE " <DONE>",!,"Beginning to change ^TEMPINST(4, back to ^DIC(4,",!,"..PLEASE WAIT!"
+7 SET ^DIC(4,0)=^TEMPINST(4,0)
+8 SET EN=9999
FOR L=0:0
SET EN=$ORDER(^TEMPINST(4,EN))
IF EN'=+EN
QUIT
SET FROM="^TEMPINST(4,"_EN_","
IF EN=10000
SET EN=0
SET TO="^DIC(4,"_EN_","
DO AUXGLOB
IF EN=0
SET EN=10000
+9 WRITE " <DONE>"
KILL EN,L,^TEMPINST
+10 QUIT
ADDLOC ; ADD IHS LOCATION NAMES TO VA INSTITUTION FILE
+1 WRITE !,"The ^DIC(4, global node has been altered!!",!,"Copying IHS Location names (^AUTTLOC) to VA Institution global (^DIC(4,",!,"..PLEASE WAIT!"
+2 SET EN=0
FOR L=0:0
SET EN=$ORDER(^AUTTLOC(EN))
IF EN'=+EN
QUIT
SET ^DIC(4,EN,0)=$PIECE(^AUTTLOC(EN,0),"^",1)
+3 WRITE " <DONE>"
+4 QUIT
XCHGLOC ; EXCHANGE LOCATION NAMES WITH ENTRY NUMBERS IN ^AUTTLOC
+1 DO BKUPLOC
+2 WRITE !,"Beginning to exchange the Location names with their entry numbers in ^AUTTLOC global.",!,"..PLEASE WAIT"
+3 SET X=0
+4 FOR L=0:0
SET X=$ORDER(^AUTTLOC(X))
IF '+X
QUIT
SET $PIECE(^(X,0),"^",1)=X
+5 WRITE " <DONE>"
KILL X,L
+6 QUIT
CHGPKG ; CHANGE INSTITUTION DATA IN ^DIC(9.4) PACKAGE FILE
+1 DO BKUPPKG
+2 WRITE !,"Beginning to change ^DIC(9.4 Alpha, Beta and Delta data values by 10000",!,"..PLEASE WAIT!"
+3 SET EN=0
FOR L=0:0
SET EN=$ORDER(^DIC(9.4,EN))
IF '+EN
QUIT
IF $DATA(^(EN,9))
DO AB
IF $DATA(^(10,0))
DO D
+4 DO D1
WRITE " <DONE>"
KILL EN,MV,X,FROM,TO,L,F,T,C,P,NF,NT,LX,F1,TF,TT,^DMV
+5 QUIT
AB ; CHANGE ALPHA/BETA VALUES
+1 IF $PIECE(^DIC(9.4,EN,9),"^",1)>0
SET $PIECE(^DIC(9.4,EN,9),"^",1)=$PIECE(^DIC(9.4,EN,9),"^",1)+10000
IF $PIECE(^DIC(9.4,EN,9),"^",2)>0
SET $PIECE(^DIC(9.4,EN,9),"^",2)=$PIECE(^DIC(9.4,EN,9),"^",2)+10000
+2 QUIT
D ; CHANGE ANY VALUES IN THE DELTA FIELDS
+1 IF $PIECE(^DIC(9.4,EN,10,0),"^",3)>0
SET $PIECE(^DIC(9.4,EN,10,0),"^",3)=$PIECE(^DIC(9.4,EN,10,0),"^",3)+10000
+2 SET MV=0
FOR L=0:0
SET MV=$ORDER(^DIC(9.4,EN,10,MV))
IF '+MV
QUIT
IF $DATA(^DIC(9.4,EN,10,MV,0))
DO DMV
+3 QUIT
DMV ; CHANGE DELTA MULTI-VALUE FIELDS
+1 IF ^DIC(9.4,EN,10,MV,0)>0
SET ^DMV(9.4,EN,10,MV+10000,0)=^DIC(9.4,EN,10,MV,0)+10000
KILL ^DIC(9.4,EN,10,MV,0)
+2 QUIT
D1 ; RESTORE ^DMV(9.4) AS ^DIC(9.4,EN,10,MV+10000,0) ENTRY
+1 SET X=0
FOR L=0:0
SET X=$ORDER(^DMV(X))
IF X'=+X!(X>9.4)
QUIT
SET FROM="^DMV(9.4,"
SET TO="^DIC(9.4,"
DO AUXGLOB
+2 QUIT
AUXGLOB ;
+1 SET F="F"
SET T="T"
SET C=","
SET P=")"
SET NF=$LENGTH(FROM,C)-1
SET NT=$LENGTH(TO,C)-1
SET LX=1
SET F1=""
+2 SET TF=FROM
FOR L1=1:1:30
SET TF=TF_F_L1_C
+3 SET TT=TO
FOR L1=1:1:30
SET TT=TT_F_L1_C
EXTR SET X=F_LX
SET Y=$PIECE(TF,C,1,LX+NF)_P
SET @X=$ORDER(@Y)
+1 IF @X'=""
IF $DATA(@(Y))#2
DO SUB
SET LX=LX+1
SET @(F_LX)=""
GOTO EXTR
+2 SET LX=LX-1
IF LX=0
QUIT
GOTO EXTR
SUB SET Z=$PIECE(TT,C,1,LX+NT)_P
SET @Z=@Y
+1 QUIT
BKUPINST ; SAVE ^DIC(4) FOR BACKUP
+1 WRITE !,"Saving ^DIC(4) as ^DICBKUP(4) for backup.",!,"..PLEASE WAIT!"
+2 SET X=3.9999
FOR L=0:0
SET X=$ORDER(^DIC(X))
IF X'=+X!(X>4)
QUIT
SET FROM="^DIC(4,"
SET TO="^DICBKUP(4,"
DO AUXGLOB
+3 WRITE " <DONE>"
KILL X,L,FROM,TO,F,T,C,P,NF,NT,LX,F1,TF,TT
+4 QUIT
BKUPPKG ; SAVE ^DIC(9.4) FOR BACKUP
+1 WRITE !,"Saving ^DIC(9.4) as ^DICBKUP(9.4) for backup.",!,"..PLEASE WAIT!"
+2 SET X=9.3999
FOR L=0:0
SET X=$ORDER(^DIC(X))
IF X'=+X!(X>9.4)
QUIT
SET FROM="^DIC(9.4,"
SET TO="^DICBKUP(9.4,"
DO AUXGLOB
+3 WRITE " <DONE>"
KILL X,L,FROM,TO,F,T,C,P,NF,NT,LX,F1,TF,TT
+4 QUIT
BKUPLOC ; SAVE ^AUTTLOC FOR BACKUP
+1 WRITE !,"Saving ^AUTTLOC, as ^AUTTBKUP for backup.",!,"..PLEASE WAIT!"
+2 SET X=""
FOR L=0:0
SET X=$ORDER(^AUTTLOC(X))
IF X'?1N.N
QUIT
SET FROM="^AUTTLOC("
SET TO="^AUTTBKUP("
DO AUXGLOB
+3 WRITE " <DONE>"
KILL X,L,FROM,TO,F,T,C,P,NF,NT,LX,F1,TF,TT
+4 QUIT
