source: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRVCONP.m@ 1378

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

initial load of FOIAVistA 6/30/08 version

File size: 3.0 KB
Line 
1LBRVCONP ;SSI/ALA/JSR-Preinstall of consolidation ;[ 06/28/2000 1:19 PM ]
2 ;;2.5;Library;**3,8**;APR 19, 2000
3CHKPT ;
4 ; Clean up version number
5 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
6 ; If single primary site quit
7 I $P(^LBRY(680.6,0),U,4)=1 Q
8 S LBRVSTA=0
9STA ;get 5-letter code and number reference
10 S LBRVSTA=$O(^A7RLBRY(LBRVSTA))
11 I LBRVSTA="" G EXIT
12 S LBRVNM=$O(^LBRY(680.6,"C",LBRVSTA,""))
13 G EXIT:$G(DUOUT)=1
14 D L680
15 S ^XTMP("LBRY","LBRVCONP",LBRVSTA,"DONE")=$H
16 G STA
17L680 ; Set those pointers that don't have a cross-reference
18 D MES^XPDUTL("Starting pre-consolidation steps...")
19 S TDA=0 D MES^XPDUTL("File 680 for "_LBRVSTA)
20 F I="B","E" K ^A7RLBRY(LBRVSTA,680,I)
21 F S TDA=$O(^A7RLBRY(LBRVSTA,680,TDA)) Q:TDA'>0 D W:TDA#50=0 "."
22 . S $P(^A7RLBRY(LBRVSTA,680,TDA,0),U,4)=LBRVNM
23 . S PDA=$P(^A7RLBRY(LBRVSTA,680,TDA,0),U)
24 . I PDA'="" S ^A7RLBRY(LBRVSTA,680,"B",PDA,TDA)=""
25 . S LD1=$P($G(^A7RLBRY(LBRVSTA,680,TDA,10)),U,7)
26 . I LD1'="" S ^A7RLBRY(LBRVSTA,680,"ZN",LD1,TDA)=""
27 . S LD2=$P($G(^A7RLBRY(LBRVSTA,680,TDA,1)),U,3)
28 . I LD2'="" S ^A7RLBRY(LBRVSTA,680,"ZL",LD2,TDA)=""
29L681 S TDA=0 D MES^XPDUTL("File 681 for "_LBRVSTA)
30 F I="AC","B","C","D","E" K ^A7RLBRY(LBRVSTA,681,I)
31 F S TDA=$O(^A7RLBRY(LBRVSTA,681,TDA)) Q:TDA'>0 D W:TDA#50=0 "."
32 . S $P(^A7RLBRY(LBRVSTA,681,TDA,0),U,4)=LBRVNM
33 . S PDA=$P(^A7RLBRY(LBRVSTA,681,TDA,0),U,2)
34 . I PDA'="" S ^A7RLBRY(LBRVSTA,681,"C",PDA,TDA)=""
35 . S D1=0 F S D1=$O(^A7RLBRY(LBRVSTA,681,TDA,2,D1)) Q:'D1 D
36 . . S PTR=$P(^A7RLBRY(LBRVSTA,681,TDA,2,D1,0),U)
37 . . S ^A7RLBRY(LBRVSTA,681,"D",PTR,TDA,D1)=""
38 . S LD1=$P($G(^A7RLBRY(LBRVSTA,681,TDA,1)),U,8)
39 . I LD1'="" S ^A7RLBRY(LBRVSTA,681,"ZN",LD1,TDA)=""
40 . S LD2=$P($G(^A7RLBRY(LBRVSTA,681,TDA,1)),U,2)
41 . I LD2'="" S ^A7RLBRY(LBRVSTA,681,"ZL",LD2,TDA)=""
42L682 S TDA=0 D MES^LBRPUTL("File 682 for "_LBRVSTA)
43 F I="A1","A3","A4","AC","B","C","D","E" K ^A7RLBRY(LBRVSTA,682,I)
44 F S TDA=$O(^A7RLBRY(LBRVSTA,682,TDA)) Q:TDA'>0 D W:TDA#50=0 "."
45 . S $P(^A7RLBRY(LBRVSTA,682,TDA,0),U,4)=LBRVNM
46 . S PDA=$P(^A7RLBRY(LBRVSTA,682,TDA,0),U,2)
47 . I PDA'="" S ^A7RLBRY(LBRVSTA,682,"C",PDA,TDA)=""
48 . S TDA1=0 F S TDA1=$O(^A7RLBRY(LBRVSTA,682,TDA,4,TDA1)) Q:TDA1'>0 D
49 .. S LD3=$P(^A7RLBRY(LBRVSTA,682,TDA,4,TDA1,0),U,3)
50 .. I LD3'="" S ^A7RLBRY(LBRVSTA,682,"ZC",LD3,TDA,TDA1)=""
51L685 S TDA=0 D MES^LBRPUTL("File 680.5 for "_LBRVSTA)
52 F S TDA=$O(^A7RLBRY(LBRVSTA,680.5,TDA)) Q:TDA>99000!(TDA="") D W:TDA#50=0 "."
53 . I $D(^LBRY(680.5,TDA)) K ^A7RLBRY(LBRVSTA,680.5,TDA) Q
54 . F ND=0,3,4 S:$G(^A7RLBRY(LBRVSTA,680.5,TDA,ND))'="" ^LBRY(680.5,TDA,ND)=^A7RLBRY(LBRVSTA,680.5,TDA,ND)
55 . F ND=1,2 I $G(^A7RLBRY(LBRVSTA,680.5,TDA,ND,0))'="" D
56 .. S ^LBRY(680.5,TDA,ND,0)=^A7RLBRY(LBRVSTA,680.5,TDA,ND,0)
57 .. S NN=0 F S NN=$O(^A7RLBRY(LBRVSTA,680.5,TDA,ND,NN)) Q:'NN D
58 ... S ^LBRY(680.5,TDA,ND,NN,0)=^A7RLBRY(LBRVSTA,680.5,TDA,ND,NN,0)
59 . K ^A7RLBRY(LBRVSTA,680.5,TDA)
60 S DIK="^LBRY(680.5," D IXALL^DIK
61 Q
62EXIT ;
63 K LBRVNM,TDA,LD1,PDA,TDA1,LD3,ND,NN,DIK,LD2,TDA1,DIC,DIE,D1,PTR
64 Q
Note: See TracBrowser for help on using the repository browser.