- YTQAPI1 ;ASF/ALB - MHAX REMOTE PROCEDURES ;Oct 31, 2024@14:00:33
- ;;5.01;MENTAL HEALTH;**85,119,121,141,217,249,252,240,250**;Dec 30, 1994;Build 26
- ;
- ;
- ;
- 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,YSERRLOG
- N YTTLKUP S YTTLKUP=1 ; don't filter 601.71
- S YSERRLOG="EDAD^YTQAPI1 : Error Saving MH Administration"
- K ^TMP("YSMHI",$J)
- S YSFILEN=$G(YS("FILEN"))
- I (YSFILEN<601)!(YSFILEN>605) D QUIT
- . D ERR(.YSDATA,"bad filen ",YSERRLOG)
- S YSIEN=$G(YS("IEN"),"?+1")_","
- 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)="^" D QUIT
- . D ERR(.YSDATA,"Value for Field Not Valid^"_YSV_U_YSF,YSERRLOG)
- L +^YTT(YSFILEN,0):DILOCKTM
- I '$T D QUIT
- . D ERR(.YSDATA,"Could not save administration. (Failed to get lock on File #"_YSFILEN_").",YSERRLOG)
- D UPDATE^DIE("E","^TMP(""YSMHI"",$J)","YSNN","YSERR")
- L -^YTT(YSFILEN,0)
- I $D(YSERR) D QUIT
- . D ERR(.YSDATA,"Update Error",YSERRLOG)
- S YSDATA(1)="[DATA]",YSDATA(2)="Update ok^"_$G(YSNN(1))_U_$G(YSNN(1,0))
- ; publish add/edit admin event
- I YSFILEN=601.84 D UPADM^YTQEVNT($S(+$G(YSNN(1)):+YSNN(1),1:+$G(YS("IEN"))),"editadd")
- ;
- 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
- ;
- ERR(YSDATA,YSRETMSG,YSLOGMSG) ; Set return error array (YSDATA); and log error to VistA error trap
- N %ZT
- S YSDATA(1)="[ERROR]"
- S YSDATA(2)=YSRETMSG
- I +$$GET^XPAR("ALL","YS MHA LOG APPLICATION ERRORS",1,"I") D APPERROR^%ZTER(YSLOGMSG)
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQAPI1 6552 printed Feb 18, 2025@23:44:22 Page 2
- YTQAPI1 ;ASF/ALB - MHAX REMOTE PROCEDURES ;Oct 31, 2024@14:00:33
- +1 ;;5.01;MENTAL HEALTH;**85,119,121,141,217,249,252,240,250**;Dec 30, 1994;Build 26
- +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,YSERRLOG
- +2 ; don't filter 601.71
- NEW YTTLKUP
- SET YTTLKUP=1
- +3 SET YSERRLOG="EDAD^YTQAPI1 : Error Saving MH Administration"
- +4 KILL ^TMP("YSMHI",$JOB)
- +5 SET YSFILEN=$GET(YS("FILEN"))
- +6 IF (YSFILEN<601)!(YSFILEN>605)
- Begin DoDot:1
- +7 DO ERR(.YSDATA,"bad filen ",YSERRLOG)
- End DoDot:1
- QUIT
- +8 SET YSIEN=$GET(YS("IEN"),"?+1")_","
- +9 IF YSFILEN=601.84
- SET N=$ORDER(YS("FILEN"),-1)+1
- if '$DATA(YS(N))
- SET YS(N)="18^`"_DUZ
- +10 SET N=0
- FOR
- SET N=$ORDER(YS(N))
- if N'>0
- QUIT
- Begin DoDot:1
- +11 SET G=YS(N)
- +12 SET YSF=$PIECE(G,U)
- SET YSV=$PIECE(G,U,2)
- SET YSX=$PIECE(G,U,3)
- +13 IF '$$VFIELD^DILFD(YSFILEN,YSF)
- SET YSRESULT=1
- QUIT
- +14 IF YSV=""
- SET YSRESULT=1
- QUIT
- +15 SET ^TMP("YSMHI",$JOB,YSFILEN,YSIEN,YSF)=YSV
- +16 if YSX'=1
- DO VAL^DIE(YSFILEN,YSIEN,+YSF,"E",YSV,.YSRESULT)
- +17 ;
- End DoDot:1
- if $GET(YSRESULT)="^"
- QUIT
- +18 IF $GET(YSRESULT)="^"
- Begin DoDot:1
- +19 DO ERR(.YSDATA,"Value for Field Not Valid^"_YSV_U_YSF,YSERRLOG)
- End DoDot:1
- QUIT
- +20 LOCK +^YTT(YSFILEN,0):DILOCKTM
- +21 IF '$TEST
- Begin DoDot:1
- +22 DO ERR(.YSDATA,"Could not save administration. (Failed to get lock on File #"_YSFILEN_").",YSERRLOG)
- End DoDot:1
- QUIT
- +23 DO UPDATE^DIE("E","^TMP(""YSMHI"",$J)","YSNN","YSERR")
- +24 LOCK -^YTT(YSFILEN,0)
- +25 IF $DATA(YSERR)
- Begin DoDot:1
- +26 DO ERR(.YSDATA,"Update Error",YSERRLOG)
- End DoDot:1
- QUIT
- +27 SET YSDATA(1)="[DATA]"
- SET YSDATA(2)="Update ok^"_$GET(YSNN(1))_U_$GET(YSNN(1,0))
- +28 ; publish add/edit admin event
- +29 IF YSFILEN=601.84
- DO UPADM^YTQEVNT($SELECT(+$GET(YSNN(1)):+YSNN(1),1:+$GET(YS("IEN"))),"editadd")
- +30 ;
- +31 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 ;
- ERR(YSDATA,YSRETMSG,YSLOGMSG) ; Set return error array (YSDATA); and log error to VistA error trap
- +1 NEW %ZT
- +2 SET YSDATA(1)="[ERROR]"
- +3 SET YSDATA(2)=YSRETMSG
- +4 IF +$$GET^XPAR("ALL","YS MHA LOG APPLICATION ERRORS",1,"I")
- DO APPERROR^%ZTER(YSLOGMSG)
- +5 QUIT
- +6 ;