- 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
- 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
