YTQRQAD ;SLC/KCM - RESTful Calls for Instrument Admin ; 1/25/2017
;;5.01;MENTAL HEALTH;**130,141,158,181,187,199,204,208,223,238**;Dec 30, 1994;Build 25
;
; Reference to ^DIC(3.1) in ICR #1234
; Reference to ^DIC(49) in ICR #10093
; Reference to ^DPT in ICR #10035
; Reference to ^VA(200) in ICR #10060
; Reference to ^VA(200,"AUSER") in ICR #4868
; Reference to DIQ in ICR #2056
; Reference to XLFNAME in ICR #3065
; Reference to XLFSTR in ICR #10104
; Reference to XQCHK in ICR #10078
; Reference to TFL^VAFCFTU2 in ICR #4648
;
;; -- GETs all return M object that is transformed to JSON
;; -- POSTs all return a path to the created/updated object
;;
PID(ARGS,RESULTS) ; get patient identifiers
N DFN
S DFN=$G(ARGS("dfn"))
;
; If DFN starts with E, treat as EDIPI and translate to DFN
; Look up using TFL^VAFCTFU2. Returns DFN by station number.
; Sample return from TFL^VAFCTFU2:
; YTTFL(1)="5000000348V286511^NI^USVHA^200M^A" (ICN)
; YTTFL(2)="100849^PI^USVHA^999^A" (DFN)
; YTTFL(3)="567861^NI^USDOD^200DOD^A" (EDIPI DOD)
; YTTFL(4)="567861^PI^USVHA^200CRNR^A" (EDIPI DEDUP VERSION)
I $E(DFN)="E" D QUIT:$G(YTQRERRS)
. ;
. ; Get EDIPI and get Treating Facilities
. N EDIPI S EDIPI=$E(DFN,2,99),DFN=""
. N YTTFL D TFL^VAFCTFU2(.YTTFL,EDIPI_"^PI^USVHA^200CRNR") ; ICR #4648 (private IA)
. ;
. ; Did we fail to get any treating facilities?
. I $P(YTTFL(1),U)=-1 D SETERROR^YTQRUTL(404,"EDIPI Not Found: "_EDIPI) QUIT
. ;
. ; Look for DFN
. ; The call gives us DFNs by Station Numbers. We need the one for this site.
. ; This explains why we loop through and test each one.
. N STA S STA=$P($$SITE^VASITE,U,3)
. N R
. F R=0:0 S R=$O(YTTFL(R)) Q:'R D Q:DFN
.. N L S L=YTTFL(R)
.. I $P(L,U,2)="PI",$P(L,U,3)="USVHA",$P(L,U,4)=STA S DFN=$P(L,U)
. ;
. I 'DFN D SETERROR^YTQRUTL(404,"EDIPI Not Found: "_EDIPI) QUIT
;
I '$D(^DPT(DFN,0)) D SETERROR^YTQRUTL(404,"Not Found: "_DFN) QUIT
S RESULTS("dfn")=DFN
S RESULTS("name")=$P($G(^DPT(DFN,0)),U)
S RESULTS("pid")="xxx-xx-"_$E($P($G(^DPT(DFN,0)),U,9),6,10)
S RESULTS("ssn")=RESULTS("pid") ; TEMPORARY until a switch to PID
S RESULTS("email")=$P($G(^DPT(DFN,.13)),U,3)
;
N HASSITE,SITE,INST,UTC,NN
S HASSITE=$$DIV4^XUSER(.SITE,DUZ)
I 'HASSITE I $G(DUZ(2))]"" S SITE(DUZ(2))="" ;Use Default site if not explicitly defined.
Q:'$D(SITE)
S INST=$O(SITE("")) ;Use first in list-assume all are in same TZ
S NN=$$NOW^XLFDT(),UTC=""
S INST="" F S INST=$O(SITE(INST)) Q:INST=""!(UTC'="") D
. S UTC=$$UTC^DIUTC(NN,,$G(INST),,1)
. S:UTC<0 UTC=""
S RESULTS("time","fileman")=$P(UTC,U)
S RESULTS("time","external")=$P(UTC,U,2)
S RESULTS("time","offset")=$P(UTC,U,3)
S RESULTS("time","timezone")=$P(UTC,U,4)
Q
APPROXY() ; return 1 if this call is via application proxy
N XQOPT D OP^XQCHK I $P(XQOPT,U)="YTQREST PATIENT ENTRY" Q 1
Q 0
;
LSTALL(ARGS,RESULTS) ; get a list of all instruments
D GETDOC("YTL ACTIVE",.RESULTS)
Q
LSTCPRS(ARGS,RESULTS) ; get a list of all instruments
D GETDOC("YTL CPRS",.RESULTS)
Q
GETSPEC(ARGS,RESULTS) ; get an instrument specification
K ^TMP("YTQ-JSON",$J)
N TEST,TESTNM,SPEC
S TESTNM=$G(ARGS("instrumentName")) I '$L(TESTNM) D QUIT
. D SETERROR^YTQRUTL(400,"Missing instrument name")
S TEST=$O(^YTT(601.71,"B",TESTNM,0))
I 'TEST S TEST=$O(^YTT(601.71,"B",$TR(TESTNM,"_"," "),0))
I 'TEST D SETERROR^YTQRUTL(404,"Not Found: "_TESTNM) QUIT
S SPEC=+$O(^YTT(601.712,"B",TEST,0))
I $D(^YTT(601.712,SPEC,1))<10 D QUIT
. D SETERROR^YTQRUTL(404,"Specification missing")
D MV2TMP(SPEC)
I TESTNM="AUDC",$L($G(ARGS("assignmentid"))) D VARYAUDC(ARGS("assignmentid"))
S RESULTS=$NA(^TMP("YTQ-JSON",$J))
Q
MV2TMP(SPEC) ; Load spec into ^TMP("YTQ-JSON",$J), cleaning up line feeds
N I,J,X,Y
K ^TMP("YTQ-JSON",$J)
S (I,J)=0 F S I=$O(^YTT(601.712,SPEC,1,I)) Q:'I S X=^(I,0) D
. S J=J+1,^TMP("YTQ-JSON",$J,J,0)=X
. I (($L(X)-$L($TR(X,"""","")))#2) D ; check for odd number of quotes
. . F S I=I+1 Q:'$D(^YTT(601.712,SPEC,1,I,0)) D Q:Y[""""
. . . S Y=^YTT(601.712,SPEC,1,I,0)
. . . S ^TMP("YTQ-JSON",$J,J,0)=^TMP("YTQ-JSON",$J,J,0)_Y
Q
GETDOC(DOCNAME,RESULTS) ; set ^TMP with contents of the document named
K ^TMP("YTQ-JSON",$J)
N IEN S IEN=$O(^YTT(601.96,"B",DOCNAME,0))
I 'IEN S IEN=$O(^YTT(601.96,"B",$TR(DOCNAME,"_"," "),0)) ; temporary
I 'IEN D SETERROR^YTQRUTL(404,"Not Found: "_DOCNAME) QUIT
M ^TMP("YTQ-JSON",$J)=^YTT(601.96,IEN,1)
K ^TMP("YTQ-JSON",$J,0) ; remove 0 node (wp meta-data)
S RESULTS=$NA(^TMP("YTQ-JSON",$J))
Q
WRCLOSE(ARGS,DATA) ; noop call for closing Delphi wrapper
Q "/api/wrapper/close/ok"
;
VARYAUDC(ASMT) ; modify the AUDC based on patient sex in ^TMP("YTQ-JSON",$J)
N NODE,DFN,I,DONE,X0,X1,X2
S NODE=$S(ASMT?36ANP:"YTQCPRS-",1:"YTQASMT-SET-")_ASMT
S DFN=+$G(^XTMP(NODE,1,"patient","dfn")) QUIT:'DFN
I $P($G(^DPT(DFN,0)),U,2)'="F" QUIT ; only need to change for female
; looking for the 3rd question, so start checked at about line 25
S DONE=0,I=25 F S I=$O(^TMP("YTQ-JSON",$J,I)) Q:'I D Q:DONE
. I ^TMP("YTQ-JSON",$J,I,0)'["six or more" QUIT
. S X0=^TMP("YTQ-JSON",$J,I,0)
. S X1=$P(X0,"six or more")
. S X2=$P(X0,"six or more",2)
. S ^TMP("YTQ-JSON",$J,I,0)=X1_"4 or more"_X2,DONE=1
Q
PERSONS(ARGS,RESULTS) ; GET /api/mha/persons/:match
N ROOT,LROOT,NM,IEN,SEQ,PREVNM,QUAL,REQCSGN
S ROOT=$$UP^XLFSTR($G(ARGS("match"))),LROOT=$L(ROOT),SEQ=0,PREVNM=""
;Handle Exact match first
I $D(^VA(200,"AUSER",ROOT)) D ;208
. S IEN="" F S IEN=$O(^VA(200,"AUSER",ROOT,IEN)) Q:'IEN D
. . S SEQ=SEQ+1
. . S RESULTS("persons",SEQ,"userId")=IEN
. . S RESULTS("persons",SEQ,"name")=$$NAMEFMT^XLFNAME(ROOT,"F","DcMPC")
. . S RESULTS("persons",SEQ,"title")=""
. . I $P(ROOT," ")=$P(PREVNM," ") D
. . . S $P(QUAL,U)=$$GET1^DIQ(200,IEN_",",8) ; try TITLE as qualifier first
. . . I $L(QUAL) S RESULTS("persons",SEQ,"title")=QUAL Q
. . . S QUAL=$$GET1^DIQ(200,IEN,",",29) ; then try service/section
. . . S RESULTS("persons",SEQ,"title")=QUAL
. . S PREVNM=ROOT
S NM=ROOT F S NM=$O(^VA(200,"AUSER",NM)) Q:NM="" Q:$E(NM,1,LROOT)'=ROOT D
. S IEN=0 F S IEN=$O(^VA(200,"AUSER",NM,IEN)) Q:'IEN D
. . S SEQ=SEQ+1
. . S RESULTS("persons",SEQ,"userId")=IEN
. . S RESULTS("persons",SEQ,"name")=$$NAMEFMT^XLFNAME(NM,"F","DcMPC")
. . S RESULTS("persons",SEQ,"title")=""
. . I $P(NM," ")=$P(PREVNM," ") D
. . . S QUAL=$$GET1^DIQ(200,IEN_",",8) ; try title first
. . . I $L(QUAL) S RESULTS("persons",SEQ,"title")=QUAL Q
. . . S QUAL=$$GET1^DIQ(200,IEN,",",29) ; then try service/section
. . . S RESULTS("persons",SEQ,"title")=QUAL
. . S PREVNM=NM
I '$D(RESULTS) D ; return empty array in ^TMP so handler knows it is JSON
. K ^TMP("YTQ-JSON",$J)
. S ^TMP("YTQ-JSON",$J,1,0)="{""persons"":[]}"
. S RESULTS=$NA(^TMP("YTQ-JSON",$J))
Q
USERS(ARGS,RESULTS) ; GET /api/mha/users/:match
N ROOT,LROOT,NM,IEN,SEQ,PREVNM,PREVLBL,LABEL,QUAL,I
S ROOT=$$UP^XLFSTR($G(ARGS("match"))),LROOT=$L(ROOT),SEQ=0,PREVNM="",PREVLBL=""
I $D(^VA(200,"AUSER",ROOT)) D ;208
. S IEN="" F S IEN=$O(^VA(200,"AUSER",ROOT,IEN)) Q:'IEN D
. . S SEQ=SEQ+1
. . S LABEL=$$NAMEFMT^XLFNAME(ROOT,"F","DcMPC"),QUAL=""
. . I $P(ROOT," ")=$P(PREVNM," ") D
. . . ; try TITLE as qualifier first
. . . S $P(QUAL,U)=$$GET1^DIQ(200,IEN_",",8)
. . . I $P((LABEL_QUAL),U)'=$P(PREVLBL,U) QUIT
. . . ; try SERVICE/SECTION as qualifier next
. . . S $P(QUAL,U,2)=$$GET1^DIQ(200,IEN,",",29)
. . . I $P(LABEL_QUAL,U,1,2)'=$P(PREVLBL,U,1,2) QUIT
. . . ; try nickname
. . . S $P(QUAL,U,3)=$$GET1^DIQ(200,IEN_",",13)
. . S PREVNM=NM,PREVLBL=LABEL_QUAL
. . I $L(QUAL) D
. . . N X,I S X=""
. . . F I=1:1:3 I $L($P(QUAL,U,I)) S X=X_$S($L(X):", ",1:"")_$P(QUAL,U,I)
. . . S LABEL=LABEL_" ("_X_")"
. . S RESULTS("persons",SEQ,"id")=IEN
. . S RESULTS("persons",SEQ,"label")=LABEL
. S IEN=0 F S IEN=$O(^VA(200,"AUSER",NM,IEN)) Q:'IEN D
. . S SEQ=SEQ+1
. . S LABEL=$$NAMEFMT^XLFNAME(NM,"F","DcMPC"),QUAL=""
. . I $P(NM," ")=$P(PREVNM," ") D
. . . ; try TITLE as qualifier first
. . . S $P(QUAL,U)=$$GET1^DIQ(200,IEN_",",8)
. . . I $P((LABEL_QUAL),U)'=$P(PREVLBL,U) QUIT
. . . ; try SERVICE/SECTION as qualifier next
. . . S $P(QUAL,U,2)=$$GET1^DIQ(200,IEN,",",29)
. . . I $P(LABEL_QUAL,U,1,2)'=$P(PREVLBL,U,1,2) QUIT
. . . ; try nickname
. . . S $P(QUAL,U,3)=$$GET1^DIQ(200,IEN_",",13)
. . S PREVNM=NM,PREVLBL=LABEL_QUAL
. . I $L(QUAL) D
. . . N X,I S X=""
. . . F I=1:1:3 I $L($P(QUAL,U,I)) S X=X_$S($L(X):", ",1:"")_$P(QUAL,U,I)
. . . S LABEL=LABEL_" ("_X_")"
. . S RESULTS("persons",SEQ,"id")=IEN
. . S RESULTS("persons",SEQ,"label")=LABEL
I '$D(RESULTS) D ; return empty array in ^TMP so handler knows it is JSON
. K ^TMP("YTQ-JSON",$J)
. S ^TMP("YTQ-JSON",$J,1,0)="{""persons"":[]}"
. S RESULTS=$NA(^TMP("YTQ-JSON",$J))
Q
NM4DFN(ARGS,RESULTS) ; get patient name given DFN
N DFN
S DFN=$G(ARGS("dfn"))
I '$D(^DPT(DFN,0)) D SETERROR^YTQRUTL(404,"Not Found: "_DFN) QUIT
S RESULTS("dfn")=DFN
S RESULTS("name")=$P($G(^DPT(DFN,0)),U)
Q
NM4DUZ(ARGS,RESULTS) ; get user name given DUZ
N USER
S USER=$G(ARGS("duz"))
I +USER=0 D SETERROR^YTQRUTL(404,"Invalid user: "_USER) QUIT
I '$D(^VA(200,USER,0)) D SETERROR^YTQRUTL(404,"Not Found: "_USER) QUIT
S RESULTS("duz")=USER
S RESULTS("name")=$P($G(^VA(200,USER,0)),U)
Q
GINSTD(ARGS,RESULTS) ;Get Instrument Description
N YS,YSDATA,YSTESTN,II,YSAR,VAR,VAL,JSONAR,XX
S YS("CODE")=$G(ARGS("instrumentName"))
D TSLIST1^YTQAPI(.YSDATA,.YS)
I '$D(YSDATA) D SETERROR^YTQRUTL(404,"Error retrieving description") Q
S YSDATA(1)=$G(YSDATA(1)),YSDATA(2)=$G(YSDATA(2))
I YSDATA(1)["ERROR",(YSDATA(2)="NO code") D SETERROR^YTQRUTL(404,"No instrument name.") Q
I YSDATA(1)["ERROR",(YSDATA(2)="bad code") D SETERROR^YTQRUTL(404,"Instrument not found.") Q
S I=0 F S I=$O(YSDATA(I)) Q:I="" D
. S XX=YSDATA(I),VAR=$P(XX,"="),VAL=$P(XX,"=",2,999)
. Q:VAR=""
. S:VAR="LAST EDIT DATE" VAL=$P($$FMTE^XLFDT(VAL,2),"@")
. I VAR="ENTRY DATE" D
.. N X,Y,%DT S X=VAL D ^%DT S VAL=$$FMTE^XLFDT(Y,2)
. S YSAR(VAR)=VAL
F VAR="PRINT TITLE^Print Title","VERSION^Version","AUTHOR^Author","PUBLISHER^Publisher","COPYRIGHT TEXT^Copyright","PUBLICATION DATE^Publication Date" D
. D SETVAR("Clinical Features",VAR)
F VAR="REFERENCE^Reference","PURPOSE^Purpose","NORM SAMPLE^Norm Sample","TARGET POPULATION^Target Population" D
. D SETVAR("Clinical Features",VAR)
F VAR="A PRIVILEGE^Administrative Privilege","R PRIVILEGE^Result Privilege","ENTERED BY^Entered By","ENTRY DATE^Entry Date" D
. D SETVAR("Technical Features",VAR)
F VAR="LAST EDITED BY^Last Edited By","LAST EDIT DATE^Last Edit Date","IS NATIONAL TEST^National Test","REQUIRES LICENSE^Requires License","IS LEGACY^Is Legacy Instrument","SUBMIT TO NATIONAL DB^Submit to National DB" D
. D SETVAR("Technical Features",VAR) ;208
;
;F VAR="PRINT TITLE^Print Title","VERSION^Version","AUTHOR^Author","PUBLISHER^Publisher","COPYRIGHT TEXT^Copyright","PUBLICATION DATE^Publication Date" D
;. D SETVAR("Clinical Features",VAR)
;F VAR="REFERENCE^Reference","PURPOSE^Purpose","NORM SAMPLE^Norm Sample","TARGET POPULATION^Target Population" D
;. D SETVAR("Clinical Features",VAR)
;F VAR="A PRIVILEGE^Administrative Privilege","LICENSE CURRENT^Requires License" D
;. D SETVAR("Technical Features",VAR)
K RESULTS M RESULTS=JSONAR Q
Q
SETVAR(XCAT,VAR) ;Set JSON array values for Instrument Description - Requires YSAR to be set
N XVAR,CAP
S XVAR=$P(VAR,U),CAP=$P(VAR,U,2)
I XVAR="REQUIRES LICENSE" D ;208 Phase in new property
. S JSONAR("Description",XCAT,"LICENSE CURRENT","value")=YSAR(XVAR)
. S JSONAR("Description",XCAT,"LICENSE CURRENT","caption")=CAP
S JSONAR("Description",XCAT,XVAR,"value")=YSAR(XVAR)
S JSONAR("Description",XCAT,XVAR,"caption")=CAP
Q
RESET ; clear the ^XTMP("YTQASMT") nodes
; WARNING -- calling this (at RESET+3) will erase all current assignments
Q
N NM
S NM="YTQASMT" F S NM=$O(^XTMP(NM)) Q:$E(NM,1,7)'="YTQASMT" D
. W !,NM
. K ^XTMP(NM)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HYTQRQAD 12156 printed Dec 13, 2024@02:18:52 Page 2
YTQRQAD ;SLC/KCM - RESTful Calls for Instrument Admin ; 1/25/2017
+1 ;;5.01;MENTAL HEALTH;**130,141,158,181,187,199,204,208,223,238**;Dec 30, 1994;Build 25
+2 ;
+3 ; Reference to ^DIC(3.1) in ICR #1234
+4 ; Reference to ^DIC(49) in ICR #10093
+5 ; Reference to ^DPT in ICR #10035
+6 ; Reference to ^VA(200) in ICR #10060
+7 ; Reference to ^VA(200,"AUSER") in ICR #4868
+8 ; Reference to DIQ in ICR #2056
+9 ; Reference to XLFNAME in ICR #3065
+10 ; Reference to XLFSTR in ICR #10104
+11 ; Reference to XQCHK in ICR #10078
+12 ; Reference to TFL^VAFCFTU2 in ICR #4648
+13 ;
+14 ;; -- GETs all return M object that is transformed to JSON
+15 ;; -- POSTs all return a path to the created/updated object
+16 ;;
PID(ARGS,RESULTS) ; get patient identifiers
+1 NEW DFN
+2 SET DFN=$GET(ARGS("dfn"))
+3 ;
+4 ; If DFN starts with E, treat as EDIPI and translate to DFN
+5 ; Look up using TFL^VAFCTFU2. Returns DFN by station number.
+6 ; Sample return from TFL^VAFCTFU2:
+7 ; YTTFL(1)="5000000348V286511^NI^USVHA^200M^A" (ICN)
+8 ; YTTFL(2)="100849^PI^USVHA^999^A" (DFN)
+9 ; YTTFL(3)="567861^NI^USDOD^200DOD^A" (EDIPI DOD)
+10 ; YTTFL(4)="567861^PI^USVHA^200CRNR^A" (EDIPI DEDUP VERSION)
+11 IF $EXTRACT(DFN)="E"
Begin DoDot:1
+12 ;
+13 ; Get EDIPI and get Treating Facilities
+14 NEW EDIPI
SET EDIPI=$EXTRACT(DFN,2,99)
SET DFN=""
+15 ; ICR #4648 (private IA)
NEW YTTFL
DO TFL^VAFCTFU2(.YTTFL,EDIPI_"^PI^USVHA^200CRNR")
+16 ;
+17 ; Did we fail to get any treating facilities?
+18 IF $PIECE(YTTFL(1),U)=-1
DO SETERROR^YTQRUTL(404,"EDIPI Not Found: "_EDIPI)
QUIT
+19 ;
+20 ; Look for DFN
+21 ; The call gives us DFNs by Station Numbers. We need the one for this site.
+22 ; This explains why we loop through and test each one.
+23 NEW STA
SET STA=$PIECE($$SITE^VASITE,U,3)
+24 NEW R
+25 FOR R=0:0
SET R=$ORDER(YTTFL(R))
if 'R
QUIT
Begin DoDot:2
+26 NEW L
SET L=YTTFL(R)
+27 IF $PIECE(L,U,2)="PI"
IF $PIECE(L,U,3)="USVHA"
IF $PIECE(L,U,4)=STA
SET DFN=$PIECE(L,U)
End DoDot:2
if DFN
QUIT
+28 ;
+29 IF 'DFN
DO SETERROR^YTQRUTL(404,"EDIPI Not Found: "_EDIPI)
QUIT
End DoDot:1
if $GET(YTQRERRS)
QUIT
+30 ;
+31 IF '$DATA(^DPT(DFN,0))
DO SETERROR^YTQRUTL(404,"Not Found: "_DFN)
QUIT
+32 SET RESULTS("dfn")=DFN
+33 SET RESULTS("name")=$PIECE($GET(^DPT(DFN,0)),U)
+34 SET RESULTS("pid")="xxx-xx-"_$EXTRACT($PIECE($GET(^DPT(DFN,0)),U,9),6,10)
+35 ; TEMPORARY until a switch to PID
SET RESULTS("ssn")=RESULTS("pid")
+36 SET RESULTS("email")=$PIECE($GET(^DPT(DFN,.13)),U,3)
+37 ;
+38 NEW HASSITE,SITE,INST,UTC,NN
+39 SET HASSITE=$$DIV4^XUSER(.SITE,DUZ)
+40 ;Use Default site if not explicitly defined.
IF 'HASSITE
IF $GET(DUZ(2))]""
SET SITE(DUZ(2))=""
+41 if '$DATA(SITE)
QUIT
+42 ;Use first in list-assume all are in same TZ
SET INST=$ORDER(SITE(""))
+43 SET NN=$$NOW^XLFDT()
SET UTC=""
+44 SET INST=""
FOR
SET INST=$ORDER(SITE(INST))
if INST=""!(UTC'="")
QUIT
Begin DoDot:1
+45 SET UTC=$$UTC^DIUTC(NN,,$GET(INST),,1)
+46 if UTC<0
SET UTC=""
End DoDot:1
+47 SET RESULTS("time","fileman")=$PIECE(UTC,U)
+48 SET RESULTS("time","external")=$PIECE(UTC,U,2)
+49 SET RESULTS("time","offset")=$PIECE(UTC,U,3)
+50 SET RESULTS("time","timezone")=$PIECE(UTC,U,4)
+51 QUIT
APPROXY() ; return 1 if this call is via application proxy
+1 NEW XQOPT
DO OP^XQCHK
IF $PIECE(XQOPT,U)="YTQREST PATIENT ENTRY"
QUIT 1
+2 QUIT 0
+3 ;
LSTALL(ARGS,RESULTS) ; get a list of all instruments
+1 DO GETDOC("YTL ACTIVE",.RESULTS)
+2 QUIT
LSTCPRS(ARGS,RESULTS) ; get a list of all instruments
+1 DO GETDOC("YTL CPRS",.RESULTS)
+2 QUIT
GETSPEC(ARGS,RESULTS) ; get an instrument specification
+1 KILL ^TMP("YTQ-JSON",$JOB)
+2 NEW TEST,TESTNM,SPEC
+3 SET TESTNM=$GET(ARGS("instrumentName"))
IF '$LENGTH(TESTNM)
Begin DoDot:1
+4 DO SETERROR^YTQRUTL(400,"Missing instrument name")
End DoDot:1
QUIT
+5 SET TEST=$ORDER(^YTT(601.71,"B",TESTNM,0))
+6 IF 'TEST
SET TEST=$ORDER(^YTT(601.71,"B",$TRANSLATE(TESTNM,"_"," "),0))
+7 IF 'TEST
DO SETERROR^YTQRUTL(404,"Not Found: "_TESTNM)
QUIT
+8 SET SPEC=+$ORDER(^YTT(601.712,"B",TEST,0))
+9 IF $DATA(^YTT(601.712,SPEC,1))<10
Begin DoDot:1
+10 DO SETERROR^YTQRUTL(404,"Specification missing")
End DoDot:1
QUIT
+11 DO MV2TMP(SPEC)
+12 IF TESTNM="AUDC"
IF $LENGTH($GET(ARGS("assignmentid")))
DO VARYAUDC(ARGS("assignmentid"))
+13 SET RESULTS=$NAME(^TMP("YTQ-JSON",$JOB))
+14 QUIT
MV2TMP(SPEC) ; Load spec into ^TMP("YTQ-JSON",$J), cleaning up line feeds
+1 NEW I,J,X,Y
+2 KILL ^TMP("YTQ-JSON",$JOB)
+3 SET (I,J)=0
FOR
SET I=$ORDER(^YTT(601.712,SPEC,1,I))
if 'I
QUIT
SET X=^(I,0)
Begin DoDot:1
+4 SET J=J+1
SET ^TMP("YTQ-JSON",$JOB,J,0)=X
+5 ; check for odd number of quotes
IF (($LENGTH(X)-$LENGTH($TRANSLATE(X,"""","")))#2)
Begin DoDot:2
+6 FOR
SET I=I+1
if '$DATA(^YTT(601.712,SPEC,1,I,0))
QUIT
Begin DoDot:3
+7 SET Y=^YTT(601.712,SPEC,1,I,0)
+8 SET ^TMP("YTQ-JSON",$JOB,J,0)=^TMP("YTQ-JSON",$JOB,J,0)_Y
End DoDot:3
if Y[""""
QUIT
End DoDot:2
End DoDot:1
+9 QUIT
GETDOC(DOCNAME,RESULTS) ; set ^TMP with contents of the document named
+1 KILL ^TMP("YTQ-JSON",$JOB)
+2 NEW IEN
SET IEN=$ORDER(^YTT(601.96,"B",DOCNAME,0))
+3 ; temporary
IF 'IEN
SET IEN=$ORDER(^YTT(601.96,"B",$TRANSLATE(DOCNAME,"_"," "),0))
+4 IF 'IEN
DO SETERROR^YTQRUTL(404,"Not Found: "_DOCNAME)
QUIT
+5 MERGE ^TMP("YTQ-JSON",$JOB)=^YTT(601.96,IEN,1)
+6 ; remove 0 node (wp meta-data)
KILL ^TMP("YTQ-JSON",$JOB,0)
+7 SET RESULTS=$NAME(^TMP("YTQ-JSON",$JOB))
+8 QUIT
WRCLOSE(ARGS,DATA) ; noop call for closing Delphi wrapper
+1 QUIT "/api/wrapper/close/ok"
+2 ;
VARYAUDC(ASMT) ; modify the AUDC based on patient sex in ^TMP("YTQ-JSON",$J)
+1 NEW NODE,DFN,I,DONE,X0,X1,X2
+2 SET NODE=$SELECT(ASMT?36ANP:"YTQCPRS-",1:"YTQASMT-SET-")_ASMT
+3 SET DFN=+$GET(^XTMP(NODE,1,"patient","dfn"))
if 'DFN
QUIT
+4 ; only need to change for female
IF $PIECE($GET(^DPT(DFN,0)),U,2)'="F"
QUIT
+5 ; looking for the 3rd question, so start checked at about line 25
+6 SET DONE=0
SET I=25
FOR
SET I=$ORDER(^TMP("YTQ-JSON",$JOB,I))
if 'I
QUIT
Begin DoDot:1
+7 IF ^TMP("YTQ-JSON",$JOB,I,0)'["six or more"
QUIT
+8 SET X0=^TMP("YTQ-JSON",$JOB,I,0)
+9 SET X1=$PIECE(X0,"six or more")
+10 SET X2=$PIECE(X0,"six or more",2)
+11 SET ^TMP("YTQ-JSON",$JOB,I,0)=X1_"4 or more"_X2
SET DONE=1
End DoDot:1
if DONE
QUIT
+12 QUIT
PERSONS(ARGS,RESULTS) ; GET /api/mha/persons/:match
+1 NEW ROOT,LROOT,NM,IEN,SEQ,PREVNM,QUAL,REQCSGN
+2 SET ROOT=$$UP^XLFSTR($GET(ARGS("match")))
SET LROOT=$LENGTH(ROOT)
SET SEQ=0
SET PREVNM=""
+3 ;Handle Exact match first
+4 ;208
IF $DATA(^VA(200,"AUSER",ROOT))
Begin DoDot:1
+5 SET IEN=""
FOR
SET IEN=$ORDER(^VA(200,"AUSER",ROOT,IEN))
if 'IEN
QUIT
Begin DoDot:2
+6 SET SEQ=SEQ+1
+7 SET RESULTS("persons",SEQ,"userId")=IEN
+8 SET RESULTS("persons",SEQ,"name")=$$NAMEFMT^XLFNAME(ROOT,"F","DcMPC")
+9 SET RESULTS("persons",SEQ,"title")=""
+10 IF $PIECE(ROOT," ")=$PIECE(PREVNM," ")
Begin DoDot:3
+11 ; try TITLE as qualifier first
SET $PIECE(QUAL,U)=$$GET1^DIQ(200,IEN_",",8)
+12 IF $LENGTH(QUAL)
SET RESULTS("persons",SEQ,"title")=QUAL
QUIT
+13 ; then try service/section
SET QUAL=$$GET1^DIQ(200,IEN,",",29)
+14 SET RESULTS("persons",SEQ,"title")=QUAL
End DoDot:3
+15 SET PREVNM=ROOT
End DoDot:2
End DoDot:1
+16 SET NM=ROOT
FOR
SET NM=$ORDER(^VA(200,"AUSER",NM))
if NM=""
QUIT
if $EXTRACT(NM,1,LROOT)'=ROOT
QUIT
Begin DoDot:1
+17 SET IEN=0
FOR
SET IEN=$ORDER(^VA(200,"AUSER",NM,IEN))
if 'IEN
QUIT
Begin DoDot:2
+18 SET SEQ=SEQ+1
+19 SET RESULTS("persons",SEQ,"userId")=IEN
+20 SET RESULTS("persons",SEQ,"name")=$$NAMEFMT^XLFNAME(NM,"F","DcMPC")
+21 SET RESULTS("persons",SEQ,"title")=""
+22 IF $PIECE(NM," ")=$PIECE(PREVNM," ")
Begin DoDot:3
+23 ; try title first
SET QUAL=$$GET1^DIQ(200,IEN_",",8)
+24 IF $LENGTH(QUAL)
SET RESULTS("persons",SEQ,"title")=QUAL
QUIT
+25 ; then try service/section
SET QUAL=$$GET1^DIQ(200,IEN,",",29)
+26 SET RESULTS("persons",SEQ,"title")=QUAL
End DoDot:3
+27 SET PREVNM=NM
End DoDot:2
End DoDot:1
+28 ; return empty array in ^TMP so handler knows it is JSON
IF '$DATA(RESULTS)
Begin DoDot:1
+29 KILL ^TMP("YTQ-JSON",$JOB)
+30 SET ^TMP("YTQ-JSON",$JOB,1,0)="{""persons"":[]}"
+31 SET RESULTS=$NAME(^TMP("YTQ-JSON",$JOB))
End DoDot:1
+32 QUIT
USERS(ARGS,RESULTS) ; GET /api/mha/users/:match
+1 NEW ROOT,LROOT,NM,IEN,SEQ,PREVNM,PREVLBL,LABEL,QUAL,I
+2 SET ROOT=$$UP^XLFSTR($GET(ARGS("match")))
SET LROOT=$LENGTH(ROOT)
SET SEQ=0
SET PREVNM=""
SET PREVLBL=""
+3 ;208
IF $DATA(^VA(200,"AUSER",ROOT))
Begin DoDot:1
+4 SET IEN=""
FOR
SET IEN=$ORDER(^VA(200,"AUSER",ROOT,IEN))
if 'IEN
QUIT
Begin DoDot:2
+5 SET SEQ=SEQ+1
+6 SET LABEL=$$NAMEFMT^XLFNAME(ROOT,"F","DcMPC")
SET QUAL=""
+7 IF $PIECE(ROOT," ")=$PIECE(PREVNM," ")
Begin DoDot:3
+8 ; try TITLE as qualifier first
+9 SET $PIECE(QUAL,U)=$$GET1^DIQ(200,IEN_",",8)
+10 IF $PIECE((LABEL_QUAL),U)'=$PIECE(PREVLBL,U)
QUIT
+11 ; try SERVICE/SECTION as qualifier next
+12 SET $PIECE(QUAL,U,2)=$$GET1^DIQ(200,IEN,",",29)
+13 IF $PIECE(LABEL_QUAL,U,1,2)'=$PIECE(PREVLBL,U,1,2)
QUIT
+14 ; try nickname
+15 SET $PIECE(QUAL,U,3)=$$GET1^DIQ(200,IEN_",",13)
End DoDot:3
+16 SET PREVNM=NM
SET PREVLBL=LABEL_QUAL
+17 IF $LENGTH(QUAL)
Begin DoDot:3
+18 NEW X,I
SET X=""
+19 FOR I=1:1:3
IF $LENGTH($PIECE(QUAL,U,I))
SET X=X_$SELECT($LENGTH(X):", ",1:"")_$PIECE(QUAL,U,I)
+20 SET LABEL=LABEL_" ("_X_")"
End DoDot:3
+21 SET RESULTS("persons",SEQ,"id")=IEN
+22 SET RESULTS("persons",SEQ,"label")=LABEL
End DoDot:2
+23 SET IEN=0
FOR
SET IEN=$ORDER(^VA(200,"AUSER",NM,IEN))
if 'IEN
QUIT
Begin DoDot:2
+24 SET SEQ=SEQ+1
+25 SET LABEL=$$NAMEFMT^XLFNAME(NM,"F","DcMPC")
SET QUAL=""
+26 IF $PIECE(NM," ")=$PIECE(PREVNM," ")
Begin DoDot:3
+27 ; try TITLE as qualifier first
+28 SET $PIECE(QUAL,U)=$$GET1^DIQ(200,IEN_",",8)
+29 IF $PIECE((LABEL_QUAL),U)'=$PIECE(PREVLBL,U)
QUIT
+30 ; try SERVICE/SECTION as qualifier next
+31 SET $PIECE(QUAL,U,2)=$$GET1^DIQ(200,IEN,",",29)
+32 IF $PIECE(LABEL_QUAL,U,1,2)'=$PIECE(PREVLBL,U,1,2)
QUIT
+33 ; try nickname
+34 SET $PIECE(QUAL,U,3)=$$GET1^DIQ(200,IEN_",",13)
End DoDot:3
+35 SET PREVNM=NM
SET PREVLBL=LABEL_QUAL
+36 IF $LENGTH(QUAL)
Begin DoDot:3
+37 NEW X,I
SET X=""
+38 FOR I=1:1:3
IF $LENGTH($PIECE(QUAL,U,I))
SET X=X_$SELECT($LENGTH(X):", ",1:"")_$PIECE(QUAL,U,I)
+39 SET LABEL=LABEL_" ("_X_")"
End DoDot:3
+40 SET RESULTS("persons",SEQ,"id")=IEN
+41 SET RESULTS("persons",SEQ,"label")=LABEL
End DoDot:2
End DoDot:1
+42 ; return empty array in ^TMP so handler knows it is JSON
IF '$DATA(RESULTS)
Begin DoDot:1
+43 KILL ^TMP("YTQ-JSON",$JOB)
+44 SET ^TMP("YTQ-JSON",$JOB,1,0)="{""persons"":[]}"
+45 SET RESULTS=$NAME(^TMP("YTQ-JSON",$JOB))
End DoDot:1
+46 QUIT
NM4DFN(ARGS,RESULTS) ; get patient name given DFN
+1 NEW DFN
+2 SET DFN=$GET(ARGS("dfn"))
+3 IF '$DATA(^DPT(DFN,0))
DO SETERROR^YTQRUTL(404,"Not Found: "_DFN)
QUIT
+4 SET RESULTS("dfn")=DFN
+5 SET RESULTS("name")=$PIECE($GET(^DPT(DFN,0)),U)
+6 QUIT
NM4DUZ(ARGS,RESULTS) ; get user name given DUZ
+1 NEW USER
+2 SET USER=$GET(ARGS("duz"))
+3 IF +USER=0
DO SETERROR^YTQRUTL(404,"Invalid user: "_USER)
QUIT
+4 IF '$DATA(^VA(200,USER,0))
DO SETERROR^YTQRUTL(404,"Not Found: "_USER)
QUIT
+5 SET RESULTS("duz")=USER
+6 SET RESULTS("name")=$PIECE($GET(^VA(200,USER,0)),U)
+7 QUIT
GINSTD(ARGS,RESULTS) ;Get Instrument Description
+1 NEW YS,YSDATA,YSTESTN,II,YSAR,VAR,VAL,JSONAR,XX
+2 SET YS("CODE")=$GET(ARGS("instrumentName"))
+3 DO TSLIST1^YTQAPI(.YSDATA,.YS)
+4 IF '$DATA(YSDATA)
DO SETERROR^YTQRUTL(404,"Error retrieving description")
QUIT
+5 SET YSDATA(1)=$GET(YSDATA(1))
SET YSDATA(2)=$GET(YSDATA(2))
+6 IF YSDATA(1)["ERROR"
IF (YSDATA(2)="NO code")
DO SETERROR^YTQRUTL(404,"No instrument name.")
QUIT
+7 IF YSDATA(1)["ERROR"
IF (YSDATA(2)="bad code")
DO SETERROR^YTQRUTL(404,"Instrument not found.")
QUIT
+8 SET I=0
FOR
SET I=$ORDER(YSDATA(I))
if I=""
QUIT
Begin DoDot:1
+9 SET XX=YSDATA(I)
SET VAR=$PIECE(XX,"=")
SET VAL=$PIECE(XX,"=",2,999)
+10 if VAR=""
QUIT
+11 if VAR="LAST EDIT DATE"
SET VAL=$PIECE($$FMTE^XLFDT(VAL,2),"@")
+12 IF VAR="ENTRY DATE"
Begin DoDot:2
+13 NEW X,Y,%DT
SET X=VAL
DO ^%DT
SET VAL=$$FMTE^XLFDT(Y,2)
End DoDot:2
+14 SET YSAR(VAR)=VAL
End DoDot:1
+15 FOR VAR="PRINT TITLE^Print Title","VERSION^Version","AUTHOR^Author","PUBLISHER^Publisher","COPYRIGHT TEXT^Copyright","PUBLICATION DATE^Publication Date"
Begin DoDot:1
+16 DO SETVAR("Clinical Features",VAR)
End DoDot:1
+17 FOR VAR="REFERENCE^Reference","PURPOSE^Purpose","NORM SAMPLE^Norm Sample","TARGET POPULATION^Target Population"
Begin DoDot:1
+18 DO SETVAR("Clinical Features",VAR)
End DoDot:1
+19 FOR VAR="A PRIVILEGE^Administrative Privilege","R PRIVILEGE^Result Privilege","ENTERED BY^Entered By","ENTRY DATE^Entry Date"
Begin DoDot:1
+20 DO SETVAR("Technical Features",VAR)
End DoDot:1
+21 FOR VAR="LAST EDITED BY^Last Edited By","LAST EDIT DATE^Last Edit Date","IS NATIONAL TEST^National Test","REQUIRES LICENSE^Requires License","IS LEGACY^Is Legacy Instrument","SUBMIT TO NATIONAL DB^Submit to National DB"
Begin DoDot:1
+22 ;208
DO SETVAR("Technical Features",VAR)
End DoDot:1
+23 ;
+24 ;F VAR="PRINT TITLE^Print Title","VERSION^Version","AUTHOR^Author","PUBLISHER^Publisher","COPYRIGHT TEXT^Copyright","PUBLICATION DATE^Publication Date" D
+25 ;. D SETVAR("Clinical Features",VAR)
+26 ;F VAR="REFERENCE^Reference","PURPOSE^Purpose","NORM SAMPLE^Norm Sample","TARGET POPULATION^Target Population" D
+27 ;. D SETVAR("Clinical Features",VAR)
+28 ;F VAR="A PRIVILEGE^Administrative Privilege","LICENSE CURRENT^Requires License" D
+29 ;. D SETVAR("Technical Features",VAR)
+30 KILL RESULTS
MERGE RESULTS=JSONAR
QUIT
+31 QUIT
SETVAR(XCAT,VAR) ;Set JSON array values for Instrument Description - Requires YSAR to be set
+1 NEW XVAR,CAP
+2 SET XVAR=$PIECE(VAR,U)
SET CAP=$PIECE(VAR,U,2)
+3 ;208 Phase in new property
IF XVAR="REQUIRES LICENSE"
Begin DoDot:1
+4 SET JSONAR("Description",XCAT,"LICENSE CURRENT","value")=YSAR(XVAR)
+5 SET JSONAR("Description",XCAT,"LICENSE CURRENT","caption")=CAP
End DoDot:1
+6 SET JSONAR("Description",XCAT,XVAR,"value")=YSAR(XVAR)
+7 SET JSONAR("Description",XCAT,XVAR,"caption")=CAP
+8 QUIT
RESET ; clear the ^XTMP("YTQASMT") nodes
+1 ; WARNING -- calling this (at RESET+3) will erase all current assignments
+2 QUIT
+3 NEW NM
+4 SET NM="YTQASMT"
FOR
SET NM=$ORDER(^XTMP(NM))
if $EXTRACT(NM,1,7)'="YTQASMT"
QUIT
Begin DoDot:1
+5 WRITE !,NM
+6 KILL ^XTMP(NM)
End DoDot:1
+7 QUIT
