source: WorldVistAEHR/trunk/r/MAILMAN-XM/XMPG.m@ 1261

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

initial load of WorldVistAEHR

File size: 3.1 KB
Line 
1XMPG ;(WASH ISC)/THM/CAP-PackMan Global List/Load ;10/07/2003 12:16
2 ;;8.0;MailMan;**23**;Jun 28, 2002
3 ; Entry point (DBIA 10071):
4 ; ENT Load and send a packman message with globals
5 ;
6 ; Entry points used by MailMan options (not covered by DBIA):
7 ; LOAD XMPGLO - Load global
8 ;
9 ; If you D ^XMPG, you are asked for a global, and it is printed
10 ; to whichever device you choose.
11 S %1="W !,D,""="",@D",%2="W !,%G_I_"")="",%T"
12 D ^%ZIS G K:POP
13 D R
14 I IO(0)'=IO U IO D ^%ZISC
15 D HOME^%ZIS
16 Q
17R D N G R:K G K:%G="" U IO D EN G R
18EN K I,R G K:%G="" S %0=0,Q=$C(34),R=1 D GP
19 S D=$P(%G,"(",1) I @("$D("_D_")#2"),$L(@D) X %1
20 D S Q
21S S I=Q_Q
22DISK S @("I=$O("_%G_I_"))") Q:I="" S D=$D(^(I)),%0=%0+1 S:D#2 %T=^(I)
23 F J=1:1:$L(I) S J=$F(I,Q,J) Q:J=0 S I=$E(I,1,J-1)_Q_$E(I,J,999)
24 I I'?1.N&(I'?.N1"."1.N)!(I?1"0".1"."1.N)!(I?.N1".".N1."0") S I=""""_I_""""
25 X:D#2 %2 I D>9 D PUSH S %G=%G_I_"," D S,POP
26 G DISK
27PUSH S R=R+1,I(R)=I,R(R)=%G Q
28POP S I=I(R),%G=R(R),R=R-1 Q
29K K %,%0,%1,%2,%D,%G,%GQ,%T,D,I,K,POP,Q,R
30 Q
31 ;
32LOAD ;LOAD GLOBAL INTO MESSAGE DEFINED IN <DIE>
33 S (DIE,DIF)="^XMB(3.9,XMZ,2," S:'$D(XCNP) XCNP=0 D %
34L1 D N G L1:K I %G="" S @(DIE_"0)")="^^"_XCNP_U_XCNP G K
35 W " Loading..." D MOVE G L1
36SET S XCNP=XCNP+1,@(DIE_XCNP_",0)")=%D Q
37GP S R=1,%G=$E("^",$E(%G)'="^")_%G
38 I ",("'[$E(%G,$L(%G)) S %G=%G_$E("(,",%G["("+1)
39 Q
40N ;GET NAME OF GLOBAL
41 U IO(0) S K=0 R !,"Global: ",%G:DTIME S I=$E(%G) Q:I=""
42 I I="^",I=%G S %G="" Q
43 I I'?1A,I'="%" G N1
44 I I'?1A,I'="%" S %G="",K=1 W !,"MUST BEGIN WITH % OR LETTER" Q
45 I I="^" S %G=$E(%G,2,99)
46 I $P(%G,"(")'?0.1"%".AN D N1 Q
47 I $E(%G,$L(%G))=")" S %G="",K=1 W !,"DO NOT END GLOBAL REFERENCE WITH ')'" Q
48 S I=$P(%G,"(",2,99) F J=1:1 Q:$P(I,",",J,99)="" I $P(I,",",J)="" S K=1 W $C(7),!,"EACH SUBSCRIPT MUST HAVE A VALUE" Q
49 F J=1:1 S I=$P($P(%G,"(",2),",",J) Q:I="" I +I'=I S I=$S($E(I)'=$C(34):1,$E(I,$L(I))'=$C(34):2,$L(I,$C(34))-1#2:3,1:0) I I S K=1 W $C(7),!,"Invalid entry ! Please enter the EXACT values of the subscripts." Q
50 Q
51N1 S %G="",K=1 W !,"GLOBAL NAME MUST BEGIN WITH '%' OR LETTER" Q
52 ;
53ENT ;LOAD UP GLOBAL ENTRY POINT FROM OUTSIDE ROUTINES
54 ; Input:
55 ; DUZ Sender's DUZ
56 ; XMSUB Message subject
57 ; XMY Recipient array
58 ; XMTEXT String of open global roots separated by semicolon
59 ; Output:
60 ; XMZ Message number
61 ; XMMG Error message, if error
62 ; Kills:
63 ; XMY
64 N XMV,XMDF,XMINSTR,XMPIECE
65 K XMERR,^TMP("XMERR",$J),XMMG
66 S XMDF=1
67 S XMINSTR("ADDR FLAGS")="R"
68 D INIT^XMVVITAE
69 I $D(XMV("ERROR")) D Q
70 . S XMMG=@$Q(XMV("ERROR"))
71 D CRE8XMZ^XMXSEND(XMSUB,.XMZ)
72 I $D(XMERR) D Q
73 . S XMMG=^TMP("XMERR",$J,1,"TEXT",1)
74 . K XMERR,^TMP("XMERR",$J)
75 D NEW^XMP
76 D %
77 S (DIE,DIF)="^XMB(3.9,XMZ,2,"
78 F XMPIECE=1:1:$L(XMTEXT,";") D
79 . S %G=$P(XMTEXT,";",XMPIECE)
80 . Q:%G=""
81 . D MOVE
82 K XCNP
83 D K
84 Q:'$O(^XMB(3.9,XMZ,2,1))
85 D ADDRNSND^XMXSEND(XMDUZ,XMZ,.XMY,.XMINSTR)
86 K:$D(XMERR) XMERR,^TMP("XMERR",$J)
87 K XMY
88 Q
89MOVE ;MOVE GLOBAL INTO MESSAGE
90 S %D="$GLO "_%G D SET
91 D EN S %D="$END GLO "_%G D SET
92 S $P(@(DIE_"0)"),U,3,4)=XCNP_U_XCNP
93 Q
94% ;SET UP EXECUTABLE STRINGS
95 S %1="S %D=D D SET S %D=@D D SET"
96 S %2="S %D=%G_I_"")"" D SET S %D=%T D SET W:'(%0#25)&'$D(ZTQUEUED) ""."""
97 Q
Note: See TracBrowser for help on using the repository browser.