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