DDEG ;SPFO/RAM,MKB - Entity GET Extract ;1/26/23 10:37
;;22.2;VA FileMan;**9,16,17,18,20,21,24,27**;Jan 05, 2016;Build 7
;;Per VA Directive 6402, this routine should not be modified.
Q
;
; $$EN1 called from ^DDEGET, assumes validated input parameters:
; DIENTY = Entity file #1.5 ien
; DIEN = ID of entity instance to return
; NOTAG = 1 if entity is a list item (omit tags)
; ERROR = returns '-1^message' if error, else ""
; DFORM = format for results (0, 1, 2); default is 0=JSON
;
EN1(DIENTY,DIEN,NOTAG,ERROR) ; -- return a single Entity (expects DFORM=0/1/2)
N DIFN,DNAME,DDEOUT,DAC,DSEQ,DITM,DRES,X
S DFORM=+$G(DFORM),(DRES,ERROR)=""
S DIENTY=+$G(DIENTY),DIEN=$G(DIEN)
S DIFN=$P($G(^DDE(DIENTY,0)),U,2)
S DNAME=$G(^DDE(DIENTY,.1)) S:DNAME="" DNAME=$P($G(^(0)),U)
;
D IENPROC I $G(DDEOUT)!$G(DDEQUIT) K DDEOUT G ENQ
I $G(DIEN)="" S ERROR="-1^Record "_$G(DIEN)_" not found" G ENQ
;
S DAC=$P($G(^DDE(+DIENTY,"DAC")),U,1) I DAC D G:ERROR ENQ ;p20
. N DDETXT,DDERR
. S DAC=$$CANDO^DIAC1(DIFN,DIEN,DAC,DUZ,,,"DDETXT","DDERR")
. S ERROR=$S(DAC<0:"-1^"_$G(DDERR(1)),'DAC:"-1^"_$G(DDETXT(1)),1:0)
;
; loop through items
S DSEQ=0 F S DSEQ=$O(^DDE(DIENTY,1,"SEQ",DSEQ)) Q:'DSEQ D Q:ERROR!$G(DDEQUIT)
. S DITM=0 F S DITM=$O(^DDE(DIENTY,1,"SEQ",DSEQ,DITM)) Q:'DITM D Q:ERROR!$G(DDEQUIT)
.. S X=$$VALUE(DITM) I X=""!ERROR!$G(DDEQUIT) Q
.. S DRES=$$ADD(DRES,X,DSEQ)
;
I $L(DRES),'$G(DDEQUIT) D
. S:'DFORM DRES="{"_DRES_"}"
. Q:$G(NOTAG) ;for embedded items
. S DRES=$$ELEMENT("",DNAME,DRES,,,"C")
ENQ ;
S:$G(DDEQUIT) DRES=""
Q DRES
;
VALUE(ITM,NOTAG) ; -- build a complete ITEM value
N ITM0,TAG,ITEM,TYPE,FILE,FIELD,IEN
;
S ITM0=$G(^DDE(+DIENTY,1,+ITM,0)),IEN=$G(DIEN)
S TAG=$P(ITM0,U),FILE=$P(ITM0,U,4),FIELD=$P(ITM0,U,5)
S:'FILE FILE=DIFN ;default file#
S TYPE=$P($$GET1^DIQ(1.51,(+ITM_","_+DIENTY_","),.03)," ")
;
S ITEM="" I $L(TYPE),$L($T(@TYPE)) D @TYPE G VQ ;build ITEM
D SIMPLE
VQ ;
Q ITEM
;
SIMPLE ; -- retrieve simple ITEM (from $$VALUE)
N VALUE,LKUP,FMT,XFRM
S VALUE="",XFRM=$G(^DDE(+DIENTY,1,+ITM,4))
;
; get VALUE via code or field
D ITMPROC I $G(DDEOUT)!$G(DDEQUIT) K DDEOUT Q
I VALUE="",$G(FIELD) D Q:VALUE=""
. S LKUP=$P(ITM0,U,6) S:LKUP'="" FIELD=FIELD_":"_LKUP
. S FMT=$S(+$P(ITM0,U,7):"I",1:"E")
. S VALUE=$$GET1^DIQ(FILE,IEN_",",FIELD,FMT)
;
; apply output transform
I $L(VALUE),$L(XFRM) X XFRM
;
I $$VALID(VALUE) D ;add tags
. S VALUE=$$ESC(VALUE)
. I $G(NOTAG) S ITEM=VALUE Q ;for List items
. S ITEM=$$ELEMENT("",TAG,VALUE)
Q
;
FIXED ; -- build one FIXED item (from $$VALUE)
N VALUE S VALUE=""
;
; get VALUE via code or string
D ITMPROC I $G(DDEOUT)!$G(DDEQUIT) K DDEOUT Q
S:VALUE="" VALUE=$G(^DDE(+DIENTY,1,+ITM,2)) ;Fixed Response
;
I $$VALID(VALUE) D ;add tags
. S VALUE=$$ESC(VALUE)
. I $G(NOTAG) S ITEM=VALUE Q ;for List items
. S ITEM=$$ELEMENT("",TAG,VALUE)
Q
;
ID ; -- build one ID item (from $$VALUE)
N VALUE,XFRM
S VALUE="",XFRM=$G(^DDE(+DIENTY,1,+ITM,4))
;
; get VALUE via code or IEN
D ITMPROC I $G(DDEOUT)!$G(DDEQUIT) K DDEOUT Q
S:VALUE="" VALUE=IEN
;
; apply output transform
I $L(VALUE),$L(XFRM) X XFRM
;
I $$VALID(VALUE) D ;add tags
. S VALUE=$$ESC(VALUE)
. I $G(NOTAG) S ITEM=VALUE Q ;for List items
. S ITEM=$$ELEMENT("",TAG,VALUE)
Q
;
WORD ; -- build one WP ITEM (from $$VALUE)
N WP,LKUP,CRLF,I,X,VALUE S VALUE="",I=0
;
; get WP(n) or WP(n,0) via code or field
D ITMPROC I $G(DDEOUT)!$G(DDEQUIT) K DDEOUT Q
I '$D(WP),$G(FIELD) D Q:'$D(WP)
. S LKUP=$P(ITM0,U,6) S:LKUP'="" FIELD=FIELD_":"_LKUP
. S I=$$GET1^DIQ(FILE,IEN_",",FIELD,,"WP")
;
S CRLF='$P(ITM0,U,9)
S I=+$O(WP(0)),X=$S($D(WP(I,0)):WP(I,0),1:$G(WP(I)))
S VALUE=X
F S I=$O(WP(I)) Q:I<1 D
. S X=$S($D(WP(I,0)):WP(I,0),1:WP(I))
. I $E(X)=" " S VALUE=VALUE_$C(13,10)_X Q
. I CRLF S VALUE=VALUE_$C(13,10)_X Q
. S VALUE=VALUE_$S($E(VALUE,$L(VALUE))=" ":"",1:" ")_X
;
I $$VALID(VALUE) D Q ;add tags
. I $P(ITM0,U,10) D ;p20
.. Q:$L(VALUE)'>$P(ITM0,U,10)
.. S VALUE=$S($P(ITM0,U,11)]"":$P(ITM0,U,11),1:"Text exceeds "_$P(ITM0,U,10)_" limit and could not be saved. Please contact the site for full original text.")
. E I $L(VALUE)>2999999 S VALUE="Text exceeds 3 megabyte limit and could not be saved. Please contact the site for full original text." ;p16
. S VALUE=$$ESC(VALUE)
. I $G(NOTAG) S ITEM=VALUE Q ;for List items
. S ITEM=$$ELEMENT("",TAG,VALUE)
Q
;
ENTITY ; -- build an entity ITEM (from $$VALUE)
N ENTITY,ERR,VALUE,DATA,LKUP,FMT,XFRM,ID
S ENTITY=$P(ITM0,U,8) Q:ENTITY=""
S (VALUE,ERR)="",XFRM=$G(^DDE(+DIENTY,1,+ITM,4))
;
; get VALUE via code or field, for Entity ID
; DATA can also be defined here, to pass to Entity
D ITMPROC I $G(DDEOUT)!$G(DDEQUIT) K DDEOUT Q
I VALUE="",$G(FIELD) D Q:VALUE=""
. S LKUP=$P(ITM0,U,6) S:LKUP'="" FIELD=FIELD_":"_LKUP
. S FMT=$S(+$P(ITM0,U,7):"I",1:"E")
. S VALUE=$$GET1^DIQ(FILE,IEN_",",FIELD,FMT)
I $L(VALUE),$L(XFRM) X XFRM
Q:VALUE="" S ID=VALUE
;
D PREPROC(+ENTITY) ;Pre-Processing
S VALUE=$$EN1^DDEG(+ENTITY,ID,1)
D POST(+ENTITY) ;Post-Processing
;
I $L(VALUE) D Q ;add tags
. I VALUE<0 S ERROR=VALUE Q
. I $G(NOTAG) S ITEM=VALUE Q ;for embedded or list items
. S ITEM=$$ELEMENT("",TAG,VALUE,,,"C")
Q
;
COMPLEX ; -- build a complex ITEM (from $$VALUE)
N SEQ,IDX1,TAG1,IDX0,VALUE
;
D ITMPROC I $G(DDEOUT)!$G(DDEQUIT) K DDEOUT Q
;
S SEQ=0 F S SEQ=$O(^DDE(DIENTY,1,ITM,3,"B",SEQ)) Q:'SEQ D Q:$G(ERROR)!$G(DDEQUIT)
. S IDX1=$O(^DDE(DIENTY,1,ITM,3,"B",SEQ,0))
. S TAG1=$P(^DDE(DIENTY,1,ITM,3,IDX1,0),U,2) Q:TAG1=""
. S IDX0=+$O(^DDE(DIENTY,1,"B",TAG1,0))
. I IDX0<1!'$D(^DDE(DIENTY,1,IDX0,0)) Q
. ;
. S VALUE=$$VALUE(IDX0) Q:$G(ERROR)!$G(DDEQUIT)
. S:VALUE'="" ITEM=$$ADD(ITEM,VALUE,SEQ)
;
Q:$G(ERROR) I $L(ITEM) D ;add tags
. S:'DFORM ITEM="{"_ITEM_"}" Q:$G(NOTAG) ;for List items
. S ITEM=$$ELEMENT("",TAG,ITEM,,,"C")
Q
;
LIST ; -- build an array of values in ITEM (from $$VALUE)
N ITM1 S ITM1=$G(^DDE(+DIENTY,1,+ITM,1))
;
D @("LIST"_+ITM1) ;LIST_type#
;
Q:$G(ERROR)!$G(DDEQUIT)
I $L(ITEM) D ;add tags
. S:'DFORM ITEM="["_ITEM_"]" Q:$G(NOTAG) ;for List items
. S ITEM=$$ELEMENT("",TAG,ITEM,,,"L")
Q
;
LIST1 ; -- list of values in FILE (from LIST)
N C,TAG,XREF,FILTER,SCREEN,LKUP,FMT,XFRM,ENTITY,QUERY,DDELIST,DLIST,SEQ,IEN1,VALUE,ERR
S C=",",ENTITY=+$P(ITM0,U,8)
S TAG=$P(ITM1,U,2),XREF=$P(ITM1,U,3),FILTER=$P(ITM1,U,4)
S SCREEN=$G(^DDE(+DIENTY,1,+ITM,1.1))
;
D ITMPROC I $G(DDEOUT)!$G(DDEQUIT) K DDEOUT Q
;
; set up for results: single FIELD or multi-field (record) ENTITY
I FIELD D
. S LKUP=$P(ITM0,U,6) S:LKUP'="" FIELD=FIELD_":"_LKUP ;support extended pointers=LKUP ;p24
. S FMT=$S(+$P(ITM0,U,7):"I",1:"E"),XFRM=$G(^DDE(+DIENTY,1,+ITM,4))
I ENTITY D
. N X0 S X0=$G(^DDE(ENTITY,0)) S:'$L(TAG) TAG=$G(^(.1))
. ; get defaults from Entity if not defined in Item
. S:'$L(XREF) XREF=$P(X0,U,3)
. S:'$L(FILTER) FILTER=$P(X0,U,4)
. S:'$L(SCREEN) SCREEN=$G(^DDE(ENTITY,5.1))
. S QUERY=$G(^DDE(ENTITY,5))
. D PREPROC(ENTITY)
I $L(FILTER) S FILTER=$S($D(@FILTER):@FILTER,1:FILTER)
S:TAG="" TAG=$P(ITM0,U)
;
L1 ; find appropriate records and process
I $L(QUERY)>1,$L($T(@($P(QUERY,"(")))) D @QUERY I 1
E D FIND^DIC(FILE,,"@","Q",.FILTER,,XREF,SCREEN,,"DDELIST") M DLIST=DDELIST("DILIST",2)
S SEQ=0 F S SEQ=$O(DLIST(SEQ)) Q:'SEQ D
. S IEN1=$G(DLIST(SEQ))
. S (VALUE,ERR)=""
. I FIELD D
.. S VALUE=$$GET1^DIQ(FILE,(IEN1_C),FIELD,FMT)
.. I $L(VALUE),$L(XFRM) X XFRM ;output transform
.. I '$$VALID(VALUE) S VALUE="" Q
.. I ENTITY S VALUE=$$EN1^DDEG(ENTITY,VALUE,1,.ERR)
. I 'FIELD,ENTITY S VALUE=$$EN1^DDEG(ENTITY,IEN1,1,.ERR)
. ;
. I VALUE=""!$G(ERR)!$G(DDEQUIT) Q
. S ITEM=$$ELEMENT(ITEM,TAG,VALUE,SEQ,"addList")
;
D:ENTITY POST(ENTITY)
Q
;
LIST2 ; -- list of values in SUBFILE (from LIST)
N IENS,C,TAG,XREF,SCREEN,LKUP,FMT,XFRM,ENTITY,DLIST,SEQ,IEN1,VALUE,ERR
S IENS=","_IEN,C=",",ENTITY=$P(ITM0,U,8) ;"" ;p21 initialize ENTITY
S TAG=$P(ITM1,U,2),XREF=$P(ITM1,U,3),SCREEN=$G(^DDE(+DIENTY,1,+ITM,1.1))
;
D ITMPROC I $G(DDEOUT)!$G(DDEQUIT) K DDEOUT Q
;
; set up FIELD and/or ENTITY for results
I FIELD D
. S LKUP=$P(ITM0,U,6) S:LKUP'="" FIELD=FIELD_":"_LKUP ;support extended pointers=LKUP ;p24
. S FMT=$S(+$P(ITM0,U,7):"I",1:"E"),XFRM=$G(^DDE(+DIENTY,1,+ITM,4))
I ENTITY D
. S:'$L(TAG) TAG=$G(^DDE(ENTITY,.1))
. S:'$L(XREF) XREF=$P($G(^DDE(ENTITY,0)),U,3)
. S:'$L(SCREEN) SCREEN=$G(^DDE(ENTITY,5.1))
. D PREPROC(ENTITY)
S:TAG="" TAG=$P(ITM0,U)
;
L2 ; find appropriate records and process
D LIST^DIC(FILE,IENS_C,"@","Q",,,,XREF,SCREEN,,"DLIST")
S SEQ=0 F S SEQ=$O(DLIST("DILIST",2,SEQ)) Q:'SEQ D Q:$G(ERR)
. S IEN1=$G(DLIST("DILIST",2,SEQ))_IENS
. S (VALUE,ERR)=""
. I FIELD D
.. S VALUE=$$GET1^DIQ(FILE,(IEN1_C),FIELD,FMT)
.. I $L(VALUE),$L(XFRM) X XFRM ;output transform
.. I '$$VALID(VALUE) S VALUE="" Q
.. I ENTITY S VALUE=$$EN1^DDEG(ENTITY,VALUE,1,.ERR)
. I 'FIELD,ENTITY S VALUE=$$EN1^DDEG(ENTITY,IEN1,1,.ERR)
. ;
. I VALUE=""!$G(ERR)!$G(DDEQUIT) Q
. S ITEM=$$ELEMENT(ITEM,TAG,VALUE,SEQ,"addList")
;
D:ENTITY POST(ENTITY)
Q
;
LIST3 ; -- list of values in COMPLEX FIELDS (from LIST)
N TAG,SEQ,IDX1,NM1,IDX0,VALUE
S TAG=$P(ITM1,U,2) S:TAG="" TAG=$P(ITM0,U)
;
D ITMPROC I $G(DDEOUT)!$G(DDEQUIT) K DDEOUT Q
;
; process list Items
S SEQ=0 F S SEQ=$O(^DDE(DIENTY,1,ITM,3,"B",SEQ)) Q:'SEQ D Q:$G(ERROR)
. S IDX1=$O(^DDE(DIENTY,1,ITM,3,"B",SEQ,0))
. S NM1=$P(^DDE(DIENTY,1,ITM,3,IDX1,0),U,2) Q:NM1=""
. S IDX0=+$O(^DDE(DIENTY,1,"B",NM1,0))
. I IDX0<1!'$D(^DDE(DIENTY,1,IDX0,0)) Q
. ;
. S VALUE=$$VALUE(IDX0,1)
. ;
. I VALUE=""!$G(ERR)!$G(DDEQUIT) Q
. S ITEM=$$ELEMENT(ITEM,TAG,VALUE,SEQ,"addList")
Q
;
LIST4 ; -- list of values in DLIST()
N DLIST,TAG,ENTITY,SEQ,X,VALUE,ERR
S TAG=$P(ITM1,U,2)
;
;create DLIST()=data value or ID for Entity
D ITMPROC I $G(DDEOUT)!$G(DDEQUIT) K DDEOUT Q
;
; set up for results: single FIELD or multi-field ENTITY
S ENTITY=$P(ITM0,U,8) I ENTITY D
. S:'$L(TAG) TAG=$G(^DDE(ENTITY,.1))
. D PREPROC(ENTITY)
I TAG="" S TAG=$P(ITM0,U)
;
; process list items
S SEQ=0 F S SEQ=$O(DLIST(SEQ)) Q:'SEQ D Q:$G(ERR)
. S X=$G(DLIST(SEQ))
. S (VALUE,ERR)=""
. I 'ENTITY,$$VALID(X) S VALUE=X
. E S VALUE=$$EN1^DDEG(ENTITY,X,1,.ERR)
. ;
. I VALUE=""!$G(ERR)!$G(DDEQUIT) Q
. S ITEM=$$ELEMENT(ITEM,TAG,VALUE,SEQ,"addList")
;
D:ENTITY POST(ENTITY)
Q
;
ADD(STRING,ELEMENT,SEQ) ; -- add ELEMENT to result STRING
Q:$G(ELEMENT)="" STRING
;
; JSON:0 XML:1 TEXT:2
S DFORM=+$G(DFORM),SEQ=+$G(SEQ)
;
N RES S RES=$G(STRING)
I DFORM=0 S RES=RES_$S($L($G(STRING)):", ",1:"")_ELEMENT ;SEQ>1
I DFORM=1 S RES=RES_ELEMENT
I DFORM=2 S RES=RES_$S($L($G(STRING)):U,1:"")_ELEMENT ;SEQ>1
Q RES
;
ELEMENT(STRING,NAME,VALUE,SEQ,OPTION,DTYPE) ; -- build an element STRING
; STRING=SERIALIZED RESPONSE
S STRING=$G(STRING) Q:$G(NAME)="" STRING
S:NAME["." NAME=$P(NAME,".",2)
S VALUE=$G(VALUE)
S SEQ=+$G(SEQ),OPTION=$G(OPTION,"addTags")
;
; does DataTYPE not require quotes?
S DTYPE=$S($G(DTYPE)="C":1,$G(DTYPE)="L":1,"[{"[$E(VALUE):1,VALUE?0.1"-"1.N1"E"1N.E:0,VALUE?0.1"-"1.N1"e"1N.E:0,+VALUE=VALUE:1,1:0) ;p27
N X,Y S X="""",Y=$S(DTYPE:"",1:"""")
;
S DFORM=+$G(DFORM) ; JSON:0 XML:1 TEXT:2
I OPTION="addTags" D Q STRING
. S:DFORM=0 STRING=X_NAME_X_":"_Y_VALUE_Y
. S:DFORM=1 STRING="<"_NAME_">"_VALUE_"</"_NAME_">"
. S:DFORM=2 STRING=VALUE
;
I OPTION="addList" D Q STRING
. S:DFORM=0 STRING=STRING_$S($L(STRING):", ",1:"")_Y_VALUE_Y ;SEQ>1
. S:DFORM=1 STRING=STRING_"<"_NAME_">"_VALUE_"</"_NAME_">"
. S:DFORM=2 STRING=STRING_$S($L(STRING):"~",1:"")_Y_VALUE_Y ;SEQ>1
;
Q STRING
;
VALID(X) ; -- return 1 or 0, if X is a valid string
; Cannot be null or only white space
S X=$G(X)
I X="" Q 0
I X?." " Q 0
;I X?.P Q 0
Q 1
;
ESC(X) ; -- convert key characters for outgoing XML/JSON
Q:DFORM=2 X
I DFORM=0 Q $$ESC^XLFJSON(X)
; DFORM=1 XML
N I,Y,QOT S QOT=""""
; strip control characters ;p16 add $C(0)
F I=0:1:8,11,12,14:1:31 I X[$C(I) S X=$TR(X,$C(I))
; p17 strip non-printable characters
F I=127:1:159 I X[$C(I) S X=$TR(X,$C(I))
; handle special characters:
; DDESC = 1 ('&' only), 2 ('&' + CDATA), or
; default (0/null/undefined) = CDATA only
I (X["&")!(X["<")!(X[">")!(X["'")!(X[QOT) D Q Y
. I $G(DDESC) D Q:DDESC=1 S X=Y
.. S Y=$P(X,"&") F I=2:1:$L(X,"&") S Y=Y_"&"_$P(X,"&",I)
.. S X=Y,Y=$P(X,"<") F I=2:1:$L(X,"<") S Y=Y_"<"_$P(X,"<",I)
.. S X=Y,Y=$P(X,">") F I=2:1:$L(X,">") S Y=Y_">"_$P(X,">",I)
.. S X=Y,Y=$P(X,"'") F I=2:1:$L(X,"'") S Y=Y_"'"_$P(X,"'",I)
.. S X=Y,Y=$P(X,QOT) F I=2:1:$L(X,QOT) S Y=Y_"""_$P(X,QOT,I)
. I X["]]>" D S X=Y ;p16 strip end brackets from transcription upload
.. S Y=$P(X,"]]>") F I=2:1:$L(X,"]]>") S Y=Y_$P(X,"]]>",I)
. S Y="<![CDATA["_X_"]]>"
Q X
;
PREPROC(DIENTY) ; -- pre-processing logic
N X
S X=$G(^DDE(+DIENTY,2)) X:X'="" X
Q
;
IENPROC ; -- IEN processing logic
; setting DDEOUT will cause this record (IEN) to not be returned
N X
S X=$G(^DDE(+DIENTY,4)) X:X'="" X
Q
;
ITMPROC ; -- ITEM processing logic
; setting DDEOUT will cause this item to not be returned
N X
S X=$G(^DDE(+DIENTY,1,+ITM,6)) X:X'="" X
Q
;
POST(DIENTY) ; -- post-processing logic
N X
S X=$G(^DDE(+DIENTY,3)) X:X'="" X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDEG 13604 printed Sep 23, 2025@20:18:07 Page 2
DDEG ;SPFO/RAM,MKB - Entity GET Extract ;1/26/23 10:37
+1 ;;22.2;VA FileMan;**9,16,17,18,20,21,24,27**;Jan 05, 2016;Build 7
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
+5 ; $$EN1 called from ^DDEGET, assumes validated input parameters:
+6 ; DIENTY = Entity file #1.5 ien
+7 ; DIEN = ID of entity instance to return
+8 ; NOTAG = 1 if entity is a list item (omit tags)
+9 ; ERROR = returns '-1^message' if error, else ""
+10 ; DFORM = format for results (0, 1, 2); default is 0=JSON
+11 ;
EN1(DIENTY,DIEN,NOTAG,ERROR) ; -- return a single Entity (expects DFORM=0/1/2)
+1 NEW DIFN,DNAME,DDEOUT,DAC,DSEQ,DITM,DRES,X
+2 SET DFORM=+$GET(DFORM)
SET (DRES,ERROR)=""
+3 SET DIENTY=+$GET(DIENTY)
SET DIEN=$GET(DIEN)
+4 SET DIFN=$PIECE($GET(^DDE(DIENTY,0)),U,2)
+5 SET DNAME=$GET(^DDE(DIENTY,.1))
if DNAME=""
SET DNAME=$PIECE($GET(^(0)),U)
+6 ;
+7 DO IENPROC
IF $GET(DDEOUT)!$GET(DDEQUIT)
KILL DDEOUT
GOTO ENQ
+8 IF $GET(DIEN)=""
SET ERROR="-1^Record "_$GET(DIEN)_" not found"
GOTO ENQ
+9 ;
+10 ;p20
SET DAC=$PIECE($GET(^DDE(+DIENTY,"DAC")),U,1)
IF DAC
Begin DoDot:1
+11 NEW DDETXT,DDERR
+12 SET DAC=$$CANDO^DIAC1(DIFN,DIEN,DAC,DUZ,,,"DDETXT","DDERR")
+13 SET ERROR=$SELECT(DAC<0:"-1^"_$GET(DDERR(1)),'DAC:"-1^"_$GET(DDETXT(1)),1:0)
End DoDot:1
if ERROR
GOTO ENQ
+14 ;
+15 ; loop through items
+16 SET DSEQ=0
FOR
SET DSEQ=$ORDER(^DDE(DIENTY,1,"SEQ",DSEQ))
if 'DSEQ
QUIT
Begin DoDot:1
+17 SET DITM=0
FOR
SET DITM=$ORDER(^DDE(DIENTY,1,"SEQ",DSEQ,DITM))
if 'DITM
QUIT
Begin DoDot:2
+18 SET X=$$VALUE(DITM)
IF X=""!ERROR!$GET(DDEQUIT)
QUIT
+19 SET DRES=$$ADD(DRES,X,DSEQ)
End DoDot:2
if ERROR!$GET(DDEQUIT)
QUIT
End DoDot:1
if ERROR!$GET(DDEQUIT)
QUIT
+20 ;
+21 IF $LENGTH(DRES)
IF '$GET(DDEQUIT)
Begin DoDot:1
+22 if 'DFORM
SET DRES="{"_DRES_"}"
+23 ;for embedded items
if $GET(NOTAG)
QUIT
+24 SET DRES=$$ELEMENT("",DNAME,DRES,,,"C")
End DoDot:1
ENQ ;
+1 if $GET(DDEQUIT)
SET DRES=""
+2 QUIT DRES
+3 ;
VALUE(ITM,NOTAG) ; -- build a complete ITEM value
+1 NEW ITM0,TAG,ITEM,TYPE,FILE,FIELD,IEN
+2 ;
+3 SET ITM0=$GET(^DDE(+DIENTY,1,+ITM,0))
SET IEN=$GET(DIEN)
+4 SET TAG=$PIECE(ITM0,U)
SET FILE=$PIECE(ITM0,U,4)
SET FIELD=$PIECE(ITM0,U,5)
+5 ;default file#
if 'FILE
SET FILE=DIFN
+6 SET TYPE=$PIECE($$GET1^DIQ(1.51,(+ITM_","_+DIENTY_","),.03)," ")
+7 ;
+8 ;build ITEM
SET ITEM=""
IF $LENGTH(TYPE)
IF $LENGTH($TEXT(@TYPE))
DO @TYPE
GOTO VQ
+9 DO SIMPLE
VQ ;
+1 QUIT ITEM
+2 ;
SIMPLE ; -- retrieve simple ITEM (from $$VALUE)
+1 NEW VALUE,LKUP,FMT,XFRM
+2 SET VALUE=""
SET XFRM=$GET(^DDE(+DIENTY,1,+ITM,4))
+3 ;
+4 ; get VALUE via code or field
+5 DO ITMPROC
IF $GET(DDEOUT)!$GET(DDEQUIT)
KILL DDEOUT
QUIT
+6 IF VALUE=""
IF $GET(FIELD)
Begin DoDot:1
+7 SET LKUP=$PIECE(ITM0,U,6)
if LKUP'=""
SET FIELD=FIELD_":"_LKUP
+8 SET FMT=$SELECT(+$PIECE(ITM0,U,7):"I",1:"E")
+9 SET VALUE=$$GET1^DIQ(FILE,IEN_",",FIELD,FMT)
End DoDot:1
if VALUE=""
QUIT
+10 ;
+11 ; apply output transform
+12 IF $LENGTH(VALUE)
IF $LENGTH(XFRM)
XECUTE XFRM
+13 ;
+14 ;add tags
IF $$VALID(VALUE)
Begin DoDot:1
+15 SET VALUE=$$ESC(VALUE)
+16 ;for List items
IF $GET(NOTAG)
SET ITEM=VALUE
QUIT
+17 SET ITEM=$$ELEMENT("",TAG,VALUE)
End DoDot:1
+18 QUIT
+19 ;
FIXED ; -- build one FIXED item (from $$VALUE)
+1 NEW VALUE
SET VALUE=""
+2 ;
+3 ; get VALUE via code or string
+4 DO ITMPROC
IF $GET(DDEOUT)!$GET(DDEQUIT)
KILL DDEOUT
QUIT
+5 ;Fixed Response
if VALUE=""
SET VALUE=$GET(^DDE(+DIENTY,1,+ITM,2))
+6 ;
+7 ;add tags
IF $$VALID(VALUE)
Begin DoDot:1
+8 SET VALUE=$$ESC(VALUE)
+9 ;for List items
IF $GET(NOTAG)
SET ITEM=VALUE
QUIT
+10 SET ITEM=$$ELEMENT("",TAG,VALUE)
End DoDot:1
+11 QUIT
+12 ;
ID ; -- build one ID item (from $$VALUE)
+1 NEW VALUE,XFRM
+2 SET VALUE=""
SET XFRM=$GET(^DDE(+DIENTY,1,+ITM,4))
+3 ;
+4 ; get VALUE via code or IEN
+5 DO ITMPROC
IF $GET(DDEOUT)!$GET(DDEQUIT)
KILL DDEOUT
QUIT
+6 if VALUE=""
SET VALUE=IEN
+7 ;
+8 ; apply output transform
+9 IF $LENGTH(VALUE)
IF $LENGTH(XFRM)
XECUTE XFRM
+10 ;
+11 ;add tags
IF $$VALID(VALUE)
Begin DoDot:1
+12 SET VALUE=$$ESC(VALUE)
+13 ;for List items
IF $GET(NOTAG)
SET ITEM=VALUE
QUIT
+14 SET ITEM=$$ELEMENT("",TAG,VALUE)
End DoDot:1
+15 QUIT
+16 ;
WORD ; -- build one WP ITEM (from $$VALUE)
+1 NEW WP,LKUP,CRLF,I,X,VALUE
SET VALUE=""
SET I=0
+2 ;
+3 ; get WP(n) or WP(n,0) via code or field
+4 DO ITMPROC
IF $GET(DDEOUT)!$GET(DDEQUIT)
KILL DDEOUT
QUIT
+5 IF '$DATA(WP)
IF $GET(FIELD)
Begin DoDot:1
+6 SET LKUP=$PIECE(ITM0,U,6)
if LKUP'=""
SET FIELD=FIELD_":"_LKUP
+7 SET I=$$GET1^DIQ(FILE,IEN_",",FIELD,,"WP")
End DoDot:1
if '$DATA(WP)
QUIT
+8 ;
+9 SET CRLF='$PIECE(ITM0,U,9)
+10 SET I=+$ORDER(WP(0))
SET X=$SELECT($DATA(WP(I,0)):WP(I,0),1:$GET(WP(I)))
+11 SET VALUE=X
+12 FOR
SET I=$ORDER(WP(I))
if I<1
QUIT
Begin DoDot:1
+13 SET X=$SELECT($DATA(WP(I,0)):WP(I,0),1:WP(I))
+14 IF $EXTRACT(X)=" "
SET VALUE=VALUE_$CHAR(13,10)_X
QUIT
+15 IF CRLF
SET VALUE=VALUE_$CHAR(13,10)_X
QUIT
+16 SET VALUE=VALUE_$SELECT($EXTRACT(VALUE,$LENGTH(VALUE))=" ":"",1:" ")_X
End DoDot:1
+17 ;
+18 ;add tags
IF $$VALID(VALUE)
Begin DoDot:1
+19 ;p20
IF $PIECE(ITM0,U,10)
Begin DoDot:2
+20 if $LENGTH(VALUE)'>$PIECE(ITM0,U,10)
QUIT
+21 SET VALUE=$SELECT($PIECE(ITM0,U,11)]"":$PIECE(ITM0,U,11),1:"Text exceeds "_$PIECE(ITM0,U,10)_" limit and could not be saved. Please contact the site for full original text.")
End DoDot:2
+22 ;p16
IF '$TEST
IF $LENGTH(VALUE)>2999999
SET VALUE="Text exceeds 3 megabyte limit and could not be saved. Please contact the site for full original text."
+23 SET VALUE=$$ESC(VALUE)
+24 ;for List items
IF $GET(NOTAG)
SET ITEM=VALUE
QUIT
+25 SET ITEM=$$ELEMENT("",TAG,VALUE)
End DoDot:1
QUIT
+26 QUIT
+27 ;
ENTITY ; -- build an entity ITEM (from $$VALUE)
+1 NEW ENTITY,ERR,VALUE,DATA,LKUP,FMT,XFRM,ID
+2 SET ENTITY=$PIECE(ITM0,U,8)
if ENTITY=""
QUIT
+3 SET (VALUE,ERR)=""
SET XFRM=$GET(^DDE(+DIENTY,1,+ITM,4))
+4 ;
+5 ; get VALUE via code or field, for Entity ID
+6 ; DATA can also be defined here, to pass to Entity
+7 DO ITMPROC
IF $GET(DDEOUT)!$GET(DDEQUIT)
KILL DDEOUT
QUIT
+8 IF VALUE=""
IF $GET(FIELD)
Begin DoDot:1
+9 SET LKUP=$PIECE(ITM0,U,6)
if LKUP'=""
SET FIELD=FIELD_":"_LKUP
+10 SET FMT=$SELECT(+$PIECE(ITM0,U,7):"I",1:"E")
+11 SET VALUE=$$GET1^DIQ(FILE,IEN_",",FIELD,FMT)
End DoDot:1
if VALUE=""
QUIT
+12 IF $LENGTH(VALUE)
IF $LENGTH(XFRM)
XECUTE XFRM
+13 if VALUE=""
QUIT
SET ID=VALUE
+14 ;
+15 ;Pre-Processing
DO PREPROC(+ENTITY)
+16 SET VALUE=$$EN1^DDEG(+ENTITY,ID,1)
+17 ;Post-Processing
DO POST(+ENTITY)
+18 ;
+19 ;add tags
IF $LENGTH(VALUE)
Begin DoDot:1
+20 IF VALUE<0
SET ERROR=VALUE
QUIT
+21 ;for embedded or list items
IF $GET(NOTAG)
SET ITEM=VALUE
QUIT
+22 SET ITEM=$$ELEMENT("",TAG,VALUE,,,"C")
End DoDot:1
QUIT
+23 QUIT
+24 ;
COMPLEX ; -- build a complex ITEM (from $$VALUE)
+1 NEW SEQ,IDX1,TAG1,IDX0,VALUE
+2 ;
+3 DO ITMPROC
IF $GET(DDEOUT)!$GET(DDEQUIT)
KILL DDEOUT
QUIT
+4 ;
+5 SET SEQ=0
FOR
SET SEQ=$ORDER(^DDE(DIENTY,1,ITM,3,"B",SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+6 SET IDX1=$ORDER(^DDE(DIENTY,1,ITM,3,"B",SEQ,0))
+7 SET TAG1=$PIECE(^DDE(DIENTY,1,ITM,3,IDX1,0),U,2)
if TAG1=""
QUIT
+8 SET IDX0=+$ORDER(^DDE(DIENTY,1,"B",TAG1,0))
+9 IF IDX0<1!'$DATA(^DDE(DIENTY,1,IDX0,0))
QUIT
+10 ;
+11 SET VALUE=$$VALUE(IDX0)
if $GET(ERROR)!$GET(DDEQUIT)
QUIT
+12 if VALUE'=""
SET ITEM=$$ADD(ITEM,VALUE,SEQ)
End DoDot:1
if $GET(ERROR)!$GET(DDEQUIT)
QUIT
+13 ;
+14 ;add tags
if $GET(ERROR)
QUIT
IF $LENGTH(ITEM)
Begin DoDot:1
+15 ;for List items
if 'DFORM
SET ITEM="{"_ITEM_"}"
if $GET(NOTAG)
QUIT
+16 SET ITEM=$$ELEMENT("",TAG,ITEM,,,"C")
End DoDot:1
+17 QUIT
+18 ;
LIST ; -- build an array of values in ITEM (from $$VALUE)
+1 NEW ITM1
SET ITM1=$GET(^DDE(+DIENTY,1,+ITM,1))
+2 ;
+3 ;LIST_type#
DO @("LIST"_+ITM1)
+4 ;
+5 if $GET(ERROR)!$GET(DDEQUIT)
QUIT
+6 ;add tags
IF $LENGTH(ITEM)
Begin DoDot:1
+7 ;for List items
if 'DFORM
SET ITEM="["_ITEM_"]"
if $GET(NOTAG)
QUIT
+8 SET ITEM=$$ELEMENT("",TAG,ITEM,,,"L")
End DoDot:1
+9 QUIT
+10 ;
LIST1 ; -- list of values in FILE (from LIST)
+1 NEW C,TAG,XREF,FILTER,SCREEN,LKUP,FMT,XFRM,ENTITY,QUERY,DDELIST,DLIST,SEQ,IEN1,VALUE,ERR
+2 SET C=","
SET ENTITY=+$PIECE(ITM0,U,8)
+3 SET TAG=$PIECE(ITM1,U,2)
SET XREF=$PIECE(ITM1,U,3)
SET FILTER=$PIECE(ITM1,U,4)
+4 SET SCREEN=$GET(^DDE(+DIENTY,1,+ITM,1.1))
+5 ;
+6 DO ITMPROC
IF $GET(DDEOUT)!$GET(DDEQUIT)
KILL DDEOUT
QUIT
+7 ;
+8 ; set up for results: single FIELD or multi-field (record) ENTITY
+9 IF FIELD
Begin DoDot:1
+10 ;support extended pointers=LKUP ;p24
SET LKUP=$PIECE(ITM0,U,6)
if LKUP'=""
SET FIELD=FIELD_":"_LKUP
+11 SET FMT=$SELECT(+$PIECE(ITM0,U,7):"I",1:"E")
SET XFRM=$GET(^DDE(+DIENTY,1,+ITM,4))
End DoDot:1
+12 IF ENTITY
Begin DoDot:1
+13 NEW X0
SET X0=$GET(^DDE(ENTITY,0))
if '$LENGTH(TAG)
SET TAG=$GET(^(.1))
+14 ; get defaults from Entity if not defined in Item
+15 if '$LENGTH(XREF)
SET XREF=$PIECE(X0,U,3)
+16 if '$LENGTH(FILTER)
SET FILTER=$PIECE(X0,U,4)
+17 if '$LENGTH(SCREEN)
SET SCREEN=$GET(^DDE(ENTITY,5.1))
+18 SET QUERY=$GET(^DDE(ENTITY,5))
+19 DO PREPROC(ENTITY)
End DoDot:1
+20 IF $LENGTH(FILTER)
SET FILTER=$SELECT($DATA(@FILTER):@FILTER,1:FILTER)
+21 if TAG=""
SET TAG=$PIECE(ITM0,U)
+22 ;
L1 ; find appropriate records and process
+1 IF $LENGTH(QUERY)>1
IF $LENGTH($TEXT(@($PIECE(QUERY,"("))))
DO @QUERY
IF 1
+2 IF '$TEST
DO FIND^DIC(FILE,,"@","Q",.FILTER,,XREF,SCREEN,,"DDELIST")
MERGE DLIST=DDELIST("DILIST",2)
+3 SET SEQ=0
FOR
SET SEQ=$ORDER(DLIST(SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+4 SET IEN1=$GET(DLIST(SEQ))
+5 SET (VALUE,ERR)=""
+6 IF FIELD
Begin DoDot:2
+7 SET VALUE=$$GET1^DIQ(FILE,(IEN1_C),FIELD,FMT)
+8 ;output transform
IF $LENGTH(VALUE)
IF $LENGTH(XFRM)
XECUTE XFRM
+9 IF '$$VALID(VALUE)
SET VALUE=""
QUIT
+10 IF ENTITY
SET VALUE=$$EN1^DDEG(ENTITY,VALUE,1,.ERR)
End DoDot:2
+11 IF 'FIELD
IF ENTITY
SET VALUE=$$EN1^DDEG(ENTITY,IEN1,1,.ERR)
+12 ;
+13 IF VALUE=""!$GET(ERR)!$GET(DDEQUIT)
QUIT
+14 SET ITEM=$$ELEMENT(ITEM,TAG,VALUE,SEQ,"addList")
End DoDot:1
+15 ;
+16 if ENTITY
DO POST(ENTITY)
+17 QUIT
+18 ;
LIST2 ; -- list of values in SUBFILE (from LIST)
+1 NEW IENS,C,TAG,XREF,SCREEN,LKUP,FMT,XFRM,ENTITY,DLIST,SEQ,IEN1,VALUE,ERR
+2 ;"" ;p21 initialize ENTITY
SET IENS=","_IEN
SET C=","
SET ENTITY=$PIECE(ITM0,U,8)
+3 SET TAG=$PIECE(ITM1,U,2)
SET XREF=$PIECE(ITM1,U,3)
SET SCREEN=$GET(^DDE(+DIENTY,1,+ITM,1.1))
+4 ;
+5 DO ITMPROC
IF $GET(DDEOUT)!$GET(DDEQUIT)
KILL DDEOUT
QUIT
+6 ;
+7 ; set up FIELD and/or ENTITY for results
+8 IF FIELD
Begin DoDot:1
+9 ;support extended pointers=LKUP ;p24
SET LKUP=$PIECE(ITM0,U,6)
if LKUP'=""
SET FIELD=FIELD_":"_LKUP
+10 SET FMT=$SELECT(+$PIECE(ITM0,U,7):"I",1:"E")
SET XFRM=$GET(^DDE(+DIENTY,1,+ITM,4))
End DoDot:1
+11 IF ENTITY
Begin DoDot:1
+12 if '$LENGTH(TAG)
SET TAG=$GET(^DDE(ENTITY,.1))
+13 if '$LENGTH(XREF)
SET XREF=$PIECE($GET(^DDE(ENTITY,0)),U,3)
+14 if '$LENGTH(SCREEN)
SET SCREEN=$GET(^DDE(ENTITY,5.1))
+15 DO PREPROC(ENTITY)
End DoDot:1
+16 if TAG=""
SET TAG=$PIECE(ITM0,U)
+17 ;
L2 ; find appropriate records and process
+1 DO LIST^DIC(FILE,IENS_C,"@","Q",,,,XREF,SCREEN,,"DLIST")
+2 SET SEQ=0
FOR
SET SEQ=$ORDER(DLIST("DILIST",2,SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+3 SET IEN1=$GET(DLIST("DILIST",2,SEQ))_IENS
+4 SET (VALUE,ERR)=""
+5 IF FIELD
Begin DoDot:2
+6 SET VALUE=$$GET1^DIQ(FILE,(IEN1_C),FIELD,FMT)
+7 ;output transform
IF $LENGTH(VALUE)
IF $LENGTH(XFRM)
XECUTE XFRM
+8 IF '$$VALID(VALUE)
SET VALUE=""
QUIT
+9 IF ENTITY
SET VALUE=$$EN1^DDEG(ENTITY,VALUE,1,.ERR)
End DoDot:2
+10 IF 'FIELD
IF ENTITY
SET VALUE=$$EN1^DDEG(ENTITY,IEN1,1,.ERR)
+11 ;
+12 IF VALUE=""!$GET(ERR)!$GET(DDEQUIT)
QUIT
+13 SET ITEM=$$ELEMENT(ITEM,TAG,VALUE,SEQ,"addList")
End DoDot:1
if $GET(ERR)
QUIT
+14 ;
+15 if ENTITY
DO POST(ENTITY)
+16 QUIT
+17 ;
LIST3 ; -- list of values in COMPLEX FIELDS (from LIST)
+1 NEW TAG,SEQ,IDX1,NM1,IDX0,VALUE
+2 SET TAG=$PIECE(ITM1,U,2)
if TAG=""
SET TAG=$PIECE(ITM0,U)
+3 ;
+4 DO ITMPROC
IF $GET(DDEOUT)!$GET(DDEQUIT)
KILL DDEOUT
QUIT
+5 ;
+6 ; process list Items
+7 SET SEQ=0
FOR
SET SEQ=$ORDER(^DDE(DIENTY,1,ITM,3,"B",SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+8 SET IDX1=$ORDER(^DDE(DIENTY,1,ITM,3,"B",SEQ,0))
+9 SET NM1=$PIECE(^DDE(DIENTY,1,ITM,3,IDX1,0),U,2)
if NM1=""
QUIT
+10 SET IDX0=+$ORDER(^DDE(DIENTY,1,"B",NM1,0))
+11 IF IDX0<1!'$DATA(^DDE(DIENTY,1,IDX0,0))
QUIT
+12 ;
+13 SET VALUE=$$VALUE(IDX0,1)
+14 ;
+15 IF VALUE=""!$GET(ERR)!$GET(DDEQUIT)
QUIT
+16 SET ITEM=$$ELEMENT(ITEM,TAG,VALUE,SEQ,"addList")
End DoDot:1
if $GET(ERROR)
QUIT
+17 QUIT
+18 ;
LIST4 ; -- list of values in DLIST()
+1 NEW DLIST,TAG,ENTITY,SEQ,X,VALUE,ERR
+2 SET TAG=$PIECE(ITM1,U,2)
+3 ;
+4 ;create DLIST()=data value or ID for Entity
+5 DO ITMPROC
IF $GET(DDEOUT)!$GET(DDEQUIT)
KILL DDEOUT
QUIT
+6 ;
+7 ; set up for results: single FIELD or multi-field ENTITY
+8 SET ENTITY=$PIECE(ITM0,U,8)
IF ENTITY
Begin DoDot:1
+9 if '$LENGTH(TAG)
SET TAG=$GET(^DDE(ENTITY,.1))
+10 DO PREPROC(ENTITY)
End DoDot:1
+11 IF TAG=""
SET TAG=$PIECE(ITM0,U)
+12 ;
+13 ; process list items
+14 SET SEQ=0
FOR
SET SEQ=$ORDER(DLIST(SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+15 SET X=$GET(DLIST(SEQ))
+16 SET (VALUE,ERR)=""
+17 IF 'ENTITY
IF $$VALID(X)
SET VALUE=X
+18 IF '$TEST
SET VALUE=$$EN1^DDEG(ENTITY,X,1,.ERR)
+19 ;
+20 IF VALUE=""!$GET(ERR)!$GET(DDEQUIT)
QUIT
+21 SET ITEM=$$ELEMENT(ITEM,TAG,VALUE,SEQ,"addList")
End DoDot:1
if $GET(ERR)
QUIT
+22 ;
+23 if ENTITY
DO POST(ENTITY)
+24 QUIT
+25 ;
ADD(STRING,ELEMENT,SEQ) ; -- add ELEMENT to result STRING
+1 if $GET(ELEMENT)=""
QUIT STRING
+2 ;
+3 ; JSON:0 XML:1 TEXT:2
+4 SET DFORM=+$GET(DFORM)
SET SEQ=+$GET(SEQ)
+5 ;
+6 NEW RES
SET RES=$GET(STRING)
+7 ;SEQ>1
IF DFORM=0
SET RES=RES_$SELECT($LENGTH($GET(STRING)):", ",1:"")_ELEMENT
+8 IF DFORM=1
SET RES=RES_ELEMENT
+9 ;SEQ>1
IF DFORM=2
SET RES=RES_$SELECT($LENGTH($GET(STRING)):U,1:"")_ELEMENT
+10 QUIT RES
+11 ;
ELEMENT(STRING,NAME,VALUE,SEQ,OPTION,DTYPE) ; -- build an element STRING
+1 ; STRING=SERIALIZED RESPONSE
+2 SET STRING=$GET(STRING)
if $GET(NAME)=""
QUIT STRING
+3 if NAME["."
SET NAME=$PIECE(NAME,".",2)
+4 SET VALUE=$GET(VALUE)
+5 SET SEQ=+$GET(SEQ)
SET OPTION=$GET(OPTION,"addTags")
+6 ;
+7 ; does DataTYPE not require quotes?
+8 ;p27
SET DTYPE=$SELECT($GET(DTYPE)="C":1,$GET(DTYPE)="L":1,"[{"[$EXTRACT(VALUE):1,VALUE?0.1"-"1.N1"E"1N.E:0,VALUE?0.1"-"1.N1"e"1N.E:0,+VALUE=VALUE:1,1:0)
+9 NEW X,Y
SET X=""""
SET Y=$SELECT(DTYPE:"",1:"""")
+10 ;
+11 ; JSON:0 XML:1 TEXT:2
SET DFORM=+$GET(DFORM)
+12 IF OPTION="addTags"
Begin DoDot:1
+13 if DFORM=0
SET STRING=X_NAME_X_":"_Y_VALUE_Y
+14 if DFORM=1
SET STRING="<"_NAME_">"_VALUE_"</"_NAME_">"
+15 if DFORM=2
SET STRING=VALUE
End DoDot:1
QUIT STRING
+16 ;
+17 IF OPTION="addList"
Begin DoDot:1
+18 ;SEQ>1
if DFORM=0
SET STRING=STRING_$SELECT($LENGTH(STRING):", ",1:"")_Y_VALUE_Y
+19 if DFORM=1
SET STRING=STRING_"<"_NAME_">"_VALUE_"</"_NAME_">"
+20 ;SEQ>1
if DFORM=2
SET STRING=STRING_$SELECT($LENGTH(STRING):"~",1:"")_Y_VALUE_Y
End DoDot:1
QUIT STRING
+21 ;
+22 QUIT STRING
+23 ;
VALID(X) ; -- return 1 or 0, if X is a valid string
+1 ; Cannot be null or only white space
+2 SET X=$GET(X)
+3 IF X=""
QUIT 0
+4 IF X?." "
QUIT 0
+5 ;I X?.P Q 0
+6 QUIT 1
+7 ;
ESC(X) ; -- convert key characters for outgoing XML/JSON
+1 if DFORM=2
QUIT X
+2 IF DFORM=0
QUIT $$ESC^XLFJSON(X)
+3 ; DFORM=1 XML
+4 NEW I,Y,QOT
SET QOT=""""
+5 ; strip control characters ;p16 add $C(0)
+6 FOR I=0:1:8,11,12,14:1:31
IF X[$CHAR(I)
SET X=$TRANSLATE(X,$CHAR(I))
+7 ; p17 strip non-printable characters
+8 FOR I=127:1:159
IF X[$CHAR(I)
SET X=$TRANSLATE(X,$CHAR(I))
+9 ; handle special characters:
+10 ; DDESC = 1 ('&' only), 2 ('&' + CDATA), or
+11 ; default (0/null/undefined) = CDATA only
+12 IF (X["&")!(X["<")!(X[">")!(X["'")!(X[QOT)
Begin DoDot:1
+13 IF $GET(DDESC)
Begin DoDot:2
+14 SET Y=$PIECE(X,"&")
FOR I=2:1:$LENGTH(X,"&")
SET Y=Y_"&"_$PIECE(X,"&",I)
+15 SET X=Y
SET Y=$PIECE(X,"<")
FOR I=2:1:$LENGTH(X,"<")
SET Y=Y_"<"_$PIECE(X,"<",I)
+16 SET X=Y
SET Y=$PIECE(X,">")
FOR I=2:1:$LENGTH(X,">")
SET Y=Y_">"_$PIECE(X,">",I)
+17 SET X=Y
SET Y=$PIECE(X,"'")
FOR I=2:1:$LENGTH(X,"'")
SET Y=Y_"'"_$PIECE(X,"'",I)
+18 SET X=Y
SET Y=$PIECE(X,QOT)
FOR I=2:1:$LENGTH(X,QOT)
SET Y=Y_"""_$PIECE(X,QOT,I)
End DoDot:2
if DDESC=1
QUIT
SET X=Y
+19 ;p16 strip end brackets from transcription upload
IF X["]]>"
Begin DoDot:2
+20 SET Y=$PIECE(X,"]]>")
FOR I=2:1:$LENGTH(X,"]]>")
SET Y=Y_$PIECE(X,"]]>",I)
End DoDot:2
SET X=Y
+21 SET Y="<![CDATA["_X_"]]>"
End DoDot:1
QUIT Y
+22 QUIT X
+23 ;
PREPROC(DIENTY) ; -- pre-processing logic
+1 NEW X
+2 SET X=$GET(^DDE(+DIENTY,2))
if X'=""
XECUTE X
+3 QUIT
+4 ;
IENPROC ; -- IEN processing logic
+1 ; setting DDEOUT will cause this record (IEN) to not be returned
+2 NEW X
+3 SET X=$GET(^DDE(+DIENTY,4))
if X'=""
XECUTE X
+4 QUIT
+5 ;
ITMPROC ; -- ITEM processing logic
+1 ; setting DDEOUT will cause this item to not be returned
+2 NEW X
+3 SET X=$GET(^DDE(+DIENTY,1,+ITM,6))
if X'=""
XECUTE X
+4 QUIT
+5 ;
POST(DIENTY) ; -- post-processing logic
+1 NEW X
+2 SET X=$GET(^DDE(+DIENTY,3))
if X'=""
XECUTE X
+3 QUIT
