- 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 Feb 18, 2025@23:45:10 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