XMP2 ;(WASH ISC)/GM/CAP-PackMan Print/Install/Summarize/Compare ;04/17/2002 11:07
;;8.0;MailMan;;Jun 28, 2002
; Entry points used by MailMan options (not covered by DBIA):
; XC XMPCOM - Compare message
; XI XMPINS - Install message
; XP XMPPRT - Print message
; XS XMPSUM - Summarize message
;;XMP2 IS INSTALLED AS XMP2Z TO AVOID CLOBBER ERRORS / FILE AS XMP2
Q
;
LIST ;LIST MESSAGE
S XCN=.999 F M=1:1 D NT Q:+XCN'=XCN W !,X
Q
;
;
PP ;PRETTY PRINT
S:'$D(XCN) XCN=.999 S XCN=+XCN K XMOUT
F I=1:1 D NT Q:XCN'=+XCN Q:$E(X)="$" D @($P("P1,G1,G2,K1",",",%1)) Q:$D(XMOUT)
Q
;
P1 Q:X?1"KEY ;;;".E
I XMP2="T" W !,$P(X," ",1)_" " S X=$P(X," ",2,99)
E W !,$P(X," ",1)," ",?8 S X=$P(X," ",2,999)
P2 I $Y+5>IOSL K DIR S DIR(0)="E" D:'$D(ZTQUEUED) ^DIR:$E(IOST)="C"&$S('$D(XMP):1,'XMP:1,1:0) K DIR,DIRUT W @IOF I $D(DTOUT)!$D(DUOUT) S XMOUT=1 Q
I $G(XMP2(0))=1 W "=" K XMP2(0)
I $X+$L(X)+1<IOM!(IOM<22) W X Q
F J=(IOM-$X-1):-1:20 Q:"),@_:"[$E(X,J) Q:J<20 I $E(X,J)?1P Q:$E(X,J-2)'=" "
W $E(X,1,J),!,?10 S X=$E(X,J+1,999)
G P2
;
XT S XMP2="T" G 1
;
XP S XMP2="P"
1 I $D(XMLOAD) W $C(7),!,"YOU CAN NOT PRINT a message while you are creating it." Q
S XCF=1 D MM,SP G SC
;
XR S XMP2="R" G 0
;
XI S XMP2="I"
0 D MM S XCF=2 G ENH^XMP2A
;
ENI D ^XMP3 G Q:X=U D S G Q:XMP2'="I"
I $D(XMINIT),$P(XMR,U,7)="X" D @XMINIT
I $D(XMINTEG) D @XMINTEG
Q K XMA0,XMB0,XMP2,XMPASS,XMPKIDS,XMINIT,XMINTEG Q
;
XC S XCF=3,XMP2="C" D MM,SP G SC ; Compare Message (DOPT 9)
;
XS S XCF=0,XMP2="S" D MM,SP G SC
;
SP G DEV^XMPH ; Output where? Queued by default. AND !!! Runs @XMP2 opt.
;
SC K XMP2 Q
;
;
; From DEV+2^XMPH and ZTASK+4^XMPH only for EVERYTHING!!!! XMP2=What
S S XCN=.999 G ENTR^XMP2A:XMP2="R",ENTT^XMP2A:XMP2="T" I '$D(XMR) S XMR=^XMB(3.9,XMZ,0)
F I=1:1 D NT Q:+XCN'=XCN D:$E(X)="$" S1:X'["$TXT" Q:+XCN'=XCN I $D(XMOUT) K XMOUT Q
Q
;
S1 Q:$E(X,1,5)="$END "!($E(X,1,5)'?1"$"3U1" ")
I XMP2="I",$P(XMR,U,7)["X",$E(X,1,9)'="$END ROU ",$E(X,1,5)'="$ROU " S XMOUT=1 Q
S T=$E(X,2,4),A=$T(@T) I A="" W $C(7),"Unknown identifier '",A,"'" K A Q
W:XCF=1 @IOF W !,"Line ",XCN,?10,"Message #"_XMZ,?29 W:XCF $P(",Unloading,Comparing,Verifying",",",XCF) W " ",$P(A,";;",2)," ",$E(X,5,999)
I XCF=0 D:$E(A,1,3)="KID" K2 Q
S A=$P($T(@T+XCF),";;",2,999) I A=";" W !,"Not implemented yet" Q
I $E(X,1,4)="$ROU",'$D(XMINIT),XMP2="I" S %=$P(X," ",2) S:%?.1"^".AN1"INIT" XMINIT="^"_% I %?.1"^".AN1"NTEG" S XMINTEG="^"_%
X A K A Q
;
NT S XCN=$O(^XMB(3.9,XMZ,2,XCN)) Q:+XCN'=XCN S X=^(XCN,0) D:$E(X)="$" CHECK^XMPSEC Q
;
MM S (DIE,DIF)="^XMB(3.9,XMZ,2," Q
;
G1 W !,X D NT Q:+XCN'=XCN G P2
;
G2 W !,X D NT Q:+XCN'=XCN S XMP2(0)=1 G P2
;
K1 ;print KIDS Distribution routines
F S XCN=$O(^XMB(3.9,XMZ,2,XCN)) Q:+XCN'=XCN S X=^(XCN,0) Q:$E(X)="$" D:X?1"""RTN"","""1.8AN1""")"
.S XCN=XCN+1,X1=$E(X,1,$L(X)-1) W !,"Routine ",$TR($P(X1,",",2),"""")
.F S XCN=$O(^XMB(3.9,XMZ,2,XCN)) Q:+XCN'=XCN S X=^(XCN,0) Q:$P(X,",",1,2)'=X1 S XCN=$O(^XMB(3.9,XMZ,2,XCN)),X=^(XCN,0) D P1 Q:$D(XMOUT)
.S:XCN=+XCN XCN=XCN-1
S XMOUT=1 Q
;
K2 ;print summary of KIDS Distribution
Q:$T(XMP2^XPDDP)="" K ^TMP($J,"BLD"),M
F S XCN=$O(^XMB(3.9,XMZ,2,XCN)) Q:+XCN'=XCN S X=^(XCN,0) Q:$E(X)="$" I X?1"""BLD"","1.N1",0)" S XCN=$O(^XMB(3.9,XMZ,2,XCN)),M=^(XCN,0) Q
Q:'$D(M) S @("^TMP("_$J_","_X)=M,X1=$P(X,",",1,2)
F S XCN=$O(^XMB(3.9,XMZ,2,XCN)) Q:+XCN'=XCN S X=^(XCN,0) Q:$P(X,",",1,2)'=X1 S XCN=$O(^XMB(3.9,XMZ,2,XCN)),M=^(XCN,0),@("^TMP("_$J_","_X)=M
D XMP2^XPDDP("TMP("_$J_","_X1_")",$P(X1,",",2))
S XMOUT=1 Q
;
SAVE D NT Q:"$END "_T=$P(X," ",1,2) S X1=X D NT Q:"$END "_T=$P(X," ",1,2)
;I $A(X)=126 S %=X D NT S X=%_$E(X,2,999) ; Set by ^DIFROM1, but DIFROM is no longer used.
S @X1=$E(X,2-$G(XMP2(0)),999)
G SAVE
;
BEG S %=0,ROU=$E(X,6,99),^TMP("XMS",$J,ROU,0,1)="""" F %0=1:1 D NT Q:$E(X)="$" S ^TMP("XMS",$J,ROU,0,%0)=X,%=%+$L(X)
S ^TMP("XMS",$J,ROU,0)=%,%0=%0-1 Q
;
COMP D NT Q:$E(X)="$"
S X1=X D NT Q:$E(X)="$"
;
;Globals
;I $A(X)=126 S %=$E(X,2,999) D NT S X=%_$E(X,2,999) ; Set by ^DIFROM1, but DIFROM is no longer used.
I '$D(@X1) W !,"Node '",X1,"' not on disk." G COMP
S Y=@X1,B=$E(X,2-$G(XMP2(0)),999)
G COMP:Y=B
W !,"Node: ",X1,!,"Disk: ",Y
W !,"Message: ",$E(X,2-$G(XMP2(0)),99)
S X=$E(X,2,999) F J=1:1:$L(X) Q:$E(X,J)'=$E(Y,J)
W !,?12+J,"^"
G COMP
;
;TAG ;;Description of type of PackMan Data
; ;;Executable Print Code
; ;;Executable Installation code
; ;;Executable Comparison to Installed
; ;;Executable Verification code
;
ROU ;;Routine
;;S %1=1 D PP
;;S X=$P(X," ",2) S:X="XMP2" X="XMP2Z" S DIE="^XMB(3.9,XMZ,2," X ^%ZOSF("SAVE") W:X="XMP2Z" !,$C(7),"CHANGE NAME OF ROUTINE XMP2Z TO XMP2"
;;D LOAD^XMPC
;;G BEG
DDD ;;Data Dictionary
;;S %1=2 D PP
;;D SAVE
;;D COMP
;;
OPT ;;Options
;;S %1=2 D PP
;;D SAVE
;;Q
;;
HEL ;;Help Frames
;;S %1=2 D PP
;;D SAVE
;;Q
;;
BUL ;;Bulletins
;;S %1=2 D PP
;;D SAVE
;;Q
;;
KEY ;;Security keys
;;S %1=2 D PP
;;D SAVE
;;Q
;;
FUN ;;Functions
;;S %1=2 D PP
;;D SAVE
;;Q
;;
PKG ;;Package File
;;S %1=2 D PP
;;D SAVE
;;Q
;;
RTN ;;Routine Documentation
;;S %1=2 D PP
;;D SAVE
;;Q
;;
DIE ;;Input Templates
;;S %1=2 D PP
;;D SAVE
;;Q
;;
DIP ;;Print Templates
;;S %1=2 D PP
;;D SAVE
;;Q
;;
DIB ;;Sort Templates
;;S %1=2 D PP
;;D SAVE
;;Q
;;
GLB ;;Global
;;S %1=2 D PP
;;D SAVE
;;D COMP
;;
DTA ;;FileMan Data
;;S %1=1 D PP
;;D SAVE
;;Q
;;
TXT ;;Text
;;Q
;;Q
;;Q
;;Q
GLO ;;Global
;;S %1=3 D PP
;;S XMP2(0)=1 D SAVE K XMP2(0)
;;S XMP2(0)=1 D COMP K XMP2(0)
;;Q
KID ;;KIDS Distribution
;;S %1=4 D PP
;;I $T(XMP2^XPDIPM)]"" D XMP2^XPDIPM
;;;
;;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMP2 5827 printed Apr 09, 2024@21:12:42 Page 2
XMP2 ;(WASH ISC)/GM/CAP-PackMan Print/Install/Summarize/Compare ;04/17/2002 11:07
+1 ;;8.0;MailMan;;Jun 28, 2002
+2 ; Entry points used by MailMan options (not covered by DBIA):
+3 ; XC XMPCOM - Compare message
+4 ; XI XMPINS - Install message
+5 ; XP XMPPRT - Print message
+6 ; XS XMPSUM - Summarize message
+7 ;;XMP2 IS INSTALLED AS XMP2Z TO AVOID CLOBBER ERRORS / FILE AS XMP2
+8 QUIT
+9 ;
LIST ;LIST MESSAGE
+1 SET XCN=.999
FOR M=1:1
DO NT
if +XCN'=XCN
QUIT
WRITE !,X
+2 QUIT
+3 ;
+4 ;
PP ;PRETTY PRINT
+1 if '$DATA(XCN)
SET XCN=.999
SET XCN=+XCN
KILL XMOUT
+2 FOR I=1:1
DO NT
if XCN'=+XCN
QUIT
if $EXTRACT(X)="$"
QUIT
DO @($PIECE("P1,G1,G2,K1",",",%1))
if $DATA(XMOUT)
QUIT
+3 QUIT
+4 ;
P1 if X?1"KEY ;;;".E
QUIT
+1 IF XMP2="T"
WRITE !,$PIECE(X," ",1)_" "
SET X=$PIECE(X," ",2,99)
+2 IF '$TEST
WRITE !,$PIECE(X," ",1)," ",?8
SET X=$PIECE(X," ",2,999)
P2 IF $Y+5>IOSL
KILL DIR
SET DIR(0)="E"
if '$DATA(ZTQUEUED)
if $EXTRACT(IOST)="C"&$SELECT('$DATA(XMP):1,'XMP:1,1:0)
DO ^DIR
KILL DIR,DIRUT
WRITE @IOF
IF $DATA(DTOUT)!$DATA(DUOUT)
SET XMOUT=1
QUIT
+1 IF $GET(XMP2(0))=1
WRITE "="
KILL XMP2(0)
+2 IF $X+$LENGTH(X)+1<IOM!(IOM<22)
WRITE X
QUIT
+3 FOR J=(IOM-$X-1):-1:20
if "),@_
QUIT
if J<20
QUIT
IF $EXTRACT(X,J)?1P
if $EXTRACT(X,J-2)'=" "
QUIT
+4 WRITE $EXTRACT(X,1,J),!,?10
SET X=$EXTRACT(X,J+1,999)
+5 GOTO P2
+6 ;
XT SET XMP2="T"
GOTO 1
+1 ;
XP SET XMP2="P"
1 IF $DATA(XMLOAD)
WRITE $CHAR(7),!,"YOU CAN NOT PRINT a message while you are creating it."
QUIT
+1 SET XCF=1
DO MM
DO SP
GOTO SC
+2 ;
XR SET XMP2="R"
GOTO 0
+1 ;
XI SET XMP2="I"
0 DO MM
SET XCF=2
GOTO ENH^XMP2A
+1 ;
ENI DO ^XMP3
if X=U
GOTO Q
DO S
if XMP2'="I"
GOTO Q
+1 IF $DATA(XMINIT)
IF $PIECE(XMR,U,7)="X"
DO @XMINIT
+2 IF $DATA(XMINTEG)
DO @XMINTEG
Q KILL XMA0,XMB0,XMP2,XMPASS,XMPKIDS,XMINIT,XMINTEG
QUIT
+1 ;
XC ; Compare Message (DOPT 9)
SET XCF=3
SET XMP2="C"
DO MM
DO SP
GOTO SC
+1 ;
XS SET XCF=0
SET XMP2="S"
DO MM
DO SP
GOTO SC
+1 ;
SP ; Output where? Queued by default. AND !!! Runs @XMP2 opt.
GOTO DEV^XMPH
+1 ;
SC KILL XMP2
QUIT
+1 ;
+2 ;
+3 ; From DEV+2^XMPH and ZTASK+4^XMPH only for EVERYTHING!!!! XMP2=What
S SET XCN=.999
if XMP2="R"
GOTO ENTR^XMP2A
if XMP2="T"
GOTO ENTT^XMP2A
IF '$DATA(XMR)
SET XMR=^XMB(3.9,XMZ,0)
+1 FOR I=1:1
DO NT
if +XCN'=XCN
QUIT
if $EXTRACT(X)="$"
if X'["$TXT"
DO S1
if +XCN'=XCN
QUIT
IF $DATA(XMOUT)
KILL XMOUT
QUIT
+2 QUIT
+3 ;
S1 if $EXTRACT(X,1,5)="$END "!($EXTRACT(X,1,5)'?1"$"3U1" ")
QUIT
+1 IF XMP2="I"
IF $PIECE(XMR,U,7)["X"
IF $EXTRACT(X,1,9)'="$END ROU "
IF $EXTRACT(X,1,5)'="$ROU "
SET XMOUT=1
QUIT
+2 SET T=$EXTRACT(X,2,4)
SET A=$TEXT(@T)
IF A=""
WRITE $CHAR(7),"Unknown identifier '",A,"'"
KILL A
QUIT
+3 if XCF=1
WRITE @IOF
WRITE !,"Line ",XCN,?10,"Message #"_XMZ,?29
if XCF
WRITE $PIECE(",Unloading,Comparing,Verifying",",",XCF)
WRITE " ",$PIECE(A,";;",2)," ",$EXTRACT(X,5,999)
+4 IF XCF=0
if $EXTRACT(A,1,3)="KID"
DO K2
QUIT
+5 SET A=$PIECE($TEXT(@T+XCF),";;",2,999)
IF A=";"
WRITE !,"Not implemented yet"
QUIT
+6 IF $EXTRACT(X,1,4)="$ROU"
IF '$DATA(XMINIT)
IF XMP2="I"
SET %=$PIECE(X," ",2)
if %?.1"^".AN1"INIT"
SET XMINIT="^"_%
IF %?.1"^".AN1"NTEG"
SET XMINTEG="^"_%
+7 XECUTE A
KILL A
QUIT
+8 ;
NT SET XCN=$ORDER(^XMB(3.9,XMZ,2,XCN))
if +XCN'=XCN
QUIT
SET X=^(XCN,0)
if $EXTRACT(X)="$"
DO CHECK^XMPSEC
QUIT
+1 ;
MM SET (DIE,DIF)="^XMB(3.9,XMZ,2,"
QUIT
+1 ;
G1 WRITE !,X
DO NT
if +XCN'=XCN
QUIT
GOTO P2
+1 ;
G2 WRITE !,X
DO NT
if +XCN'=XCN
QUIT
SET XMP2(0)=1
GOTO P2
+1 ;
K1 ;print KIDS Distribution routines
+1 FOR
SET XCN=$ORDER(^XMB(3.9,XMZ,2,XCN))
if +XCN'=XCN
QUIT
SET X=^(XCN,0)
if $EXTRACT(X)="$"
QUIT
if X?1"""RTN"","""1.8AN1""")"
Begin DoDot:1
+2 SET XCN=XCN+1
SET X1=$EXTRACT(X,1,$LENGTH(X)-1)
WRITE !,"Routine ",$TRANSLATE($PIECE(X1,",",2),"""")
+3 FOR
SET XCN=$ORDER(^XMB(3.9,XMZ,2,XCN))
if +XCN'=XCN
QUIT
SET X=^(XCN,0)
if $PIECE(X,",",1,2)'=X1
QUIT
SET XCN=$ORDER(^XMB(3.9,XMZ,2,XCN))
SET X=^(XCN,0)
DO P1
if $DATA(XMOUT)
QUIT
+4 if XCN=+XCN
SET XCN=XCN-1
End DoDot:1
+5 SET XMOUT=1
QUIT
+6 ;
K2 ;print summary of KIDS Distribution
+1 if $TEXT(XMP2^XPDDP)=""
QUIT
KILL ^TMP($JOB,"BLD"),M
+2 FOR
SET XCN=$ORDER(^XMB(3.9,XMZ,2,XCN))
if +XCN'=XCN
QUIT
SET X=^(XCN,0)
if $EXTRACT(X)="$"
QUIT
IF X?1"""BLD"","1.N1",0)"
SET XCN=$ORDER(^XMB(3.9,XMZ,2,XCN))
SET M=^(XCN,0)
QUIT
+3 if '$DATA(M)
QUIT
SET @("^TMP("_$JOB_","_X)=M
SET X1=$PIECE(X,",",1,2)
+4 FOR
SET XCN=$ORDER(^XMB(3.9,XMZ,2,XCN))
if +XCN'=XCN
QUIT
SET X=^(XCN,0)
if $PIECE(X,",",1,2)'=X1
QUIT
SET XCN=$ORDER(^XMB(3.9,XMZ,2,XCN))
SET M=^(XCN,0)
SET @("^TMP("_$JOB_","_X)=M
+5 DO XMP2^XPDDP("TMP("_$JOB_","_X1_")",$PIECE(X1,",",2))
+6 SET XMOUT=1
QUIT
+7 ;
SAVE DO NT
if "$END "_T=$PIECE(X," ",1,2)
QUIT
SET X1=X
DO NT
if "$END "_T=$PIECE(X," ",1,2)
QUIT
+1 ;I $A(X)=126 S %=X D NT S X=%_$E(X,2,999) ; Set by ^DIFROM1, but DIFROM is no longer used.
+2 SET @X1=$EXTRACT(X,2-$GET(XMP2(0)),999)
+3 GOTO SAVE
+4 ;
BEG SET %=0
SET ROU=$EXTRACT(X,6,99)
SET ^TMP("XMS",$JOB,ROU,0,1)=""""
FOR %0=1:1
DO NT
if $EXTRACT(X)="$"
QUIT
SET ^TMP("XMS",$JOB,ROU,0,%0)=X
SET %=%+$LENGTH(X)
+1 SET ^TMP("XMS",$JOB,ROU,0)=%
SET %0=%0-1
QUIT
+2 ;
COMP DO NT
if $EXTRACT(X)="$"
QUIT
+1 SET X1=X
DO NT
if $EXTRACT(X)="$"
QUIT
+2 ;
+3 ;Globals
+4 ;I $A(X)=126 S %=$E(X,2,999) D NT S X=%_$E(X,2,999) ; Set by ^DIFROM1, but DIFROM is no longer used.
+5 IF '$DATA(@X1)
WRITE !,"Node '",X1,"' not on disk."
GOTO COMP
+6 SET Y=@X1
SET B=$EXTRACT(X,2-$GET(XMP2(0)),999)
+7 if Y=B
GOTO COMP
+8 WRITE !,"Node: ",X1,!,"Disk: ",Y
+9 WRITE !,"Message: ",$EXTRACT(X,2-$GET(XMP2(0)),99)
+10 SET X=$EXTRACT(X,2,999)
FOR J=1:1:$LENGTH(X)
if $EXTRACT(X,J)'=$EXTRACT(Y,J)
QUIT
+11 WRITE !,?12+J,"^"
+12 GOTO COMP
+13 ;
+14 ;TAG ;;Description of type of PackMan Data
+15 ; ;;Executable Print Code
+16 ; ;;Executable Installation code
+17 ; ;;Executable Comparison to Installed
+18 ; ;;Executable Verification code
+19 ;
ROU ;;Routine
+1 ;;S %1=1 D PP
+2 ;;S X=$P(X," ",2) S:X="XMP2" X="XMP2Z" S DIE="^XMB(3.9,XMZ,2," X ^%ZOSF("SAVE") W:X="XMP2Z" !,$C(7),"CHANGE NAME OF ROUTINE XMP2Z TO XMP2"
+3 ;;D LOAD^XMPC
+4 ;;G BEG
DDD ;;Data Dictionary
+1 ;;S %1=2 D PP
+2 ;;D SAVE
+3 ;;D COMP
+4 ;;
OPT ;;Options
+1 ;;S %1=2 D PP
+2 ;;D SAVE
+3 ;;Q
+4 ;;
HEL ;;Help Frames
+1 ;;S %1=2 D PP
+2 ;;D SAVE
+3 ;;Q
+4 ;;
BUL ;;Bulletins
+1 ;;S %1=2 D PP
+2 ;;D SAVE
+3 ;;Q
+4 ;;
KEY ;;Security keys
+1 ;;S %1=2 D PP
+2 ;;D SAVE
+3 ;;Q
+4 ;;
FUN ;;Functions
+1 ;;S %1=2 D PP
+2 ;;D SAVE
+3 ;;Q
+4 ;;
PKG ;;Package File
+1 ;;S %1=2 D PP
+2 ;;D SAVE
+3 ;;Q
+4 ;;
RTN ;;Routine Documentation
+1 ;;S %1=2 D PP
+2 ;;D SAVE
+3 ;;Q
+4 ;;
DIE ;;Input Templates
+1 ;;S %1=2 D PP
+2 ;;D SAVE
+3 ;;Q
+4 ;;
DIP ;;Print Templates
+1 ;;S %1=2 D PP
+2 ;;D SAVE
+3 ;;Q
+4 ;;
DIB ;;Sort Templates
+1 ;;S %1=2 D PP
+2 ;;D SAVE
+3 ;;Q
+4 ;;
GLB ;;Global
+1 ;;S %1=2 D PP
+2 ;;D SAVE
+3 ;;D COMP
+4 ;;
DTA ;;FileMan Data
+1 ;;S %1=1 D PP
+2 ;;D SAVE
+3 ;;Q
+4 ;;
TXT ;;Text
+1 ;;Q
+2 ;;Q
+3 ;;Q
+4 ;;Q
GLO ;;Global
+1 ;;S %1=3 D PP
+2 ;;S XMP2(0)=1 D SAVE K XMP2(0)
+3 ;;S XMP2(0)=1 D COMP K XMP2(0)
+4 ;;Q
KID ;;KIDS Distribution
+1 ;;S %1=4 D PP
+2 ;;I $T(XMP2^XPDIPM)]"" D XMP2^XPDIPM
+3 ;;;
+4 ;;;
