1 | LBRYCK2 ;ISC2/DJM-CHECK-IN ROUTING LIST PRINTING ;[ 05/23/97 12:13 PM ]
|
---|
2 | ;;2.5;Library;**2**;Mar 11, 1996
|
---|
3 | START S LBRYQ=0 D NOW^%DTC S LBRYDT=%,LBRYD=%\1
|
---|
4 | ST S LBRYQ=$O(^LBRY(682,"A2",LBRYQ)) G:LBRYQ="" EXIT
|
---|
5 | S Q1=0
|
---|
6 | ST1 S Q1=$O(^LBRY(682,"A2",LBRYQ,Q1)) G ST:Q1=""
|
---|
7 | I $P(^LBRY(682,LBRYQ,0),U,4)'=LBRYPTR G ST1
|
---|
8 | G ST1:'$D(^LBRY(682,LBRYQ,4,Q1,0))
|
---|
9 | S LBRYDAT=^LBRY(682,LBRYQ,4,Q1,0)
|
---|
10 | D:$P(LBRYDAT,U)="ToC" TOC D:$P(LBRYDAT,U)'="ToC" COPY
|
---|
11 | D A2
|
---|
12 | G ST1
|
---|
13 | TOC S PTR=$P(LBRYDAT,U,3),PTRLST=0
|
---|
14 | TC S PTRLST=$O(^LBRY(681,PTR,2,"AC",PTRLST)) Q:PTRLST=""
|
---|
15 | S PTRL2=$O(^LBRY(681,PTR,2,"AC",PTRLST,0)) D HEADER,NAME,TRLR,PAUSE
|
---|
16 | G TC
|
---|
17 | HEADER W @IOF,!!!!!!!!!!,?5,"Veterans Administration ROUTING SLIP"
|
---|
18 | W !!,?10,"ROUTE TO:",!
|
---|
19 | Q
|
---|
20 | TRLR W !,?5 F K=1:1:40 W $C(42)
|
---|
21 | S TTN=$P(^LBRY(681,PTR,0),U,2),TTT=$P(^LBRY(680,TTN,0),U)
|
---|
22 | S TITLE=$E($P(^LBRY(680.5,TTT,0),U),1,39)
|
---|
23 | W !,?5,TITLE
|
---|
24 | S VID=^LBRY(682,LBRYQ,1),V=$P(VID,U,2),ISSUE=$P(VID,U,3),Y=$P(VID,U) X ^DD("DD")
|
---|
25 | S ISSUE=$S(ISSUE]"":"("_ISSUE_")",1:"") S:V]"" ISSUE=V_ISSUE
|
---|
26 | W !,?5,Y,?32,ISSUE
|
---|
27 | S NUMB=$P(LBRYDAT,U) W:NUMB="ToC" !,?5,"TABLE of CONTENTS ROUTING SLIP"
|
---|
28 | W:NUMB=+NUMB !,?5,"COPY ",NUMB," ROUTING SLIP"
|
---|
29 | S LBRRSM=$P($G(^LBRY(680.6,LBRYPTR,0)),U,8) S:LBRRSM="" LBRRSM="142D"
|
---|
30 | W !!!!!,?5,"FROM LIBRARY, "_LBRRSM,?35 S Y=LBRYD X ^DD("DD") W Y,!
|
---|
31 | Q
|
---|
32 | NAME S NMPTR=$P(^LBRY(681,PTR,2,PTRL2,0),U)
|
---|
33 | S NMSVC=$S(NMPTR'="":$G(^LBRY(680.4,NMPTR,0)),1:"")
|
---|
34 | S NAME=$P(NMSVC,U),SVC=$P(NMSVC,U,2)
|
---|
35 | S MS="" I SVC]"" S SVC=$G(^DIC(49,SVC,0)),MS=$P(SVC,U,8),SVC=$P(SVC,U)
|
---|
36 | W !,?5 W:MS]"" MS W ?18,NAME W:SVC]"" "/",SVC W !
|
---|
37 | Q
|
---|
38 | A2 K ^LBRY(682,"A2",LBRYQ,Q1)
|
---|
39 | S ^LBRY(682,"A3",LBRYDT,LBRYQ,Q1)="",$P(^LBRY(682,LBRYQ,4,Q1,0),U,6)=LBRYDT
|
---|
40 | Q
|
---|
41 | COPY S PTR=$P(LBRYDAT,U,3),PTRLST=0 D HEADER
|
---|
42 | CP S PTRLST=$O(^LBRY(681,PTR,2,"AC",PTRLST)) G:PTRLST="" COPY1
|
---|
43 | S PTRL2=$O(^LBRY(681,PTR,2,"AC",PTRLST,0)) D NAME
|
---|
44 | G CP
|
---|
45 | COPY1 D TRLR,PAUSE Q
|
---|
46 | PAUSE Q:IO'=IO(0)!($D(ZTSK)) S XZ="Continue//" D PAUSE^LBRYCK0 Q
|
---|
47 | EXIT D ^%ZISC K:$D(ZTSK) ^%ZTSK(ZTSK),ZTSK
|
---|
48 | K IOP,LBRYQ,Q1,LBRYDAT,LBRYRET,PTR,PTRL2,PTRLST,VID,V,ISSUE,Y,VI,NMPTR
|
---|
49 | K NMSVC,NAME,SVC,MS,TTT,TTN,TITLE,LBRRSM
|
---|
50 | Q
|
---|