- 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 Feb 18, 2025@23:30:42 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