DDEGET ;SPFO/RAM,MKB - Entity GET Handler ;1/26/23 10:37
;;22.2;VA FileMan;**9,17,18,20,24**;Jan 05, 2016;Build 3
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
EN(ENTITY,ID,FILTER,MAX,FORMAT,TARGET,ERROR) ; -- Return [list of] data entities
; where ENTITY = ien or name of desired Entity #1.5
; ID = single item ID to return [opt]
; MAX = maximum number of items to return [opt]
; FORMAT = 0:JSON (default) or 1:XML [opt]
; TARGET = closed array reference to return data [opt]
; ERROR = closed array reference for error msgs [opt]
; FILTER[(#)] = search values, if using FIND^DIC [opt]
; FILTER("from") = starting search value, for LIST^DIC [opt]
; FILTER("partial") = partial search value, for LIST^DIC [opt]
; FILTER("start") = start date.time of search, for Query [opt]
; FILTER("stop") = stop date.time of search, for Query [opt]
; FILTER("patient") = DFN or DFN;ICN [opt]
; FILTER("init") = initial value for array subscript [opt]
;
N DDEY,DDEI,DDER,DSYS,DTYPE,DSTRT,DSTOP,DMAX,DFORM,DDEN,DDEX,DDEZ,DDEQUIT,DDELIST,DLIST
N DFN,ICN,FILE,QUERY,LIST
;
S DDEY=$G(TARGET,$NA(^TMP("DDE GET",$J)))
S DDEI=$S($G(FILTER("init")):FILTER("init"),1:0) K:'DDEI @DDEY ;p20
S DDER=$G(ERROR,$NA(^TMP("DDERR",$J))) K @DDER
S DT=$$DT^XLFDT ;for crossing midnight boundary
S DSYS=$$SYS,ID=$G(ID)
;
A ; parse & validate input parameters
I $G(ENTITY)="" D ERROR("Entity parameter invalid") G ENQ
S DTYPE=$S((+ENTITY=ENTITY):+ENTITY,1:+$O(^DDE("B",ENTITY,0))) ;IEN or Name
I DTYPE<1!'$D(^DDE(DTYPE)) D ERROR("Entity "_ENTITY_" does not exist") G ENQ
;
S FILE=$P($G(^DDE(DTYPE,0)),U,2)
I FILE,'$$VFILE^DILFD(FILE) D ERROR("Invalid file number for Entity "_DTYPE) G ENQ
;
S DSTRT=+$G(FILTER("start"),1410102)
S DSTOP=+$G(FILTER("stop"),4141015)
I DSTRT,DSTOP,DSTOP<DSTRT D
. N X S X=DSTRT,DSTRT=DSTOP,DSTOP=X
I DSTOP,$L(DSTOP,".")<2 S DSTOP=DSTOP_".24"
S DMAX=+$G(MAX,9999)
;
I ID="",$D(FILTER("id")) S ID=FILTER("id")
S DFN=$G(FILTER("patient")),ICN=+$P($G(DFN),";",2),DFN=+$G(DFN)
I DFN<1,ICN S DFN=+$$GETDFN^MPIF001(ICN)
I FILE=2,DFN<1,ID S DFN=ID
I DFN,'$$VALID(DFN) D ERROR("Invalid Patient file DFN: "_DFN) G ENQ
;
; DFORM 2:TEXT 1:XML 0:JSON (default = JSON)
S DFORM=$$UP^XLFSTR($G(FORMAT))
S DFORM=$S(DFORM=0:0,+DFORM:DFORM,DFORM="JSON":0,DFORM="XML":1,DFORM="TEXT":2,1:0)
;
D PRE(DTYPE) Q:$G(DDEQUIT)
;
B ; extract data
S QUERY=$G(^DDE(DTYPE,5)) ;TAG^RTN from ENTITY
S LIST=$S(DFORM:0,1:+$G(FILTER("notag"))) ;omit tag for JSON item
I ID'="",$E(ID)'="," S DLIST(1)=ID ;pass subfile iens to query ;p24
E D S:'DFORM LIST=1 ;no outer tags for a JSON list
. N $ES,$ET S $ET="D QRY^DDERR"
. I $L(QUERY)>1,$L($T(@($P(QUERY,"(")))) D @QUERY Q
. D DIC(DTYPE)
;
S DDEN=0 F S DDEN=$O(DLIST(DDEN)) Q:DDEN<1 D
. N $ES,$ET S $ET="D ONE^DDERR"
. S ID=DLIST(DDEN)
. S DDEX=$$EN1^DDEG(DTYPE,ID,LIST,.DDEZ)
. I DDEZ D ERROR($P(DDEZ,U,2)) Q ;Error msg
. I $L(DDEX) S DDEI=DDEI+1,@DDEY@(DDEI)=DDEX
S @DDEY@(0)=DDEI
;
D POST(DTYPE)
;
ENQ ;exit
S TARGET=DDEY,ERROR=DDER
Q
;
DIC(ENT) ; -- FIND/LIST^DIC, returns DLIST(#)=id for query ;p24
; ID should be null, or iens for sub-file search (",###,")
N XREF,VAL,SCR,FROM,PART,DDVAL,I Q:'$G(FILE)
S XREF=$P($G(^DDE(ENT,0)),U,3),VAL=$P($G(^(0)),U,4),SCR=$G(^(5.1))
S FROM=$G(FILTER("from")),PART=$G(FILTER("partial"))
I $D(FILTER)!$L(VAL) D ;set up DDVAL for FIND using simple or
. S:$L($G(FILTER)) DDVAL=FILTER ;compound index value(s) where I=#
. N I S I=0 F S I=$O(FILTER(I)) Q:'I S DDVAL(I)=FILTER(I)
. I '$L($G(DDVAL)),'$O(DDVAL(0)),$L(VAL) S DDVAL=$S($D(@VAL):@VAL,1:VAL)
D:$D(DDVAL) FIND^DIC(FILE,ID,"@","Q",.DDVAL,DMAX,XREF,SCR,,"DDELIST")
D:'$D(DDVAL) LIST^DIC(FILE,ID,"@","Q",DMAX,FROM,PART,XREF,SCR,,"DDELIST")
I $D(^DIC(FILE,0)) M DLIST=DDELIST("DILIST",2) Q
; append ID (iens) to each DA for sub-files
S I=0 F S I=$O(DDELIST("DILIST",2,I)) Q:I<1 S DLIST(I)=DDELIST("DILIST",2,I)_ID
Q
;
PRE(ENT) ; -- pre-processing logic
N X
S X=$G(^DDE(+ENT,2)) X:X'="" X
Q
;
POST(ENT) ; -- post-processing logic
N X
S X=$G(^DDE(+ENT,3)) X:X'="" X
Q
;
ERROR(MSG) ; -- return error MSG
N I S I=+$O(@DDER@("A"),-1)
S I=I+1,@DDER@(I)=$G(MSG)
Q
;
VALID(PAT) ; -- return 1 or 0, if valid PATient #2 ien
S PAT=+$G(PAT)
; invalid pointer?
I PAT<1 Q 0
I '$D(^DPT(PAT,0)) Q 0
; merged [from] patient?
I $P(^DPT(PAT,0),U)["MERGING INTO" Q 0
I $G(^DPT(PAT,-9)) Q 0
; ok
Q 1
;
SYS() ; -- return hashed system name
Q $$BASE^XLFUTL($$CRC16^XLFCRC($$KSP^XUPARAM("WHERE")),10,16)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDEGET 4892 printed Apr 09, 2024@21:47:28 Page 2
DDEGET ;SPFO/RAM,MKB - Entity GET Handler ;1/26/23 10:37
+1 ;;22.2;VA FileMan;**9,17,18,20,24**;Jan 05, 2016;Build 3
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
EN(ENTITY,ID,FILTER,MAX,FORMAT,TARGET,ERROR) ; -- Return [list of] data entities
+1 ; where ENTITY = ien or name of desired Entity #1.5
+2 ; ID = single item ID to return [opt]
+3 ; MAX = maximum number of items to return [opt]
+4 ; FORMAT = 0:JSON (default) or 1:XML [opt]
+5 ; TARGET = closed array reference to return data [opt]
+6 ; ERROR = closed array reference for error msgs [opt]
+7 ; FILTER[(#)] = search values, if using FIND^DIC [opt]
+8 ; FILTER("from") = starting search value, for LIST^DIC [opt]
+9 ; FILTER("partial") = partial search value, for LIST^DIC [opt]
+10 ; FILTER("start") = start date.time of search, for Query [opt]
+11 ; FILTER("stop") = stop date.time of search, for Query [opt]
+12 ; FILTER("patient") = DFN or DFN;ICN [opt]
+13 ; FILTER("init") = initial value for array subscript [opt]
+14 ;
+15 NEW DDEY,DDEI,DDER,DSYS,DTYPE,DSTRT,DSTOP,DMAX,DFORM,DDEN,DDEX,DDEZ,DDEQUIT,DDELIST,DLIST
+16 NEW DFN,ICN,FILE,QUERY,LIST
+17 ;
+18 SET DDEY=$GET(TARGET,$NAME(^TMP("DDE GET",$JOB)))
+19 ;p20
SET DDEI=$SELECT($GET(FILTER("init")):FILTER("init"),1:0)
if 'DDEI
KILL @DDEY
+20 SET DDER=$GET(ERROR,$NAME(^TMP("DDERR",$JOB)))
KILL @DDER
+21 ;for crossing midnight boundary
SET DT=$$DT^XLFDT
+22 SET DSYS=$$SYS
SET ID=$GET(ID)
+23 ;
A ; parse & validate input parameters
+1 IF $GET(ENTITY)=""
DO ERROR("Entity parameter invalid")
GOTO ENQ
+2 ;IEN or Name
SET DTYPE=$SELECT((+ENTITY=ENTITY):+ENTITY,1:+$ORDER(^DDE("B",ENTITY,0)))
+3 IF DTYPE<1!'$DATA(^DDE(DTYPE))
DO ERROR("Entity "_ENTITY_" does not exist")
GOTO ENQ
+4 ;
+5 SET FILE=$PIECE($GET(^DDE(DTYPE,0)),U,2)
+6 IF FILE
IF '$$VFILE^DILFD(FILE)
DO ERROR("Invalid file number for Entity "_DTYPE)
GOTO ENQ
+7 ;
+8 SET DSTRT=+$GET(FILTER("start"),1410102)
+9 SET DSTOP=+$GET(FILTER("stop"),4141015)
+10 IF DSTRT
IF DSTOP
IF DSTOP<DSTRT
Begin DoDot:1
+11 NEW X
SET X=DSTRT
SET DSTRT=DSTOP
SET DSTOP=X
End DoDot:1
+12 IF DSTOP
IF $LENGTH(DSTOP,".")<2
SET DSTOP=DSTOP_".24"
+13 SET DMAX=+$GET(MAX,9999)
+14 ;
+15 IF ID=""
IF $DATA(FILTER("id"))
SET ID=FILTER("id")
+16 SET DFN=$GET(FILTER("patient"))
SET ICN=+$PIECE($GET(DFN),";",2)
SET DFN=+$GET(DFN)
+17 IF DFN<1
IF ICN
SET DFN=+$$GETDFN^MPIF001(ICN)
+18 IF FILE=2
IF DFN<1
IF ID
SET DFN=ID
+19 IF DFN
IF '$$VALID(DFN)
DO ERROR("Invalid Patient file DFN: "_DFN)
GOTO ENQ
+20 ;
+21 ; DFORM 2:TEXT 1:XML 0:JSON (default = JSON)
+22 SET DFORM=$$UP^XLFSTR($GET(FORMAT))
+23 SET DFORM=$SELECT(DFORM=0:0,+DFORM:DFORM,DFORM="JSON":0,DFORM="XML":1,DFORM="TEXT":2,1:0)
+24 ;
+25 DO PRE(DTYPE)
if $GET(DDEQUIT)
QUIT
+26 ;
B ; extract data
+1 ;TAG^RTN from ENTITY
SET QUERY=$GET(^DDE(DTYPE,5))
+2 ;omit tag for JSON item
SET LIST=$SELECT(DFORM:0,1:+$GET(FILTER("notag")))
+3 ;pass subfile iens to query ;p24
IF ID'=""
IF $EXTRACT(ID)'=","
SET DLIST(1)=ID
+4 ;no outer tags for a JSON list
IF '$TEST
Begin DoDot:1
+5 NEW $ESTACK,$ETRAP
SET $ETRAP="D QRY^DDERR"
+6 IF $LENGTH(QUERY)>1
IF $LENGTH($TEXT(@($PIECE(QUERY,"("))))
DO @QUERY
QUIT
+7 DO DIC(DTYPE)
End DoDot:1
if 'DFORM
SET LIST=1
+8 ;
+9 SET DDEN=0
FOR
SET DDEN=$ORDER(DLIST(DDEN))
if DDEN<1
QUIT
Begin DoDot:1
+10 NEW $ESTACK,$ETRAP
SET $ETRAP="D ONE^DDERR"
+11 SET ID=DLIST(DDEN)
+12 SET DDEX=$$EN1^DDEG(DTYPE,ID,LIST,.DDEZ)
+13 ;Error msg
IF DDEZ
DO ERROR($PIECE(DDEZ,U,2))
QUIT
+14 IF $LENGTH(DDEX)
SET DDEI=DDEI+1
SET @DDEY@(DDEI)=DDEX
End DoDot:1
+15 SET @DDEY@(0)=DDEI
+16 ;
+17 DO POST(DTYPE)
+18 ;
ENQ ;exit
+1 SET TARGET=DDEY
SET ERROR=DDER
+2 QUIT
+3 ;
DIC(ENT) ; -- FIND/LIST^DIC, returns DLIST(#)=id for query ;p24
+1 ; ID should be null, or iens for sub-file search (",###,")
+2 NEW XREF,VAL,SCR,FROM,PART,DDVAL,I
if '$GET(FILE)
QUIT
+3 SET XREF=$PIECE($GET(^DDE(ENT,0)),U,3)
SET VAL=$PIECE($GET(^(0)),U,4)
SET SCR=$GET(^(5.1))
+4 SET FROM=$GET(FILTER("from"))
SET PART=$GET(FILTER("partial"))
+5 ;set up DDVAL for FIND using simple or
IF $DATA(FILTER)!$LENGTH(VAL)
Begin DoDot:1
+6 ;compound index value(s) where I=#
if $LENGTH($GET(FILTER))
SET DDVAL=FILTER
+7 NEW I
SET I=0
FOR
SET I=$ORDER(FILTER(I))
if 'I
QUIT
SET DDVAL(I)=FILTER(I)
+8 IF '$LENGTH($GET(DDVAL))
IF '$ORDER(DDVAL(0))
IF $LENGTH(VAL)
SET DDVAL=$SELECT($DATA(@VAL):@VAL,1:VAL)
End DoDot:1
+9 if $DATA(DDVAL)
DO FIND^DIC(FILE,ID,"@","Q",.DDVAL,DMAX,XREF,SCR,,"DDELIST")
+10 if '$DATA(DDVAL)
DO LIST^DIC(FILE,ID,"@","Q",DMAX,FROM,PART,XREF,SCR,,"DDELIST")
+11 IF $DATA(^DIC(FILE,0))
MERGE DLIST=DDELIST("DILIST",2)
QUIT
+12 ; append ID (iens) to each DA for sub-files
+13 SET I=0
FOR
SET I=$ORDER(DDELIST("DILIST",2,I))
if I<1
QUIT
SET DLIST(I)=DDELIST("DILIST",2,I)_ID
+14 QUIT
+15 ;
PRE(ENT) ; -- pre-processing logic
+1 NEW X
+2 SET X=$GET(^DDE(+ENT,2))
if X'=""
XECUTE X
+3 QUIT
+4 ;
POST(ENT) ; -- post-processing logic
+1 NEW X
+2 SET X=$GET(^DDE(+ENT,3))
if X'=""
XECUTE X
+3 QUIT
+4 ;
ERROR(MSG) ; -- return error MSG
+1 NEW I
SET I=+$ORDER(@DDER@("A"),-1)
+2 SET I=I+1
SET @DDER@(I)=$GET(MSG)
+3 QUIT
+4 ;
VALID(PAT) ; -- return 1 or 0, if valid PATient #2 ien
+1 SET PAT=+$GET(PAT)
+2 ; invalid pointer?
+3 IF PAT<1
QUIT 0
+4 IF '$DATA(^DPT(PAT,0))
QUIT 0
+5 ; merged [from] patient?
+6 IF $PIECE(^DPT(PAT,0),U)["MERGING INTO"
QUIT 0
+7 IF $GET(^DPT(PAT,-9))
QUIT 0
+8 ; ok
+9 QUIT 1
+10 ;
SYS() ; -- return hashed system name
+1 QUIT $$BASE^XLFUTL($$CRC16^XLFCRC($$KSP^XUPARAM("WHERE")),10,16)
