- YTQAPI3 ;ASF/ALB - MHQ REMOTE PROCEDURES CONT ; 4/3/07 11:53am
- ;;5.01;MENTAL HEALTH;**85,142**;DEC 30,1994;Build 14
- ;
- Q
- SCALEG(YSDATA,YS) ;returns all scale groups for an instrument
- ;input CODE
- ; output:SCALE NAME^ABBREVIATION^SCALE IEN^SCALE SEQUENCE^SCALE GROUP NAME^SCALE GRUOP IEN^GROUP SEQUENCE^ORD TITLE^MIN^INCREASE^MAX^GRID1^GRID2^GRID3
- ;
- N N,N1,G1,S1,G6,G7,YSCALEN,YSCN,YSCODE,YSGIEN,YSGN
- K ^TMP($J,"YSG") S YSDATA=$NA(^TMP($J,"YSG"))
- S YSCODE=$G(YS("CODE"))
- I '$D(^YTT(601.71,"B",YSCODE)) S ^TMP($J,"YSG",1)="[ERROR]",^TMP($J,"YSG",2)="BAD CODE" Q ;-->out
- S ^TMP($J,"YSG",1)="[DATA]",N=1,S1=0,G1=0
- S YSCN=$O(^YTT(601.71,"B",YSCODE,0))
- S YSGN=0 F S YSGN=$O(^YTT(601.86,"AC",YSCN,YSGN)) Q:YSGN'>0 D
- . S YSGIEN=0 F S YSGIEN=$O(^YTT(601.86,"AC",YSCN,YSGN,YSGIEN)) Q:YSGIEN'>0 D
- .. S N=N+1,G1=G1+1,^TMP($J,"YSG",N)="Group"_G1_"="_YSGIEN_U_$$GET1^DIQ(601.86,YSGIEN_",",1)_U_$P($G(^YTT(601.86,YSGIEN,0)),U,3,99)
- .. S N1=0 F S N1=$O(^YTT(601.87,"AC",YSGIEN,N1)) Q:N1'>0 D
- ... S YSCALEN=0 F S YSCALEN=$O(^YTT(601.87,"AC",YSGIEN,N1,YSCALEN)) Q:YSCALEN'>0 D
- .... S N=N+1,S1=S1+1,^TMP($J,"YSG",N)="Scale"_S1_"="_$G(^YTT(601.87,YSCALEN,0))
- Q
- BATTC(YSDATA,YS) ;battery content
- ; OUTPUT: BATTERY NAME ^ INSTRUMENT list sorted by BATTERY & SEQUENCE
- N N,N1,G7,YSBATS,YSBID,YSCONID,YSNAME,YSUB,YS1,YSBNAME
- S N=1,YSDATA(1)="[DATA]"
- S YSUB=0 F S YSUB=$O(^YTT(601.781,"AC",DUZ,YSUB)) Q:YSUB'>0 D
- . S YSBID=$P(^YTT(601.781,YSUB,0),U,3)
- . S YSBNAME=$P($G(^YTT(601.77,YSBID,0)),U,2)
- . S:$L(YSBNAME) YS1(YSBNAME)=YSBID
- S YSNAME="" F S YSNAME=$O(YS1(YSNAME)) Q:YSNAME="" S YSBID=YS1(YSNAME) D
- . S YSBATS=0 F S YSBATS=$O(^YTT(601.78,"AC",YSBID,YSBATS)) Q:YSBATS'>0 D
- .. S YSCONID=$O(^YTT(601.78,"AC",YSBID,YSBATS,0))
- ..S G7=$G(^YTT(601.78,YSCONID,0))
- .. S N=N+1,YSDATA(N)=$P(G7,U,2)_U_$P(^YTT(601.77,YSBID,0),U,2)_U_$P(G7,U,3,4)_U_$$GET1^DIQ(601.78,YSCONID_",",3)
- Q
- FIRSTWP(YSDATA,YS) ;first line of all intros
- ;returns the first line only of a WP field
- ;Input: FILEN(file number), FIELD (WP filed #)
- ;Ouput IEN^WP Text line 1
- N N,YSN,YSFILEN,YSFIELD
- S YSDATA=$NA(^TMP($J,"YSFWP")) K ^TMP($J,"YSFWP")
- S YSFILEN=$G(YS("FILEN"),0) I $$VFILE^DILFD(YSFILEN)<1 S ^TMP($J,"YSFWP",1)="[ERROR]",^TMP($J,"YSFWP",2)="BAD FILE N" Q ;--->out
- S YSFIELD=$G(YS("FIELD"),0) S N=$$VFIELD^DILFD(YSFILEN,YSFIELD) I N<1 S ^TMP($J,"YSFWP",1)="[ERROR]",^TMP($J,"YSFWP",2)="BAD field" Q ;--> out
- S YSN=0,N=1,^TMP($J,"YSFWP",1)="[DATA]"
- F S YSN=$O(^YTT(YSFILEN,YSN)) Q:YSN'>0 D
- . S N=N+1
- . S ^TMP($J,"YSFWP",N)=YSN_U_$G(^YTT(YSFILEN,YSN,YSFIELD,1,0))
- Q
- QUESTALL(YSDATA,YS) ;all questions for a test
- ;input: CODE as test name
- ;output: Field^Value
- N YSTESTN,YSTEST,YSF,YSV,N,N2,N3,YSEQX,YSIC,YSQN,G
- S YSDATA=$NA(^TMP($J,"YSQU")) K ^TMP($J,"YSQU")
- S YSTEST=$G(YS("CODE"))
- S YSTESTN=$O(^YTT(601.71,"B",YSTEST,0))
- I YSTESTN'>0 S ^TMP($J,"YSQU",1)="[ERROR]",^TMP($J,"YSQU",2)="bad code" Q ;-->out
- S N=2,N3=0,^TMP($J,"YSQU",1)="[DATA]"
- ;
- S YSEQX=0
- F S YSEQX=$O(^YTT(601.76,"AD",YSTESTN,YSEQX)) Q:YSEQX'>0 D
- . S YSIC=0 F S YSIC=$O(^YTT(601.76,"AD",YSTESTN,YSEQX,YSIC)) Q:YSIC'>0 S YSQN=$P(^YTT(601.76,YSIC,0),U,4) D QUEST2
- S ^TMP($J,"YSQU",2)="NUMBER OF QUESTIONS="_N3
- Q
- QUEST2 ;
- S N=N+1,N3=N3+1
- S ^TMP($J,"YSQU",N)="QUESTION NUMBER"_N3_"="_YSQN_U_$P(^YTT(601.76,YSIC,0),U,3)_U_$P(^YTT(601.76,YSIC,0),U,5)_U_YSIC
- S N2=0 F S N2=$O(^YTT(601.72,YSQN,1,N2)) Q:N2'>0 S N=N+1,^TMP($J,"YSQU",N)=$S(N2=1:"QUESTION TEXT"_N3_"=",1:"")_$G(^YTT(601.72,YSQN,1,N2,0))
- S N=N+1,G=$G(^YTT(601.72,YSQN,2))
- S ^TMP($J,"YSQU",N)="INTRO TEXT"_N3_"="_$S(+G>0:+G,1:"")_U D:+G
- . S N2=0 F S N2=$O(^YTT(601.73,+G,1,N2)) Q:N2'>0 S:N2>1 N=N+1 S ^TMP($J,"YSQU",N)=$G(^TMP($J,"YSQU",N))_$G(^YTT(601.73,+G,1,N2,0))
- S N=N+1
- S ^TMP($J,"YSQU",N)="DESC"_N3_"="_$P($G(^YTT(601.74,+$P(G,U,2),0)),U,2)_U_$P(G,U,3)_U_$P(G,U,4)_U_$P(G,U,5)_U_$P(G,U,6)_U_$P(G,U,7)_U
- S G=+$P(G,U,3),G=$O(^YTT(601.89,"B",G,0)) S:G>0 ^TMP($J,"YSQU",N)=^TMP($J,"YSQU",N)_$P(^YTT(601.89,G,0),U,2)
- S G=^YTT(601.76,YSIC,0)
- S N=N+1
- S ^TMP($J,"YSQU",N)="QDISPLAY"_N3_"=" S:$P(G,U,6)?1N.N ^TMP($J,"YSQU",N)=^TMP($J,"YSQU",N)_$$DISPEXT^YTQAPI5($P(G,U,6))
- S N=N+1
- S ^TMP($J,"YSQU",N)="IDISPLAY"_N3_"=" S:$P(G,U,7)?1N.N ^TMP($J,"YSQU",N)=^TMP($J,"YSQU",N)_$$DISPEXT^YTQAPI5($P(G,U,7))
- S N=N+1
- S ^TMP($J,"YSQU",N)="CDISPLAY"_N3_"=" S:$P(G,U,8)?1N.N ^TMP($J,"YSQU",N)=^TMP($J,"YSQU",N)_$$DISPEXT^YTQAPI5($P(G,U,8))
- Q
- PURGE(YSDATA,YS) ; delete a record
- ;input: FILEN (FILE #)
- ; IEN (internal record #)
- ;Output :only conformation
- N YSFILEN,YSROOT,YSNODE,DIK,DA
- S DA=$G(YS("IEN"),0)
- S YSFILEN=$G(YS("FILEN"),0)
- Q:YSFILEN<601 Q:YSFILEN>605 ; restrict to Mental Health
- I $$VFILE^DILFD(YSFILEN)<1 S YSDATA(1)="[ERROR]",YSDATA(2)="BAD FILE N" Q ;--->out
- S YSROOT=$$ROOT^DILFD(YSFILEN)
- S YSNODE=YSROOT_DA_",0)"
- I $D(@YSNODE)'>0 S YSDATA(1)="[ERROR]",YSDATA(2)="no such record" Q ;-->out
- S DIK=YSROOT D ^DIK
- S YSDATA(1)="[DATA]",YSDATA(2)="record "_DA_" of "_YSFILEN_" deleted"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQAPI3 5072 printed Feb 18, 2025@23:44:35 Page 2
- YTQAPI3 ;ASF/ALB - MHQ REMOTE PROCEDURES CONT ; 4/3/07 11:53am
- +1 ;;5.01;MENTAL HEALTH;**85,142**;DEC 30,1994;Build 14
- +2 ;
- +3 QUIT
- SCALEG(YSDATA,YS) ;returns all scale groups for an instrument
- +1 ;input CODE
- +2 ; output:SCALE NAME^ABBREVIATION^SCALE IEN^SCALE SEQUENCE^SCALE GROUP NAME^SCALE GRUOP IEN^GROUP SEQUENCE^ORD TITLE^MIN^INCREASE^MAX^GRID1^GRID2^GRID3
- +3 ;
- +4 NEW N,N1,G1,S1,G6,G7,YSCALEN,YSCN,YSCODE,YSGIEN,YSGN
- +5 KILL ^TMP($JOB,"YSG")
- SET YSDATA=$NAME(^TMP($JOB,"YSG"))
- +6 SET YSCODE=$GET(YS("CODE"))
- +7 ;-->out
- IF '$DATA(^YTT(601.71,"B",YSCODE))
- SET ^TMP($JOB,"YSG",1)="[ERROR]"
- SET ^TMP($JOB,"YSG",2)="BAD CODE"
- QUIT
- +8 SET ^TMP($JOB,"YSG",1)="[DATA]"
- SET N=1
- SET S1=0
- SET G1=0
- +9 SET YSCN=$ORDER(^YTT(601.71,"B",YSCODE,0))
- +10 SET YSGN=0
- FOR
- SET YSGN=$ORDER(^YTT(601.86,"AC",YSCN,YSGN))
- if YSGN'>0
- QUIT
- Begin DoDot:1
- +11 SET YSGIEN=0
- FOR
- SET YSGIEN=$ORDER(^YTT(601.86,"AC",YSCN,YSGN,YSGIEN))
- if YSGIEN'>0
- QUIT
- Begin DoDot:2
- +12 SET N=N+1
- SET G1=G1+1
- SET ^TMP($JOB,"YSG",N)="Group"_G1_"="_YSGIEN_U_$$GET1^DIQ(601.86,YSGIEN_",",1)_U_$PIECE($GET(^YTT(601.86,YSGIEN,0)),U,3,99)
- +13 SET N1=0
- FOR
- SET N1=$ORDER(^YTT(601.87,"AC",YSGIEN,N1))
- if N1'>0
- QUIT
- Begin DoDot:3
- +14 SET YSCALEN=0
- FOR
- SET YSCALEN=$ORDER(^YTT(601.87,"AC",YSGIEN,N1,YSCALEN))
- if YSCALEN'>0
- QUIT
- Begin DoDot:4
- +15 SET N=N+1
- SET S1=S1+1
- SET ^TMP($JOB,"YSG",N)="Scale"_S1_"="_$GET(^YTT(601.87,YSCALEN,0))
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +16 QUIT
- BATTC(YSDATA,YS) ;battery content
- +1 ; OUTPUT: BATTERY NAME ^ INSTRUMENT list sorted by BATTERY & SEQUENCE
- +2 NEW N,N1,G7,YSBATS,YSBID,YSCONID,YSNAME,YSUB,YS1,YSBNAME
- +3 SET N=1
- SET YSDATA(1)="[DATA]"
- +4 SET YSUB=0
- FOR
- SET YSUB=$ORDER(^YTT(601.781,"AC",DUZ,YSUB))
- if YSUB'>0
- QUIT
- Begin DoDot:1
- +5 SET YSBID=$PIECE(^YTT(601.781,YSUB,0),U,3)
- +6 SET YSBNAME=$PIECE($GET(^YTT(601.77,YSBID,0)),U,2)
- +7 if $LENGTH(YSBNAME)
- SET YS1(YSBNAME)=YSBID
- End DoDot:1
- +8 SET YSNAME=""
- FOR
- SET YSNAME=$ORDER(YS1(YSNAME))
- if YSNAME=""
- QUIT
- SET YSBID=YS1(YSNAME)
- Begin DoDot:1
- +9 SET YSBATS=0
- FOR
- SET YSBATS=$ORDER(^YTT(601.78,"AC",YSBID,YSBATS))
- if YSBATS'>0
- QUIT
- Begin DoDot:2
- +10 SET YSCONID=$ORDER(^YTT(601.78,"AC",YSBID,YSBATS,0))
- +11 SET G7=$GET(^YTT(601.78,YSCONID,0))
- +12 SET N=N+1
- SET YSDATA(N)=$PIECE(G7,U,2)_U_$PIECE(^YTT(601.77,YSBID,0),U,2)_U_$PIECE(G7,U,3,4)_U_$$GET1^DIQ(601.78,YSCONID_",",3)
- End DoDot:2
- End DoDot:1
- +13 QUIT
- FIRSTWP(YSDATA,YS) ;first line of all intros
- +1 ;returns the first line only of a WP field
- +2 ;Input: FILEN(file number), FIELD (WP filed #)
- +3 ;Ouput IEN^WP Text line 1
- +4 NEW N,YSN,YSFILEN,YSFIELD
- +5 SET YSDATA=$NAME(^TMP($JOB,"YSFWP"))
- KILL ^TMP($JOB,"YSFWP")
- +6 ;--->out
- SET YSFILEN=$GET(YS("FILEN"),0)
- IF $$VFILE^DILFD(YSFILEN)<1
- SET ^TMP($JOB,"YSFWP",1)="[ERROR]"
- SET ^TMP($JOB,"YSFWP",2)="BAD FILE N"
- QUIT
- +7 ;--> out
- SET YSFIELD=$GET(YS("FIELD"),0)
- SET N=$$VFIELD^DILFD(YSFILEN,YSFIELD)
- IF N<1
- SET ^TMP($JOB,"YSFWP",1)="[ERROR]"
- SET ^TMP($JOB,"YSFWP",2)="BAD field"
- QUIT
- +8 SET YSN=0
- SET N=1
- SET ^TMP($JOB,"YSFWP",1)="[DATA]"
- +9 FOR
- SET YSN=$ORDER(^YTT(YSFILEN,YSN))
- if YSN'>0
- QUIT
- Begin DoDot:1
- +10 SET N=N+1
- +11 SET ^TMP($JOB,"YSFWP",N)=YSN_U_$GET(^YTT(YSFILEN,YSN,YSFIELD,1,0))
- End DoDot:1
- +12 QUIT
- QUESTALL(YSDATA,YS) ;all questions for a test
- +1 ;input: CODE as test name
- +2 ;output: Field^Value
- +3 NEW YSTESTN,YSTEST,YSF,YSV,N,N2,N3,YSEQX,YSIC,YSQN,G
- +4 SET YSDATA=$NAME(^TMP($JOB,"YSQU"))
- KILL ^TMP($JOB,"YSQU")
- +5 SET YSTEST=$GET(YS("CODE"))
- +6 SET YSTESTN=$ORDER(^YTT(601.71,"B",YSTEST,0))
- +7 ;-->out
- IF YSTESTN'>0
- SET ^TMP($JOB,"YSQU",1)="[ERROR]"
- SET ^TMP($JOB,"YSQU",2)="bad code"
- QUIT
- +8 SET N=2
- SET N3=0
- SET ^TMP($JOB,"YSQU",1)="[DATA]"
- +9 ;
- +10 SET YSEQX=0
- +11 FOR
- SET YSEQX=$ORDER(^YTT(601.76,"AD",YSTESTN,YSEQX))
- if YSEQX'>0
- QUIT
- Begin DoDot:1
- +12 SET YSIC=0
- FOR
- SET YSIC=$ORDER(^YTT(601.76,"AD",YSTESTN,YSEQX,YSIC))
- if YSIC'>0
- QUIT
- SET YSQN=$PIECE(^YTT(601.76,YSIC,0),U,4)
- DO QUEST2
- End DoDot:1
- +13 SET ^TMP($JOB,"YSQU",2)="NUMBER OF QUESTIONS="_N3
- +14 QUIT
- QUEST2 ;
- +1 SET N=N+1
- SET N3=N3+1
- +2 SET ^TMP($JOB,"YSQU",N)="QUESTION NUMBER"_N3_"="_YSQN_U_$PIECE(^YTT(601.76,YSIC,0),U,3)_U_$PIECE(^YTT(601.76,YSIC,0),U,5)_U_YSIC
- +3 SET N2=0
- FOR
- SET N2=$ORDER(^YTT(601.72,YSQN,1,N2))
- if N2'>0
- QUIT
- SET N=N+1
- SET ^TMP($JOB,"YSQU",N)=$SELECT(N2=1:"QUESTION TEXT"_N3_"=",1:"")_$GET(^YTT(601.72,YSQN,1,N2,0))
- +4 SET N=N+1
- SET G=$GET(^YTT(601.72,YSQN,2))
- +5 SET ^TMP($JOB,"YSQU",N)="INTRO TEXT"_N3_"="_$SELECT(+G>0:+G,1:"")_U
- if +G
- Begin DoDot:1
- +6 SET N2=0
- FOR
- SET N2=$ORDER(^YTT(601.73,+G,1,N2))
- if N2'>0
- QUIT
- if N2>1
- SET N=N+1
- SET ^TMP($JOB,"YSQU",N)=$GET(^TMP($JOB,"YSQU",N))_$GET(^YTT(601.73,+G,1,N2,0))
- End DoDot:1
- +7 SET N=N+1
- +8 SET ^TMP($JOB,"YSQU",N)="DESC"_N3_"="_$PIECE($GET(^YTT(601.74,+$PIECE(G,U,2),0)),U,2)_U_$PIECE(G,U,3)_U_$PIECE(G,U,4)_U_$PIECE(G,U,5)_U_$PIECE(G,U,6)_U_$PIECE(G,U,7)_U
- +9 SET G=+$PIECE(G,U,3)
- SET G=$ORDER(^YTT(601.89,"B",G,0))
- if G>0
- SET ^TMP($JOB,"YSQU",N)=^TMP($JOB,"YSQU",N)_$PIECE(^YTT(601.89,G,0),U,2)
- +10 SET G=^YTT(601.76,YSIC,0)
- +11 SET N=N+1
- +12 SET ^TMP($JOB,"YSQU",N)="QDISPLAY"_N3_"="
- if $PIECE(G,U,6)?1N.N
- SET ^TMP($JOB,"YSQU",N)=^TMP($JOB,"YSQU",N)_$$DISPEXT^YTQAPI5($PIECE(G,U,6))
- +13 SET N=N+1
- +14 SET ^TMP($JOB,"YSQU",N)="IDISPLAY"_N3_"="
- if $PIECE(G,U,7)?1N.N
- SET ^TMP($JOB,"YSQU",N)=^TMP($JOB,"YSQU",N)_$$DISPEXT^YTQAPI5($PIECE(G,U,7))
- +15 SET N=N+1
- +16 SET ^TMP($JOB,"YSQU",N)="CDISPLAY"_N3_"="
- if $PIECE(G,U,8)?1N.N
- SET ^TMP($JOB,"YSQU",N)=^TMP($JOB,"YSQU",N)_$$DISPEXT^YTQAPI5($PIECE(G,U,8))
- +17 QUIT
- PURGE(YSDATA,YS) ; delete a record
- +1 ;input: FILEN (FILE #)
- +2 ; IEN (internal record #)
- +3 ;Output :only conformation
- +4 NEW YSFILEN,YSROOT,YSNODE,DIK,DA
- +5 SET DA=$GET(YS("IEN"),0)
- +6 SET YSFILEN=$GET(YS("FILEN"),0)
- +7 ; restrict to Mental Health
- if YSFILEN<601
- QUIT
- if YSFILEN>605
- QUIT
- +8 ;--->out
- IF $$VFILE^DILFD(YSFILEN)<1
- SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)="BAD FILE N"
- QUIT
- +9 SET YSROOT=$$ROOT^DILFD(YSFILEN)
- +10 SET YSNODE=YSROOT_DA_",0)"
- +11 ;-->out
- IF $DATA(@YSNODE)'>0
- SET YSDATA(1)="[ERROR]"
- SET YSDATA(2)="no such record"
- QUIT
- +12 SET DIK=YSROOT
- DO ^DIK
- +13 SET YSDATA(1)="[DATA]"
- SET YSDATA(2)="record "_DA_" of "_YSFILEN_" deleted"
- +14 QUIT