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

YTQRQAD.m

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