XQT3 ;SEA/MJM Create menu templates (cont.);11/20/89 11:12 AM ;01/09/2001 13:33
;;8.0;KERNEL;**46,37,155**;Jul 10, 1995
STORE ;See if this is what the User wants and if so store it
W @IOF,!,"You have chosen the following options in this order:",!!
S XQN="" F XQI=0:0 S XQN=$O(XQLIST(XQN)) Q:XQN="" W !,$P(XQLIST(XQN),U,4)," (",$P(XQLIST(XQN),U,3),")"
W !!,"Are we in agreement so far? [Y/N] Y// " R %:DTIME S:%="" %="Y" S:'$T %=U G:%=U OUT I %["?"!("YyNn"'[%) W !!,"Please answer 'Y' or 'N'",*7 H 10 G STORE
I "Nn"[% W !!,"OK, lets take it from the top...." D O1 H 10 G EN^XQT2
W @IOF,!!,"Fine. Since all menu-type options will be processed in the background",!," you will only be asked to respond to the following:",!!
S XQN=0 F XQI=0:0 S XQN=$O(XQLIST(XQN)) Q:XQN="" I "MQ"'[$P(XQLIST(XQN),U,6) W !,$P(XQLIST(XQN),U,4)," (",$P(XQLIST(XQN),U,3),")"
W !!,"Are these the functions you want when you invoke this template? [Y/N] Y// " R %:DTIME S:'$T %=U G:%=U OUT S:%="" %="Y" I %["?"!("YyNn"'[%) W !!,*7,"Please answer 'Y' or 'N'" H 10 G STORE
I "Nn"[% W !!,"OK, lets take it from the top...." D O1 H 10 G EN^XQT2
;
NAM ;Get a legitimate name for this template and file it.
W !!,"Enter a name (6 characters or less in UPPER CASE)",!?5,"for this template or '^' to quit: " R XQUR:DTIME S:'$T XQUR=U G:XQUR=U OUT
I XQUR["??" S XQH="XQTNAM" D EN^XQH S XQUR="" G NAM
I XQUR[U W !!,"A menu template name may not contain the '^' character.",!,"Are you telling me you want to quit? [Y/N] N// " R XQUR:DTIME S:'$T XQUR=U G:XQUR=U OUT S:XQUR="" XQUR="N" I "Nn"[XQUR G NAM
I XQUR="" W *7," ??" G NAM
I $L(XQUR)>6 W *7,!!,"Six (6) characters or less, please." G NAM
I XQUR["?" W !!,"A six character (or less) name like 'LAB', or 'E1',",!," something you will remember." S XQUR="" G NAM
S XQUP=XQUR I XQUR'?.PUN S XQUP=$$UP^XLFSTR(XQUP) ;F XQI=1:1 Q:XQUP?.NUP S %=$A(XQUP,XQI) I %<123,%>96 S XQUP=$E(XQUP,1,XQI-1)_$C(%-32)_$E(XQUP,XQI+1,255)
S XQUR=XQUP
W !!,"'",XQUR,"' it is. In the future you will start this template by typing '[",XQUR,"'"
;
RPT ;Set the default for repeating the template
W !!,"After you have finished using '",XQUR,"' will you want it to repeat? [Y/N] N// " R %:DTIME S:'$T %=U G:%=U OUT S:%="" %="N"
I %["?" W !!,?5,"Please answer Yes or No."
I %["??" S XQH="XQTREPEAT" D EN^XQH G RPT
S XQTRPT=0 I "Yy"[% S XQTRPT=1
;
;Create the 'DR' strings to load the template into ^VA(200,DUZ,19.8)
;
S XQJ=0,XQDR(0)="1///"_XQTRPT_U
F XQI=1:1:XQOPN-1 S:$L(XQDR(XQJ))>200 XQJ=XQJ+1,XQDR(XQJ)="1///+" S XQDR(XQJ)=XQDR(XQJ)_$P(XQLIST(XQI),U,1)_","_$P(XQLIST(XQI),U,2)_","_$S($D(XQLIST(XQI,0)):"E",1:"")_$S($D(XQLIST(XQI,1)):"X",1:"")_"^"
;
FIL ;File this template in the New Person File
K DIC,DIE,DR,DA
S X=XQUR,DA=0,U="^",DA(1)=DUZ,DIC="^VA(200,"_DA(1)_",19.8,",DIC(0)="NFL"
I '$D(^VA(200,DUZ,19.8,0)) S ^(0)="^200.198^^"
I $D(^VA(200,DUZ,19.8,"B",X)) W !,"You already have a template called ",X,". Do you want to replace it? N// " R %:30 S:%="" %="N" S:'$T %=U G:%=U OUT G:"Yy"'[% NAM S DA=$O(^(X,0)),DIK=DIC D ^DIK S X=XQUR
I '$D(^VA(200,DUZ,19.8,"B",X)) D FILE^DICN
S DA=$O(^VA(200,DUZ,19.8,"B",X,0))
S DIE=DIC
F XQI=0:1:XQJ S DR=XQDR(XQI) D ^DIE
;
OUT ;Clean up, restore XQY and quit
;S XQY=+XQTSV,XQDIC=$P(XQTSV,U,2),XQY0=$P(XQTSV,U,3,99)
I $D(XQTSV) S XQY=+XQTSV,XQDIC=$P(XQTSV,U,2),XQY0=$P(XQTSV,U,3,99)
I '$D(XQTSV) S XQY=^(^XUTL("XQ",$J,"T")),XQDIC=$P($P(XQY,U),+XQY,2),XQY0=$P(XQY,U,2,99),XQY=+XQY
K XQTSV
;
;Come to O1 if we're restarting from "Are We In Agreement" Store+4, +9
O1 K %,D0,DA,DI,DIC,DQ,DR,XQA,XQAA,XQDR,XQH,XQH1,XQH2,XQI,XQJ,XQK,XQLIST,XQLK,XQN,XQNM,XQOO,XQOPN,XQRD,XQRL,XQSAV,XQSN,XQTF,XQTF1,XQTM,XQTRPT,XQTT,XQTXT,XQUR
K XQT,XQT1,XQTSAV,XQUP,XQFLAG,XQFLG,XQL,XQLN,XQSAVE,XQX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQT3 3818 printed Dec 13, 2024@02:06:50 Page 2
XQT3 ;SEA/MJM Create menu templates (cont.);11/20/89 11:12 AM ;01/09/2001 13:33
+1 ;;8.0;KERNEL;**46,37,155**;Jul 10, 1995
STORE ;See if this is what the User wants and if so store it
+1 WRITE @IOF,!,"You have chosen the following options in this order:",!!
+2 SET XQN=""
FOR XQI=0:0
SET XQN=$ORDER(XQLIST(XQN))
if XQN=""
QUIT
WRITE !,$PIECE(XQLIST(XQN),U,4)," (",$PIECE(XQLIST(XQN),U,3),")"
+3 WRITE !!,"Are we in agreement so far? [Y/N] Y// "
READ %:DTIME
if %=""
SET %="Y"
if '$TEST
SET %=U
if %=U
GOTO OUT
IF %["?"!("YyNn"'[%)
WRITE !!,"Please answer 'Y' or 'N'",*7
HANG 10
GOTO STORE
+4 IF "Nn"[%
WRITE !!,"OK, lets take it from the top...."
DO O1
HANG 10
GOTO EN^XQT2
+5 WRITE @IOF,!!,"Fine. Since all menu-type options will be processed in the background",!," you will only be asked to respond to the following:",!!
+6 SET XQN=0
FOR XQI=0:0
SET XQN=$ORDER(XQLIST(XQN))
if XQN=""
QUIT
IF "MQ"'[$PIECE(XQLIST(XQN),U,6)
WRITE !,$PIECE(XQLIST(XQN),U,4)," (",$PIECE(XQLIST(XQN),U,3),")"
+7 WRITE !!,"Are these the functions you want when you invoke this template? [Y/N] Y// "
READ %:DTIME
if '$TEST
SET %=U
if %=U
GOTO OUT
if %=""
SET %="Y"
IF %["?"!("YyNn"'[%)
WRITE !!,*7,"Please answer 'Y' or 'N'"
HANG 10
GOTO STORE
+8 IF "Nn"[%
WRITE !!,"OK, lets take it from the top...."
DO O1
HANG 10
GOTO EN^XQT2
+9 ;
NAM ;Get a legitimate name for this template and file it.
+1 WRITE !!,"Enter a name (6 characters or less in UPPER CASE)",!?5,"for this template or '^' to quit: "
READ XQUR:DTIME
if '$TEST
SET XQUR=U
if XQUR=U
GOTO OUT
+2 IF XQUR["??"
SET XQH="XQTNAM"
DO EN^XQH
SET XQUR=""
GOTO NAM
+3 IF XQUR[U
WRITE !!,"A menu template name may not contain the '^' character.",!,"Are you telling me you want to quit? [Y/N] N// "
READ XQUR:DTIME
if '$TEST
SET XQUR=U
if XQUR=U
GOTO OUT
if XQUR=""
SET XQUR="N"
IF "Nn"[XQUR
GOTO NAM
+4 IF XQUR=""
WRITE *7," ??"
GOTO NAM
+5 IF $LENGTH(XQUR)>6
WRITE *7,!!,"Six (6) characters or less, please."
GOTO NAM
+6 IF XQUR["?"
WRITE !!,"A six character (or less) name like 'LAB', or 'E1',",!," something you will remember."
SET XQUR=""
GOTO NAM
+7 ;F XQI=1:1 Q:XQUP?.NUP S %=$A(XQUP,XQI) I %<123,%>96 S XQUP=$E(XQUP,1,XQI-1)_$C(%-32)_$E(XQUP,XQI+1,255)
SET XQUP=XQUR
IF XQUR'?.PUN
SET XQUP=$$UP^XLFSTR(XQUP)
+8 SET XQUR=XQUP
+9 WRITE !!,"'",XQUR,"' it is. In the future you will start this template by typing '[",XQUR,"'"
+10 ;
RPT ;Set the default for repeating the template
+1 WRITE !!,"After you have finished using '",XQUR,"' will you want it to repeat? [Y/N] N// "
READ %:DTIME
if '$TEST
SET %=U
if %=U
GOTO OUT
if %=""
SET %="N"
+2 IF %["?"
WRITE !!,?5,"Please answer Yes or No."
+3 IF %["??"
SET XQH="XQTREPEAT"
DO EN^XQH
GOTO RPT
+4 SET XQTRPT=0
IF "Yy"[%
SET XQTRPT=1
+5 ;
+6 ;Create the 'DR' strings to load the template into ^VA(200,DUZ,19.8)
+7 ;
+8 SET XQJ=0
SET XQDR(0)="1///"_XQTRPT_U
+9 FOR XQI=1:1:XQOPN-1
if $LENGTH(XQDR(XQJ))>200
SET XQJ=XQJ+1
SET XQDR(XQJ)="1///+"
SET XQDR(XQJ)=XQDR(XQJ)_$PIECE(XQLIST(XQI),U,1)_","_$PIECE(XQLIST(XQI),U,2)_","_$SELECT($DATA(XQLIST(XQI,0)):"E",1:"")_$SELECT($DATA(XQLIST(XQI,1)):"X",1:"")_"^"
+10 ;
FIL ;File this template in the New Person File
+1 KILL DIC,DIE,DR,DA
+2 SET X=XQUR
SET DA=0
SET U="^"
SET DA(1)=DUZ
SET DIC="^VA(200,"_DA(1)_",19.8,"
SET DIC(0)="NFL"
+3 IF '$DATA(^VA(200,DUZ,19.8,0))
SET ^(0)="^200.198^^"
+4 IF $DATA(^VA(200,DUZ,19.8,"B",X))
WRITE !,"You already have a template called ",X,". Do you want to replace it? N// "
READ %:30
if %=""
SET %="N"
if '$TEST
SET %=U
if %=U
GOTO OUT
if "Yy"'[%
GOTO NAM
SET DA=$ORDER(^(X,0))
SET DIK=DIC
DO ^DIK
SET X=XQUR
+5 IF '$DATA(^VA(200,DUZ,19.8,"B",X))
DO FILE^DICN
+6 SET DA=$ORDER(^VA(200,DUZ,19.8,"B",X,0))
+7 SET DIE=DIC
+8 FOR XQI=0:1:XQJ
SET DR=XQDR(XQI)
DO ^DIE
+9 ;
OUT ;Clean up, restore XQY and quit
+1 ;S XQY=+XQTSV,XQDIC=$P(XQTSV,U,2),XQY0=$P(XQTSV,U,3,99)
+2 IF $DATA(XQTSV)
SET XQY=+XQTSV
SET XQDIC=$PIECE(XQTSV,U,2)
SET XQY0=$PIECE(XQTSV,U,3,99)
+3 IF '$DATA(XQTSV)
SET XQY=^(^XUTL("XQ",$JOB,"T"))
SET XQDIC=$PIECE($PIECE(XQY,U),+XQY,2)
SET XQY0=$PIECE(XQY,U,2,99)
SET XQY=+XQY
+4 KILL XQTSV
+5 ;
+6 ;Come to O1 if we're restarting from "Are We In Agreement" Store+4, +9
O1 KILL %,D0,DA,DI,DIC,DQ,DR,XQA,XQAA,XQDR,XQH,XQH1,XQH2,XQI,XQJ,XQK,XQLIST,XQLK,XQN,XQNM,XQOO,XQOPN,XQRD,XQRL,XQSAV,XQSN,XQTF,XQTF1,XQTM,XQTRPT,XQTT,XQTXT,XQUR
+1 KILL XQT,XQT1,XQTSAV,XQUP,XQFLAG,XQFLG,XQL,XQLN,XQSAVE,XQX
+2 QUIT
