YTQAPI13 ;ASF/ALB MHQ EXPORT PROCEEDURES ; 4/3/07 11:21am
;;5.01;MENTAL HEALTH;**85**;Dec 30, 1994;Build 48
Q
EXPORT(YSDATA,YS) ;export instrument
N %X,%Y,G,I,N,N1,N2,YSCALE,YSCI,YSCNT,YSDI,YSEQ,YSERR,YSFILE,YSKEY,YSN,YSNAM,YSNUM,YSQ,YSQN,YSR,YSCT
K ^TMP($J,"YSE"),^TMP($J,"YSQ")
S YSCNT=0
S YSERR=0
D PARSE Q:YSERR ; set/check inputs
S YSFILE=601.71 D SET(YSNUM) ; test entry
D CONTENT ;inst content
D QUES ;questions
D INTRO
D DISPLAY ; q<i>c displays
D CHOICE ;types & choices
D SKIP ;skipped questions
D RULES ;instrument rules and rules
D SECTION
D SCALES ;scale grps,scales,keys
D MAIL ;export mailman
Q
CHOICE ;
;choice type
S YSQ=0 F S YSQ=$O(^TMP($J,"YSQ",YSQ)) Q:YSQ="" D
. S YSCT=$P($G(^YTT(601.72,YSQ,2)),U,3)
. Q:YSCT'?1N.N
. S ^TMP($J,"YSCT",YSCT)=""
. S YSFILE=601.751 D SET(YSCT)
S YSCT=0 F S YSCT=$O(^TMP($J,"YSCT",YSCT)) Q:YSCT'>0 D
. S YSCI=$P($G(^YTT(601.751,0)),U,3)
. S YSFILE=601.75 D:YSCI?1N.N SET(YSCI)
Q
SCALES ;
;scale grp
S YSFILE=601.86
S YSN=0 F S N=$O(^YTT(601.86,"AD",YSNUM,YSN)) Q:YSN'>0 D
. S YSFILE=601.86 D SET(YSN)
. ;scales
. S YSCALE=0 F S YSCALE=$O(^YTT(601.87,"AD",YSN,YSCALE)) Q:YSCALE'>0 D
.. S YSFILE=601.87 D SET(YSCALE)
.. S YSKEY=0 F S YSKEY=$O(^YTT(601.91,"AC",YSCALE,YSKEY)) Q:YSKEY'>0 S YSFILE=601.91 D SET(YSKEY)
Q
RULES ;ins rules-rules
S YSFILE=601.83
S YSN=0 F S YSN=$O(^YTT(601.83,"C",YSNUM,YSN)) Q:YSN'>0 D
. D SET(YSN)
S YSFILE=601.82
S YSN=0 F S YSN=$O(^YTT(601.83,"C",YSNUM,YSN)) Q:YSN'>0 D
. S YSR=$P($G(^YTT(601.83,YSN,0)),U,4)
. D:YSR?1N.N SET(YSN)
Q
SECTION ;headings
S YSFILE=601.81
S YSN=0 F S YSN=$O(^YTT(601.81,"AC",YSNUM,YSN)) Q:YSN'>0 D
. D SET(YSN)
Q
SKIP ;skipped qs
S YSFILE=601.79
S YSN=0 F S YSN=$O(^YTT(601.79,"AC",YSNUM,YSN)) Q:YSN'>0 D
. D SET(YSN)
Q
DISPLAY ;display ques<intro<choice
S YSFILE=601.88
S YSN=0 F S YSN=$O(^YTT(601.76,"AC",YSNUM,YSN)) Q:YSN'>0 D
. S G=$G(^YTT(601.76,YSN,0))
. F I=7,8,9 S YSDI=$P(G,U,I) D:YSDI?1N.N SET(YSDI)
Q
CONTENT ;
S YSFILE=601.76
S YSEQ=0 F S YSEQ=$O(^YTT(601.76,"AD",YSNUM,YSEQ)) Q:YSEQ'>0 S YSN=0 F S YSN=$O(^YTT(601.76,"AD",YSNUM,YSEQ,YSN)) Q:YSN'>0 D
. D SET(YSN)
Q
QUES ;questions
S YSFILE=601.72
S YSEQ=0 F S YSEQ=$O(^YTT(601.76,"AD",YSNUM,YSEQ)) Q:YSEQ'>0 S YSN=0 F S YSN=$O(^YTT(601.76,"AD",YSNUM,YSEQ,YSN)) Q:YSN'>0 D
. S YSQN=$P(^YTT(601.76,YSN,0),U,4)
. S ^TMP($J,"YSQ",YSQN)=""
. D SET(YSQN)
Q
INTRO ;intros
S YSFILE=601.73
S YSQN=0 F S YSQN=$O(^TMP($J,"YSQ",YSQN)) Q:YSQN'>0 D
. S YSN=$P($G(^YTT(601.72,YSQN,2)),U)
. D:YSN>0 SET(YSN)
Q
PARSE ;get old name, new name and national
S YSERR=1,YSDATA(1)="[ERROR]"
S YSNAM=$G(YS("CODE"))
I YSNAM="" S YSDATA(2)="no code" Q ;-->out
I '$D(^YTT(601.71,"B",YSNAM)) S YSDATA(2)="bad code" Q ;--->out
S YSNUM=$O(^YTT(601.71,"B",YSNAM,0)),YSDATA(1)="[DATA]",YSERR=0
Q
MAIL ;Mailman
N XMSUB,XMTEXT,XMDUZ,XMY
S XMSUB="Export of "_YS("CODE")
S XMTEXT="^TMP($J,""YSE"","
S XMY(DUZ)=""
S XMDUZ="AUTOMATED MESSAGE"
D ^XMD
Q
SET(YSIEN) ;content set
S N=-1 F S N=$O(^YTT(YSFILE,YSIEN,N)) Q:N="" D G1
Q
G1 D:$D(^YTT(YSFILE,YSIEN,N))#2 S N1=-1 F S N1=$O(^YTT(YSFILE,YSIEN,N,N1)) Q:N1="" D G2
. S YSCNT=YSCNT+1
. S ^TMP($J,"YSE",YSCNT)="^TMP($J,""YSI"","_YSFILE_","_YSIEN_","_N_")"
. S YSCNT=YSCNT+1
. S ^TMP($J,"YSE",YSCNT)=^YTT(YSFILE,YSIEN,N)
Q
G2 D:$D(^YTT(YSFILE,YSIEN,N,N1))#2 S N2=-1 F S N2=$O(^YTT(YSFILE,YSIEN,N,N1,N2)) Q:N2="" D G3
. S YSCNT=YSCNT+1
. S ^TMP($J,"YSE",YSCNT)="^TMP($J,""YSI"","_YSFILE_","_YSIEN_","_N_","_N1_")"
. S YSCNT=YSCNT+1
. S ^TMP($J,"YSE",YSCNT)=^YTT(YSFILE,YSIEN,N,N1)
Q
G3 D:$D(^YTT(YSFILE,YSIEN,N,N1,N2))#2
. S YSCNT=YSCNT+1
. S ^TMP($J,"YSE",YSCNT)="^TMP($J,""YSI"","_YSFILE_","_YSIEN_","_N_","_N1_","_N2_")"
. S YSCNT=YSCNT+1
. S ^TMP($J,"YSE",YSCNT)=^YTT(YSFILE,YSIEN,N,N1,N2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQAPI13 3941 printed Apr 09, 2024@21:19:11 Page 2
YTQAPI13 ;ASF/ALB MHQ EXPORT PROCEEDURES ; 4/3/07 11:21am
+1 ;;5.01;MENTAL HEALTH;**85**;Dec 30, 1994;Build 48
+2 QUIT
EXPORT(YSDATA,YS) ;export instrument
+1 NEW %X,%Y,G,I,N,N1,N2,YSCALE,YSCI,YSCNT,YSDI,YSEQ,YSERR,YSFILE,YSKEY,YSN,YSNAM,YSNUM,YSQ,YSQN,YSR,YSCT
+2 KILL ^TMP($JOB,"YSE"),^TMP($JOB,"YSQ")
+3 SET YSCNT=0
+4 SET YSERR=0
+5 ; set/check inputs
DO PARSE
if YSERR
QUIT
+6 ; test entry
SET YSFILE=601.71
DO SET(YSNUM)
+7 ;inst content
DO CONTENT
+8 ;questions
DO QUES
+9 DO INTRO
+10 ; q<i>c displays
DO DISPLAY
+11 ;types & choices
DO CHOICE
+12 ;skipped questions
DO SKIP
+13 ;instrument rules and rules
DO RULES
+14 DO SECTION
+15 ;scale grps,scales,keys
DO SCALES
+16 ;export mailman
DO MAIL
+17 QUIT
CHOICE ;
+1 ;choice type
+2 SET YSQ=0
FOR
SET YSQ=$ORDER(^TMP($JOB,"YSQ",YSQ))
if YSQ=""
QUIT
Begin DoDot:1
+3 SET YSCT=$PIECE($GET(^YTT(601.72,YSQ,2)),U,3)
+4 if YSCT'?1N.N
QUIT
+5 SET ^TMP($JOB,"YSCT",YSCT)=""
+6 SET YSFILE=601.751
DO SET(YSCT)
End DoDot:1
+7 SET YSCT=0
FOR
SET YSCT=$ORDER(^TMP($JOB,"YSCT",YSCT))
if YSCT'>0
QUIT
Begin DoDot:1
+8 SET YSCI=$PIECE($GET(^YTT(601.751,0)),U,3)
+9 SET YSFILE=601.75
if YSCI?1N.N
DO SET(YSCI)
End DoDot:1
+10 QUIT
SCALES ;
+1 ;scale grp
+2 SET YSFILE=601.86
+3 SET YSN=0
FOR
SET N=$ORDER(^YTT(601.86,"AD",YSNUM,YSN))
if YSN'>0
QUIT
Begin DoDot:1
+4 SET YSFILE=601.86
DO SET(YSN)
+5 ;scales
+6 SET YSCALE=0
FOR
SET YSCALE=$ORDER(^YTT(601.87,"AD",YSN,YSCALE))
if YSCALE'>0
QUIT
Begin DoDot:2
+7 SET YSFILE=601.87
DO SET(YSCALE)
+8 SET YSKEY=0
FOR
SET YSKEY=$ORDER(^YTT(601.91,"AC",YSCALE,YSKEY))
if YSKEY'>0
QUIT
SET YSFILE=601.91
DO SET(YSKEY)
End DoDot:2
End DoDot:1
+9 QUIT
RULES ;ins rules-rules
+1 SET YSFILE=601.83
+2 SET YSN=0
FOR
SET YSN=$ORDER(^YTT(601.83,"C",YSNUM,YSN))
if YSN'>0
QUIT
Begin DoDot:1
+3 DO SET(YSN)
End DoDot:1
+4 SET YSFILE=601.82
+5 SET YSN=0
FOR
SET YSN=$ORDER(^YTT(601.83,"C",YSNUM,YSN))
if YSN'>0
QUIT
Begin DoDot:1
+6 SET YSR=$PIECE($GET(^YTT(601.83,YSN,0)),U,4)
+7 if YSR?1N.N
DO SET(YSN)
End DoDot:1
+8 QUIT
SECTION ;headings
+1 SET YSFILE=601.81
+2 SET YSN=0
FOR
SET YSN=$ORDER(^YTT(601.81,"AC",YSNUM,YSN))
if YSN'>0
QUIT
Begin DoDot:1
+3 DO SET(YSN)
End DoDot:1
+4 QUIT
SKIP ;skipped qs
+1 SET YSFILE=601.79
+2 SET YSN=0
FOR
SET YSN=$ORDER(^YTT(601.79,"AC",YSNUM,YSN))
if YSN'>0
QUIT
Begin DoDot:1
+3 DO SET(YSN)
End DoDot:1
+4 QUIT
DISPLAY ;display ques<intro<choice
+1 SET YSFILE=601.88
+2 SET YSN=0
FOR
SET YSN=$ORDER(^YTT(601.76,"AC",YSNUM,YSN))
if YSN'>0
QUIT
Begin DoDot:1
+3 SET G=$GET(^YTT(601.76,YSN,0))
+4 FOR I=7,8,9
SET YSDI=$PIECE(G,U,I)
if YSDI?1N.N
DO SET(YSDI)
End DoDot:1
+5 QUIT
CONTENT ;
+1 SET YSFILE=601.76
+2 SET YSEQ=0
FOR
SET YSEQ=$ORDER(^YTT(601.76,"AD",YSNUM,YSEQ))
if YSEQ'>0
QUIT
SET YSN=0
FOR
SET YSN=$ORDER(^YTT(601.76,"AD",YSNUM,YSEQ,YSN))
if YSN'>0
QUIT
Begin DoDot:1
+3 DO SET(YSN)
End DoDot:1
+4 QUIT
QUES ;questions
+1 SET YSFILE=601.72
+2 SET YSEQ=0
FOR
SET YSEQ=$ORDER(^YTT(601.76,"AD",YSNUM,YSEQ))
if YSEQ'>0
QUIT
SET YSN=0
FOR
SET YSN=$ORDER(^YTT(601.76,"AD",YSNUM,YSEQ,YSN))
if YSN'>0
QUIT
Begin DoDot:1
+3 SET YSQN=$PIECE(^YTT(601.76,YSN,0),U,4)
+4 SET ^TMP($JOB,"YSQ",YSQN)=""
+5 DO SET(YSQN)
End DoDot:1
+6 QUIT
INTRO ;intros
+1 SET YSFILE=601.73
+2 SET YSQN=0
FOR
SET YSQN=$ORDER(^TMP($JOB,"YSQ",YSQN))
if YSQN'>0
QUIT
Begin DoDot:1
+3 SET YSN=$PIECE($GET(^YTT(601.72,YSQN,2)),U)
+4 if YSN>0
DO SET(YSN)
End DoDot:1
+5 QUIT
PARSE ;get old name, new name and national
+1 SET YSERR=1
SET YSDATA(1)="[ERROR]"
+2 SET YSNAM=$GET(YS("CODE"))
+3 ;-->out
IF YSNAM=""
SET YSDATA(2)="no code"
QUIT
+4 ;--->out
IF '$DATA(^YTT(601.71,"B",YSNAM))
SET YSDATA(2)="bad code"
QUIT
+5 SET YSNUM=$ORDER(^YTT(601.71,"B",YSNAM,0))
SET YSDATA(1)="[DATA]"
SET YSERR=0
+6 QUIT
MAIL ;Mailman
+1 NEW XMSUB,XMTEXT,XMDUZ,XMY
+2 SET XMSUB="Export of "_YS("CODE")
+3 SET XMTEXT="^TMP($J,""YSE"","
+4 SET XMY(DUZ)=""
+5 SET XMDUZ="AUTOMATED MESSAGE"
+6 DO ^XMD
+7 QUIT
SET(YSIEN) ;content set
+1 SET N=-1
FOR
SET N=$ORDER(^YTT(YSFILE,YSIEN,N))
if N=""
QUIT
DO G1
+2 QUIT
G1 if $DATA(^YTT(YSFILE,YSIEN,N))#2
Begin DoDot:1
+1 SET YSCNT=YSCNT+1
+2 SET ^TMP($JOB,"YSE",YSCNT)="^TMP($J,""YSI"","_YSFILE_","_YSIEN_","_N_")"
+3 SET YSCNT=YSCNT+1
+4 SET ^TMP($JOB,"YSE",YSCNT)=^YTT(YSFILE,YSIEN,N)
End DoDot:1
SET N1=-1
FOR
SET N1=$ORDER(^YTT(YSFILE,YSIEN,N,N1))
if N1=""
QUIT
DO G2
+5 QUIT
G2 if $DATA(^YTT(YSFILE,YSIEN,N,N1))#2
Begin DoDot:1
+1 SET YSCNT=YSCNT+1
+2 SET ^TMP($JOB,"YSE",YSCNT)="^TMP($J,""YSI"","_YSFILE_","_YSIEN_","_N_","_N1_")"
+3 SET YSCNT=YSCNT+1
+4 SET ^TMP($JOB,"YSE",YSCNT)=^YTT(YSFILE,YSIEN,N,N1)
End DoDot:1
SET N2=-1
FOR
SET N2=$ORDER(^YTT(YSFILE,YSIEN,N,N1,N2))
if N2=""
QUIT
DO G3
+5 QUIT
G3 if $DATA(^YTT(YSFILE,YSIEN,N,N1,N2))#2
Begin DoDot:1
+1 SET YSCNT=YSCNT+1
+2 SET ^TMP($JOB,"YSE",YSCNT)="^TMP($J,""YSI"","_YSFILE_","_YSIEN_","_N_","_N1_","_N2_")"
+3 SET YSCNT=YSCNT+1
+4 SET ^TMP($JOB,"YSE",YSCNT)=^YTT(YSFILE,YSIEN,N,N1,N2)
End DoDot:1
+5 QUIT
