YTQAPI10 ;ASF/ALB MHQ COPY PROCEEDURES ;12/2/04 11:41am
;;5.01;MENTAL HEALTH;**85**;Dec 30, 1994;Build 48
Q
ZZ K YS,YSDATA R !,"OLD TEST: ",Z1:30 R !,"new test: ",Z2:30
S YS("ORIGINAL")=Z1,YS("NEW")=Z2 D COPY(.YSDATA,.YS)
Q
COPY(YSDATA,YS) ;copy instrument
N %X,%Y,DA,DIK,G,G1,G2,N,N1,N3,X,Y,YSDISNEW,YSDISOLD,YSECNEW,YSERR
N YSFILE,YSI,YSISRNEW,YSKEYNEW,YSKEYOLD,YSKIPNEW,YSN,YSN1,YSNAT,YSNEWI,YSNEWNAM,YSNEWNUM,YSOLDI,YSOLDNAM
N YSOLDNUM,YSPROG,YSQUNEW,YSQX,YSRULNEW,YSRULOLD,YSSGNEW,YSSGOLD,YSSLNEW,YSSLOLD,Z1,Z2
S YSERR=0
K ^TMP($J,"YSM")
D PARSE Q:YSERR ; set/check inputs
D INS ;add new test entry
D QUES ;duplicate questions
D INTRO ;introductions
D DISPLAY ; q<i>c displays
D SKIP ;skipped questions
D RULES^YTQAPI11 ;instrument rules and rules
D SECTION
D SCALES^YTQAPI11 ;scale grps,scales,keys
S YSDATA(1)="[DATA]"
Q
SECTION ;headings
S YSFILE=601.81,N=0
S N=$O(^YTT(601.81,"AC",YSOLDNUM,N)) Q:N'>0 D
. S G1=^YTT(601.81,N,0)
. S YSECNEW=$$NEW^YTQLIB(YSFILE)
. S ^YTT(601.81,YSECNEW,0)=G1
. S $P(^YTT(601.81,YSECNEW,0),U)=YSECNEW
. S $P(^YTT(601.81,YSECNEW,0),U,2)=YSNEWNUM
. S YSQX=$P(G1,U,3)
. I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.81,YSECNEW,0),U,3)=^TMP($J,"YSM","O",YSQX)
. S DA=YSECNEW,DIK="^YTT("_YSFILE_"," D IX^DIK
. S YSDISOLD=$P(G1,U,6)
. Q:YSDISOLD'?1N.N
. S YSDISNEW=$$NEW^YTQLIB(YSFILE)
. S %X="^YTT(601.88,"_YSDISOLD_","
. S %Y="^YTT(601.88,"_YSDISNEW_","
. D %XY^%RCR
. S $P(^YTT(601.88,YSDISNEW,0),U)=YSDISNEW
. S DA=YSDISNEW,DIK="^YTT(601.88," D IX^DIK
. S $P(^YTT(601.81,YSECNEW,0),U,6)=YSDISNEW
Q
SKIP ;skipped qs
S YSFILE=601.79,N=0
F S N=$O(^YTT(601.79,"AC",YSOLDNUM,N)) Q:N'>0 D
. S G1=^YTT(601.79,N,0)
. S YSKIPNEW=$$NEW^YTQLIB(YSFILE)
. S ^YTT(601.79,YSKIPNEW,0)=G1
. S $P(^YTT(601.79,YSKIPNEW,0),U)=YSKIPNEW
. S $P(^YTT(601.79,YSKIPNEW,0),U,2)=YSNEWNUM
. S YSQX=$P(G1,U,3)
. I (YSQX?1N.N)&($D(^TMP($J,"YSM","O",YSQX))) S $P(^YTT(601.79,YSKIPNEW,0),U,3)=^TMP($J,"YSM","O",YSQX)
S DA=YSKIPNEW,DIK="^YTT("_YSFILE_"," D IX^DIK
Q
DISPLAY ;display ques<intro<choice
S YSFILE=601.88
S YSN=0 F S YSN=$O(^YTT(601.76,"AC",YSNEWNUM,YSN)) Q:YSN'>0 D
. S G=^YTT(601.76,YSN,0)
. F YSI=7,8,9 S YSDISOLD=$P(G,U,YSI) D:YSDISOLD?1N.N
.. S YSDISNEW=$$NEW^YTQLIB(YSFILE)
.. S %X="^YTT("_YSFILE_","_YSDISOLD_","
.. S %Y="^YTT("_YSFILE_","_YSDISNEW_","
.. D %XY^%RCR
.. S $P(^YTT(601.88,YSDISNEW,0),U)=YSDISNEW
.. S DA=YSDISNEW,DIK="^YTT("_YSFILE_"," D IX^DIK
.. S $P(^YTT(601.76,YSN,0),U,YSI)=YSDISNEW
Q
INS ; new one
S YSFILE=601.71
S YSOLDNUM=$O(^YTT(601.71,"B",YSOLDNAM,-1))
S YSNEWNUM=$$NEW^YTQLIB(YSFILE)
S %X="^YTT("_YSFILE_","_YSOLDNUM_","
S %Y="^YTT("_YSFILE_","_YSNEWNUM_","
D %XY^%RCR
S $P(^YTT(YSFILE,YSNEWNUM,0),U)=YSNEWNAM
S $P(^YTT(YSFILE,YSNEWNUM,2),U,2)="U"
S $P(^YTT(YSFILE,YSNEWNUM,2),U,5)=""
S DA=YSNEWNUM,DIK="^YTT("_YSFILE_"," D IX^DIK
Q
QUES ;questions, content and intros
S N=0 F S N=$O(^YTT(601.76,"AD",YSOLDNUM,N)) Q:N'>0 D
. S YSQUNEW=$$NEW^YTQLIB(601.72)
. S %X="^YTT(601.72,"_N_","
. S %Y="^YTT(601.72,"_YSQUNEW_","
. D %XY^%RCR
. S $P(^YTT(601.72,YSQUNEW,0),U)=YSQUNEW
. S ^TMP($J,"YSM","N",YSQUNEW)=N
. S ^TMP($J,"YSM","O",N)=YSQUNEW
. S DA=YSQUNEW,DIK="^YTT(601.72," D IX^DIK ;xref questions
. S N1=0 F S N1=$O(^YTT(601.76,"AD",YSOLDNUM,N,N1)) Q:N1'>0 D
..S N3=$$NEW^YTQLIB(601.76)
.. S ^YTT(601.76,N3,0)=^YTT(601.76,N1,0)
.. S $P(^YTT(601.76,N3,0),U)=N3
.. S $P(^YTT(601.76,N3,0),U,2)=YSNEWNUM
.. S DA=N3,DIK="^YTT(601.76," D IX^DIK
Q
INTRO ;set intros
S N=0 F S N=$O(^TMP($J,"YSM","N",N)) Q:N'>0 D
. S YSOLDI=$P($G(^YTT(601.72,N,2)),U)
. Q:YSOLDI'?1N.N
. S YSNEWI=$$NEW^YTQLIB(601.73)
. S %X="^YTT(601.73,"_YSOLDI_","
. S %Y="^YTT(601.72,"_YSNEWI_","
. D %XY^%RCR
. S $P(^YTT(601.73,YSNEWI,0),U)=YSNEWI
. S DA=YSNEWI,DIK="^YTT(601.73," D IX^DIK
. S $P(^YTT(601.72,N,2),U)=YSNEWI
Q
PARSE ;get old name, new name and national
S YSOLDNAM=$G(YS("ORIGINAL"))
I YSOLDNAM="" S YSDATA(1)="[ERROR]",YSDATA(2)="bad orig",YSERR=1 Q ;-->out
I '$D(^YTT(601.71,"B",YSOLDNAM)) S YSDATA(1)="[ERROR]",YSDATA(2)="orig not found",YSERR=1 Q ;-->out
S YSNEWNAM=$G(YS("NEW"))
I YSNEWNAM="" S YSDATA(1)="[ERROR]",YSDATA(2)="bad new",YSERR=1 Q ;-->out
I $D(^YTT(601.71,"B",YSNEWNAM)) S YSDATA(1)="[ERROR]",YSDATA(2)="new already exits",YSERR=1 Q ;-->out
I $L(YSNEWNAM)>50!($L(YSNEWNAM)<3)!'(YSNEWNAM'?1P.E) S YSDATA(1)="[ERROR]",YSDATA(2)="new out out bounds",YSERR=1 Q ;-->out
S YSNAT=$G(YS("NATIONAL"),0)
K YSPROG S:YSNAT=1&($D(^XUSEC("YSPROG",DUZ))) YSPROG=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQAPI10 4657 printed Sep 23, 2025@19:54:11 Page 2
YTQAPI10 ;ASF/ALB MHQ COPY PROCEEDURES ;12/2/04 11:41am
+1 ;;5.01;MENTAL HEALTH;**85**;Dec 30, 1994;Build 48
+2 QUIT
ZZ KILL YS,YSDATA
READ !,"OLD TEST: ",Z1:30
READ !,"new test: ",Z2:30
+1 SET YS("ORIGINAL")=Z1
SET YS("NEW")=Z2
DO COPY(.YSDATA,.YS)
+2 QUIT
COPY(YSDATA,YS) ;copy instrument
+1 NEW %X,%Y,DA,DIK,G,G1,G2,N,N1,N3,X,Y,YSDISNEW,YSDISOLD,YSECNEW,YSERR
+2 NEW YSFILE,YSI,YSISRNEW,YSKEYNEW,YSKEYOLD,YSKIPNEW,YSN,YSN1,YSNAT,YSNEWI,YSNEWNAM,YSNEWNUM,YSOLDI,YSOLDNAM
+3 NEW YSOLDNUM,YSPROG,YSQUNEW,YSQX,YSRULNEW,YSRULOLD,YSSGNEW,YSSGOLD,YSSLNEW,YSSLOLD,Z1,Z2
+4 SET YSERR=0
+5 KILL ^TMP($JOB,"YSM")
+6 ; set/check inputs
DO PARSE
if YSERR
QUIT
+7 ;add new test entry
DO INS
+8 ;duplicate questions
DO QUES
+9 ;introductions
DO INTRO
+10 ; q<i>c displays
DO DISPLAY
+11 ;skipped questions
DO SKIP
+12 ;instrument rules and rules
DO RULES^YTQAPI11
+13 DO SECTION
+14 ;scale grps,scales,keys
DO SCALES^YTQAPI11
+15 SET YSDATA(1)="[DATA]"
+16 QUIT
SECTION ;headings
+1 SET YSFILE=601.81
SET N=0
+2 SET N=$ORDER(^YTT(601.81,"AC",YSOLDNUM,N))
if N'>0
QUIT
Begin DoDot:1
+3 SET G1=^YTT(601.81,N,0)
+4 SET YSECNEW=$$NEW^YTQLIB(YSFILE)
+5 SET ^YTT(601.81,YSECNEW,0)=G1
+6 SET $PIECE(^YTT(601.81,YSECNEW,0),U)=YSECNEW
+7 SET $PIECE(^YTT(601.81,YSECNEW,0),U,2)=YSNEWNUM
+8 SET YSQX=$PIECE(G1,U,3)
+9 IF (YSQX?1N.N)&($DATA(^TMP($JOB,"YSM","O",YSQX)))
SET $PIECE(^YTT(601.81,YSECNEW,0),U,3)=^TMP($JOB,"YSM","O",YSQX)
+10 SET DA=YSECNEW
SET DIK="^YTT("_YSFILE_","
DO IX^DIK
+11 SET YSDISOLD=$PIECE(G1,U,6)
+12 if YSDISOLD'?1N.N
QUIT
+13 SET YSDISNEW=$$NEW^YTQLIB(YSFILE)
+14 SET %X="^YTT(601.88,"_YSDISOLD_","
+15 SET %Y="^YTT(601.88,"_YSDISNEW_","
+16 DO %XY^%RCR
+17 SET $PIECE(^YTT(601.88,YSDISNEW,0),U)=YSDISNEW
+18 SET DA=YSDISNEW
SET DIK="^YTT(601.88,"
DO IX^DIK
+19 SET $PIECE(^YTT(601.81,YSECNEW,0),U,6)=YSDISNEW
End DoDot:1
+20 QUIT
SKIP ;skipped qs
+1 SET YSFILE=601.79
SET N=0
+2 FOR
SET N=$ORDER(^YTT(601.79,"AC",YSOLDNUM,N))
if N'>0
QUIT
Begin DoDot:1
+3 SET G1=^YTT(601.79,N,0)
+4 SET YSKIPNEW=$$NEW^YTQLIB(YSFILE)
+5 SET ^YTT(601.79,YSKIPNEW,0)=G1
+6 SET $PIECE(^YTT(601.79,YSKIPNEW,0),U)=YSKIPNEW
+7 SET $PIECE(^YTT(601.79,YSKIPNEW,0),U,2)=YSNEWNUM
+8 SET YSQX=$PIECE(G1,U,3)
+9 IF (YSQX?1N.N)&($DATA(^TMP($JOB,"YSM","O",YSQX)))
SET $PIECE(^YTT(601.79,YSKIPNEW,0),U,3)=^TMP($JOB,"YSM","O",YSQX)
End DoDot:1
+10 SET DA=YSKIPNEW
SET DIK="^YTT("_YSFILE_","
DO IX^DIK
+11 QUIT
DISPLAY ;display ques<intro<choice
+1 SET YSFILE=601.88
+2 SET YSN=0
FOR
SET YSN=$ORDER(^YTT(601.76,"AC",YSNEWNUM,YSN))
if YSN'>0
QUIT
Begin DoDot:1
+3 SET G=^YTT(601.76,YSN,0)
+4 FOR YSI=7,8,9
SET YSDISOLD=$PIECE(G,U,YSI)
if YSDISOLD?1N.N
Begin DoDot:2
+5 SET YSDISNEW=$$NEW^YTQLIB(YSFILE)
+6 SET %X="^YTT("_YSFILE_","_YSDISOLD_","
+7 SET %Y="^YTT("_YSFILE_","_YSDISNEW_","
+8 DO %XY^%RCR
+9 SET $PIECE(^YTT(601.88,YSDISNEW,0),U)=YSDISNEW
+10 SET DA=YSDISNEW
SET DIK="^YTT("_YSFILE_","
DO IX^DIK
+11 SET $PIECE(^YTT(601.76,YSN,0),U,YSI)=YSDISNEW
End DoDot:2
End DoDot:1
+12 QUIT
INS ; new one
+1 SET YSFILE=601.71
+2 SET YSOLDNUM=$ORDER(^YTT(601.71,"B",YSOLDNAM,-1))
+3 SET YSNEWNUM=$$NEW^YTQLIB(YSFILE)
+4 SET %X="^YTT("_YSFILE_","_YSOLDNUM_","
+5 SET %Y="^YTT("_YSFILE_","_YSNEWNUM_","
+6 DO %XY^%RCR
+7 SET $PIECE(^YTT(YSFILE,YSNEWNUM,0),U)=YSNEWNAM
+8 SET $PIECE(^YTT(YSFILE,YSNEWNUM,2),U,2)="U"
+9 SET $PIECE(^YTT(YSFILE,YSNEWNUM,2),U,5)=""
+10 SET DA=YSNEWNUM
SET DIK="^YTT("_YSFILE_","
DO IX^DIK
+11 QUIT
QUES ;questions, content and intros
+1 SET N=0
FOR
SET N=$ORDER(^YTT(601.76,"AD",YSOLDNUM,N))
if N'>0
QUIT
Begin DoDot:1
+2 SET YSQUNEW=$$NEW^YTQLIB(601.72)
+3 SET %X="^YTT(601.72,"_N_","
+4 SET %Y="^YTT(601.72,"_YSQUNEW_","
+5 DO %XY^%RCR
+6 SET $PIECE(^YTT(601.72,YSQUNEW,0),U)=YSQUNEW
+7 SET ^TMP($JOB,"YSM","N",YSQUNEW)=N
+8 SET ^TMP($JOB,"YSM","O",N)=YSQUNEW
+9 ;xref questions
SET DA=YSQUNEW
SET DIK="^YTT(601.72,"
DO IX^DIK
+10 SET N1=0
FOR
SET N1=$ORDER(^YTT(601.76,"AD",YSOLDNUM,N,N1))
if N1'>0
QUIT
Begin DoDot:2
+11 SET N3=$$NEW^YTQLIB(601.76)
+12 SET ^YTT(601.76,N3,0)=^YTT(601.76,N1,0)
+13 SET $PIECE(^YTT(601.76,N3,0),U)=N3
+14 SET $PIECE(^YTT(601.76,N3,0),U,2)=YSNEWNUM
+15 SET DA=N3
SET DIK="^YTT(601.76,"
DO IX^DIK
End DoDot:2
End DoDot:1
+16 QUIT
INTRO ;set intros
+1 SET N=0
FOR
SET N=$ORDER(^TMP($JOB,"YSM","N",N))
if N'>0
QUIT
Begin DoDot:1
+2 SET YSOLDI=$PIECE($GET(^YTT(601.72,N,2)),U)
+3 if YSOLDI'?1N.N
QUIT
+4 SET YSNEWI=$$NEW^YTQLIB(601.73)
+5 SET %X="^YTT(601.73,"_YSOLDI_","
+6 SET %Y="^YTT(601.72,"_YSNEWI_","
+7 DO %XY^%RCR
+8 SET $PIECE(^YTT(601.73,YSNEWI,0),U)=YSNEWI
+9 SET DA=YSNEWI
SET DIK="^YTT(601.73,"
DO IX^DIK
+10 SET $PIECE(^YTT(601.72,N,2),U)=YSNEWI
End DoDot:1
+11 QUIT
PARSE ;get old name, new name and national
+1 SET YSOLDNAM=$GET(YS("ORIGINAL"))
+2 ;-->out
IF YSOLDNAM=""
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad orig"
SET YSERR=1
QUIT
+3 ;-->out
IF '$DATA(^YTT(601.71,"B",YSOLDNAM))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="orig not found"
SET YSERR=1
QUIT
+4 SET YSNEWNAM=$GET(YS("NEW"))
+5 ;-->out
IF YSNEWNAM=""
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad new"
SET YSERR=1
QUIT
+6 ;-->out
IF $DATA(^YTT(601.71,"B",YSNEWNAM))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="new already exits"
SET YSERR=1
QUIT
+7 ;-->out
IF $LENGTH(YSNEWNAM)>50!($LENGTH(YSNEWNAM)<3)!'(YSNEWNAM'?1P.E)
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="new out out bounds"
SET YSERR=1
QUIT
+8 SET YSNAT=$GET(YS("NATIONAL"),0)
+9 KILL YSPROG
if YSNAT=1&($DATA(^XUSEC("YSPROG",DUZ)))
SET YSPROG=1
+10 QUIT
