65 lines
3.0 KiB
Mathematica
65 lines
3.0 KiB
Mathematica
LBRVCONP ;SSI/ALA/JSR-Preinstall of consolidation ;[ 06/28/2000 1:19 PM ]
|
|
;;2.5;Library;**3,8**;APR 19, 2000
|
|
CHKPT ;
|
|
; Clean up version number
|
|
S N=679.9999 F S N=$O(^DD(N)) Q:N>689.4 I $G(^DD(N,0,"VR"))?1"2.5"1A.N S ^DD(N,0,"VR")=2.5
|
|
; If single primary site quit
|
|
I $P(^LBRY(680.6,0),U,4)=1 Q
|
|
S LBRVSTA=0
|
|
STA ;get 5-letter code and number reference
|
|
S LBRVSTA=$O(^A7RLBRY(LBRVSTA))
|
|
I LBRVSTA="" G EXIT
|
|
S LBRVNM=$O(^LBRY(680.6,"C",LBRVSTA,""))
|
|
G EXIT:$G(DUOUT)=1
|
|
D L680
|
|
S ^XTMP("LBRY","LBRVCONP",LBRVSTA,"DONE")=$H
|
|
G STA
|
|
L680 ; Set those pointers that don't have a cross-reference
|
|
D MES^XPDUTL("Starting pre-consolidation steps...")
|
|
S TDA=0 D MES^XPDUTL("File 680 for "_LBRVSTA)
|
|
F I="B","E" K ^A7RLBRY(LBRVSTA,680,I)
|
|
F S TDA=$O(^A7RLBRY(LBRVSTA,680,TDA)) Q:TDA'>0 D W:TDA#50=0 "."
|
|
. S $P(^A7RLBRY(LBRVSTA,680,TDA,0),U,4)=LBRVNM
|
|
. S PDA=$P(^A7RLBRY(LBRVSTA,680,TDA,0),U)
|
|
. I PDA'="" S ^A7RLBRY(LBRVSTA,680,"B",PDA,TDA)=""
|
|
. S LD1=$P($G(^A7RLBRY(LBRVSTA,680,TDA,10)),U,7)
|
|
. I LD1'="" S ^A7RLBRY(LBRVSTA,680,"ZN",LD1,TDA)=""
|
|
. S LD2=$P($G(^A7RLBRY(LBRVSTA,680,TDA,1)),U,3)
|
|
. I LD2'="" S ^A7RLBRY(LBRVSTA,680,"ZL",LD2,TDA)=""
|
|
L681 S TDA=0 D MES^XPDUTL("File 681 for "_LBRVSTA)
|
|
F I="AC","B","C","D","E" K ^A7RLBRY(LBRVSTA,681,I)
|
|
F S TDA=$O(^A7RLBRY(LBRVSTA,681,TDA)) Q:TDA'>0 D W:TDA#50=0 "."
|
|
. S $P(^A7RLBRY(LBRVSTA,681,TDA,0),U,4)=LBRVNM
|
|
. S PDA=$P(^A7RLBRY(LBRVSTA,681,TDA,0),U,2)
|
|
. I PDA'="" S ^A7RLBRY(LBRVSTA,681,"C",PDA,TDA)=""
|
|
. S D1=0 F S D1=$O(^A7RLBRY(LBRVSTA,681,TDA,2,D1)) Q:'D1 D
|
|
. . S PTR=$P(^A7RLBRY(LBRVSTA,681,TDA,2,D1,0),U)
|
|
. . S ^A7RLBRY(LBRVSTA,681,"D",PTR,TDA,D1)=""
|
|
. S LD1=$P($G(^A7RLBRY(LBRVSTA,681,TDA,1)),U,8)
|
|
. I LD1'="" S ^A7RLBRY(LBRVSTA,681,"ZN",LD1,TDA)=""
|
|
. S LD2=$P($G(^A7RLBRY(LBRVSTA,681,TDA,1)),U,2)
|
|
. I LD2'="" S ^A7RLBRY(LBRVSTA,681,"ZL",LD2,TDA)=""
|
|
L682 S TDA=0 D MES^LBRPUTL("File 682 for "_LBRVSTA)
|
|
F I="A1","A3","A4","AC","B","C","D","E" K ^A7RLBRY(LBRVSTA,682,I)
|
|
F S TDA=$O(^A7RLBRY(LBRVSTA,682,TDA)) Q:TDA'>0 D W:TDA#50=0 "."
|
|
. S $P(^A7RLBRY(LBRVSTA,682,TDA,0),U,4)=LBRVNM
|
|
. S PDA=$P(^A7RLBRY(LBRVSTA,682,TDA,0),U,2)
|
|
. I PDA'="" S ^A7RLBRY(LBRVSTA,682,"C",PDA,TDA)=""
|
|
. S TDA1=0 F S TDA1=$O(^A7RLBRY(LBRVSTA,682,TDA,4,TDA1)) Q:TDA1'>0 D
|
|
.. S LD3=$P(^A7RLBRY(LBRVSTA,682,TDA,4,TDA1,0),U,3)
|
|
.. I LD3'="" S ^A7RLBRY(LBRVSTA,682,"ZC",LD3,TDA,TDA1)=""
|
|
L685 S TDA=0 D MES^LBRPUTL("File 680.5 for "_LBRVSTA)
|
|
F S TDA=$O(^A7RLBRY(LBRVSTA,680.5,TDA)) Q:TDA>99000!(TDA="") D W:TDA#50=0 "."
|
|
. I $D(^LBRY(680.5,TDA)) K ^A7RLBRY(LBRVSTA,680.5,TDA) Q
|
|
. F ND=0,3,4 S:$G(^A7RLBRY(LBRVSTA,680.5,TDA,ND))'="" ^LBRY(680.5,TDA,ND)=^A7RLBRY(LBRVSTA,680.5,TDA,ND)
|
|
. F ND=1,2 I $G(^A7RLBRY(LBRVSTA,680.5,TDA,ND,0))'="" D
|
|
.. S ^LBRY(680.5,TDA,ND,0)=^A7RLBRY(LBRVSTA,680.5,TDA,ND,0)
|
|
.. S NN=0 F S NN=$O(^A7RLBRY(LBRVSTA,680.5,TDA,ND,NN)) Q:'NN D
|
|
... S ^LBRY(680.5,TDA,ND,NN,0)=^A7RLBRY(LBRVSTA,680.5,TDA,ND,NN,0)
|
|
. K ^A7RLBRY(LBRVSTA,680.5,TDA)
|
|
S DIK="^LBRY(680.5," D IXALL^DIK
|
|
Q
|
|
EXIT ;
|
|
K LBRVNM,TDA,LD1,PDA,TDA1,LD3,ND,NN,DIK,LD2,TDA1,DIC,DIE,D1,PTR
|
|
Q
|