- 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 Feb 18, 2025@23:33:16 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