XPDIQ ;SFISC/RSD - Install Questions ;03/21/2008
;;8.0;KERNEL;**21,28,58,61,95,108,399**;Jul 10, 1995;Build 12
Q
DIR(XPFR,XPFP) ;XPFR=prefix, XPFP=file no._# or Mail Group ien
;XPFP is for XPF or XPM questions
N DIR,DR,XPDI,XPDJ,X,Y,Z
S XPFP=$G(XPFP),XPDI=$S(XPFP:XPFR_XPFP,1:XPFR)
D QUES(XPDI)
;ask questions
S X=XPFR
F S X=$O(^XTMP("XPDI",XPDA,"QUES",X)),Z="" Q:X=""!($P(X,XPFR)]"") D I $D(DIRUT) S XPDQUIT=1 Q
.S XPDJ=$S('XPFP:X,1:XPDI_$P(X,XPFR,2))
.F S Z=$O(^XTMP("XPDI",XPDA,"QUES",X,Z)) Q:Z="" M DIR(Z)=^(Z)
.;if there was a previous answer, reset DIR("B") to external or internal answer
.S:$L($G(XPDQUES(XPDJ))) DIR("B")=$G(XPDQUES(XPDJ,"B"),XPDQUES(XPDJ)) D Q:'$D(Y)
..N FLAG,X,Z K Y
..;this is the M CODE node that was set to DIR("M") in prev for loop
..;FLAG is used by KIDS questions
..I $D(DIR("M")) S %=DIR("M"),FLAG="" K DIR("M") X %
..Q:'$D(DIR)
..;'|' is used to mark variable in prompt, reset prompt with value of variable
..S:$G(DIR("A"))["|" DIR("A")=$P(DIR("A"),"|")_@$P(DIR("A"),"|",2)_$P(DIR("A"),"|",3)
..K:$G(DIR("B"))="" DIR("B")
..D ^DIR
.S %=$P(DIR(0),U)
.;read was optional and didn't timeout and user didn't enter anything
.I %["O",'$D(DTOUT),$S(%["P":Y=-1,1:Y="") K DIRUT Q
.;quit if the user up-arrowed out
.Q:$D(DIRUT)
.;if pointer, reset Y & Y(0)
.I %["P" S Y(0)=$S(%["Z":$P(Y(0),U),1:$P(Y,U,2)),Y=+Y
.;if Y(0) is not defined, but Y is
.S:$D(Y)#2&'($D(Y(0))#2) Y(0)=Y
.S XPDQUES(XPDJ)=Y,XPDQUES(XPDJ,"A")=$G(DIR("A")),XPDQUES(XPDJ,"B")=$G(Y(0))
.K DIR
K XPDJ S XPDI=XPFR
;code to save XPDQUES to INSTALL ANSWERS in file 9.7, loop thru the answers starting with the from value, XPFR
F Y=1:1 S XPDI=$O(XPDQUES(XPDI)) Q:XPDI=""!($P(XPDI,XPFR)]"") D
.S X="XPDJ(9.701,""?+"_Y_","_XPDA_","")",@X@(.01)=XPDI,@X@(1)=$G(XPDQUES(XPDI,"A")),@X@(2)=$G(XPDQUES(XPDI,"B")),@X@(3)=XPDQUES(XPDI)
K XPDI D:$D(XPDJ)>9 UPDATE^DIE("","XPDJ","XPDI")
Q
;
QUES(X) ;build XPDQUES array, X="INI","INIT","XPF","XPM"
;move INSTALL ANSWERS from file 9.7 to XPDQUES
;XPDQUES(X)=internal answer, XPDQUES(X,"A")=prompt, XPDQUES(X,"B")=external answer.
N Y,Z K XPDQUES S Z=X
F S Z=$O(^XPD(9.7,XPDA,"QUES","B",Z)) Q:Z=""!($P(Z,X)]"") S Y=$O(^(Z,0)) D
.Q:'$D(^XPD(9.7,XPDA,"QUES",Y,0))
.S XPDQUES(Z)=$G(^(1)),XPDQUES(Z,"A")=$G(^("A")),XPDQUES(Z,"B")=$G(^("B")) ; ^(1) refer to prev line ^XPD(9.7,XPDA,"QUES","B",Z)
Q
;
ANSWER(QUES) ;E.F. Return answer to question
N IEN I '$D(XPDA)!($G(QUES)="") Q ""
S IEN=$O(^XPD(9.7,XPDA,"QUES","B",QUES,0)) I IEN'>0 Q ""
Q $G(^XPD(9.7,XPDA,"QUES",IEN,1))
;codes for install process questions
;XPDFIL=file #, XPDFILN=file name^global ref^partial DD
;XPDFILO=update DD^security codes^^^resolve pt^list template^data with file^add,merge,overwrite,replace^user override data update
;XPDSCR=screen to determine DD update
;XPDANS is define in QUES^XPDI
XPF1 ;write over existing file
N XPDI
W !!?3,XPDFIL,?13,$P(XPDFILN,U),$P(" (Partial Definition)",U,$P(XPDFILN,U,3)),$P(" (including data)",U,$P(XPDFILO,U,7)="y")
;file doesn't exists
I XPDANS K DIR Q
I $L($G(XPDSCR)) S XPDI=1 D Q:'XPDI
.X XPDSCR S XPDI=$T Q:XPDI
.W !,"Data Dictionary FAILED the screening logic, file will NOT be installed!"
.S $P(XPDANS,U,2)="1" K DIR
S FLAG=$P($G(^DIC(XPDFIL,0)),U)
;file exist and has the same name
I $P(FLAG,$P(XPDFILN,U))="" W !,"Note: You already have the '",$P(XPDFILN,U),"' File." K DIR Q
W *7,!,"*BUT YOU ALREADY HAVE '",FLAG,"' AS FILE #",XPDFIL,"!"
S $P(XPDANS,U,4)=1
Q
XPF2 ;data
;if they don't want to overwrite a file with a different name then set the DIRUT flag and ABORT, this will stop the rest of the questions and abort the install
I $G(XPDQUES("XPF"_XPFP_1))=0 S DIRUT=1 K DIR Q
;if Data doesn't exists or DD failed screen or data wasn't sent, don't ask question
I '$P(XPDANS,U,3)!$P(XPDANS,U,2)!($P(XPDFILO,U,7)'="y") K DIR Q
S %=$F("amor",$P(XPDFILO,U,8))-1
;if this is add and file is not new
I %=1 W !,"Data will NOT be added." K DIR Q
;check if dev. doesn't want to ask user
I $P(XPDFILO,U,9)'="y" W !,"I will ",$P("^MERGE^OVERWRITE^REPLACE",U,%)," your data with mine." K DIR Q
S FLAG=$P("^merged with^to overwrite^to replace",U,%)
Q
;XPDDIQ(name)=internal value, (name,"A")=prompt, (name,"B")=external
XPQ(NM) ;Build XPDDIQ
Q:'$D(XPDDIQ(NM))
I $D(XPDDIQ(NM))#2 S XPDQUES(NM)=XPDDIQ(NM) K DIR Q
S:$D(XPDDIQ(NM,"A")) DIR("A")=XPDDIQ(NM,"A")
S:$D(XPDDIQ(NM,"B")) DIR("B")=XPDDIQ(NM,"B")
Q
XPI1 ;Inhibit Logons
D XPQ("XPI1")
Q
XPM1 ;mail groups
S FLAG=XPDANS
;DIR("B") is null if first time here
I DIR("B")="" D
.;check if mail group already exist
.S X=$$FIND1^DIC(3.8,"","XQf",XPDANS,"","","")
.;get the current coordinator
.Q:'X S X=$P($G(^XMB(3.8,X,0)),U,7)
.;set the default to current coordinator
.I X,$D(^VA(200,X,0))#10 S DIR("B")=$P(^(0),U)
D XPQ("XPM1")
Q
XPO1 ;rebuild menu trees
D XPQ("XPO1")
Q
XPZ1 ;disable options
D XPQ("XPZ1")
Q
XPZ2 ;move routines
N Y
;if they are not in production UCI don't ask
X ^%ZOSF("UCI") I Y'=^%ZOSF("PROD") K DIR Q
;if they are not running MSM don't ask
I ^%ZOSF("OS")'["MSM" K DIR Q
Q:'$D(XPDDIQ("XPZ2"))
I $D(XPDDIQ("XPZ2"))#2 S XPDQUES("XPZ2")=XPDDIQ("XPZ2") K DIR Q
S:$D(XPDDIQ("XPZ2","A")) DIR("A")=XPDDIQ("XPZ2","A")
S:$D(XPDDIQ("XPZ2","B")) DIR("B")=XPDDIQ("XPZ2","B")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXPDIQ 5417 printed Dec 13, 2024@02:04:17 Page 2
XPDIQ ;SFISC/RSD - Install Questions ;03/21/2008
+1 ;;8.0;KERNEL;**21,28,58,61,95,108,399**;Jul 10, 1995;Build 12
+2 QUIT
DIR(XPFR,XPFP) ;XPFR=prefix, XPFP=file no._# or Mail Group ien
+1 ;XPFP is for XPF or XPM questions
+2 NEW DIR,DR,XPDI,XPDJ,X,Y,Z
+3 SET XPFP=$GET(XPFP)
SET XPDI=$SELECT(XPFP:XPFR_XPFP,1:XPFR)
+4 DO QUES(XPDI)
+5 ;ask questions
+6 SET X=XPFR
+7 FOR
SET X=$ORDER(^XTMP("XPDI",XPDA,"QUES",X))
SET Z=""
if X=""!($PIECE(X,XPFR)]"")
QUIT
Begin DoDot:1
+8 SET XPDJ=$SELECT('XPFP:X,1:XPDI_$PIECE(X,XPFR,2))
+9 FOR
SET Z=$ORDER(^XTMP("XPDI",XPDA,"QUES",X,Z))
if Z=""
QUIT
MERGE DIR(Z)=^(Z)
+10 ;if there was a previous answer, reset DIR("B") to external or internal answer
+11 if $LENGTH($GET(XPDQUES(XPDJ)))
SET DIR("B")=$GET(XPDQUES(XPDJ,"B"),XPDQUES(XPDJ))
Begin DoDot:2
+12 NEW FLAG,X,Z
KILL Y
+13 ;this is the M CODE node that was set to DIR("M") in prev for loop
+14 ;FLAG is used by KIDS questions
+15 IF $DATA(DIR("M"))
SET %=DIR("M")
SET FLAG=""
KILL DIR("M")
XECUTE %
+16 if '$DATA(DIR)
QUIT
+17 ;'|' is used to mark variable in prompt, reset prompt with value of variable
+18 if $GET(DIR("A"))["|"
SET DIR("A")=$PIECE(DIR("A"),"|")_@$PIECE(DIR("A"),"|",2)_$PIECE(DIR("A"),"|",3)
+19 if $GET(DIR("B"))=""
KILL DIR("B")
+20 DO ^DIR
End DoDot:2
if '$DATA(Y)
QUIT
+21 SET %=$PIECE(DIR(0),U)
+22 ;read was optional and didn't timeout and user didn't enter anything
+23 IF %["O"
IF '$DATA(DTOUT)
IF $SELECT(%["P":Y=-1,1:Y="")
KILL DIRUT
QUIT
+24 ;quit if the user up-arrowed out
+25 if $DATA(DIRUT)
QUIT
+26 ;if pointer, reset Y & Y(0)
+27 IF %["P"
SET Y(0)=$SELECT(%["Z":$PIECE(Y(0),U),1:$PIECE(Y,U,2))
SET Y=+Y
+28 ;if Y(0) is not defined, but Y is
+29 if $DATA(Y)#2&'($DATA(Y(0))#2)
SET Y(0)=Y
+30 SET XPDQUES(XPDJ)=Y
SET XPDQUES(XPDJ,"A")=$GET(DIR("A"))
SET XPDQUES(XPDJ,"B")=$GET(Y(0))
+31 KILL DIR
End DoDot:1
IF $DATA(DIRUT)
SET XPDQUIT=1
QUIT
+32 KILL XPDJ
SET XPDI=XPFR
+33 ;code to save XPDQUES to INSTALL ANSWERS in file 9.7, loop thru the answers starting with the from value, XPFR
+34 FOR Y=1:1
SET XPDI=$ORDER(XPDQUES(XPDI))
if XPDI=""!($PIECE(XPDI,XPFR)]"")
QUIT
Begin DoDot:1
+35 SET X="XPDJ(9.701,""?+"_Y_","_XPDA_","")"
SET @X@(.01)=XPDI
SET @X@(1)=$GET(XPDQUES(XPDI,"A"))
SET @X@(2)=$GET(XPDQUES(XPDI,"B"))
SET @X@(3)=XPDQUES(XPDI)
End DoDot:1
+36 KILL XPDI
if $DATA(XPDJ)>9
DO UPDATE^DIE("","XPDJ","XPDI")
+37 QUIT
+38 ;
QUES(X) ;build XPDQUES array, X="INI","INIT","XPF","XPM"
+1 ;move INSTALL ANSWERS from file 9.7 to XPDQUES
+2 ;XPDQUES(X)=internal answer, XPDQUES(X,"A")=prompt, XPDQUES(X,"B")=external answer.
+3 NEW Y,Z
KILL XPDQUES
SET Z=X
+4 FOR
SET Z=$ORDER(^XPD(9.7,XPDA,"QUES","B",Z))
if Z=""!($PIECE(Z,X)]"")
QUIT
SET Y=$ORDER(^(Z,0))
Begin DoDot:1
+5 if '$DATA(^XPD(9.7,XPDA,"QUES",Y,0))
QUIT
+6 ; ^(1) refer to prev line ^XPD(9.7,XPDA,"QUES","B",Z)
SET XPDQUES(Z)=$GET(^(1))
SET XPDQUES(Z,"A")=$GET(^("A"))
SET XPDQUES(Z,"B")=$GET(^("B"))
End DoDot:1
+7 QUIT
+8 ;
ANSWER(QUES) ;E.F. Return answer to question
+1 NEW IEN
IF '$DATA(XPDA)!($GET(QUES)="")
QUIT ""
+2 SET IEN=$ORDER(^XPD(9.7,XPDA,"QUES","B",QUES,0))
IF IEN'>0
QUIT ""
+3 QUIT $GET(^XPD(9.7,XPDA,"QUES",IEN,1))
+4 ;codes for install process questions
+5 ;XPDFIL=file #, XPDFILN=file name^global ref^partial DD
+6 ;XPDFILO=update DD^security codes^^^resolve pt^list template^data with file^add,merge,overwrite,replace^user override data update
+7 ;XPDSCR=screen to determine DD update
+8 ;XPDANS is define in QUES^XPDI
XPF1 ;write over existing file
+1 NEW XPDI
+2 WRITE !!?3,XPDFIL,?13,$PIECE(XPDFILN,U),$PIECE(" (Partial Definition)",U,$PIECE(XPDFILN,U,3)),$PIECE(" (including data)",U,$PIECE(XPDFILO,U,7)="y")
+3 ;file doesn't exists
+4 IF XPDANS
KILL DIR
QUIT
+5 IF $LENGTH($GET(XPDSCR))
SET XPDI=1
Begin DoDot:1
+6 XECUTE XPDSCR
SET XPDI=$TEST
if XPDI
QUIT
+7 WRITE !,"Data Dictionary FAILED the screening logic, file will NOT be installed!"
+8 SET $PIECE(XPDANS,U,2)="1"
KILL DIR
End DoDot:1
if 'XPDI
QUIT
+9 SET FLAG=$PIECE($GET(^DIC(XPDFIL,0)),U)
+10 ;file exist and has the same name
+11 IF $PIECE(FLAG,$PIECE(XPDFILN,U))=""
WRITE !,"Note: You already have the '",$PIECE(XPDFILN,U),"' File."
KILL DIR
QUIT
+12 WRITE *7,!,"*BUT YOU ALREADY HAVE '",FLAG,"' AS FILE #",XPDFIL,"!"
+13 SET $PIECE(XPDANS,U,4)=1
+14 QUIT
XPF2 ;data
+1 ;if they don't want to overwrite a file with a different name then set the DIRUT flag and ABORT, this will stop the rest of the questions and abort the install
+2 IF $GET(XPDQUES("XPF"_XPFP_1))=0
SET DIRUT=1
KILL DIR
QUIT
+3 ;if Data doesn't exists or DD failed screen or data wasn't sent, don't ask question
+4 IF '$PIECE(XPDANS,U,3)!$PIECE(XPDANS,U,2)!($PIECE(XPDFILO,U,7)'="y")
KILL DIR
QUIT
+5 SET %=$FIND("amor",$PIECE(XPDFILO,U,8))-1
+6 ;if this is add and file is not new
+7 IF %=1
WRITE !,"Data will NOT be added."
KILL DIR
QUIT
+8 ;check if dev. doesn't want to ask user
+9 IF $PIECE(XPDFILO,U,9)'="y"
WRITE !,"I will ",$PIECE("^MERGE^OVERWRITE^REPLACE",U,%)," your data with mine."
KILL DIR
QUIT
+10 SET FLAG=$PIECE("^merged with^to overwrite^to replace",U,%)
+11 QUIT
+12 ;XPDDIQ(name)=internal value, (name,"A")=prompt, (name,"B")=external
XPQ(NM) ;Build XPDDIQ
+1 if '$DATA(XPDDIQ(NM))
QUIT
+2 IF $DATA(XPDDIQ(NM))#2
SET XPDQUES(NM)=XPDDIQ(NM)
KILL DIR
QUIT
+3 if $DATA(XPDDIQ(NM,"A"))
SET DIR("A")=XPDDIQ(NM,"A")
+4 if $DATA(XPDDIQ(NM,"B"))
SET DIR("B")=XPDDIQ(NM,"B")
+5 QUIT
XPI1 ;Inhibit Logons
+1 DO XPQ("XPI1")
+2 QUIT
XPM1 ;mail groups
+1 SET FLAG=XPDANS
+2 ;DIR("B") is null if first time here
+3 IF DIR("B")=""
Begin DoDot:1
+4 ;check if mail group already exist
+5 SET X=$$FIND1^DIC(3.8,"","XQf",XPDANS,"","","")
+6 ;get the current coordinator
+7 if 'X
QUIT
SET X=$PIECE($GET(^XMB(3.8,X,0)),U,7)
+8 ;set the default to current coordinator
+9 IF X
IF $DATA(^VA(200,X,0))#10
SET DIR("B")=$PIECE(^(0),U)
End DoDot:1
+10 DO XPQ("XPM1")
+11 QUIT
XPO1 ;rebuild menu trees
+1 DO XPQ("XPO1")
+2 QUIT
XPZ1 ;disable options
+1 DO XPQ("XPZ1")
+2 QUIT
XPZ2 ;move routines
+1 NEW Y
+2 ;if they are not in production UCI don't ask
+3 XECUTE ^%ZOSF("UCI")
IF Y'=^%ZOSF("PROD")
KILL DIR
QUIT
+4 ;if they are not running MSM don't ask
+5 IF ^%ZOSF("OS")'["MSM"
KILL DIR
QUIT
+6 if '$DATA(XPDDIQ("XPZ2"))
QUIT
+7 IF $DATA(XPDDIQ("XPZ2"))#2
SET XPDQUES("XPZ2")=XPDDIQ("XPZ2")
KILL DIR
QUIT
+8 if $DATA(XPDDIQ("XPZ2","A"))
SET DIR("A")=XPDDIQ("XPZ2","A")
+9 if $DATA(XPDDIQ("XPZ2","B"))
SET DIR("B")=XPDDIQ("XPZ2","B")
+10 QUIT
