Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: YTQAPI15

YTQAPI15.m

Go to the documentation of this file.
  1. YTQAPI15 ;ASF/ALB MHA XML ;Nov 19, 2020@15:02
  1. ;;5.01;MENTAL HEALTH;**85,97,119,171**;Dec 30, 1994;Build 3
  1. Q
  1. MAIN ;
  1. N N,G,YSCN,ICN,Y,YSA,YSAD,YSB,YSC,YSCN,YSCODE,YSD,YSDFN,YSDG,YSE,YSEA
  1. N YSER,YSF,YSFIELD,YSFILE,YSIENS,YSJ,YSLOC,YSOD,YSQNUMB,YSQTEXT,YSR
  1. N DFN,DIRUT,L1,L2,CNT,IDX,LEN,DUOUT,DTOUT,YSQUIT,POP,YSOUT
  1. S YSQUIT=0
  1. D SELAD
  1. ;YS*5.01*171: quit if user entered "^" at previous prompts or timeout occurred
  1. Q:$G(DIRUT) Q:$G(DUOUT) Q:$G(DTOUT)
  1. Q:YSQUIT
  1. DEV S %ZIS="QM" D ^%ZIS Q:IO=""
  1. ;YS*5.01*171: POP = user entered "^" at device prompt.
  1. I $G(POP) Q
  1. I '$D(IO("Q")) W !,"Please Queue this job",! G DEV
  1. D D ^%ZTLOAD D HOME^%ZIS K IO("Q") Q ;-->out
  1. .S ZTRTN="ENQ^YTQAPI15",ZTDESC="MHA3 XML Export",ZTSAVE("YS*")=""
  1. .S ZTIO=ION_";"_IOST
  1. .I $D(IO("DOC"))#2,IO("DOC")]"" S ZTIO=ZTIO_";"_IO("DOC") Q
  1. .I IOM S ZTIO=ZTIO_";"_IOM
  1. .I IOSL S ZTIO=ZTIO_";"_IOSL
  1. ;
  1. ENQ ;taskman entry
  1. K ^TMP("YSXML",$J),^TMP("YSAD",$J)
  1. S N=0
  1. D SI:YSF="I",SP:YSF="P",SO:YSF="O",SL:YSF="L",SD:YSF="D"
  1. I '$D(^TMP("YSAD",$J)) S ^TMP("YSXML",$J,1)="[ERROR]^no data" Q ;-->out
  1. S N=N+1,^TMP("YSXML",$J,N)="<?xml version='1.0' encoding='UTF-8'?>"
  1. S N=N+1,^TMP("YSXML",$J,N)="<Export>"
  1. D ADMIN
  1. S N=N+1,^TMP("YSXML",$J,N)="</Export>"
  1. U IO S N=0 F S N=$O(^TMP("YSXML",$J,N)) Q:N'>0 W ^(N),!
  1. D ^%ZISC
  1. Q ;-->out
  1. SELAD ;administation filter
  1. W @IOF,!!,"MHA XML Export"
  1. K DIR S DIR(0)="S^D:Date Only;I:Instrument;L:Location;P:Patient;O:Ordered By"
  1. S DIR("A")="Filter By" D ^DIR
  1. Q:$D(DIRUT)
  1. S YSF=Y
  1. K DIR S DIR(0)="DA^2961001:NOW:TX",DIR("A")="Begin date/time: ",DIR("B")="T-1M" D ^DIR
  1. Q:$D(DIRUT)
  1. S YSB=Y
  1. K DIR S DIR(0)="DA^2961001:NOW:TX",DIR("A")="End date/time: ",DIR("B")="NOW" D ^DIR
  1. Q:$D(DIRUT)
  1. S YSE=Y
  1. K DIR S DIR(0)="Y",DIR("A")="Export Answers",DIR("B")="No" D ^DIR
  1. Q:$D(DIRUT)
  1. S YSEA=Y
  1. K DIR S DIR(0)="Y",DIR("A")="Export Results",DIR("B")="No" D ^DIR
  1. Q:$D(DIRUT)
  1. S YSER=Y
  1. K DIC
  1. N YTTLKUP S YTTLKUP=1 ; suppress filter
  1. I YSF="I" D Q
  1. . S DIC(0)="AEQ",DIC="^YTT(601.71,"
  1. . D ^DIC
  1. . I Y'>0 S YSQUIT=1 Q
  1. . S YSCODE=$P(Y,U,2)
  1. I YSF="P" D Q
  1. . D ^YSLRP
  1. . I $G(DFN)'>0 S YSQUIT=1
  1. I YSF="O" D Q
  1. . S DIC("A")="Ordered By: "
  1. . S DIC(0)="AEQ",DIC="^VA(200,"
  1. . D ^DIC
  1. . I Y'>0 S YSQUIT=1 Q
  1. . S YSOD=+Y
  1. ;YS*5.01*171: corrected line below to validate against file 44 instead of file 42
  1. I YSF="L" D
  1. . S DIC(0)="AEMQZ",DIC=44
  1. . D ^DIC
  1. . I Y'>0 S YSQUIT=1 Q
  1. . S YSLOC=+Y
  1. Q
  1. SI ;select by instrument
  1. S YSCN=$O(^YTT(601.71,"B",YSCODE,-1))
  1. S YSD=YSB-.00001 F S YSD=$O(^YTT(601.84,"AC",YSCN,YSD)) Q:(YSD'>0)!(YSD>YSE) D
  1. . S YSAD=0 F S YSAD=$O(^YTT(601.84,"AC",YSCN,YSD,YSAD)) Q:YSAD'>0 S ^TMP("YSAD",$J,YSAD)=""
  1. Q
  1. SP ;select by patient
  1. S YSAD=0 F S YSAD=$O(^YTT(601.84,"C",YSDFN,YSAD)) Q:YSAD'>0 D
  1. . S YSDG=$P(^YTT(601.84,YSAD,0),U,4)
  1. . S:(YSDG'<YSB)&(YSDG'>(YSE+.9)) ^TMP("YSAD",$J,YSAD)=""
  1. Q
  1. SD ;select by Date Only
  1. S YSAD=0 F S YSAD=$O(^YTT(601.84,"B",YSAD)) Q:YSAD'>0 D
  1. . S YSDG=$P(^YTT(601.84,YSAD,0),U,4)
  1. . S:(YSDG'<YSB)&(YSDG'>(YSE+.9)) ^TMP("YSAD",$J,YSAD)=""
  1. Q
  1. SO ;select by Ordered by
  1. S YSAD=0 F S YSAD=$O(^YTT(601.84,"AO",YSOD,YSAD)) Q:YSAD'>0 D
  1. . S YSDG=$P(^YTT(601.84,YSAD,0),U,4)
  1. . S:(YSDG'<YSB)&(YSDG'>(YSE+.9)) ^TMP("YSAD",$J,YSAD)=""
  1. Q
  1. SL ;select by location
  1. S YSAD=0 F S YSAD=$O(^YTT(601.84,"AL",YSLOC,YSAD)) Q:YSAD'>0 D
  1. . S YSDG=$P(^YTT(601.84,YSAD,0),U,4)
  1. . S:(YSDG'<YSB)&(YSDG'>(YSE+.9)) ^TMP("YSAD",$J,YSAD)=""
  1. Q
  1. ADMIN ;extract the data into an XML global
  1. S YSAD=0 F S YSAD=$O(^TMP("YSAD",$J,YSAD)) Q:YSAD'>0 D
  1. . S N=N+1,^TMP("YSXML",$J,N)="<Admin>"
  1. . S N=N+1,^TMP("YSXML",$J,N)="<Admin_ID>"_YSAD_"</Admin_ID>"
  1. . D FORM("Patient",601.84,YSAD,1)
  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>"
  1. . D FORM("Instrument",601.84,YSAD,2)
  1. . D FORM("Given",601.84,YSAD,3)
  1. . D FORM("Saved",601.84,YSAD,4)
  1. . D FORM("Ordered",601.84,YSAD,5)
  1. . D FORM("Complete",601.84,YSAD,8)
  1. . D FORM("Location",601.84,YSAD,13)
  1. . D QUEST:YSEA
  1. . D RESULT:YSER
  1. . S N=N+1,^TMP("YSXML",$J,N)="</Admin>"
  1. Q
  1. FORM(YSTAG,YSFILE,YSIENS,YSFIELD) ;xml entry
  1. N G,Y1,Y2
  1. S N=N+1
  1. S Y1=$$GET1^DIQ(YSFILE,YSIENS_",",YSFIELD)
  1. S Y2=$$CONVSTR(Y1)
  1. S G="<"_YSTAG_">"_Y2_"</"_YSTAG_">"
  1. S ^TMP("YSXML",$J,N)=G
  1. Q
  1. QUEST ;answers out
  1. S YSA=0,YSJ=0 F S YSA=$O(^YTT(601.85,"AD",YSAD,YSA)) Q:YSA'>0 D
  1. . S N=N+1,^TMP("YSXML",$J,N)="<Quest>"
  1. . S N=N+1,^TMP("YSXML",$J,N)="<Admin_ID>"_YSAD_"</Admin_ID>"
  1. . S YSQNUMB=$P(^YTT(601.85,YSA,0),U,3)
  1. . S N=N+1,^TMP("YSXML",$J,N)="<Qnumb>"_YSQNUMB_"</Qnumb>"
  1. . S YSQTEXT=$G(^YTT(601.72,YSQNUMB,1,1,0))
  1. . S N=N+1,^TMP("YSXML",$J,N)="<Qtext>"_YSQTEXT_"</Qtext>"
  1. . S N=N+1,YSJ=YSJ+1,^TMP("YSXML",$J,N)="<Seq>"_YSJ_"</Seq>"
  1. . D FORM("Choice",601.85,YSA,4)
  1. . S N=N+1
  1. . S YSC=$P(^YTT(601.85,YSA,0),U,4)
  1. . S YSCN=$S(YSC?1N.N:^YTT(601.75,YSC,1),1:"???")
  1. . S:$D(^YTT(601.85,YSA,1,1,0)) YSCN=^YTT(601.85,YSA,1,1,0)
  1. . S ^TMP("YSXML",$J,N)="<Ans>"_YSCN_"</Ans>"
  1. . S N=N+1,^TMP("YSXML",$J,N)="</Quest>"
  1. Q
  1. RESULT ;results out
  1. S YSR=0
  1. F S YSR=$O(^YTT(601.92,"AC",YSAD,YSR)) Q:YSR'>0 D
  1. . S N=N+1,^TMP("YSXML",$J,N)="<Score>"
  1. . S N=N+1,^TMP("YSXML",$J,N)="<Admin_ID>"_YSAD_"</Admin_ID>"
  1. . D FORM("Scale",601.92,YSR,2)
  1. . D FORM("Raw",601.92,YSR,3)
  1. . D FORM("Trans1",601.92,YSR,4)
  1. . S N=N+1,^TMP("YSXML",$J,N)="</Score>"
  1. Q
  1. ;
  1. CONVSTR(YSIN) ;convert string to valid xml
  1. S L1(1)="&",L2(1)="&" ; Keep "&" first
  1. S L1(2)=">",L2(2)=">"
  1. S L1(3)="<",L2(3)="<"
  1. S L1(4)="'",L2(4)="'"
  1. S L1(5)="""",L2(5)="""
  1. S YSOUT=YSIN
  1. F CNT=1:1:5 D
  1. .S LEN=$L(L1(CNT))+1
  1. .S IDX=0
  1. .F S IDX=$F(YSOUT,L1(CNT),IDX) Q:IDX=0 D
  1. .. S YSOUT=$E(YSOUT,1,IDX-LEN)_L2(CNT)_$E(YSOUT,IDX,250)
  1. .. S IDX=IDX-(LEN-2)
  1. Q YSOUT