YTQAPI1 ;ASF/ALB- MHAX REMOTE PROCEDURES ; 4/3/07 10:50am
;;5.01;MENTAL HEALTH;**85,119,121,141,217**;Dec 30, 1994;Build 12
;
;
;
Q
RULES(YSDATA,YS) ;list rules for a survey
;entry point for YTQ RULES rpc
;input: CODE as test name
;output: Field^Value
N YSBOOL,YSQID,YSRID,YSTESTN,YSTEST,G,G1,G2,N,N1,N2,Z
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 YSDATA(1)="[DATA]"
S N1=1
I '$D(^YTT(601.83,"C",YSTESTN)) S YSDATA(2)="No Rules" Q ;--> out
S N=0 F S N=$O(^YTT(601.83,"C",YSTESTN,N)) Q:N'>0 D
. S YSRID=$P(^YTT(601.83,N,0),U,4)
. S G=$G(^YTT(601.82,YSRID,0)) Q:G="" ;-->cross bad 83 vs 82
. S G1=$G(^YTT(601.82,YSRID,1)),G2=$G(^YTT(601.82,YSRID,2))
. S YSQID=$P(G,U,2) S:YSQID="" YSQID=0
. S YSBOOL=$P(G,U,6) S:YSBOOL="" YSBOOL=0
. S N1=N1+1
. S Z(YSQID,YSBOOL,N1,1)=$P(G,U)_"="_$P(G,U,2)_U_$P(G,U,4)_U_$P(G,U,5)_U_$P(G,U,3)_U_$P(G,U,6)_U_$P(G,U,7)
. S Z(YSQID,YSBOOL,N1,2)=$P(G1,U,2)_U_$P(G1,U,3)_U_$P(G1,U)
. S Z(YSQID,YSBOOL,N1,3)=$P(G2,U)_U_$S($P(G2,U,2)="Y":"YES",$P(G2,U,2)="N":"NO",1:"")
S N2=1
S YSQID=0 F S YSQID=$O(Z(YSQID)) Q:YSQID'>0 S YSBOOL="Z" F S YSBOOL=$O(Z(YSQID,YSBOOL),-1) Q:YSBOOL="" S N1=0 F S N1=$O(Z(YSQID,YSBOOL,N1)) Q:N1'>0 D
. S N2=N2+1,YSDATA(N2)=Z(YSQID,YSBOOL,N1,1)
. S N2=N2+1,YSDATA(N2)=Z(YSQID,YSBOOL,N1,2)
. S N2=N2+1,YSDATA(N2)=Z(YSQID,YSBOOL,N1,3)
Q
EDAD(YSDATA,YS) ;Edit and Save Data
N YSERR,YSX,YSNN,YSRESULT,G,YSF,YSV,N,YSIEN,YSFILEN
N YTTLKUP S YTTLKUP=1 ; don't filter 601.71
K ^TMP("YSMHI",$J)
S YSFILEN=$G(YS("FILEN"))
Q:YSFILEN<601 Q:YSFILEN>605
S YSIEN=$G(YS("IEN"),"?+1")_","
I YSFILEN="" S YSDATA(1)="[ERROR]",YSDATA(2)="bad filen " Q ;-->out
I YSFILEN=601.84 S N=$O(YS("FILEN"),-1)+1 S:'$D(YS(N)) YS(N)="18^`"_DUZ
S N=0 F S N=$O(YS(N)) Q:N'>0 D Q:$G(YSRESULT)="^"
. S G=YS(N)
. S YSF=$P(G,U),YSV=$P(G,U,2),YSX=$P(G,U,3)
. I '$$VFIELD^DILFD(YSFILEN,YSF) S YSRESULT=1 Q
. I YSV="" S YSRESULT=1 Q
. S ^TMP("YSMHI",$J,YSFILEN,YSIEN,YSF)=YSV
. D:YSX'=1 VAL^DIE(YSFILEN,YSIEN,+YSF,"E",YSV,.YSRESULT)
. ;
I $G(YSRESULT)="^" S YSDATA(1)="[ERROR]",YSDATA(2)="Value for Field Not Valid^"_YSV_U_YSF Q ;--> out
D UPDATE^DIE("E","^TMP(""YSMHI"",$J)","YSNN","YSERR")
I $D(YSERR) S YSDATA(1)="[ERROR]",YSDATA(2)="Update Error" Q ;-->out
S YSDATA(1)="[DATA]",YSDATA(2)="Update ok^"_$G(YSNN(1))_U_$G(YSNN(1,0))
;
Q
WPED(YSDATA,YS) ;Replace WP field
;entry point for YTQ WP FILER rpc
;INPUT: filen,ien,field,ys(1)...ys(x)= text
N YSF,N,YSIEN,YSERR,YSFILEN
N YTTLKUP S YTTLKUP=1 ; don't filter 601.71
K ^TMP("YSMHI",$J)
S YSFILEN=$G(YS("FILEN"))
I YSFILEN="" S YSDATA(1)="[ERROR]",YSDATA(2)="bad filen " Q ;-->out
S YSIEN=$G(YS("IEN"))
I YSIEN'?1N.N S YSDATA(1)="[ERROR]",YSDATA(2)="bad IEN " Q ;-->out
S YSIEN=YSIEN_","
S YSF=$G(YS("FIELD")) S X=$$VFIELD^DILFD(YSFILEN,YSF) I X=0 S YSDATA(1)="[ERROR]",YSDATA(2)="BAD FIELD #" Q ;-->out
S N=0 F S N=$O(YS(N)) Q:N'>0 D
. S ^TMP("YSMHI",$J,N)=$G(YS(N))
D WP^DIE(YSFILEN,YSIEN,YSF,,"^TMP(""YSMHI"",$J)","YSERR")
I $D(YSERR) S YSDATA(1)="[ERROR]",YSDATA(2)="very BAD Update Error" Q ;-->out
S YSDATA(1)="[DATA]",YSDATA(2)="ZZUpdate ok WP "_YSIEN
Q
GETANS(YSDATA,YS) ;get an answer
;entry point for YTQ GETANS rpc
;AD = ADMINISTRATION #
;QN= QUESTION #
N G,G1,N,YSAD,YSQN
S YSAD=$G(YS("AD"))
S YSQN=$G(YS("QN"))
I YSAD'?1N.N S YSDATA(1)="[ERROR]",YSDATA(2)="bad ad num" Q ;-->out
I YSQN'?1N.N S YSDATA(1)="[ERROR]",YSDATA(2)="bad quest num" Q ;-->out
I '$D(^YTT(601.85,"AC",YSAD,YSQN)) S YSDATA(1)="[ERROR]",YSDATA(2)="no such reference" Q ;-->out
S YSDATA(1)="[DATA]"
S G=0,N=1
S G=$O(^YTT(601.85,"AC",YSAD,YSQN,G)) Q:G'>0 S G1=0 D
. S:$P(^YTT(601.85,G,0),U,4)?1N.N N=N+1,YSDATA(N)=$P(^YTT(601.85,G,0),U,4) ;ASF 3/10/04 ***
. F S G1=$O(^YTT(601.85,G,1,G1)) Q:G1'>0 S N=N+1,YSDATA(N)=$G(^YTT(601.85,G,1,G1,0))
Q
CAPIE(YSDATA,YS) ;entry point for YTQ CAPIE rpc
N N,N1,N2,YSFIELDS,YSFILEN,YSIENS,X
K ^TMP("YS",$J)
K ^TMP("YSDATA",$J) S YSDATA=$NA(^TMP("YSDATA",$J))
S ^TMP("YSDATA",$J,1)="[ERROR]"
S YSFILEN=$G(YS("FILEN"),0) I $$VFILE^DILFD(YSFILEN)<1 S ^TMP("YSDATA",$J,2)="BAD FILE N" Q ;--->out
S YSFIELDS=$G(YS("FIELDS"),"")
S:YSFIELDS="*" YSFIELDS="**"
I YSFIELDS="**"&(YSFILEN=604) S YSFIELDS=".03:200"
I YSFIELDS?1N.N S N=$$VFIELD^DILFD(YSFILEN,YSFIELDS) I N<1 S ^TMP("YSDATA",$J,2)="BAD field" Q ;--> out
S YSIENS=$G(YS("IENS")) I YSIENS'?1N.N S ^TMP("YSDATA",$J,2)="BAD IENS" Q ;-->out
S YSIENS=YSIENS_","
D GETS^DIQ(YSFILEN,YSIENS,YSFIELDS,"IE","^TMP(""YS"",$J")
S N=1,^TMP("YSDATA",$J,1)="[DATA]"
S N1=0 F S N1=$O(^TMP("YS",$J,YSFILEN,YSIENS,N1)) Q:N1'>0 D
. S N2=0 F S N2=$O(^TMP("YS",$J,YSFILEN,YSIENS,N1,N2)) Q:N2'>0 S N=N+1,^TMP("YSDATA",$J,N)=N1_";"_N2_U_$$GET1^DID(YSFILEN,N1,"","LABEL")_U_^TMP("YS",$J,YSFILEN,YSIENS,N1,N2)
. I ^TMP("YS",$J,YSFILEN,YSIENS,N1,"I")'?1"^TMP(".E S N=N+1,^TMP("YSDATA",$J,N)=N1_U_$$GET1^DID(YSFILEN,N1,"","LABEL")_U_$G(^TMP("YS",$J,YSFILEN,YSIENS,N1,"I"))
. S:(^TMP("YS",$J,YSFILEN,YSIENS,N1,"E")'=^TMP("YS",$J,YSFILEN,YSIENS,N1,"I")) ^TMP("YSDATA",$J,N)=^TMP("YSDATA",$J,N)_U_^TMP("YS",$J,YSFILEN,YSIENS,N1,"E")
K ^TMP("YS",$J)
Q
ADMSAVE(YSDATA,YS) ; create new entry in MH ADMINISTRATIONS (601.84)
; ensure the YTQ ADMIN SAVE rpc can only modify 601.84
S YS("FILEN")=601.84
N I S I=0
F S I=$O(YS(I)) Q:'I I $P(YS(I),U)="15" S YS(I)="15^`"_$$SRC($P(YS(I),U,2))
D EDAD(.YSDATA,.YS)
Q
SRC(ANAME) ; return IEN for entry source, adding if needed
N IEN
S IEN=$O(^YTT(601.844,"C",$$UP^XLFSTR(ANAME),0))
I IEN QUIT IEN
;
N YTFDA,YTIEN,YTERR,DIERR
S YTFDA(601.844,"+1,",.01)=ANAME
D UPDATE^DIE("E","YTFDA","YTIEN","YTERR")
S IEN="" I '$D(DIERR),YTIEN(1) S IEN=YTIEN(1)
D CLEAN^DILF
Q IEN
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQAPI1 5951 printed Apr 09, 2024@21:20:49 Page 2
YTQAPI1 ;ASF/ALB- MHAX REMOTE PROCEDURES ; 4/3/07 10:50am
+1 ;;5.01;MENTAL HEALTH;**85,119,121,141,217**;Dec 30, 1994;Build 12
+2 ;
+3 ;
+4 ;
+5 QUIT
RULES(YSDATA,YS) ;list rules for a survey
+1 ;entry point for YTQ RULES rpc
+2 ;input: CODE as test name
+3 ;output: Field^Value
+4 NEW YSBOOL,YSQID,YSRID,YSTESTN,YSTEST,G,G1,G2,N,N1,N2,Z
+5 SET YSTEST=$GET(YS("CODE"))
+6 ;-->out
IF YSTEST=""
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="NO code"
QUIT
+7 SET YSTESTN=$ORDER(^YTT(601.71,"B",YSTEST,0))
+8 ;-->out
IF YSTESTN'>0
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad code"
QUIT
+9 SET YSDATA(1)="[DATA]"
+10 SET N1=1
+11 ;--> out
IF '$DATA(^YTT(601.83,"C",YSTESTN))
SET YSDATA(2)="No Rules"
QUIT
+12 SET N=0
FOR
SET N=$ORDER(^YTT(601.83,"C",YSTESTN,N))
if N'>0
QUIT
Begin DoDot:1
+13 SET YSRID=$PIECE(^YTT(601.83,N,0),U,4)
+14 ;-->cross bad 83 vs 82
SET G=$GET(^YTT(601.82,YSRID,0))
if G=""
QUIT
+15 SET G1=$GET(^YTT(601.82,YSRID,1))
SET G2=$GET(^YTT(601.82,YSRID,2))
+16 SET YSQID=$PIECE(G,U,2)
if YSQID=""
SET YSQID=0
+17 SET YSBOOL=$PIECE(G,U,6)
if YSBOOL=""
SET YSBOOL=0
+18 SET N1=N1+1
+19 SET Z(YSQID,YSBOOL,N1,1)=$PIECE(G,U)_"="_$PIECE(G,U,2)_U_$PIECE(G,U,4)_U_$PIECE(G,U,5)_U_$PIECE(G,U,3)_U_$PIECE(G,U,6)_U_$PIECE(G,U,7)
+20 SET Z(YSQID,YSBOOL,N1,2)=$PIECE(G1,U,2)_U_$PIECE(G1,U,3)_U_$PIECE(G1,U)
+21 SET Z(YSQID,YSBOOL,N1,3)=$PIECE(G2,U)_U_$SELECT($PIECE(G2,U,2)="Y":"YES",$PIECE(G2,U,2)="N":"NO",1:"")
End DoDot:1
+22 SET N2=1
+23 SET YSQID=0
FOR
SET YSQID=$ORDER(Z(YSQID))
if YSQID'>0
QUIT
SET YSBOOL="Z"
FOR
SET YSBOOL=$ORDER(Z(YSQID,YSBOOL),-1)
if YSBOOL=""
QUIT
SET N1=0
FOR
SET N1=$ORDER(Z(YSQID,YSBOOL,N1))
if N1'>0
QUIT
Begin DoDot:1
+24 SET N2=N2+1
SET YSDATA(N2)=Z(YSQID,YSBOOL,N1,1)
+25 SET N2=N2+1
SET YSDATA(N2)=Z(YSQID,YSBOOL,N1,2)
+26 SET N2=N2+1
SET YSDATA(N2)=Z(YSQID,YSBOOL,N1,3)
End DoDot:1
+27 QUIT
EDAD(YSDATA,YS) ;Edit and Save Data
+1 NEW YSERR,YSX,YSNN,YSRESULT,G,YSF,YSV,N,YSIEN,YSFILEN
+2 ; don't filter 601.71
NEW YTTLKUP
SET YTTLKUP=1
+3 KILL ^TMP("YSMHI",$JOB)
+4 SET YSFILEN=$GET(YS("FILEN"))
+5 if YSFILEN<601
QUIT
if YSFILEN>605
QUIT
+6 SET YSIEN=$GET(YS("IEN"),"?+1")_","
+7 ;-->out
IF YSFILEN=""
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad filen "
QUIT
+8 IF YSFILEN=601.84
SET N=$ORDER(YS("FILEN"),-1)+1
if '$DATA(YS(N))
SET YS(N)="18^`"_DUZ
+9 SET N=0
FOR
SET N=$ORDER(YS(N))
if N'>0
QUIT
Begin DoDot:1
+10 SET G=YS(N)
+11 SET YSF=$PIECE(G,U)
SET YSV=$PIECE(G,U,2)
SET YSX=$PIECE(G,U,3)
+12 IF '$$VFIELD^DILFD(YSFILEN,YSF)
SET YSRESULT=1
QUIT
+13 IF YSV=""
SET YSRESULT=1
QUIT
+14 SET ^TMP("YSMHI",$JOB,YSFILEN,YSIEN,YSF)=YSV
+15 if YSX'=1
DO VAL^DIE(YSFILEN,YSIEN,+YSF,"E",YSV,.YSRESULT)
+16 ;
End DoDot:1
if $GET(YSRESULT)="^"
QUIT
+17 ;--> out
IF $GET(YSRESULT)="^"
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="Value for Field Not Valid^"_YSV_U_YSF
QUIT
+18 DO UPDATE^DIE("E","^TMP(""YSMHI"",$J)","YSNN","YSERR")
+19 ;-->out
IF $DATA(YSERR)
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="Update Error"
QUIT
+20 SET YSDATA(1)="[DATA]"
SET YSDATA(2)="Update ok^"_$GET(YSNN(1))_U_$GET(YSNN(1,0))
+21 ;
+22 QUIT
WPED(YSDATA,YS) ;Replace WP field
+1 ;entry point for YTQ WP FILER rpc
+2 ;INPUT: filen,ien,field,ys(1)...ys(x)= text
+3 NEW YSF,N,YSIEN,YSERR,YSFILEN
+4 ; don't filter 601.71
NEW YTTLKUP
SET YTTLKUP=1
+5 KILL ^TMP("YSMHI",$JOB)
+6 SET YSFILEN=$GET(YS("FILEN"))
+7 ;-->out
IF YSFILEN=""
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad filen "
QUIT
+8 SET YSIEN=$GET(YS("IEN"))
+9 ;-->out
IF YSIEN'?1N.N
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad IEN "
QUIT
+10 SET YSIEN=YSIEN_","
+11 ;-->out
SET YSF=$GET(YS("FIELD"))
SET X=$$VFIELD^DILFD(YSFILEN,YSF)
IF X=0
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="BAD FIELD #"
QUIT
+12 SET N=0
FOR
SET N=$ORDER(YS(N))
if N'>0
QUIT
Begin DoDot:1
+13 SET ^TMP("YSMHI",$JOB,N)=$GET(YS(N))
End DoDot:1
+14 DO WP^DIE(YSFILEN,YSIEN,YSF,,"^TMP(""YSMHI"",$J)","YSERR")
+15 ;-->out
IF $DATA(YSERR)
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="very BAD Update Error"
QUIT
+16 SET YSDATA(1)="[DATA]"
SET YSDATA(2)="ZZUpdate ok WP "_YSIEN
+17 QUIT
GETANS(YSDATA,YS) ;get an answer
+1 ;entry point for YTQ GETANS rpc
+2 ;AD = ADMINISTRATION #
+3 ;QN= QUESTION #
+4 NEW G,G1,N,YSAD,YSQN
+5 SET YSAD=$GET(YS("AD"))
+6 SET YSQN=$GET(YS("QN"))
+7 ;-->out
IF YSAD'?1N.N
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad ad num"
QUIT
+8 ;-->out
IF YSQN'?1N.N
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="bad quest num"
QUIT
+9 ;-->out
IF '$DATA(^YTT(601.85,"AC",YSAD,YSQN))
SET YSDATA(1)="[ERROR]"
SET YSDATA(2)="no such reference"
QUIT
+10 SET YSDATA(1)="[DATA]"
+11 SET G=0
SET N=1
+12 SET G=$ORDER(^YTT(601.85,"AC",YSAD,YSQN,G))
if G'>0
QUIT
SET G1=0
Begin DoDot:1
+13 ;ASF 3/10/04 ***
if $PIECE(^YTT(601.85,G,0),U,4)?1N.N
SET N=N+1
SET YSDATA(N)=$PIECE(^YTT(601.85,G,0),U,4)
+14 FOR
SET G1=$ORDER(^YTT(601.85,G,1,G1))
if G1'>0
QUIT
SET N=N+1
SET YSDATA(N)=$GET(^YTT(601.85,G,1,G1,0))
End DoDot:1
+15 QUIT
CAPIE(YSDATA,YS) ;entry point for YTQ CAPIE rpc
+1 NEW N,N1,N2,YSFIELDS,YSFILEN,YSIENS,X
+2 KILL ^TMP("YS",$JOB)
+3 KILL ^TMP("YSDATA",$JOB)
SET YSDATA=$NAME(^TMP("YSDATA",$JOB))
+4 SET ^TMP("YSDATA",$JOB,1)="[ERROR]"
+5 ;--->out
SET YSFILEN=$GET(YS("FILEN"),0)
IF $$VFILE^DILFD(YSFILEN)<1
SET ^TMP("YSDATA",$JOB,2)="BAD FILE N"
QUIT
+6 SET YSFIELDS=$GET(YS("FIELDS"),"")
+7 if YSFIELDS="*"
SET YSFIELDS="**"
+8 IF YSFIELDS="**"&(YSFILEN=604)
SET YSFIELDS=".03:200"
+9 ;--> out
IF YSFIELDS?1N.N
SET N=$$VFIELD^DILFD(YSFILEN,YSFIELDS)
IF N<1
SET ^TMP("YSDATA",$JOB,2)="BAD field"
QUIT
+10 ;-->out
SET YSIENS=$GET(YS("IENS"))
IF YSIENS'?1N.N
SET ^TMP("YSDATA",$JOB,2)="BAD IENS"
QUIT
+11 SET YSIENS=YSIENS_","
+12 DO GETS^DIQ(YSFILEN,YSIENS,YSFIELDS,"IE","^TMP(""YS"",$J")
+13 SET N=1
SET ^TMP("YSDATA",$JOB,1)="[DATA]"
+14 SET N1=0
FOR
SET N1=$ORDER(^TMP("YS",$JOB,YSFILEN,YSIENS,N1))
if N1'>0
QUIT
Begin DoDot:1
+15 SET N2=0
FOR
SET N2=$ORDER(^TMP("YS",$JOB,YSFILEN,YSIENS,N1,N2))
if N2'>0
QUIT
SET N=N+1
SET ^TMP("YSDATA",$JOB,N)=N1_";"_N2_U_$$GET1^DID(YSFILEN,N1,"","LABEL")_U_^TMP("YS",$JOB,YSFILEN,YSIENS,N1,N2)
+16 IF ^TMP("YS",$JOB,YSFILEN,YSIENS,N1,"I")'?1"^TMP(".E
SET N=N+1
SET ^TMP("YSDATA",$JOB,N)=N1_U_$$GET1^DID(YSFILEN,N1,"","LABEL")_U_$GET(^TMP("YS",$JOB,YSFILEN,YSIENS,N1,"I"))
+17 if (^TMP("YS",$JOB,YSFILEN,YSIENS,N1,"E")'=^TMP("YS",$JOB,YSFILEN,YSIENS,N1,"I"))
SET ^TMP("YSDATA",$JOB,N)=^TMP("YSDATA",$JOB,N)_U_^TMP("YS",$JOB,YSFILEN,YSIENS,N1,"E")
End DoDot:1
+18 KILL ^TMP("YS",$JOB)
+19 QUIT
ADMSAVE(YSDATA,YS) ; create new entry in MH ADMINISTRATIONS (601.84)
+1 ; ensure the YTQ ADMIN SAVE rpc can only modify 601.84
+2 SET YS("FILEN")=601.84
+3 NEW I
SET I=0
+4 FOR
SET I=$ORDER(YS(I))
if 'I
QUIT
IF $PIECE(YS(I),U)="15"
SET YS(I)="15^`"_$$SRC($PIECE(YS(I),U,2))
+5 DO EDAD(.YSDATA,.YS)
+6 QUIT
SRC(ANAME) ; return IEN for entry source, adding if needed
+1 NEW IEN
+2 SET IEN=$ORDER(^YTT(601.844,"C",$$UP^XLFSTR(ANAME),0))
+3 IF IEN
QUIT IEN
+4 ;
+5 NEW YTFDA,YTIEN,YTERR,DIERR
+6 SET YTFDA(601.844,"+1,",.01)=ANAME
+7 DO UPDATE^DIE("E","YTFDA","YTIEN","YTERR")
+8 SET IEN=""
IF '$DATA(DIERR)
IF YTIEN(1)
SET IEN=YTIEN(1)
+9 DO CLEAN^DILF
+10 QUIT IEN
+11 ;
