XMPG ;(WASH ISC)/THM/CAP-PackMan Global List/Load ;10/07/2003 12:16
;;8.0;MailMan;**23**;Jun 28, 2002
; Entry point (DBIA 10071):
; ENT Load and send a packman message with globals
;
; Entry points used by MailMan options (not covered by DBIA):
; LOAD XMPGLO - Load global
;
; If you D ^XMPG, you are asked for a global, and it is printed
; to whichever device you choose.
S %1="W !,D,""="",@D",%2="W !,%G_I_"")="",%T"
D ^%ZIS G K:POP
D R
I IO(0)'=IO U IO D ^%ZISC
D HOME^%ZIS
Q
R D N G R:K G K:%G="" U IO D EN G R
EN K I,R G K:%G="" S %0=0,Q=$C(34),R=1 D GP
S D=$P(%G,"(",1) I @("$D("_D_")#2"),$L(@D) X %1
D S Q
S S I=Q_Q
DISK S @("I=$O("_%G_I_"))") Q:I="" S D=$D(^(I)),%0=%0+1 S:D#2 %T=^(I)
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)
I I'?1.N&(I'?.N1"."1.N)!(I?1"0".1"."1.N)!(I?.N1".".N1."0") S I=""""_I_""""
X:D#2 %2 I D>9 D PUSH S %G=%G_I_"," D S,POP
G DISK
PUSH S R=R+1,I(R)=I,R(R)=%G Q
POP S I=I(R),%G=R(R),R=R-1 Q
K K %,%0,%1,%2,%D,%G,%GQ,%T,D,I,K,POP,Q,R
Q
;
LOAD ;LOAD GLOBAL INTO MESSAGE DEFINED IN <DIE>
S (DIE,DIF)="^XMB(3.9,XMZ,2," S:'$D(XCNP) XCNP=0 D %
L1 D N G L1:K I %G="" S @(DIE_"0)")="^^"_XCNP_U_XCNP G K
W " Loading..." D MOVE G L1
SET S XCNP=XCNP+1,@(DIE_XCNP_",0)")=%D Q
GP S R=1,%G=$E("^",$E(%G)'="^")_%G
I ",("'[$E(%G,$L(%G)) S %G=%G_$E("(,",%G["("+1)
Q
N ;GET NAME OF GLOBAL
U IO(0) S K=0 R !,"Global: ",%G:DTIME S I=$E(%G) Q:I=""
I I="^",I=%G S %G="" Q
I I'?1A,I'="%" G N1
I I'?1A,I'="%" S %G="",K=1 W !,"MUST BEGIN WITH % OR LETTER" Q
I I="^" S %G=$E(%G,2,99)
I $P(%G,"(")'?0.1"%".AN D N1 Q
I $E(%G,$L(%G))=")" S %G="",K=1 W !,"DO NOT END GLOBAL REFERENCE WITH ')'" Q
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
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
Q
N1 S %G="",K=1 W !,"GLOBAL NAME MUST BEGIN WITH '%' OR LETTER" Q
;
ENT ;LOAD UP GLOBAL ENTRY POINT FROM OUTSIDE ROUTINES
; Input:
; DUZ Sender's DUZ
; XMSUB Message subject
; XMY Recipient array
; XMTEXT String of open global roots separated by semicolon
; Output:
; XMZ Message number
; XMMG Error message, if error
; Kills:
; XMY
N XMV,XMDF,XMINSTR,XMPIECE
K XMERR,^TMP("XMERR",$J),XMMG
S XMDF=1
S XMINSTR("ADDR FLAGS")="R"
D INIT^XMVVITAE
I $D(XMV("ERROR")) D Q
. S XMMG=@$Q(XMV("ERROR"))
D CRE8XMZ^XMXSEND(XMSUB,.XMZ)
I $D(XMERR) D Q
. S XMMG=^TMP("XMERR",$J,1,"TEXT",1)
. K XMERR,^TMP("XMERR",$J)
D NEW^XMP
D %
S (DIE,DIF)="^XMB(3.9,XMZ,2,"
F XMPIECE=1:1:$L(XMTEXT,";") D
. S %G=$P(XMTEXT,";",XMPIECE)
. Q:%G=""
. D MOVE
K XCNP
D K
Q:'$O(^XMB(3.9,XMZ,2,1))
D ADDRNSND^XMXSEND(XMDUZ,XMZ,.XMY,.XMINSTR)
K:$D(XMERR) XMERR,^TMP("XMERR",$J)
K XMY
Q
MOVE ;MOVE GLOBAL INTO MESSAGE
S %D="$GLO "_%G D SET
D EN S %D="$END GLO "_%G D SET
S $P(@(DIE_"0)"),U,3,4)=XCNP_U_XCNP
Q
% ;SET UP EXECUTABLE STRINGS
S %1="S %D=D D SET S %D=@D D SET"
S %2="S %D=%G_I_"")"" D SET S %D=%T D SET W:'(%0#25)&'$D(ZTQUEUED) ""."""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMPG 3256 printed Oct 16, 2024@18:13:31 Page 2
XMPG ;(WASH ISC)/THM/CAP-PackMan Global List/Load ;10/07/2003 12:16
+1 ;;8.0;MailMan;**23**;Jun 28, 2002
+2 ; Entry point (DBIA 10071):
+3 ; ENT Load and send a packman message with globals
+4 ;
+5 ; Entry points used by MailMan options (not covered by DBIA):
+6 ; LOAD XMPGLO - Load global
+7 ;
+8 ; If you D ^XMPG, you are asked for a global, and it is printed
+9 ; to whichever device you choose.
+10 SET %1="W !,D,""="",@D"
SET %2="W !,%G_I_"")="",%T"
+11 DO ^%ZIS
if POP
GOTO K
+12 DO R
+13 IF IO(0)'=IO
USE IO
DO ^%ZISC
+14 DO HOME^%ZIS
+15 QUIT
R DO N
if K
GOTO R
if %G=""
GOTO K
USE IO
DO EN
GOTO R
EN KILL I,R
if %G=""
GOTO K
SET %0=0
SET Q=$CHAR(34)
SET R=1
DO GP
+1 SET D=$PIECE(%G,"(",1)
IF @("$D("_D_")#2")
IF $LENGTH(@D)
XECUTE %1
+2 DO S
QUIT
S SET I=Q_Q
DISK SET @("I=$O("_%G_I_"))")
if I=""
QUIT
SET D=$DATA(^(I))
SET %0=%0+1
if D#2
SET %T=^(I)
+1 FOR J=1:1:$LENGTH(I)
SET J=$FIND(I,Q,J)
if J=0
QUIT
SET I=$EXTRACT(I,1,J-1)_Q_$EXTRACT(I,J,999)
+2 IF I'?1.N&(I'?.N1"."1.N)!(I?1"0".1"."1.N)!(I?.N1".".N1."0")
SET I=""""_I_""""
+3 if D#2
XECUTE %2
IF D>9
DO PUSH
SET %G=%G_I_","
DO S
DO POP
+4 GOTO DISK
PUSH SET R=R+1
SET I(R)=I
SET R(R)=%G
QUIT
POP SET I=I(R)
SET %G=R(R)
SET R=R-1
QUIT
K KILL %,%0,%1,%2,%D,%G,%GQ,%T,D,I,K,POP,Q,R
+1 QUIT
+2 ;
LOAD ;LOAD GLOBAL INTO MESSAGE DEFINED IN <DIE>
+1 SET (DIE,DIF)="^XMB(3.9,XMZ,2,"
if '$DATA(XCNP)
SET XCNP=0
DO %
L1 DO N
if K
GOTO L1
IF %G=""
SET @(DIE_"0)")="^^"_XCNP_U_XCNP
GOTO K
+1 WRITE " Loading..."
DO MOVE
GOTO L1
SET SET XCNP=XCNP+1
SET @(DIE_XCNP_",0)")=%D
QUIT
GP SET R=1
SET %G=$EXTRACT("^",$EXTRACT(%G)'="^")_%G
+1 IF ",("'[$EXTRACT(%G,$LENGTH(%G))
SET %G=%G_$EXTRACT("(,",%G["("+1)
+2 QUIT
N ;GET NAME OF GLOBAL
+1 USE IO(0)
SET K=0
READ !,"Global: ",%G:DTIME
SET I=$EXTRACT(%G)
if I=""
QUIT
+2 IF I="^"
IF I=%G
SET %G=""
QUIT
+3 IF I'?1A
IF I'="%"
GOTO N1
+4 IF I'?1A
IF I'="%"
SET %G=""
SET K=1
WRITE !,"MUST BEGIN WITH % OR LETTER"
QUIT
+5 IF I="^"
SET %G=$EXTRACT(%G,2,99)
+6 IF $PIECE(%G,"(")'?0.1"%".AN
DO N1
QUIT
+7 IF $EXTRACT(%G,$LENGTH(%G))=")"
SET %G=""
SET K=1
WRITE !,"DO NOT END GLOBAL REFERENCE WITH ')'"
QUIT
+8 SET I=$PIECE(%G,"(",2,99)
FOR J=1:1
if $PIECE(I,",",J,99)=""
QUIT
IF $PIECE(I,",",J)=""
SET K=1
WRITE $CHAR(7),!,"EACH SUBSCRIPT MUST HAVE A VALUE"
QUIT
+9 FOR J=1:1
SET I=$PIECE($PIECE(%G,"(",2),",",J)
if I=""
QUIT
IF +I'=I
SET I=$SELECT($EXTRACT(I)'=$CHAR(34):1,$EXTRACT(I,$LENGTH(I))'=$CHAR(34):2,$LENGTH(I,$CHAR(34))-1#2:3,1:0)
IF I
SET K=1
WRITE $CHAR(7),!,"Invalid entry ! Please enter the EXACT values of the subscripts."
QUIT
+10 QUIT
N1 SET %G=""
SET K=1
WRITE !,"GLOBAL NAME MUST BEGIN WITH '%' OR LETTER"
QUIT
+1 ;
ENT ;LOAD UP GLOBAL ENTRY POINT FROM OUTSIDE ROUTINES
+1 ; Input:
+2 ; DUZ Sender's DUZ
+3 ; XMSUB Message subject
+4 ; XMY Recipient array
+5 ; XMTEXT String of open global roots separated by semicolon
+6 ; Output:
+7 ; XMZ Message number
+8 ; XMMG Error message, if error
+9 ; Kills:
+10 ; XMY
+11 NEW XMV,XMDF,XMINSTR,XMPIECE
+12 KILL XMERR,^TMP("XMERR",$JOB),XMMG
+13 SET XMDF=1
+14 SET XMINSTR("ADDR FLAGS")="R"
+15 DO INIT^XMVVITAE
+16 IF $DATA(XMV("ERROR"))
Begin DoDot:1
+17 SET XMMG=@$QUERY(XMV("ERROR"))
End DoDot:1
QUIT
+18 DO CRE8XMZ^XMXSEND(XMSUB,.XMZ)
+19 IF $DATA(XMERR)
Begin DoDot:1
+20 SET XMMG=^TMP("XMERR",$JOB,1,"TEXT",1)
+21 KILL XMERR,^TMP("XMERR",$JOB)
End DoDot:1
QUIT
+22 DO NEW^XMP
+23 DO %
+24 SET (DIE,DIF)="^XMB(3.9,XMZ,2,"
+25 FOR XMPIECE=1:1:$LENGTH(XMTEXT,";")
Begin DoDot:1
+26 SET %G=$PIECE(XMTEXT,";",XMPIECE)
+27 if %G=""
QUIT
+28 DO MOVE
End DoDot:1
+29 KILL XCNP
+30 DO K
+31 if '$ORDER(^XMB(3.9,XMZ,2,1))
QUIT
+32 DO ADDRNSND^XMXSEND(XMDUZ,XMZ,.XMY,.XMINSTR)
+33 if $DATA(XMERR)
KILL XMERR,^TMP("XMERR",$JOB)
+34 KILL XMY
+35 QUIT
MOVE ;MOVE GLOBAL INTO MESSAGE
+1 SET %D="$GLO "_%G
DO SET
+2 DO EN
SET %D="$END GLO "_%G
DO SET
+3 SET $PIECE(@(DIE_"0)"),U,3,4)=XCNP_U_XCNP
+4 QUIT
% ;SET UP EXECUTABLE STRINGS
+1 SET %1="S %D=D D SET S %D=@D D SET"
+2 SET %2="S %D=%G_I_"")"" D SET S %D=%T D SET W:'(%0#25)&'$D(ZTQUEUED) ""."""
+3 QUIT
