- XMP2A ;(WASH ISC)/GM/CAP-PackMan Install ;12/04/2002 13:47
- ;;8.0;MailMan;**10**;Jun 28, 2002
- ENH I $P(XMR,U,7)]"" D G:$D(XMPKIDS) 2
- .;check if KIDS format
- .I $P(XMR,U,7)["K",$$CHECK1("I $E(XMB0,1,5)=""$KID """) S XMPKIDS=1 Q
- .I $P(XMR,U,7)["X",$$CHECK1("I $E(XMB0,1,11)=""$TXT $KIDS """) S XMPKIDS=1 Q
- ;check if KIDS but Message Type field got lost
- I $P(XMR,U,7)="",$$CHECK1("I $E(XMB0,1,5)=""$KID """) S XMPKIDS=1 G 2
- G 1:$S('$D(DUZ(0)):1,DUZ(0)="@":0,$D(^XUSEC("XUPROGMODE",DUZ)):0,1:1)
- W !!,$C(7),"Warning: Installing this message will cause a permanent update of globals"
- W !,"and routines"_$S($P(XMR,U,7)["X":" and run the INIT",1:"")_"." D Q:'Y
- .N DIR,DIRUT
- .S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you really want to do this"
- .D ^DIR
- 1 D CHECK D:Y<0 G:'Y Q
- .N DIR,DIRUT
- .S DIR(0)="Y",DIR("B")="NO",DIR("A")="This doesn't appear to be an installable message, do you wish to continue"
- .D ^DIR
- 2 S XMPASS=1,XMA0=^XMB(3.9,XMZ,0) I $L(XMB0),$L($P(XMA0,U,10)),$D(^("K")) D ^XMPSEC G 3:$S('$D(DUZ(0)):0,DUZ(0)="@":1,$D(^XUSEC("XUPROGMODE",DUZ)):1,1:0)
- I $P(XMB0," at ",3)["on" S XMPASS=0 D FAIL^XMPSEC
- I $S('$D(DUZ(0)):1,DUZ(0)="@":0,$D(^XUSEC("XUPROGMODE",DUZ)):0,1:1) G Q
- 3 G X:XMP2="R",ENI^XMP2:XMPASS'=0
- W !,"This message may not be installed !!" G Q
- X G Z:'$D(XMP2),Z:XMP2'="R" K DIR
- S DIR("A")="ROUTINE(S)",DIR(0)="FO^2:30",DIR("?")="^D HLP^XMP2A"
- Y D ^DIR K DIRUT G Z:$D(DTOUT)!$D(DUOUT) G:X="" Q:$O(XMP2(""))="",ENI^XMP2
- I X'?1.A.AN.1"*" W $C(7)," ???" G Y
- S XMP2(X)="" G Y
- Z G Q^XMP2
- Q K DIR G Q^XMP2
- ENTT ;LIST/PRINT TEXT ONLY
- N XMI,XMTEXT,XMABORT,XMPAGE
- S XMI=.999999,XMABORT=0,XMPAGE=1
- F S XMI=$O(^XMB(3.9,XMZ,2,XMI)) Q:'XMI S XMTEXT=^(XMI,0) D Q:XMABORT
- . I $E(XMTEXT,1,8)="$END TXT" S XMABORT=1 Q
- . F D Q:$L(XMTEXT)<IOM!XMABORT!(IOM<2) S XMTEXT=$E(XMTEXT,IOM,999)
- . . I $Y+3+($E($G(IOST),1,2)="C-")>IOSL D Q:XMABORT
- . . . I $E($G(IOST),1,2)="C-" W ! D PAGE^XMXUTIL(.XMABORT) Q:XMABORT
- . . . W @IOF Q:$E($G(IOST),1,2)="C-"
- . . . D PAGE2HDR^XMJMP1(XMSUBJ,XMZSTR,.XMPAGE)
- . . E W !
- . . W $S(IOM>1:$E(XMTEXT,1,IOM-1),1:XMTEXT)
- Q
- ENTR ;INSTALL SELECTED ROUTINE(S) [IN XMP2 ARRAY]
- F I=0:0 S XCN=$O(^XMB(3.9,XMZ,2,XCN)) Q:XCN="" S X=^(XCN,0) I $E(X)="$" S Y=$P(X," ",2),J="" F I=0:0 S J=$O(XMP2(J)),K=$L(J)-1 Q:J="" I $S(J=Y:1,J'?.AN1"*":0,$E(J,1,K)=$E(Y,1,K):1,1:0) D S1^XMP2
- Q
- HLP ;Routine selection
- W !!,"Choose routines that you wish to install from this message by entering",!,"single names or a series (XMP2*=all routines that begin with 'XMP2')."
- W !,"The message is not checked to see if there are any matches to your input.",!,"It may be helpful to request a SUMMARY of the message first."
- W !,"Only routines selected for installation are backed up.",!!
- Q
- CHECK ;check text header
- S %="I $E(XMB0,1,5)=""$TXT "",$P(XMB0,""Created ""_$S(XMB0[""BACKUP"":""on "",1:""by ""),2)?1E.E1"" at "".E1"" at "".E",%=$$CHECK1(%)
- S Y=$S(%:%,1:-1)
- Q
- CHECK1(XMCHK) ;Check text header meets condition XMCHK
- ;returns line number of text header or 0, XMB0=text header
- N XMCNT,XMFLAG
- S XMFLAG=0,XMCNT=.999,XMB0=""
- F S XMCNT=$O(^XMB(3.9,XMZ,2,XMCNT)) Q:'XMCNT S XMB0=$G(^(XMCNT,0)) D Q:'XMCNT
- .X XMCHK I S XMFLAG=XMCNT,XMCNT=""
- Q XMFLAG
- XMP2A ;(WASH ISC)/GM/CAP-PackMan Install ;12/04/2002 13:47
- +1 ;;8.0;MailMan;**10**;Jun 28, 2002
- ENH IF $PIECE(XMR,U,7)]""
- Begin DoDot:1
- +1 ;check if KIDS format
- +2 IF $PIECE(XMR,U,7)["K"
- IF $$CHECK1("I $E(XMB0,1,5)=""$KID """)
- SET XMPKIDS=1
- QUIT
- +3 IF $PIECE(XMR,U,7)["X"
- IF $$CHECK1("I $E(XMB0,1,11)=""$TXT $KIDS """)
- SET XMPKIDS=1
- QUIT
- End DoDot:1
- IF $DATA(XMPKIDS)
- GOTO 2
- +4 ;check if KIDS but Message Type field got lost
- +5 IF $PIECE(XMR,U,7)=""
- IF $$CHECK1("I $E(XMB0,1,5)=""$KID """)
- SET XMPKIDS=1
- GOTO 2
- +6 IF $SELECT('$DATA(DUZ(0)):1,DUZ(0)="@":0,$DATA(^XUSEC("XUPROGMODE",DUZ)):0,1:1)
- GOTO 1
- +7 WRITE !!,$CHAR(7),"Warning: Installing this message will cause a permanent update of globals"
- +8 WRITE !,"and routines"_$SELECT($PIECE(XMR,U,7)["X":" and run the INIT",1:"")_"."
- Begin DoDot:1
- +9 NEW DIR,DIRUT
- +10 SET DIR(0)="Y"
- SET DIR("B")="NO"
- SET DIR("A")="Do you really want to do this"
- +11 DO ^DIR
- End DoDot:1
- IF 'Y
- QUIT
- 1 DO CHECK
- IF Y<0
- Begin DoDot:1
- +1 NEW DIR,DIRUT
- +2 SET DIR(0)="Y"
- SET DIR("B")="NO"
- SET DIR("A")="This doesn't appear to be an installable message, do you wish to continue"
- +3 DO ^DIR
- End DoDot:1
- IF 'Y
- GOTO Q
- 2 SET XMPASS=1
- SET XMA0=^XMB(3.9,XMZ,0)
- IF $LENGTH(XMB0)
- IF $LENGTH($PIECE(XMA0,U,10))
- IF $DATA(^("K"))
- DO ^XMPSEC
- IF $SELECT('$DATA(DUZ(0)):0,DUZ(0)="@":1,$DATA(^XUSEC("XUPROGMODE",DUZ)):1,1:0)
- GOTO 3
- +1 IF $PIECE(XMB0," at ",3)["on"
- SET XMPASS=0
- DO FAIL^XMPSEC
- +2 IF $SELECT('$DATA(DUZ(0)):1,DUZ(0)="@":0,$DATA(^XUSEC("XUPROGMODE",DUZ)):0,1:1)
- GOTO Q
- 3 IF XMP2="R"
- GOTO X
- IF XMPASS'=0
- GOTO ENI^XMP2
- +1 WRITE !,"This message may not be installed !!"
- GOTO Q
- X IF '$DATA(XMP2)
- GOTO Z
- IF XMP2'="R"
- GOTO Z
- KILL DIR
- +1 SET DIR("A")="ROUTINE(S)"
- SET DIR(0)="FO^2:30"
- SET DIR("?")="^D HLP^XMP2A"
- Y DO ^DIR
- KILL DIRUT
- IF $DATA(DTOUT)!$DATA(DUOUT)
- GOTO Z
- IF X=""
- IF $ORDER(XMP2(""))=""
- GOTO Q
- GOTO ENI^XMP2
- +1 IF X'?1.A.AN.1"*"
- WRITE $CHAR(7)," ???"
- GOTO Y
- +2 SET XMP2(X)=""
- GOTO Y
- Z GOTO Q^XMP2
- Q KILL DIR
- GOTO Q^XMP2
- ENTT ;LIST/PRINT TEXT ONLY
- +1 NEW XMI,XMTEXT,XMABORT,XMPAGE
- +2 SET XMI=.999999
- SET XMABORT=0
- SET XMPAGE=1
- +3 FOR
- SET XMI=$ORDER(^XMB(3.9,XMZ,2,XMI))
- IF 'XMI
- QUIT
- SET XMTEXT=^(XMI,0)
- Begin DoDot:1
- +4 IF $EXTRACT(XMTEXT,1,8)="$END TXT"
- SET XMABORT=1
- QUIT
- +5 FOR
- Begin DoDot:2
- +6 IF $Y+3+($EXTRACT($GET(IOST),1,2)="C-")>IOSL
- Begin DoDot:3
- +7 IF $EXTRACT($GET(IOST),1,2)="C-"
- WRITE !
- DO PAGE^XMXUTIL(.XMABORT)
- IF XMABORT
- QUIT
- +8 WRITE @IOF
- IF $EXTRACT($GET(IOST),1,2)="C-"
- QUIT
- +9 DO PAGE2HDR^XMJMP1(XMSUBJ,XMZSTR,.XMPAGE)
- End DoDot:3
- IF XMABORT
- QUIT
- +10 IF '$TEST
- WRITE !
- +11 WRITE $SELECT(IOM>1:$EXTRACT(XMTEXT,1,IOM-1),1:XMTEXT)
- End DoDot:2
- IF $LENGTH(XMTEXT)<IOM!XMABORT!(IOM<2)
- QUIT
- SET XMTEXT=$EXTRACT(XMTEXT,IOM,999)
- End DoDot:1
- IF XMABORT
- QUIT
- +12 QUIT
- ENTR ;INSTALL SELECTED ROUTINE(S) [IN XMP2 ARRAY]
- +1 FOR I=0:0
- SET XCN=$ORDER(^XMB(3.9,XMZ,2,XCN))
- IF XCN=""
- QUIT
- SET X=^(XCN,0)
- IF $EXTRACT(X)="$"
- SET Y=$PIECE(X," ",2)
- SET J=""
- FOR I=0:0
- SET J=$ORDER(XMP2(J))
- SET K=$LENGTH(J)-1
- IF J=""
- QUIT
- IF $SELECT(J=Y:1,J'?.AN1"*":0,$EXTRACT(J,1,K)=$EXTRACT(Y,1,K):1,1:0)
- DO S1^XMP2
- +2 QUIT
- HLP ;Routine selection
- +1 WRITE !!,"Choose routines that you wish to install from this message by entering",!,"single names or a series (XMP2*=all routines that begin with 'XMP2')."
- +2 WRITE !,"The message is not checked to see if there are any matches to your input.",!,"It may be helpful to request a SUMMARY of the message first."
- +3 WRITE !,"Only routines selected for installation are backed up.",!!
- +4 QUIT
- CHECK ;check text header
- +1 SET %="I $E(XMB0,1,5)=""$TXT "",$P(XMB0,""Created ""_$S(XMB0[""BACKUP"":""on "",1:""by ""),2)?1E.E1"" at "".E1"" at "".E"
- SET %=$$CHECK1(%)
- +2 SET Y=$SELECT(%:%,1:-1)
- +3 QUIT
- CHECK1(XMCHK) ;Check text header meets condition XMCHK
- +1 ;returns line number of text header or 0, XMB0=text header
- +2 NEW XMCNT,XMFLAG
- +3 SET XMFLAG=0
- SET XMCNT=.999
- SET XMB0=""
- +4 FOR
- SET XMCNT=$ORDER(^XMB(3.9,XMZ,2,XMCNT))
- IF 'XMCNT
- QUIT
- SET XMB0=$GET(^(XMCNT,0))
- Begin DoDot:1
- +5 XECUTE XMCHK
- IF $TEST
- SET XMFLAG=XMCNT
- SET XMCNT=""
- End DoDot:1
- IF 'XMCNT
- QUIT
- +6 QUIT XMFLAG
