source: FOIAVistA/tag/r/LIBRARY-LBR-LBRS/LBRVCON2.m@ 808

LBRVCON2 ;SSI/ALA/JSR-Consolidate files continued ;[ 07/06/2000  3:41 PM ]
 ;;2.5;Library;**3,8**;APR 19, 1996
EN ;  Continue with update
 I $P(^LBRY(680.6,0),U,4)=1 Q
 I '$D(^XTMP("LBRY",LBRVSTA,"ODA4","DONE")) D STP4 S ^XTMP("LBRY",LBRVSTA,"ODA4","DONE")=""
 S DA=0 F  S DA=$O(^A7RLBRY(LBRVSTA,681,DA)) Q:'DA  D
 . S TDA=$P(^A7RLBRY(LBRVSTA,681,DA,0),U,2)
 . I TDA="" K ^A7RLBRY(LBRVSTA,681,DA) Q
 . S ^A7RLBRY(LBRVSTA,681,"C",TDA,DA)=""
 S DA=0 F  S DA=$O(^A7RLBRY(LBRVSTA,682,DA)) Q:'DA  D
 . S TDA=$P(^A7RLBRY(LBRVSTA,682,DA,0),U,2)
 . I TDA="" K ^A7RLBRY(LBRVSTA,682,DA) Q
 . S ^A7RLBRY(LBRVSTA,682,"C",TDA,DA)=""
 I '$D(^XTMP("LBRY",LBRVSTA,"ODA5","DONE")) D STP5 S ^XTMP("LBRY",LBRVSTA,"ODA5","DONE")=""
 I '$D(^XTMP("LBRY",LBRVSTA,"CON3","DONE")) D ^LBRVCON3 S ^XTMP("LBRY",LBRVSTA,"CON3","DONE")="",^XTMP("LBRY",LBRVSTA,"CON2","DONE")=""
 K NDA,ODA,USRN,LDA,TDA,Y,%X,%Y,DA,TDA1,VNDN,X,LBRYCLS,USR
 Q
STP4 D MES^LBRPUTL("I am beginning Step 4....for "_LBRVSTA_" at "_$$HTE^XLFDT($H))
 ;  For each local title moved from original site, set into new site
 S T1=99000 F  S T1=$O(^A7RLBRY(LBRVSTA,680.5,T1)) Q:'T1  S LT1=T1
 S T2=99000 F  S T2=$O(^LBRY(680.5,T2)) Q:'T2  S LT2=T2
 Q:'$D(LT1)
 S LT=$S(LT1>$G(LT2):LT1,1:$G(LT2))
 S $P(^LBRY(680.5,0),"^",3)=LT
 S ODA=$P(^XTMP("LBRY",LBRVSTA,"ODA4"),"^",1)
GDA4 S ODA=$O(^A7RLBRY(LBRVSTA,680.5,ODA)) Q:ODA'>0
 S DINUM=LT
GD4RET F  S DINUM=DINUM+1 Q:'$D(^LBRY(680.5,DINUM,0))
 S X=DINUM,DLAYGO=680.5,DIC(0)="L",DIC="^LBRY(680.5,"
 D FILE^DICN S (NDA,LBRYCLS)=+Y
 I NDA=-1 S DINUM=X G GD4RET
 ;  Set Local Serials
 S TDA="" F  S TDA=$O(^A7RLBRY(LBRVSTA,680,"B",ODA,TDA)) Q:TDA=""  D
 . K ^A7RLBRY(LBRVSTA,680,"B",ODA,TDA)
 . S $P(^A7RLBRY(LBRVSTA,680,TDA,0),U,1)=NDA
 S TDA="" F  S TDA=$O(^A7RLBRY(LBRVSTA,681,"C",ODA,TDA)) Q:TDA=""  D
 . K ^A7RLBRY(LBRVSTA,681,"C",ODA,TDA)
 . S $P(^A7RLBRY(LBRVSTA,681,TDA,0),U,2)=NDA
 S TDA="" F  S TDA=$O(^A7RLBRY(LBRVSTA,682,"C",ODA,TDA)) Q:TDA=""  D
 . K ^A7RLBRY(LBRVSTA,682,"C",ODA,TDA)
 . S $P(^A7RLBRY(LBRVSTA,682,TDA,0),U,2)=NDA
 ;  Move data over in TAF
 S %X="^A7RLBRY(LBRVSTA,680.5,"_ODA_",",%Y="^LBRY(680.5,"_NDA_"," D %XY^%RCR
 ;  Reset cross-references
 ;S DA=NDA D ^LBRYX53
 ;  Create transaction for FORUM
 ; I ODA>99000&(NDA>99000) D ^LBRYLTF ;ask per Nancy do not send titles to forum 4/6/2000 jsr
 S $P(^XTMP("LBRY",LBRVSTA,"ODA4"),"^",1)=ODA G GDA4
STP5 D MES^LBRPUTL("I am beginning Step 5....for "_LBRVSTA_" at "_$$HTE^XLFDT($H))
 S $P(^LBRY(680,0),"^",3)=1,ODA=$P(^XTMP("LBRY",LBRVSTA,"ODA5"),"^",1)
GDA5 S ODA=$O(^A7RLBRY(LBRVSTA,680,ODA)) Q:ODA'>0
 S VND=$P($G(^A7RLBRY(LBRVSTA,680,ODA,2)),U,5)
 I VND'="" D
 . S VND=$P(VND,"*",1)
 . S VNDN=$O(^PRC(440,"B",VND,""))
 . I VNDN'="" S $P(^A7RLBRY(LBRVSTA,680,ODA,2),U,5)=VND
NNDA ;  Get next available DA
 S DINUM=0
NNDRET F  S DINUM=DINUM+1 Q:'$D(^LBRY(680,DINUM,0))
 S X=DINUM,DLAYGO=680,DIC(0)="L",DIC="^LBRY(680,"
 D FILE^DICN S (DA,NDA)=+Y
 I NDA=-1 S DINUM=X G NNDRET
 S %X="^A7RLBRY(LBRVSTA,680,"_ODA_",",%Y="^LBRY(680,"_NDA_"," D %XY^%RCR
 S OTDA=$P(^A7RLBRY(LBRVSTA,680,ODA,0),U)
 S DIE=DIC,DR=".01////^S X=OTDA" D ^DIE
 F I=3,4,6,13 K ^LBRY(680,NDA,I,"B")
 I $G(^LBRY(680,NDA,3,0))'="" S $P(^(0),U,2)="680.03PA"
 I $G(^LBRY(680,NDA,4,0))'="" S $P(^(0),U,2)="680.01SA"
 I $G(^LBRY(680,NDA,6,0))'="" S $P(^(0),U,2)="680.02SA"
 S DA=ODA D ^LBRYX12 S DA=NDA D ^LBRYX14
 S PDA=$P(^LBRY(680,NDA,0),U)
 S TDA=""
 F  S TDA=$O(^A7RLBRY(LBRVSTA,681,"C",PDA,TDA)) Q:TDA=""  D
 . S $P(^A7RLBRY(LBRVSTA,681,TDA,0),U,2)=NDA K ^A7RLBRY(LBRVSTA,681,"C",ODA,TDA)
 F  S TDA=$O(^A7RLBRY(LBRVSTA,682,"C",PDA,TDA)) Q:TDA=""  D
 . S $P(^A7RLBRY(LBRVSTA,682,TDA,0),U,2)=NDA
 . K ^A7RLBRY(LBRVSTA,682,"C",ODA,TDA)
 ; W "STEP 5   "_ODA
 S $P(^XTMP("LBRY",LBRVSTA,"ODA5"),"^",1)=ODA G GDA5