source: FOIAVistA/trunk/r/LIBRARY-LBR-LBRS/LBRYRTX.m@ 1389

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

initial load of FOIAVistA 6/30/08 version
File size: 3.4 KB
Line 
1LBRYRTX ;ISC2/DJM-ROUTINES USED IN FILE 682 ;[ 07/06/00 2:18 PM ]
2 ;;2.5;Library;**2,8**;Mar 11, 1996
3 K LBRYPTR Q
4I ;ENTERED FROM JOURNAL DATE SET STATEMENT OF X-REF AD
5 Q:($G(DIC)'[682)
6 I $D(^LBRY(682,DA,1))#2,$P(^(1),U,6)]"" Q
7 S LDFX=$P(^LBRY(682,DA,0),U,2),LBRYX=X
8COPY ;MOVE COPIES FROM FILE 681 INTO FILE 682 AT THE COPY OF ISSUE
9 ;MULTIPLE AND SET ROUTING STATUS TO 4 OR 5.
10 S (COPY,TOTAL,CO682)=0
11 F S COPY=$O(^LBRY(681,"AC",LDFX,COPY)) G:COPY="" EXIT S COPY1=0 D COPY1
12COPY1 S COPY1=$O(^LBRY(681,"AC",LDFX,COPY,COPY1)) Q:COPY1=""
13 S COPY2=^LBRY(681,COPY1,1),START=$P(COPY2,U,10),STOP=$P(COPY2,U,11)
14 I START="",STOP="" D TRANS G COPY1
15 I START]"",STOP="",START-X<1 D TRANS G COPY1
16 I START="",STOP]"",STOP-X'<0 D TRANS G COPY1
17 I START]"",STOP]"" I START-X<1&(STOP-X'<0) D TRANS G COPY1
18 G COPY1
19TRANS S TOTAL=TOTAL+1,CO682=CO682+1,COPYNO=$E($P(COPY2,U),1,30)
20 S ^LBRY(682,DA,4,TOTAL,0)=COPYNO_"^4^"_COPY1,^LBRY(682,DA,4,"B",COPYNO,TOTAL)=""
21 I COPYNO="ToC" S $P(^LBRY(682,DA,4,TOTAL,0),U,2)=5,CO682=CO682-1 S:CO682<0 CO682=0
22 Q
23EXIT I TOTAL>0 S ENTRY=$P(^DD(682,4,0),U,2),^LBRY(682,DA,4,0)="^"_ENTRY_"^"_TOTAL_"^"_TOTAL
24 S $P(^LBRY(682,DA,1),U,6)=DUZ S:CO682=0 CO682="" S $P(^LBRY(682,DA,1),U,5)=CO682
25EXIT1 K COPY,COPY1,COPY2,COPYNO,ENTRY,LBX,LDFX,START,STOP,TOC,TOC1,TOTAL,XX1,XXZ
26 Q
27NOCS ;ISSUE ROUTING STATUS SET OF X-REF AD IN MULTIPLE 682.04,1
28 ;
29 ; Q:'$D(LBRYPTR) exists to prevent the setting of the field
30 ; when executing Reindex from FileMan.
31 Q:'$D(LBRYPTR)
32 ;
33 ; Q:$G(LBRYINT)=1 exists to prevent the setting of the field
34 ; when integrating sites.
35 Q:$G(LBRYINT)=1
36 ;
37 I $P(^LBRY(682,DA(1),4,DA,0),U)'="ToC" S XXZ=^LBRY(682,DA(1),1),XX1=$P(XXZ,U,4) I X<4 S XX1=XX1+1,$P(^LBRY(682,DA(1),1),U,4)=XX1 G DAS
38 I $P(^LBRY(682,DA(1),4,DA,0),U)'="ToC" I XX1="" S TOC=$O(^LBRY(682,DA(1),4,"B","ToC",0)) D:TOC'="" TOCRMV
39 G DAS
40NOCD ;ISSUE ROUTING STATUS KILL OF X-REF AD IN MULTIPLE 682.04,1
41 ;
42 ; Q:'$D(LBRYPTR) exists to prevent the subtracting of the field
43 ; when executing Reindex from FileMan.
44 Q:'$D(LBRYPTR)
45 ;
46 ; Q:$G(LBRYINT)=1 exists to prevent the subtracting of the field
47 ; when integrating sites.
48 Q:$G(LBRYINT)=1
49 ;
50 I $P(^LBRY(682,DA(1),4,DA,0),U)'="ToC" I X<4 S XXZ=^LBRY(682,DA(1),1),XX1=$P(XXZ,U,4),XX1=XX1-1 S:XX1<1 XX1="" S $P(XXZ,U,4)=XX1 S:XX1="" $P(XXZ,U,7)="" S ^LBRY(682,DA(1),1)=XXZ
51 G DAK
52TOCRMV S TOC1=^LBRY(682,DA(1),4,TOC,0),$P(TOC1,U,2)=5,TOC1=$P(TOC1,U,1,3)
53 S ^LBRY(682,DA(1),4,TOC,0)=TOC1 K ^LBRY(682,"A2",DA(1),TOC)
54 Q
55DAS I X<4 S $P(^LBRY(682,DA(1),4,DA,0),U,8)=DUZ,LBX=X D
56 . S LDATE=$P(^LBRY(682,DA(1),4,DA,0),U,7) S:LDATE="" LDATE=DT
57 G EXIT1
58DAK S XX=$P(^LBRY(682,DA(1),4,DA,0),U,7),$P(^(0),U,7)="",$P(^(0),U,8)="",$P(^(0),U,6)=""
59 I XX]""&($P($G(^LBRY(682,DA(1),0)),U,2)'="") K ^LBRY(682,"A4",XX,$P(^LBRY(682,DA(1),0),U,2),DA(1),DA)
60 G EXIT1
61CNO ;INPUT TRANSFORM FROM 689.04 FIELD .02
62 Q
63 I $P(^LBRY(682,DA(1),0),U,2)=$P(^(0),U,2) D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X
64 Q
65A4 ;SET/KILL FOR "A4" CROSS-REFERENCE FOR CHANGE IN .02 FIELD
66 N LBRCOPN,LBRDA1
67 S LBRCOPN=0
68A4LP1 S LBRCOPN=$O(^LBRY(682,DA,4,"B",LBRCOPN)) Q:LBRCOPN=""
69 S LBRDA1=0
70A4LP2 S LBRDA1=$O(^LBRY(682,DA,4,"B",LBRCOPN,LBRDA1)) G A4LP1:LBRDA1=""
71 I LBRTYPE="SET",$P($G(^LBRY(682,DA,4,LBRDA1,0)),U,7)'="" S ^LBRY(682,"A4",$P(^LBRY(682,DA,4,LBRDA1,0),U,7),$E(X,1,30),DA,LBRDA1)=""
72 I LBRTYPE="KILL",$P($G(^LBRY(682,DA,4,LBRDA1,0)),U,7)'="" K ^LBRY(682,"A4",$P(^LBRY(682,DA,4,LBRDA1,0),U,7),$E(X,1,30),DA,LBRDA1)
73 G A4LP2
Note: See TracBrowser for help on using the repository browser.