YTQAPI ;ASF/ALB - MHQ REMOTE PROCEEDURES ; 4/3/07 10:36am
;;5.01;MENTAL HEALTH;**85,130,141,182**;Dec 30, 1994;Build 13
;
; External Reference ICR#
; ------------------ -----
; DID 2052
; DIQ 2056
;
Q
TSLIST(YSDATA) ;list tests and surveys
;Input: none
;Output: TEST NAME = LAST EDIT DATE^OPERATIONAL^REQUIRES LISCENCE^LISCENCE CURRENT^IS LEGACY^IEN^R PRIVILEGE^IS NATIONAL^HAS BEEN OPERATIONAL
N YSTESTN,YSTEST,N,G,G1,G2,G3,G4,G5,G6,G7,G8
K ^TMP($J,"YSTL")
S YSDATA=$NA(^TMP($J,"YSTL"))
S N=1,^TMP($J,"YSTL",N)="[DATA]"
S YSTEST="" F S YSTEST=$O(^YTT(601.71,"B",YSTEST)) Q:YSTEST="" D
. I $E(YSTEST,1,4)="CAT-"!($E(YSTEST,1,4)="CAD-") Q ;CAT only in MHA-Web
. S YSTESTN=$O(^YTT(601.71,"B",YSTEST,0)) ;6
. S N=N+1
. S G=$$GET1^DIQ(601.71,YSTESTN_",",18,"I") ;1
. S G1=$$GET1^DIQ(601.71,YSTESTN_",",10,"E") ;2
. S G2=$$GET1^DIQ(601.71,YSTESTN_",",11,"E") ;3
. S G3=$$GET1^DIQ(601.71,YSTESTN_",",20,"E") ;4
. S G4=$$GET1^DIQ(601.71,YSTESTN_",",23,"E") ;5
. S G5=$$GET1^DIQ(601.71,YSTESTN_",",9,"E") ;7
. S G6=$$GET1^DIQ(601.71,YSTESTN_",",19,"E") ;8
. S G7=$$GET1^DIQ(601.71,YSTESTN_",",10.5,"E") ;9
. S G8=+$O(^YTT(601.712,"B",YSTESTN,0)) ;instrument hash
. I G8,$D(^YTT(601.712,G8,0)) S G8=$P(^YTT(601.712,G8,0),U,3)
. S ^TMP($J,"YSTL",N)=YSTEST_"="_G_U_G1_U_G2_U_G3_U_G4_U_YSTESTN_U_G5_U_G6_U_G7_U_U_G8
Q
TSLIST1(YSDATA,YS) ;list questions for a single test
;input: CODE as test name
;output: Field^Value
N YSTESTN,YSTEST,YSF,YSV,N,I,YSEI
S YSTEST=$G(YS("CODE"))
I YSTEST="" S YSDATA(1)="[ERROR]",YSDATA(2)="NO code" Q ;-->out
S YSTESTN=$O(^YTT(601.71,"B",YSTEST,0))
I YSTESTN'>0 S YSDATA(1)="[ERROR]",YSDATA(2)="bad code" Q ;-->out
S N=2,YSDATA(1)="[DATA]",YSDATA(2)="IEN="_YSTESTN
F I=.01,2,3,4,5,7,7.5,8,9,10,10.5,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,100.01,100.02,100.03,100.04 D
. S N=N+1
. S YSEI=$S(I=18:"I",1:"E")
. D FIELD^DID(601.71,I,"","LABEL","YSF")
. S YSV=$$GET1^DIQ(601.71,YSTESTN_",",I,YSEI)
. S YSDATA(N)=YSF("LABEL")_"="_YSV
Q
CHOICES(YSDATA,YS) ;list choices for a question
;input: CODE as test name
;output: 601.75(1) CHOICETYPE ID^SEQUENCE^CHOICE IFN^CHOICE TEXT^LEGACY VALUE
N YSCDA,YSIC,YSQN,YSN,YSN1,YSTESTN,YSTEST,YSF,YSV,N,G,YSCTYP,YSCTYPID,G,G1,X
S YSTEST=$G(YS("CODE"))
S YSTESTN=$O(^YTT(601.71,"B",YSTEST,0))
I YSTESTN'>0 S YSDATA(1)="[ERROR]",YSDATA(2)="bad code" Q ;-->out
S N=1,YSDATA(1)="[DATA]"
;
S YSIC=0
F S YSIC=$O(^YTT(601.76,"AC",YSTESTN,YSIC)) Q:YSIC'>0 S YSQN=$P(^YTT(601.76,YSIC,0),U,4) D
. S YSCTYP=$P($G(^YTT(601.72,YSQN,2)),U,3)
. S:YSCTYP'="" YSCTYPID(YSCTYP)=""
C2 ;
S YSN=0
F S YSN=$O(YSCTYPID(YSN)) Q:YSN'>0 D
. S YSN1=0 F S YSN1=$O(^YTT(601.751,"AC",YSN,YSN1)) Q:YSN1'>0 D
.. S YSCDA=0 F S YSCDA=$O(^YTT(601.751,"AC",YSN,YSN1,YSCDA)) Q:YSCDA'>0 D
... S N=N+1
... S YSDATA(N)=YSN_U_YSN1_U_YSCDA_U_$G(^YTT(601.75,YSCDA,1))_U_$P($G(^YTT(601.75,YSCDA,0)),U,2)
Q
SKIPPED(YSDATA,YS) ; skipped questions for an instrument
;input: CODE as test name
;output: QUESTIONID^SKIPQUESTIONID
; for single test in question,skipped order
N YSTESTN,YSTEST,N,N1,N2,YSQ,YSK,G
S YSTEST=$G(YS("CODE"))
S YSTESTN=$O(^YTT(601.71,"B",YSTEST,0))
I YSTESTN'>0 S YSDATA(1)="[ERROR]",YSDATA(2)="bad code" Q ;-->out
I '$D(^YTT(601.79,"AC",YSTESTN)) S YSDATA(1)="[ERROR]",YSDATA(2)="no entries for this code" Q ;--> out
S N=1,YSDATA(1)="[DATA]"
;
S N1=0 F S N1=$O(^YTT(601.79,"AC",YSTESTN,N1)) Q:N1'>0 D
. S G=^YTT(601.79,N1,0),YSQ=$P(G,U,3),YSK=$P(G,U,4)
. S:(YSQ?1N.N)&(YSK?1N.N) G(YSQ,YSK)=""
S N1=0 F S N1=$O(G(N1)) Q:N1'>0 S N2=0 F S N2=$O(G(N1,N2)) Q:N2'>0 S N=N+1,YSDATA(N)=N1_U_N2
Q
SECTION(YSDATA,YS) ;section captions
;input: CODE as test name
;output: FIRSTQUESTIONID^TABCAPTION^SECTIONCAPTION^DISPLAYID
; for single test in questionID order
N YSTESTN,YSTEST,N,N1,G,YSQ
S YSTEST=$G(YS("CODE"))
S YSTESTN=$O(^YTT(601.71,"B",YSTEST,0))
I YSTESTN'>0 S YSDATA(1)="[ERROR]",YSDATA(2)="bad code" Q ;-->out
I '$D(^YTT(601.81,"AC",YSTESTN)) S YSDATA(1)="[DATA]" Q ;-->out no entries for this code
S N=1,YSDATA(1)="[DATA]"
;
S N1=0 F S N1=$O(^YTT(601.81,"AC",YSTESTN,N1)) Q:N1'>0 D
. S G=^YTT(601.81,N1,0),YSQ=$P(G,U,3)
. S:(YSQ?1N.N) G(YSQ)=$P(G,U,3,6)
S N1=0 F S N1=$O(G(N1)) Q:N1'>0 D
. S N=N+1,YSDATA(N)=G(N1)
. S N=N+1,YSDATA(N)="DISPLAY=" S:$P(G(N1),U,4)?1N.N YSDATA(N)=YSDATA(N)_$$DISPEXT^YTQAPI5($P(G(N1),U,4))
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQAPI 4568 printed Oct 16, 2024@18:18:46 Page 2
YTQAPI ;ASF/ALB - MHQ REMOTE PROCEEDURES ; 4/3/07 10:36am
+1 ;;5.01;MENTAL HEALTH;**85,130,141,182**;Dec 30, 1994;Build 13
+2 ;
+3 ; External Reference ICR#
+4 ; ------------------ -----
+5 ; DID 2052
+6 ; DIQ 2056
+7 ;
+8 QUIT
TSLIST(YSDATA) ;list tests and surveys
+1 ;Input: none
+2 ;Output: TEST NAME = LAST EDIT DATE^OPERATIONAL^REQUIRES LISCENCE^LISCENCE CURRENT^IS LEGACY^IEN^R PRIVILEGE^IS NATIONAL^HAS BEEN OPERATIONAL
+3 NEW YSTESTN,YSTEST,N,G,G1,G2,G3,G4,G5,G6,G7,G8
+4 KILL ^TMP($JOB,"YSTL")
+5 SET YSDATA=$NAME(^TMP($JOB,"YSTL"))
+6 SET N=1
SET ^TMP($JOB,"YSTL",N)="[DATA]"
+7 SET YSTEST=""
FOR
SET YSTEST=$ORDER(^YTT(601.71,"B",YSTEST))
if YSTEST=""
QUIT
Begin DoDot:1
+8 ;CAT only in MHA-Web
IF $EXTRACT(YSTEST,1,4)="CAT-"!($EXTRACT(YSTEST,1,4)="CAD-")
QUIT
+9 ;6
SET YSTESTN=$ORDER(^YTT(601.71,"B",YSTEST,0))
+10 SET N=N+1
+11 ;1
SET G=$$GET1^DIQ(601.71,YSTESTN_",",18,"I")
+12 ;2
SET G1=$$GET1^DIQ(601.71,YSTESTN_",",10,"E")
+13 ;3
SET G2=$$GET1^DIQ(601.71,YSTESTN_",",11,"E")
+14 ;4
SET G3=$$GET1^DIQ(601.71,YSTESTN_",",20,"E")
+15 ;5
SET G4=$$GET1^DIQ(601.71,YSTESTN_",",23,"E")
+16 ;7
SET G5=$$GET1^DIQ(601.71,YSTESTN_",",9,"E")
+17 ;8
SET G6=$$GET1^DIQ(601.71,YSTESTN_",",19,"E")
+18 ;9
SET G7=$$GET1^DIQ(601.71,YSTESTN_",",10.5,"E")
+19 ;instrument hash
SET G8=+$ORDER(^YTT(601.712,"B",YSTESTN,0))
+20 IF G8
IF $DATA(^YTT(601.712,G8,0))
SET G8=$PIECE(^YTT(601.712,G8,0),U,3)
+21 SET ^TMP($JOB,"YSTL",N)=YSTEST_"="_G_U_G1_U_G2_U_G3_U_G4_U_YSTESTN_U_G5_U_G6_U_G7_U_U_G8
End DoDot:1
+22 QUIT
TSLIST1(YSDATA,YS) ;list questions for a single test
+1 ;input: CODE as test name
+2 ;output: Field^Value
+3 NEW YSTESTN,YSTEST,YSF,YSV,N,I,YSEI
+4 SET YSTEST=$GET(YS("CODE"))
+5 ;-->out
IF YSTEST=""
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="NO code"
QUIT
+6 SET YSTESTN=$ORDER(^YTT(601.71,"B",YSTEST,0))
+7 ;-->out
IF YSTESTN'>0
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad code"
QUIT
+8 SET N=2
SET YSDATA(1)="[DATA]"
SET YSDATA(2)="IEN="_YSTESTN
+9 FOR I=.01,2,3,4,5,7,7.5,8,9,10,10.5,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,100.01,100.02,100.03,100.04
Begin DoDot:1
+10 SET N=N+1
+11 SET YSEI=$SELECT(I=18:"I",1:"E")
+12 DO FIELD^DID(601.71,I,"","LABEL","YSF")
+13 SET YSV=$$GET1^DIQ(601.71,YSTESTN_",",I,YSEI)
+14 SET YSDATA(N)=YSF("LABEL")_"="_YSV
End DoDot:1
+15 QUIT
CHOICES(YSDATA,YS) ;list choices for a question
+1 ;input: CODE as test name
+2 ;output: 601.75(1) CHOICETYPE ID^SEQUENCE^CHOICE IFN^CHOICE TEXT^LEGACY VALUE
+3 NEW YSCDA,YSIC,YSQN,YSN,YSN1,YSTESTN,YSTEST,YSF,YSV,N,G,YSCTYP,YSCTYPID,G,G1,X
+4 SET YSTEST=$GET(YS("CODE"))
+5 SET YSTESTN=$ORDER(^YTT(601.71,"B",YSTEST,0))
+6 ;-->out
IF YSTESTN'>0
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad code"
QUIT
+7 SET N=1
SET YSDATA(1)="[DATA]"
+8 ;
+9 SET YSIC=0
+10 FOR
SET YSIC=$ORDER(^YTT(601.76,"AC",YSTESTN,YSIC))
if YSIC'>0
QUIT
SET YSQN=$PIECE(^YTT(601.76,YSIC,0),U,4)
Begin DoDot:1
+11 SET YSCTYP=$PIECE($GET(^YTT(601.72,YSQN,2)),U,3)
+12 if YSCTYP'=""
SET YSCTYPID(YSCTYP)=""
End DoDot:1
C2 ;
+1 SET YSN=0
+2 FOR
SET YSN=$ORDER(YSCTYPID(YSN))
if YSN'>0
QUIT
Begin DoDot:1
+3 SET YSN1=0
FOR
SET YSN1=$ORDER(^YTT(601.751,"AC",YSN,YSN1))
if YSN1'>0
QUIT
Begin DoDot:2
+4 SET YSCDA=0
FOR
SET YSCDA=$ORDER(^YTT(601.751,"AC",YSN,YSN1,YSCDA))
if YSCDA'>0
QUIT
Begin DoDot:3
+5 SET N=N+1
+6 SET YSDATA(N)=YSN_U_YSN1_U_YSCDA_U_$GET(^YTT(601.75,YSCDA,1))_U_$PIECE($GET(^YTT(601.75,YSCDA,0)),U,2)
End DoDot:3
End DoDot:2
End DoDot:1
+7 QUIT
SKIPPED(YSDATA,YS) ; skipped questions for an instrument
+1 ;input: CODE as test name
+2 ;output: QUESTIONID^SKIPQUESTIONID
+3 ; for single test in question,skipped order
+4 NEW YSTESTN,YSTEST,N,N1,N2,YSQ,YSK,G
+5 SET YSTEST=$GET(YS("CODE"))
+6 SET YSTESTN=$ORDER(^YTT(601.71,"B",YSTEST,0))
+7 ;-->out
IF YSTESTN'>0
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad code"
QUIT
+8 ;--> out
IF '$DATA(^YTT(601.79,"AC",YSTESTN))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="no entries for this code"
QUIT
+9 SET N=1
SET YSDATA(1)="[DATA]"
+10 ;
+11 SET N1=0
FOR
SET N1=$ORDER(^YTT(601.79,"AC",YSTESTN,N1))
if N1'>0
QUIT
Begin DoDot:1
+12 SET G=^YTT(601.79,N1,0)
SET YSQ=$PIECE(G,U,3)
SET YSK=$PIECE(G,U,4)
+13 if (YSQ?1N.N)&(YSK?1N.N)
SET G(YSQ,YSK)=""
End DoDot:1
+14 SET N1=0
FOR
SET N1=$ORDER(G(N1))
if N1'>0
QUIT
SET N2=0
FOR
SET N2=$ORDER(G(N1,N2))
if N2'>0
QUIT
SET N=N+1
SET YSDATA(N)=N1_U_N2
+15 QUIT
SECTION(YSDATA,YS) ;section captions
+1 ;input: CODE as test name
+2 ;output: FIRSTQUESTIONID^TABCAPTION^SECTIONCAPTION^DISPLAYID
+3 ; for single test in questionID order
+4 NEW YSTESTN,YSTEST,N,N1,G,YSQ
+5 SET YSTEST=$GET(YS("CODE"))
+6 SET YSTESTN=$ORDER(^YTT(601.71,"B",YSTEST,0))
+7 ;-->out
IF YSTESTN'>0
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad code"
QUIT
+8 ;-->out no entries for this code
IF '$DATA(^YTT(601.81,"AC",YSTESTN))
SET YSDATA(1)="[DATA]"
QUIT
+9 SET N=1
SET YSDATA(1)="[DATA]"
+10 ;
+11 SET N1=0
FOR
SET N1=$ORDER(^YTT(601.81,"AC",YSTESTN,N1))
if N1'>0
QUIT
Begin DoDot:1
+12 SET G=^YTT(601.81,N1,0)
SET YSQ=$PIECE(G,U,3)
+13 if (YSQ?1N.N)
SET G(YSQ)=$PIECE(G,U,3,6)
End DoDot:1
+14 SET N1=0
FOR
SET N1=$ORDER(G(N1))
if N1'>0
QUIT
Begin DoDot:1
+15 SET N=N+1
SET YSDATA(N)=G(N1)
+16 SET N=N+1
SET YSDATA(N)="DISPLAY="
if $PIECE(G(N1),U,4)?1N.N
SET YSDATA(N)=YSDATA(N)_$$DISPEXT^YTQAPI5($PIECE(G(N1),U,4))
End DoDot:1
+17 QUIT
+18 ;
