source: FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYPRCM.m@ 1635

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

initial load of FOIAVistA 6/30/08 version
File size: 3.2 KB
Line 
1LBRYPRCM ;SSI/ALA-PROCESS FORUM TRANSACTIONS MANUALLY ;[ 05/23/97 12:13 PM ]
2 ;;2.5;Library;**2**;Mar 11, 1996
3 ; This is to manually process the library transactions
4 ; received from FORUM and not updated automatically
5 S TRN="",CT=0
6TR S TRN=$O(^LBRY(682.1,"AC","M",TRN)) G EXIT:TRN=""
7 S TYP=$P(^LBRY(682.1,TRN,0),U,2) K %,LBRANS
8 F I=1:1:4 S LBDATA(I)=$G(^LBRY(682.1,TRN,I))
9 S TAF=$P(LBDATA(1),U,2),LDA=$P(LBDATA(1),U,3)
10 G TR:TAF=""
11 I LDA'="",$G(^LBRY(680.5,LDA,0))="" G TR
12 S TIT=$P(LBDATA(1),U),CT=CT+1
13 I $D(^LBRY(680.5,TAF,0)),TIT'[$P(^LBRY(680.5,TAF,0),U) D DSP G TR:$G(LBRANS)="N",EXIT:$G(LBRANS)=""
14 D TI
15TR1 S DIC="^LBRY(682.1,",DIE=DIC,DA=TRN,DR="2///^S X=""P""" D ^DIE
16 K CHD,FX,TX,ND1,PC1,ND2,PC2,FR,TO,PF,PT,PO,GLB,IN,INP,DR,DIE,DIC,DA
17 K D,D0,X,LBRYCLS,LBDATA,LDA,TAF,TYP,QFL,FLG,LBRANS,%,OTIT,NTIT,TIT
18 G TR
19TI ; Update a title from a transaction
20 I LDA'="" S DA=LDA D ^LBRYX51
21 S LBRYCLS=TAF,$P(^LBRY(680.5,LBRYCLS,0),U)=$P(LBDATA(1),U)
22 S FLG=$S(LDA'="":$P(^LBRY(680.5,LDA,0),U,2),TAF'="":$P(^LBRY(680.5,TAF,0),U,2),1:"")
23 ; Move the data from the transaction into the Title Authority File
24 S TX="0;5^0;6^3;5^3;8^3;1^3;3^3;4",FX="1;4^2;1^2;2^3;1^3;3^4;2^4;3"
25 F I=1:1:7 S FR=$P(FX,U,I),TO=$P(TX,U,I) D
26 . S ND1=$P(FR,";"),PC1=$P(FR,";",2),ND2=$P(TO,";"),PC2=$P(TO,";",2)
27 . S $P(^LBRY(680.5,LBRYCLS,ND2),U,PC2)=$P($G(^LBRY(682.1,TRN,ND1)),U,PC1)
28 S PF="2;3-680.5^3;2-680.5^4;1-680.1^4;4-680.2^4;5-680.9",PT="3;6^3;7^3;2^0;4^0;3"
29 F I=1:1:5 S FR=$P(PF,U,I),TO=$P(PT,U,I) D
30 . S PO=$P(FR,"-"),GLB=$P(FR,"-",2)
31 . S ND1=$P(PO,";"),PC1=$P(PO,";",2),ND2=$P(TO,";"),PC2=$P(TO,";",2)
32 . S CH=$P($G(^LBRY(682.1,TRN,ND1)),U,PC1),CHD=CH
33 . I CH'="" S J="" F S J=$O(^LBRY(GLB,"B",$E(CH,1,30),J)) Q:J'>0 S:$P(^LBRY(GLB,J,0),U)=CH CHD=J
34 . S $P(^LBRY(680.5,LBRYCLS,ND2),U,PC2)=CHD
35 I $D(^LBRY(682.1,TRN,6)) S IN=0 F S IN=$O(^LBRY(682.1,TRN,6,IN)) Q:IN'>0 D
36 . S INP=^LBRY(682.1,TRN,6,IN,0)
37 . S ^LBRY(680.5,LBRYCLS,1,IN,0)=$S($D(^LBRY(680.8,"B",INP)):$O(^LBRY(680.8,"B",INP,"")),1:INP)
38 . S ^LBRY(680.5,LBRYCLS,1,0)="^680.53PA^"_IN_U_IN
39 I $D(^LBRY(682.1,TRN,7)) S IN=0 F S IN=$O(^LBRY(682.1,TRN,7,IN)) Q:IN'>0 D
40 . S ^LBRY(680.5,LBRYCLS,2,IN,0)=^LBRY(682.1,TRN,7,IN,0)
41 . S ^LBRY(680.5,LBRYCLS,2,0)="^680.54^"_IN_U_IN_U_DT
42 S $P(^LBRY(680.5,LBRYCLS,0),U,5)="N",$P(^(0),U,2)=FLG
43 I $F("CTI,TIC,LTR",TYP) S DA=LDA,DIK="^LBRY(680.5," D ^DIK
44 S DA=LBRYCLS D ^LBRYX53
45 I LDA'="" S LBRTDA="" D
46 . F S LBRTDA=$O(^LBRY(680,"B",LDA,LBRTDA)) Q:LBRTDA="" D
47 . . S DR=".01///^S X=TAF",DIC="^LBRY(680,",DIE=DIC,DA=LBRTDA D ^DIE
48 Q
49EXIT I CT=0 R !!,"No transactions to process. Press Return to continue: ",C:DTIME
50 K CHD,FX,TX,ND1,PC1,ND2,PC2,FR,TO,PF,PT,PO,GLB,IN,INP,DR,DIE,DIC,DA
51 K D,D0,X,LBRYCLS,LBDATA,LDA,TAF,TRN,QFL,FLG,CT,C,OTIT,NTIT,TIT,%
52 K LBRANS
53 S $P(^LBRY(680.5,0),U,3)=99000
54 Q
55DSP ; Display differences and ask for override
56 S OTIT="" I LDA'="" S OTIT=$P($G(^LBRY(680.5,LDA,0)),U)
57 I OTIT="" S OTIT=$P($G(^LBRY(680.5,TAF,0)),U)
58 S NTIT=$P($G(^LBRY(682.1,TRN,1)),U)
59 W !!,"OLD TITLE: "_OTIT
60 W !!,"NEW TITLE: "_NTIT
61QS W !!,"Overwrite OLD TITLE with NEW TITLE " D YN^DICN
62 I %=0 W !!,"Please answer 'Y' to correct old title or 'N' to not process this title" G QS
63 S LBRANS=$S(%=1:"Y",%=2:"N",1:"")
64 Q
Note: See TracBrowser for help on using the repository browser.