YTQAPI15 ;ASF/ALB MHA XML ;Nov 19, 2020@15:02
;;5.01;MENTAL HEALTH;**85,97,119,171**;Dec 30, 1994;Build 3
Q
MAIN ;
N N,G,YSCN,ICN,Y,YSA,YSAD,YSB,YSC,YSCN,YSCODE,YSD,YSDFN,YSDG,YSE,YSEA
N YSER,YSF,YSFIELD,YSFILE,YSIENS,YSJ,YSLOC,YSOD,YSQNUMB,YSQTEXT,YSR
N DFN,DIRUT,L1,L2,CNT,IDX,LEN,DUOUT,DTOUT,YSQUIT,POP,YSOUT
S YSQUIT=0
D SELAD
;YS*5.01*171: quit if user entered "^" at previous prompts or timeout occurred
Q:$G(DIRUT) Q:$G(DUOUT) Q:$G(DTOUT)
Q:YSQUIT
DEV S %ZIS="QM" D ^%ZIS Q:IO=""
;YS*5.01*171: POP = user entered "^" at device prompt.
I $G(POP) Q
I '$D(IO("Q")) W !,"Please Queue this job",! G DEV
D D ^%ZTLOAD D HOME^%ZIS K IO("Q") Q ;-->out
.S ZTRTN="ENQ^YTQAPI15",ZTDESC="MHA3 XML Export",ZTSAVE("YS*")=""
.S ZTIO=ION_";"_IOST
.I $D(IO("DOC"))#2,IO("DOC")]"" S ZTIO=ZTIO_";"_IO("DOC") Q
.I IOM S ZTIO=ZTIO_";"_IOM
.I IOSL S ZTIO=ZTIO_";"_IOSL
;
ENQ ;taskman entry
K ^TMP("YSXML",$J),^TMP("YSAD",$J)
S N=0
D SI:YSF="I",SP:YSF="P",SO:YSF="O",SL:YSF="L",SD:YSF="D"
I '$D(^TMP("YSAD",$J)) S ^TMP("YSXML",$J,1)="[ERROR]^no data" Q ;-->out
S N=N+1,^TMP("YSXML",$J,N)="<?xml version='1.0' encoding='UTF-8'?>"
S N=N+1,^TMP("YSXML",$J,N)="<Export>"
D ADMIN
S N=N+1,^TMP("YSXML",$J,N)="</Export>"
U IO S N=0 F S N=$O(^TMP("YSXML",$J,N)) Q:N'>0 W ^(N),!
D ^%ZISC
Q ;-->out
SELAD ;administation filter
W @IOF,!!,"MHA XML Export"
K DIR S DIR(0)="S^D:Date Only;I:Instrument;L:Location;P:Patient;O:Ordered By"
S DIR("A")="Filter By" D ^DIR
Q:$D(DIRUT)
S YSF=Y
K DIR S DIR(0)="DA^2961001:NOW:TX",DIR("A")="Begin date/time: ",DIR("B")="T-1M" D ^DIR
Q:$D(DIRUT)
S YSB=Y
K DIR S DIR(0)="DA^2961001:NOW:TX",DIR("A")="End date/time: ",DIR("B")="NOW" D ^DIR
Q:$D(DIRUT)
S YSE=Y
K DIR S DIR(0)="Y",DIR("A")="Export Answers",DIR("B")="No" D ^DIR
Q:$D(DIRUT)
S YSEA=Y
K DIR S DIR(0)="Y",DIR("A")="Export Results",DIR("B")="No" D ^DIR
Q:$D(DIRUT)
S YSER=Y
K DIC
N YTTLKUP S YTTLKUP=1 ; suppress filter
I YSF="I" D Q
. S DIC(0)="AEQ",DIC="^YTT(601.71,"
. D ^DIC
. I Y'>0 S YSQUIT=1 Q
. S YSCODE=$P(Y,U,2)
I YSF="P" D Q
. D ^YSLRP
. I $G(DFN)'>0 S YSQUIT=1
I YSF="O" D Q
. S DIC("A")="Ordered By: "
. S DIC(0)="AEQ",DIC="^VA(200,"
. D ^DIC
. I Y'>0 S YSQUIT=1 Q
. S YSOD=+Y
;YS*5.01*171: corrected line below to validate against file 44 instead of file 42
I YSF="L" D
. S DIC(0)="AEMQZ",DIC=44
. D ^DIC
. I Y'>0 S YSQUIT=1 Q
. S YSLOC=+Y
Q
SI ;select by instrument
S YSCN=$O(^YTT(601.71,"B",YSCODE,-1))
S YSD=YSB-.00001 F S YSD=$O(^YTT(601.84,"AC",YSCN,YSD)) Q:(YSD'>0)!(YSD>YSE) D
. S YSAD=0 F S YSAD=$O(^YTT(601.84,"AC",YSCN,YSD,YSAD)) Q:YSAD'>0 S ^TMP("YSAD",$J,YSAD)=""
Q
SP ;select by patient
S YSAD=0 F S YSAD=$O(^YTT(601.84,"C",YSDFN,YSAD)) Q:YSAD'>0 D
. S YSDG=$P(^YTT(601.84,YSAD,0),U,4)
. S:(YSDG'<YSB)&(YSDG'>(YSE+.9)) ^TMP("YSAD",$J,YSAD)=""
Q
SD ;select by Date Only
S YSAD=0 F S YSAD=$O(^YTT(601.84,"B",YSAD)) Q:YSAD'>0 D
. S YSDG=$P(^YTT(601.84,YSAD,0),U,4)
. S:(YSDG'<YSB)&(YSDG'>(YSE+.9)) ^TMP("YSAD",$J,YSAD)=""
Q
SO ;select by Ordered by
S YSAD=0 F S YSAD=$O(^YTT(601.84,"AO",YSOD,YSAD)) Q:YSAD'>0 D
. S YSDG=$P(^YTT(601.84,YSAD,0),U,4)
. S:(YSDG'<YSB)&(YSDG'>(YSE+.9)) ^TMP("YSAD",$J,YSAD)=""
Q
SL ;select by location
S YSAD=0 F S YSAD=$O(^YTT(601.84,"AL",YSLOC,YSAD)) Q:YSAD'>0 D
. S YSDG=$P(^YTT(601.84,YSAD,0),U,4)
. S:(YSDG'<YSB)&(YSDG'>(YSE+.9)) ^TMP("YSAD",$J,YSAD)=""
Q
ADMIN ;extract the data into an XML global
S YSAD=0 F S YSAD=$O(^TMP("YSAD",$J,YSAD)) Q:YSAD'>0 D
. S N=N+1,^TMP("YSXML",$J,N)="<Admin>"
. S N=N+1,^TMP("YSXML",$J,N)="<Admin_ID>"_YSAD_"</Admin_ID>"
. D FORM("Patient",601.84,YSAD,1)
. S DFN=$P(^YTT(601.84,YSAD,0),U,2),ICN=$$GETICN^MPIF001(DFN),N=N+1,^TMP("YSXML",$J,N)="<ICN>"_ICN_"</ICN>"
. D FORM("Instrument",601.84,YSAD,2)
. D FORM("Given",601.84,YSAD,3)
. D FORM("Saved",601.84,YSAD,4)
. D FORM("Ordered",601.84,YSAD,5)
. D FORM("Complete",601.84,YSAD,8)
. D FORM("Location",601.84,YSAD,13)
. D QUEST:YSEA
. D RESULT:YSER
. S N=N+1,^TMP("YSXML",$J,N)="</Admin>"
Q
FORM(YSTAG,YSFILE,YSIENS,YSFIELD) ;xml entry
N G,Y1,Y2
S N=N+1
S Y1=$$GET1^DIQ(YSFILE,YSIENS_",",YSFIELD)
S Y2=$$CONVSTR(Y1)
S G="<"_YSTAG_">"_Y2_"</"_YSTAG_">"
S ^TMP("YSXML",$J,N)=G
Q
QUEST ;answers out
S YSA=0,YSJ=0 F S YSA=$O(^YTT(601.85,"AD",YSAD,YSA)) Q:YSA'>0 D
. S N=N+1,^TMP("YSXML",$J,N)="<Quest>"
. S N=N+1,^TMP("YSXML",$J,N)="<Admin_ID>"_YSAD_"</Admin_ID>"
. S YSQNUMB=$P(^YTT(601.85,YSA,0),U,3)
. S N=N+1,^TMP("YSXML",$J,N)="<Qnumb>"_YSQNUMB_"</Qnumb>"
. S YSQTEXT=$G(^YTT(601.72,YSQNUMB,1,1,0))
. S N=N+1,^TMP("YSXML",$J,N)="<Qtext>"_YSQTEXT_"</Qtext>"
. S N=N+1,YSJ=YSJ+1,^TMP("YSXML",$J,N)="<Seq>"_YSJ_"</Seq>"
. D FORM("Choice",601.85,YSA,4)
. S N=N+1
. S YSC=$P(^YTT(601.85,YSA,0),U,4)
. S YSCN=$S(YSC?1N.N:^YTT(601.75,YSC,1),1:"???")
. S:$D(^YTT(601.85,YSA,1,1,0)) YSCN=^YTT(601.85,YSA,1,1,0)
. S ^TMP("YSXML",$J,N)="<Ans>"_YSCN_"</Ans>"
. S N=N+1,^TMP("YSXML",$J,N)="</Quest>"
Q
RESULT ;results out
S YSR=0
F S YSR=$O(^YTT(601.92,"AC",YSAD,YSR)) Q:YSR'>0 D
. S N=N+1,^TMP("YSXML",$J,N)="<Score>"
. S N=N+1,^TMP("YSXML",$J,N)="<Admin_ID>"_YSAD_"</Admin_ID>"
. D FORM("Scale",601.92,YSR,2)
. D FORM("Raw",601.92,YSR,3)
. D FORM("Trans1",601.92,YSR,4)
. S N=N+1,^TMP("YSXML",$J,N)="</Score>"
Q
HEAD ;
;
CONVSTR(YSIN) ;convert string to valid xml
S L1(1)="&",L2(1)="&" ; Keep "&" first
S L1(2)=">",L2(2)=">"
S L1(3)="<",L2(3)="<"
S L1(4)="'",L2(4)="'"
S L1(5)="""",L2(5)="""
S YSOUT=YSIN
F CNT=1:1:5 D
.S LEN=$L(L1(CNT))+1
.S IDX=0
.F S IDX=$F(YSOUT,L1(CNT),IDX) Q:IDX=0 D
.. S YSOUT=$E(YSOUT,1,IDX-LEN)_L2(CNT)_$E(YSOUT,IDX,250)
.. S IDX=IDX-(LEN-2)
Q YSOUT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQAPI15 5847 printed Sep 23, 2025@19:54:16 Page 2
YTQAPI15 ;ASF/ALB MHA XML ;Nov 19, 2020@15:02
+1 ;;5.01;MENTAL HEALTH;**85,97,119,171**;Dec 30, 1994;Build 3
+2 QUIT
MAIN ;
+1 NEW N,G,YSCN,ICN,Y,YSA,YSAD,YSB,YSC,YSCN,YSCODE,YSD,YSDFN,YSDG,YSE,YSEA
+2 NEW YSER,YSF,YSFIELD,YSFILE,YSIENS,YSJ,YSLOC,YSOD,YSQNUMB,YSQTEXT,YSR
+3 NEW DFN,DIRUT,L1,L2,CNT,IDX,LEN,DUOUT,DTOUT,YSQUIT,POP,YSOUT
+4 SET YSQUIT=0
+5 DO SELAD
+6 ;YS*5.01*171: quit if user entered "^" at previous prompts or timeout occurred
+7 if $GET(DIRUT)
QUIT
if $GET(DUOUT)
QUIT
if $GET(DTOUT)
QUIT
+8 if YSQUIT
QUIT
DEV SET %ZIS="QM"
DO ^%ZIS
if IO=""
QUIT
+1 ;YS*5.01*171: POP = user entered "^" at device prompt.
+2 IF $GET(POP)
QUIT
+3 IF '$DATA(IO("Q"))
WRITE !,"Please Queue this job",!
GOTO DEV
+4 ;-->out
Begin DoDot:1
+5 SET ZTRTN="ENQ^YTQAPI15"
SET ZTDESC="MHA3 XML Export"
SET ZTSAVE("YS*")=""
+6 SET ZTIO=ION_";"_IOST
+7 IF $DATA(IO("DOC"))#2
IF IO("DOC")]""
SET ZTIO=ZTIO_";"_IO("DOC")
QUIT
+8 IF IOM
SET ZTIO=ZTIO_";"_IOM
+9 IF IOSL
SET ZTIO=ZTIO_";"_IOSL
End DoDot:1
DO ^%ZTLOAD
DO HOME^%ZIS
KILL IO("Q")
QUIT
+10 ;
ENQ ;taskman entry
+1 KILL ^TMP("YSXML",$JOB),^TMP("YSAD",$JOB)
+2 SET N=0
+3 if YSF="I"
DO SI
if YSF="P"
DO SP
if YSF="O"
DO SO
if YSF="L"
DO SL
if YSF="D"
DO SD
+4 ;-->out
IF '$DATA(^TMP("YSAD",$JOB))
SET ^TMP("YSXML",$JOB,1)="[ERROR]^no data"
QUIT
+5 SET N=N+1
SET ^TMP("YSXML",$JOB,N)="<?xml version='1.0' encoding='UTF-8'?>"
+6 SET N=N+1
SET ^TMP("YSXML",$JOB,N)="<Export>"
+7 DO ADMIN
+8 SET N=N+1
SET ^TMP("YSXML",$JOB,N)="</Export>"
+9 USE IO
SET N=0
FOR
SET N=$ORDER(^TMP("YSXML",$JOB,N))
if N'>0
QUIT
WRITE ^(N),!
+10 DO ^%ZISC
+11 ;-->out
QUIT
SELAD ;administation filter
+1 WRITE @IOF,!!,"MHA XML Export"
+2 KILL DIR
SET DIR(0)="S^D:Date Only;I:Instrument;L:Location;P:Patient;O:Ordered By"
+3 SET DIR("A")="Filter By"
DO ^DIR
+4 if $DATA(DIRUT)
QUIT
+5 SET YSF=Y
+6 KILL DIR
SET DIR(0)="DA^2961001:NOW:TX"
SET DIR("A")="Begin date/time: "
SET DIR("B")="T-1M"
DO ^DIR
+7 if $DATA(DIRUT)
QUIT
+8 SET YSB=Y
+9 KILL DIR
SET DIR(0)="DA^2961001:NOW:TX"
SET DIR("A")="End date/time: "
SET DIR("B")="NOW"
DO ^DIR
+10 if $DATA(DIRUT)
QUIT
+11 SET YSE=Y
+12 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Export Answers"
SET DIR("B")="No"
DO ^DIR
+13 if $DATA(DIRUT)
QUIT
+14 SET YSEA=Y
+15 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Export Results"
SET DIR("B")="No"
DO ^DIR
+16 if $DATA(DIRUT)
QUIT
+17 SET YSER=Y
+18 KILL DIC
+19 ; suppress filter
NEW YTTLKUP
SET YTTLKUP=1
+20 IF YSF="I"
Begin DoDot:1
+21 SET DIC(0)="AEQ"
SET DIC="^YTT(601.71,"
+22 DO ^DIC
+23 IF Y'>0
SET YSQUIT=1
QUIT
+24 SET YSCODE=$PIECE(Y,U,2)
End DoDot:1
QUIT
+25 IF YSF="P"
Begin DoDot:1
+26 DO ^YSLRP
+27 IF $GET(DFN)'>0
SET YSQUIT=1
End DoDot:1
QUIT
+28 IF YSF="O"
Begin DoDot:1
+29 SET DIC("A")="Ordered By: "
+30 SET DIC(0)="AEQ"
SET DIC="^VA(200,"
+31 DO ^DIC
+32 IF Y'>0
SET YSQUIT=1
QUIT
+33 SET YSOD=+Y
End DoDot:1
QUIT
+34 ;YS*5.01*171: corrected line below to validate against file 44 instead of file 42
+35 IF YSF="L"
Begin DoDot:1
+36 SET DIC(0)="AEMQZ"
SET DIC=44
+37 DO ^DIC
+38 IF Y'>0
SET YSQUIT=1
QUIT
+39 SET YSLOC=+Y
End DoDot:1
+40 QUIT
SI ;select by instrument
+1 SET YSCN=$ORDER(^YTT(601.71,"B",YSCODE,-1))
+2 SET YSD=YSB-.00001
FOR
SET YSD=$ORDER(^YTT(601.84,"AC",YSCN,YSD))
if (YSD'>0)!(YSD>YSE)
QUIT
Begin DoDot:1
+3 SET YSAD=0
FOR
SET YSAD=$ORDER(^YTT(601.84,"AC",YSCN,YSD,YSAD))
if YSAD'>0
QUIT
SET ^TMP("YSAD",$JOB,YSAD)=""
End DoDot:1
+4 QUIT
SP ;select by patient
+1 SET YSAD=0
FOR
SET YSAD=$ORDER(^YTT(601.84,"C",YSDFN,YSAD))
if YSAD'>0
QUIT
Begin DoDot:1
+2 SET YSDG=$PIECE(^YTT(601.84,YSAD,0),U,4)
+3 if (YSDG'<YSB)&(YSDG'>(YSE+.9))
SET ^TMP("YSAD",$JOB,YSAD)=""
End DoDot:1
+4 QUIT
SD ;select by Date Only
+1 SET YSAD=0
FOR
SET YSAD=$ORDER(^YTT(601.84,"B",YSAD))
if YSAD'>0
QUIT
Begin DoDot:1
+2 SET YSDG=$PIECE(^YTT(601.84,YSAD,0),U,4)
+3 if (YSDG'<YSB)&(YSDG'>(YSE+.9))
SET ^TMP("YSAD",$JOB,YSAD)=""
End DoDot:1
+4 QUIT
SO ;select by Ordered by
+1 SET YSAD=0
FOR
SET YSAD=$ORDER(^YTT(601.84,"AO",YSOD,YSAD))
if YSAD'>0
QUIT
Begin DoDot:1
+2 SET YSDG=$PIECE(^YTT(601.84,YSAD,0),U,4)
+3 if (YSDG'<YSB)&(YSDG'>(YSE+.9))
SET ^TMP("YSAD",$JOB,YSAD)=""
End DoDot:1
+4 QUIT
SL ;select by location
+1 SET YSAD=0
FOR
SET YSAD=$ORDER(^YTT(601.84,"AL",YSLOC,YSAD))
if YSAD'>0
QUIT
Begin DoDot:1
+2 SET YSDG=$PIECE(^YTT(601.84,YSAD,0),U,4)
+3 if (YSDG'<YSB)&(YSDG'>(YSE+.9))
SET ^TMP("YSAD",$JOB,YSAD)=""
End DoDot:1
+4 QUIT
ADMIN ;extract the data into an XML global
+1 SET YSAD=0
FOR
SET YSAD=$ORDER(^TMP("YSAD",$JOB,YSAD))
if YSAD'>0
QUIT
Begin DoDot:1
+2 SET N=N+1
SET ^TMP("YSXML",$JOB,N)="<Admin>"
+3 SET N=N+1
SET ^TMP("YSXML",$JOB,N)="<Admin_ID>"_YSAD_"</Admin_ID>"
+4 DO FORM("Patient",601.84,YSAD,1)
+5 SET DFN=$PIECE(^YTT(601.84,YSAD,0),U,2)
SET ICN=$$GETICN^MPIF001(DFN)
SET N=N+1
SET ^TMP("YSXML",$JOB,N)="<ICN>"_ICN_"</ICN>"
+6 DO FORM("Instrument",601.84,YSAD,2)
+7 DO FORM("Given",601.84,YSAD,3)
+8 DO FORM("Saved",601.84,YSAD,4)
+9 DO FORM("Ordered",601.84,YSAD,5)
+10 DO FORM("Complete",601.84,YSAD,8)
+11 DO FORM("Location",601.84,YSAD,13)
+12 if YSEA
DO QUEST
+13 if YSER
DO RESULT
+14 SET N=N+1
SET ^TMP("YSXML",$JOB,N)="</Admin>"
End DoDot:1
+15 QUIT
FORM(YSTAG,YSFILE,YSIENS,YSFIELD) ;xml entry
+1 NEW G,Y1,Y2
+2 SET N=N+1
+3 SET Y1=$$GET1^DIQ(YSFILE,YSIENS_",",YSFIELD)
+4 SET Y2=$$CONVSTR(Y1)
+5 SET G="<"_YSTAG_">"_Y2_"</"_YSTAG_">"
+6 SET ^TMP("YSXML",$JOB,N)=G
+7 QUIT
QUEST ;answers out
+1 SET YSA=0
SET YSJ=0
FOR
SET YSA=$ORDER(^YTT(601.85,"AD",YSAD,YSA))
if YSA'>0
QUIT
Begin DoDot:1
+2 SET N=N+1
SET ^TMP("YSXML",$JOB,N)="<Quest>"
+3 SET N=N+1
SET ^TMP("YSXML",$JOB,N)="<Admin_ID>"_YSAD_"</Admin_ID>"
+4 SET YSQNUMB=$PIECE(^YTT(601.85,YSA,0),U,3)
+5 SET N=N+1
SET ^TMP("YSXML",$JOB,N)="<Qnumb>"_YSQNUMB_"</Qnumb>"
+6 SET YSQTEXT=$GET(^YTT(601.72,YSQNUMB,1,1,0))
+7 SET N=N+1
SET ^TMP("YSXML",$JOB,N)="<Qtext>"_YSQTEXT_"</Qtext>"
+8 SET N=N+1
SET YSJ=YSJ+1
SET ^TMP("YSXML",$JOB,N)="<Seq>"_YSJ_"</Seq>"
+9 DO FORM("Choice",601.85,YSA,4)
+10 SET N=N+1
+11 SET YSC=$PIECE(^YTT(601.85,YSA,0),U,4)
+12 SET YSCN=$SELECT(YSC?1N.N:^YTT(601.75,YSC,1),1:"???")
+13 if $DATA(^YTT(601.85,YSA,1,1,0))
SET YSCN=^YTT(601.85,YSA,1,1,0)
+14 SET ^TMP("YSXML",$JOB,N)="<Ans>"_YSCN_"</Ans>"
+15 SET N=N+1
SET ^TMP("YSXML",$JOB,N)="</Quest>"
End DoDot:1
+16 QUIT
RESULT ;results out
+1 SET YSR=0
+2 FOR
SET YSR=$ORDER(^YTT(601.92,"AC",YSAD,YSR))
if YSR'>0
QUIT
Begin DoDot:1
+3 SET N=N+1
SET ^TMP("YSXML",$JOB,N)="<Score>"
+4 SET N=N+1
SET ^TMP("YSXML",$JOB,N)="<Admin_ID>"_YSAD_"</Admin_ID>"
+5 DO FORM("Scale",601.92,YSR,2)
+6 DO FORM("Raw",601.92,YSR,3)
+7 DO FORM("Trans1",601.92,YSR,4)
+8 SET N=N+1
SET ^TMP("YSXML",$JOB,N)="</Score>"
End DoDot:1
+9 QUIT
HEAD ;
+1 ;
CONVSTR(YSIN) ;convert string to valid xml
+1 ; Keep "&" first
SET L1(1)="&"
SET L2(1)="&"
+2 SET L1(2)=">"
SET L2(2)=">"
+3 SET L1(3)="<"
SET L2(3)="<"
+4 SET L1(4)="'"
SET L2(4)="'"
+5 SET L1(5)=""""
SET L2(5)="""
+6 SET YSOUT=YSIN
+7 FOR CNT=1:1:5
Begin DoDot:1
+8 SET LEN=$LENGTH(L1(CNT))+1
+9 SET IDX=0
+10 FOR
SET IDX=$FIND(YSOUT,L1(CNT),IDX)
if IDX=0
QUIT
Begin DoDot:2
+11 SET YSOUT=$EXTRACT(YSOUT,1,IDX-LEN)_L2(CNT)_$EXTRACT(YSOUT,IDX,250)
+12 SET IDX=IDX-(LEN-2)
End DoDot:2
End DoDot:1
+13 QUIT YSOUT
