CIAZGUTL ;MSC/IND/DKM - Generic Retrieval Utility Functions ;29-Aug-2011 14:05;PLS
;;1.4;GENERIC RETRIEVAL UTILITY;;Feb 14, 2008
;;Copyright 2000-2008, Medsphere Systems Corporation
;=================================================================
; Return unique result id
RSLTID() ; EP
N X
L +^CIAZG(19950.41,-1):5
F S (X,^(-1))=$G(^CIAZG(19950.41,-1))+1 Q:'$D(^(X))
L -^CIAZG(19950.41,-1)
Q X
; Return temp global reference
TMPGBL(NMSP) ; EP
K ^TMP("CIAZG."_$G(NMSP),$J) Q $NA(^($J))
; Return true if operator is valid for given item.
OPRITM(OPR,ITM) ; EP
N DTP
S DTP=+$P($G(^CIAZG(19950.42,+ITM,0)),U,7)
Q $D(^CIAZG(19950.43,DTP,20,"B",+OPR))
; Return a list of fields that point from one file (FROM)
; to a second file (TO) and that have a standard xref.
; Returns list in the format:
; <field #>^<field name>^<xref>
FLDJOIN(TO,FROM,LST) ;
N FLD,CNT,DD,XRF,X
S (FLD,CNT)=0,TO=+TO,FROM=+FROM
F S FLD=$O(^DD(TO,0,"PT",FROM,FLD)) D:FLD Q:'FLD
.S DD=$G(^DD(FROM,FLD,0)),X=0,XRF=""
.Q:+$P($P(DD,U,2),"P",2)'=TO
.F S X=$O(^DD(FROM,FLD,1,X)) Q:'X S XRF=$G(^(X,0)) D Q:$L(XRF)
..I $P(XRF,U,3)="" S XRF=$P(XRF,U,2)
..E S XRF=""
.Q:'$L(XRF)
.S CNT=CNT+1
.I $D(LST) S @LST@(CNT)=FLD_U_$P(DD,U)_U_XRF
.E S FLD=0
Q:$Q CNT
Q
; Return root global for a standard xref
XRFROOT(FIL,XRF,IEN) ; EP
N GBL
S GBL=$$ROOT^DILFD(FIL,,1)
S:$L(GBL) GBL=$NA(@GBL@(XRF,IEN))
Q GBL
; Returns true if query can be a cohort for another query.
COHORTOK(RSLT,DEFN1) ;
N DEFN2,SRC1,SRC2
Q:'$D(^XTMP("CIAZGRU",RSLT,"IEN")) 0
S DEFN2=+$P($G(^CIAZG(19950.49,RSLT,0)),U,10)
Q:'DEFN1!'DEFN2 0
S SRC1=+$P($G(^CIAZG(19950.41,DEFN1,0)),U,2)
S SRC2=+$P($G(^CIAZG(19950.41,DEFN2,0)),U,2)
Q:SRC1=SRC2 1
Q:$$DINUM(SRC1)=SRC2 1
Q:$$DINUM(SRC2)=SRC1 1
Q 0
; Returns file # of linked file if DINUM'd
DINUM(SRC) ;
N X
S X=$G(^DD(SRC,.01,0))
Q:$P(X,U,5)'[" DINUM=X" 0
S X=$P(X,U,2)
Q:X'["P" 0
Q +$P(X,"P",2)
; Update a field in the result file
RSLTUPD(RSLT,FLD,VAL,NOBR) ; EP
N FDA
S FDA(19950.49,RSLT_",",FLD)=VAL
D UPDATE^DIE(,"FDA")
D:'$G(NOBR) BRDCAST^CIANBEVT("CIAZG.RESULT."_RSLT,FLD)
Q
; Abort a query in progress
RSLTABR(RSLT) ; EP
N RTN
S RTN=$$RSLTSTA(RSLT)
I 'RTN D
.N ZTSK
.S ZTSK=$P($G(^CIAZG(19950.49,RSLT,0)),U,7)
.D:ZTSK KILL^%ZTLOAD
D:RTN<2 RSLTUPD(RSLT,5,$S(RTN:4,1:3))
Q:$Q RTN<2
Q
; Return query status
RSLTSTA(RSLT) ; EP
Q $P($G(^CIAZG(19950.49,+RSLT,0)),U,6)
; Fetch query result in XML format
; DATA: Global to receive data
; RSLT: Query result IEN
; STRT: Starting position
; COUNT: # of record to retrieve (-1=all,0=none,>0=#)
; SCHEMA: If nonzero, include schema
; Returned data is XML recordset except first node is:
; Records Retrieved^Last Record Retrieved^Total Records
RSLTGET(DATA,RSLT,STRT,COUNT,SCHEMA) ; EP
N FLDS,TDTP
M FLDS=^XTMP("CIAZGRU",RSLT,"FLD")
S @DATA@(0)="0^0^"_$P(^CIAZG(19950.49,RSLT,0),U,8),SCHEMA=+$G(SCHEMA),COUNT(0)=COUNT,TDTP=$$FIND1^DIC(19950.43,,,"TEXT")
Q:$D(FLDS)<10
D ADD("<xml xmlns:s='uuid:BDC6E3F0-6DA3-11d1-A2A3-00AA00C14882'")
D ADD("xmlns:dt='uuid:C2F41010-65B3-11d1-A29F-00AA00C14882'")
D ADD("xmlns:rs='urn:schemas-microsoft-com:rowset'")
D ADD("xmlns:z='#RowsetSchema'>")
D:SCHEMA ADD("<s:Schema id='RowsetSchema'>")
D ADDFLDS("FLDS","row")
D:SCHEMA ADD("</s:Schema>")
D ADD("<rs:data>")
D:COUNT RSLTADD(1,"FLDS",.STRT,,"z:row")
D ADD("</rs:data>")
D ADD("</xml>")
S $P(@DATA@(0),U,1,2)=(COUNT(0)-COUNT)_U_STRT
Q
; Add field attribute to output global
ADDFLD(NAM,DTP,ALIAS) ;
N X
S ORD=ORD+1
S X="<s:AttributeType name='"_NAM_"'"
S X=X_" rs:number='"_ORD_"'"
S:$L($G(ALIAS)) X=X_" rs:name='"_ALIAS_"'"
D ADD(X_" "_DTP_" />")
Q
; Add field names to output global
ADDFLDS(ARY,NAM,REL,PAR) ;
N ARYX,FLD,DTP,ITM,TYPE,FMT,WIDTH,ORD,X
S ORD=0
I SCHEMA D
.D ADD("<s:ElementType name='"_$$ESCAPE(NAM)_"' content='eltOnly'"_$G(REL)_">")
.D ADDFLD("id_"_$$ESCAPE(NAM),"dt:type='i4'")
.D:$D(PAR) ADDFLD("id_"_PAR,"dt:type='i4'")
S ARYX=0
F S ARYX=$O(@ARY@(ARYX)) Q:'ARYX D
.I $P(@ARY@(ARYX),U,5) D
..D FIXFLD
..Q:'SCHEMA
..S FLD=@ARY@(ARYX)
..S WIDTH=$P(FLD,U,2),FMT=$P(FLD,U,3),DTP=$S(FMT:TDTP,1:$P(FLD,U,4))
..S DTP=$P($G(^CIAZG(19950.43,$S(DTP:DTP,1:TDTP),0)),U,2)
..D ADDFLD("f"_ARYX,$$MSG^CIAU(DTP),$$ESCAPE($P(FLD,U)))
.I $D(@ARY@(ARYX))>9 D
..D FIXFLD
..Q:'SCHEMA
..S FLD=@ARY@(ARYX)
..D ADDFLDS($NA(@ARY@(ARYX)),"f"_ARYX," rs:name='"_$$ESCAPE($P(FLD,U))_"' rs:relation='010000000200000000000000'",NAM)
D:SCHEMA ADD("<s:extends type='rs:rowbase' />"),ADD("</s:ElementType>")
Q
; Return XML attribute for a string datatype
STRING() Q "dt:type='string'"_$S(WIDTH>0:" dt:maxLength='"_WIDTH_"'",1:"")
; Format date/time as XML
; X = Date/time in FM format
; XF = 0 = date/time; 1=date only; 2=time only
DT(X,XF) N %DT,D,T,Y
S %DT="TS"
D ^%DT
Q:Y'>0 ""
S Y=+$$FMTHL7^XLFDT(Y)
S D=$E(Y,1,8),T=$E(Y,9,15)
S:$L(T) T=T_"000000"
S:XF<2 X=$E(D,1,4)_"-"_$$VR($E(D,5,6),"01",12)_"-"_$$VR($E(D,7,8),"01",31)_$S('XF&$L(T):"T",1:"")
S:$L(T)&(XF'=1) X=X_$$VR($E(T,1,2),0,24)_":"_$$VR($E(T,3,4),0,59)_":"_$$VR($E(T,5,6),0,59)
Q X
; Validate range
VR(VAL,LO,HI) ;
Q $S(VAL<LO:LO,VAL>HI:HI,1:VAL)
; Fix field name to avoid dups
FIXFLD N F
S F=$P(@ARY@(ARYX),U)
F Q:$G(FLD(F),ARYX)=ARYX S F=F_"_"
S $P(@ARY@(ARYX),U)=F,FLD(F)=ARYX
Q
; Add results to output global
RSLTADD(LVL,ARY,RECN,LINK,TAG,IDS) ;
F S RECN=$O(^XTMP("CIAZGRU",RSLT,LVL,RECN)) Q:'RECN D Q:'COUNT
.N ARYX,LVX,CLS,FMT,DTP,WID,ITM,LNK,OVF,X
.D ADD("<"_TAG_" ")
.S IDS(TAG)=$G(IDS(TAG))+1
.S LNK="id_"_$S(TAG[":":$P(TAG,":",2),1:TAG)_"='"_IDS(TAG)_"'"
.D ADD(LNK)
.D:$D(LINK) ADD(LINK)
.S ARYX=0,CLS=1
.F S ARYX=$O(@ARY@(ARYX)) Q:'ARYX D
..S X=@ARY@(ARYX),WID=$P(X,U,2),FMT=$P(X,U,3),DTP=$S(FMT:TDTP,1:$P(X,U,4)),ITM=$P(X,U,5)
..S X=$G(^XTMP("CIAZGRU",RSLT,LVL,RECN,ARYX)),OVF=$S(WID:0,1:$O(^(ARYX,0)))
..Q:'$L(X)
..X $G(^CIAZG(19950.43,+DTP,2))
..Q:'ITM
..D ADD("f"_ARYX_"='"_$$ESCAPE(X,WID)_$S(OVF:"",1:"'"))
..I OVF D
...F D Q:'OVF
....S X=^XTMP("CIAZGRU",RSLT,LVL,RECN,ARYX,OVF),OVF=$O(^(OVF))
....D ADD($$ESCAPE(X)_$S(OVF:"",1:"'"))
.F S ARYX=$O(@ARY@(ARYX)) Q:'ARYX D
..Q:$P(@ARY@(ARYX),U,5)
..S LVX=+$G(^XTMP("CIAZGRU",RSLT,LVL,RECN,ARYX))
..Q:'LVX
..D:CLS ADD(">")
..S CLS=0
..D RSLTADD(LVX,$NA(@ARY@(ARYX)),0,LNK,"f"_ARYX,.IDS)
.D ADD($S(CLS:"/>",1:"</"_TAG_">"))
.S:LVL=1 COUNT=COUNT-1
Q
; Add result to output global
ADD(X) S @DATA@($O(@DATA@(""),-1)+1)=X
Q
; Replace reserved characters with XML escape codes
ESCAPE(STR,MAX) ;
N X,Y
I $G(MAX),$L(STR)>MAX S STR=$E(STR,1,MAX)
F X="&;amp","<lt",">gt","';apos",""";quot" D
.S STR=$$SUBST^CIAU(STR,$P(X,";"),"&"_$P(X,";",2)_";")
F X=1:1 S Y=$A(STR,X) Q:Y<0 S:Y>126 $E(STR,X)="&#"_Y_";",X=X+5
Q STR
; Delete a query definition
; DEFN: IEN of definition
; FLAG: 0 = delete definition and all children
; 1 = delete items and children only
DEFNDEL(DEFN,FLAG) ; EP
N FDA,ERR,X
S X=$G(^CIAZG(19950.41,+DEFN,0))
Q:'$L(X) "1^Cannot find query definition"
S X=$P(X,U,3)
I X,X'=DUZ Q "2^Insufficient privilege"
D DDL2(DEFN,+$G(FLAG))
D:$D(FDA)>1 UPDATE^DIE(,"FDA",,"ERR")
Q:$G(DIERR) "3^"_$G(ERR("DIERR","1","TEXT",1))
Q 0
DDL2(DEFN,FLAG) ;
N SUB,IEN,LNK,ITM
S:'FLAG FDA(19950.41,DEFN_",",.01)="@"
F SUB=20,30,40 D
.S IEN=0
.F S IEN=$O(^CIAZG(19950.41,DEFN,SUB,IEN)) Q:'IEN S ITM=$P(^(IEN,0),U,2) D
..S LNK=$P(^CIAZG(19950.42,ITM,0),U,6)
..D:LNK DDL2(LNK,0)
..S FDA(19950.42,ITM_",",.01)="@"
Q
; Delete orphaned child definitions
DEFNDLO ; EP
N DEFN
S DEFN=0
F S DEFN=$O(^CIAZG(19950.41,DEFN)) Q:'DEFN D:'$P(^(DEFN,0),U,3)
.I '$D(^CIAZG(19950.42,"ALINK",DEFN)),$$DEFNDEL(DEFN)
Q
; Create a new query definition
DEFNNEW(NAME,SOURCE,OWNER,ACCESS,DESC) ; EP
N FDA,IEN
S FDA=$NA(FDA(19950.41,"+1,"))
S @FDA@(.01)=NAME
S @FDA@(1)=SOURCE
S @FDA@(2)=OWNER
S @FDA@(3)=ACCESS
S:$D(DESC) @FDA@(99)="DESC"
D UPDATE^DIE(,"FDA","IEN")
Q:$Q $G(IEN(1))
Q
; Create a child query definition
DEFNSUB(DEFN,FLD,SOURCE) ; EP
N IEN,DESC,PNAM
S PNAM=$P(^CIAZG(19950.41,DEFN,0),U),DESC(1,0)="Child definition of "_PNAM,PNAM=PNAM_"."_FLD
F Q:$L(PNAM)'>80 S PNAM=$P(PNAM,".",2,999)
S IEN=$$DEFNNEW(PNAM,SOURCE,"","",.DESC)
Q:$Q IEN
Q
; Find a definition by name
DEFNFND(NAME) ; EP
N X,IEN
S X=$E(NAME,1,30),IEN=0
F S IEN=$O(^CIAZG(19950.41,"B",X,IEN)) Q:'IEN Q:$P($G(^CIAZG(19950.41,IEN,0)),U)=NAME
Q +IEN
; Clone a query definition
DEFNCLN(DEFN) ; EP
N DEFN2,SUB,X,Y
S OLD=^CIAZG(19950.41,DEFN,0),X=$P(OLD,U)
S:X?1.E1"_"1.N X=$P(X,"_",1,$L(X,"_")-1)
F Y=1:1 S DEFN2=X_"_"_Y Q:'$$DEFNFND(DEFN2)
S DEFN2=$$DEFNNEW(DEFN2,$P(OLD,U,2),$S($P(OLD,U,3):DUZ,1:""),$P(OLD,U,4))
I DEFN2 D
.N ITM,LNK
.S OLD=^CIAZG(19950.41,DEFN2,0)
.K ^CIAZG(19950.41,DEFN2)
.M ^(DEFN2)=^(DEFN)
.S ^(DEFN2,0)=OLD
.F SUB=20,30,40 D DC2(SUB)
.D REINDEX(19950.41,DEFN2)
Q:$Q DEFN2
Q
; Clone all items in multiple
DC2(SUB) N ITMX,ITM0
S ITMX=0
F S ITMX=$O(^CIAZG(19950.41,DEFN2,SUB,ITMX)) Q:'ITMX S ITM=$P(^(ITMX,0),U,2) D
.S LNK=$P(^CIAZG(19950.42,ITM,0),U,6)
.I LNK,'$G(LNK(LNK)) S LNK(LNK)=$$DEFNCLN(LNK)
.S:'$G(ITM(ITM)) ITM(ITM)=$$ITEMCLN(ITM,DEFN2,$S(LNK:LNK(LNK),1:""))
.S $P(^CIAZG(19950.41,DEFN2,SUB,ITMX,0),U,2)=ITM(ITM)
Q
; Reindex an entry in a file
REINDEX(DIK,DA) ;
S DIK=$$ROOT^DILFD(DIK)
D IX1^DIK
Q
; Clone an item entry
ITEMCLN(ITEM,DEFN,LNK) ; EP
N FDA,IEN
S FDA=$NA(FDA(19950.42,"+1,"))
S @FDA@(.01)=$P(^CIAZG(19950.42,ITEM,0),U)
D UPDATE^DIE(,"FDA","IEN")
S IEN=$G(IEN(1))
I IEN D
.M ^CIAZG(19950.42,IEN)=^CIAZG(19950.42,ITEM)
.S $P(^CIAZG(19950.42,IEN,0),U,2)=DEFN,$P(^(0),U,6)=LNK
.D REINDEX(19950.42,IEN)
Q:$Q IEN
Q
; Delete orphaned items
; ITEMS: List of items to check (optional)
ITEMDLO(ITEMS) ; EP
N ITEM,XREF,FDA,ALL,OK
S ITEM=0,ALL=$D(ITEMS)<10
F S ITEM=$S(ALL:$O(^CIAZG(19950.42,ITEM)),1:$O(ITEMS(ITEM))) Q:'ITEM D
.S OK=1
.F XREF="AITEMC","AITEMS","AITEME" I $D(^CIAZG(19950.41,XREF,ITEM)) S OK=0 Q
.S:OK FDA(19950.42,ITEM_",",.01)="@"
D:$D(FDA) UPDATE^DIE(,"FDA")
Q
CIAZGUTL ;MSC/IND/DKM - Generic Retrieval Utility Functions ;29-Aug-2011 14:05;PLS
+1 ;;1.4;GENERIC RETRIEVAL UTILITY;;Feb 14, 2008
+2 ;;Copyright 2000-2008, Medsphere Systems Corporation
+3 ;=================================================================
+4 ; Return unique result id
RSLTID() ; EP
+1 NEW X
+2 LOCK +^CIAZG(19950.41,-1):5
+3 FOR
SET (X,^(-1))=$GET(^CIAZG(19950.41,-1))+1
IF '$DATA(^(X))
QUIT
+4 LOCK -^CIAZG(19950.41,-1)
+5 QUIT X
+6 ; Return temp global reference
TMPGBL(NMSP) ; EP
+1 KILL ^TMP("CIAZG."_$GET(NMSP),$JOB)
QUIT $NAME(^($JOB))
+2 ; Return true if operator is valid for given item.
OPRITM(OPR,ITM) ; EP
+1 NEW DTP
+2 SET DTP=+$PIECE($GET(^CIAZG(19950.42,+ITM,0)),U,7)
+3 QUIT $DATA(^CIAZG(19950.43,DTP,20,"B",+OPR))
+4 ; Return a list of fields that point from one file (FROM)
+5 ; to a second file (TO) and that have a standard xref.
+6 ; Returns list in the format:
+7 ; <field #>^<field name>^<xref>
FLDJOIN(TO,FROM,LST) ;
+1 NEW FLD,CNT,DD,XRF,X
+2 SET (FLD,CNT)=0
SET TO=+TO
SET FROM=+FROM
+3 FOR
SET FLD=$ORDER(^DD(TO,0,"PT",FROM,FLD))
IF FLD
Begin DoDot:1
+4 SET DD=$GET(^DD(FROM,FLD,0))
SET X=0
SET XRF=""
+5 IF +$PIECE($PIECE(DD,U,2),"P",2)'=TO
QUIT
+6 FOR
SET X=$ORDER(^DD(FROM,FLD,1,X))
IF 'X
QUIT
SET XRF=$GET(^(X,0))
Begin DoDot:2
+7 IF $PIECE(XRF,U,3)=""
SET XRF=$PIECE(XRF,U,2)
+8 IF '$TEST
SET XRF=""
End DoDot:2
IF $LENGTH(XRF)
QUIT
+9 IF '$LENGTH(XRF)
QUIT
+10 SET CNT=CNT+1
+11 IF $DATA(LST)
SET @LST@(CNT)=FLD_U_$PIECE(DD,U)_U_XRF
+12 IF '$TEST
SET FLD=0
End DoDot:1
IF 'FLD
QUIT
+13 IF $QUIT
QUIT CNT
+14 QUIT
+15 ; Return root global for a standard xref
XRFROOT(FIL,XRF,IEN) ; EP
+1 NEW GBL
+2 SET GBL=$$ROOT^DILFD(FIL,,1)
+3 IF $LENGTH(GBL)
SET GBL=$NAME(@GBL@(XRF,IEN))
+4 QUIT GBL
+5 ; Returns true if query can be a cohort for another query.
COHORTOK(RSLT,DEFN1) ;
+1 NEW DEFN2,SRC1,SRC2
+2 IF '$DATA(^XTMP("CIAZGRU",RSLT,"IEN"))
QUIT 0
+3 SET DEFN2=+$PIECE($GET(^CIAZG(19950.49,RSLT,0)),U,10)
+4 IF 'DEFN1!'DEFN2
QUIT 0
+5 SET SRC1=+$PIECE($GET(^CIAZG(19950.41,DEFN1,0)),U,2)
+6 SET SRC2=+$PIECE($GET(^CIAZG(19950.41,DEFN2,0)),U,2)
+7 IF SRC1=SRC2
QUIT 1
+8 IF $$DINUM(SRC1)=SRC2
QUIT 1
+9 IF $$DINUM(SRC2)=SRC1
QUIT 1
+10 QUIT 0
+11 ; Returns file # of linked file if DINUM'd
DINUM(SRC) ;
+1 NEW X
+2 SET X=$GET(^DD(SRC,.01,0))
+3 IF $PIECE(X,U,5)'[" DINUM=X"
QUIT 0
+4 SET X=$PIECE(X,U,2)
+5 IF X'["P"
QUIT 0
+6 QUIT +$PIECE(X,"P",2)
+7 ; Update a field in the result file
RSLTUPD(RSLT,FLD,VAL,NOBR) ; EP
+1 NEW FDA
+2 SET FDA(19950.49,RSLT_",",FLD)=VAL
+3 DO UPDATE^DIE(,"FDA")
+4 IF '$GET(NOBR)
DO BRDCAST^CIANBEVT("CIAZG.RESULT."_RSLT,FLD)
+5 QUIT
+6 ; Abort a query in progress
RSLTABR(RSLT) ; EP
+1 NEW RTN
+2 SET RTN=$$RSLTSTA(RSLT)
+3 IF 'RTN
Begin DoDot:1
+4 NEW ZTSK
+5 SET ZTSK=$PIECE($GET(^CIAZG(19950.49,RSLT,0)),U,7)
+6 IF ZTSK
DO KILL^%ZTLOAD
End DoDot:1
+7 IF RTN<2
DO RSLTUPD(RSLT,5,$SELECT(RTN:4,1:3))
+8 IF $QUIT
QUIT RTN<2
+9 QUIT
+10 ; Return query status
RSLTSTA(RSLT) ; EP
+1 QUIT $PIECE($GET(^CIAZG(19950.49,+RSLT,0)),U,6)
+2 ; Fetch query result in XML format
+3 ; DATA: Global to receive data
+4 ; RSLT: Query result IEN
+5 ; STRT: Starting position
+6 ; COUNT: # of record to retrieve (-1=all,0=none,>0=#)
+7 ; SCHEMA: If nonzero, include schema
+8 ; Returned data is XML recordset except first node is:
+9 ; Records Retrieved^Last Record Retrieved^Total Records
RSLTGET(DATA,RSLT,STRT,COUNT,SCHEMA) ; EP
+1 NEW FLDS,TDTP
+2 MERGE FLDS=^XTMP("CIAZGRU",RSLT,"FLD")
+3 SET @DATA@(0)="0^0^"_$PIECE(^CIAZG(19950.49,RSLT,0),U,8)
SET SCHEMA=+$GET(SCHEMA)
SET COUNT(0)=COUNT
SET TDTP=$$FIND1^DIC(19950.43,,,"TEXT")
+4 IF $DATA(FLDS)<10
QUIT
+5 DO ADD("<xml xmlns:s='uuid:BDC6E3F0-6DA3-11d1-A2A3-00AA00C14882'")
+6 DO ADD("xmlns:dt='uuid:C2F41010-65B3-11d1-A29F-00AA00C14882'")
+7 DO ADD("xmlns:rs='urn:schemas-microsoft-com:rowset'")
+8 DO ADD("xmlns:z='#RowsetSchema'>")
+9 IF SCHEMA
DO ADD("<s:Schema id='RowsetSchema'>")
+10 DO ADDFLDS("FLDS","row")
+11 IF SCHEMA
DO ADD("</s:Schema>")
+12 DO ADD("<rs:data>")
+13 IF COUNT
DO RSLTADD(1,"FLDS",.STRT,,"z:row")
+14 DO ADD("</rs:data>")
+15 DO ADD("</xml>")
+16 SET $PIECE(@DATA@(0),U,1,2)=(COUNT(0)-COUNT)_U_STRT
+17 QUIT
+18 ; Add field attribute to output global
ADDFLD(NAM,DTP,ALIAS) ;
+1 NEW X
+2 SET ORD=ORD+1
+3 SET X="<s:AttributeType name='"_NAM_"'"
+4 SET X=X_" rs:number='"_ORD_"'"
+5 IF $LENGTH($GET(ALIAS))
SET X=X_" rs:name='"_ALIAS_"'"
+6 DO ADD(X_" "_DTP_" />")
+7 QUIT
+8 ; Add field names to output global
ADDFLDS(ARY,NAM,REL,PAR) ;
+1 NEW ARYX,FLD,DTP,ITM,TYPE,FMT,WIDTH,ORD,X
+2 SET ORD=0
+3 IF SCHEMA
Begin DoDot:1
+4 DO ADD("<s:ElementType name='"_$$ESCAPE(NAM)_"' content='eltOnly'"_$GET(REL)_">")
+5 DO ADDFLD("id_"_$$ESCAPE(NAM),"dt:type='i4'")
+6 IF $DATA(PAR)
DO ADDFLD("id_"_PAR,"dt:type='i4'")
End DoDot:1
+7 SET ARYX=0
+8 FOR
SET ARYX=$ORDER(@ARY@(ARYX))
IF 'ARYX
QUIT
Begin DoDot:1
+9 IF $PIECE(@ARY@(ARYX),U,5)
Begin DoDot:2
+10 DO FIXFLD
+11 IF 'SCHEMA
QUIT
+12 SET FLD=@ARY@(ARYX)
+13 SET WIDTH=$PIECE(FLD,U,2)
SET FMT=$PIECE(FLD,U,3)
SET DTP=$SELECT(FMT:TDTP,1:$PIECE(FLD,U,4))
+14 SET DTP=$PIECE($GET(^CIAZG(19950.43,$SELECT(DTP:DTP,1:TDTP),0)),U,2)
+15 DO ADDFLD("f"_ARYX,$$MSG^CIAU(DTP),$$ESCAPE($PIECE(FLD,U)))
End DoDot:2
+16 IF $DATA(@ARY@(ARYX))>9
Begin DoDot:2
+17 DO FIXFLD
+18 IF 'SCHEMA
QUIT
+19 SET FLD=@ARY@(ARYX)
+20 DO ADDFLDS($NAME(@ARY@(ARYX)),"f"_ARYX," rs:name='"_$$ESCAPE($PIECE(FLD,U))_"' rs:relation='010000000200000000000000'",NAM)
End DoDot:2
End DoDot:1
+21 IF SCHEMA
DO ADD("<s:extends type='rs:rowbase' />")
DO ADD("</s:ElementType>")
+22 QUIT
+23 ; Return XML attribute for a string datatype
STRING() QUIT "dt:type='string'"_$SELECT(WIDTH>0:" dt:maxLength='"_WIDTH_"'",1:"")
+1 ; Format date/time as XML
+2 ; X = Date/time in FM format
+3 ; XF = 0 = date/time; 1=date only; 2=time only
DT(X,XF) NEW %DT,D,T,Y
+1 SET %DT="TS"
+2 DO ^%DT
+3 IF Y'>0
QUIT ""
+4 SET Y=+$$FMTHL7^XLFDT(Y)
+5 SET D=$EXTRACT(Y,1,8)
SET T=$EXTRACT(Y,9,15)
+6 IF $LENGTH(T)
SET T=T_"000000"
+7 IF XF<2
SET X=$EXTRACT(D,1,4)_"-"_$$VR($EXTRACT(D,5,6),"01",12)_"-"_$$VR($EXTRACT(D,7,8),"01",31)_$SELECT('XF&$LENGTH(T):"T",1:"")
+8 IF $LENGTH(T)&(XF'=1)
SET X=X_$$VR($EXTRACT(T,1,2),0,24)_":"_$$VR($EXTRACT(T,3,4),0,59)_":"_$$VR($EXTRACT(T,5,6),0,59)
+9 QUIT X
+10 ; Validate range
VR(VAL,LO,HI) ;
+1 QUIT $SELECT(VAL<LO:LO,VAL>HI:HI,1:VAL)
+2 ; Fix field name to avoid dups
FIXFLD NEW F
+1 SET F=$PIECE(@ARY@(ARYX),U)
+2 FOR
IF $GET(FLD(F),ARYX)=ARYX
QUIT
SET F=F_"_"
+3 SET $PIECE(@ARY@(ARYX),U)=F
SET FLD(F)=ARYX
+4 QUIT
+5 ; Add results to output global
RSLTADD(LVL,ARY,RECN,LINK,TAG,IDS) ;
+1 FOR
SET RECN=$ORDER(^XTMP("CIAZGRU",RSLT,LVL,RECN))
IF 'RECN
QUIT
Begin DoDot:1
+2 NEW ARYX,LVX,CLS,FMT,DTP,WID,ITM,LNK,OVF,X
+3 DO ADD("<"_TAG_" ")
+4 SET IDS(TAG)=$GET(IDS(TAG))+1
+5 SET LNK="id_"_$SELECT(TAG[":":$PIECE(TAG,":",2),1:TAG)_"='"_IDS(TAG)_"'"
+6 DO ADD(LNK)
+7 IF $DATA(LINK)
DO ADD(LINK)
+8 SET ARYX=0
SET CLS=1
+9 FOR
SET ARYX=$ORDER(@ARY@(ARYX))
IF 'ARYX
QUIT
Begin DoDot:2
+10 SET X=@ARY@(ARYX)
SET WID=$PIECE(X,U,2)
SET FMT=$PIECE(X,U,3)
SET DTP=$SELECT(FMT:TDTP,1:$PIECE(X,U,4))
SET ITM=$PIECE(X,U,5)
+11 SET X=$GET(^XTMP("CIAZGRU",RSLT,LVL,RECN,ARYX))
SET OVF=$SELECT(WID:0,1:$ORDER(^(ARYX,0)))
+12 IF '$LENGTH(X)
QUIT
+13 XECUTE $GET(^CIAZG(19950.43,+DTP,2))
+14 IF 'ITM
QUIT
+15 DO ADD("f"_ARYX_"='"_$$ESCAPE(X,WID)_$SELECT(OVF:"",1:"'"))
+16 IF OVF
Begin DoDot:3
+17 FOR
Begin DoDot:4
+18 SET X=^XTMP("CIAZGRU",RSLT,LVL,RECN,ARYX,OVF)
SET OVF=$ORDER(^(OVF))
+19 DO ADD($$ESCAPE(X)_$SELECT(OVF:"",1:"'"))
End DoDot:4
IF 'OVF
QUIT
End DoDot:3
End DoDot:2
+20 FOR
SET ARYX=$ORDER(@ARY@(ARYX))
IF 'ARYX
QUIT
Begin DoDot:2
+21 IF $PIECE(@ARY@(ARYX),U,5)
QUIT
+22 SET LVX=+$GET(^XTMP("CIAZGRU",RSLT,LVL,RECN,ARYX))
+23 IF 'LVX
QUIT
+24 IF CLS
DO ADD(">")
+25 SET CLS=0
+26 DO RSLTADD(LVX,$NAME(@ARY@(ARYX)),0,LNK,"f"_ARYX,.IDS)
End DoDot:2
+27 DO ADD($SELECT(CLS:"/>",1:"</"_TAG_">"))
+28 IF LVL=1
SET COUNT=COUNT-1
End DoDot:1
IF 'COUNT
QUIT
+29 QUIT
+30 ; Add result to output global
ADD(X) SET @DATA@($ORDER(@DATA@(""),-1)+1)=X
+1 QUIT
+2 ; Replace reserved characters with XML escape codes
ESCAPE(STR,MAX) ;
+1 NEW X,Y
+2 IF $GET(MAX)
IF $LENGTH(STR)>MAX
SET STR=$EXTRACT(STR,1,MAX)
+3 FOR X="&;amp","<lt",">gt","';apos",""";quot"
Begin DoDot:1
+4 SET STR=$$SUBST^CIAU(STR,$PIECE(X,";"),"&"_$PIECE(X,";",2)_";")
End DoDot:1
+5 FOR X=1:1
SET Y=$ASCII(STR,X)
IF Y<0
QUIT
IF Y>126
SET $EXTRACT(STR,X)="&#"_Y_";"
SET X=X+5
+6 QUIT STR
+7 ; Delete a query definition
+8 ; DEFN: IEN of definition
+9 ; FLAG: 0 = delete definition and all children
+10 ; 1 = delete items and children only
DEFNDEL(DEFN,FLAG) ; EP
+1 NEW FDA,ERR,X
+2 SET X=$GET(^CIAZG(19950.41,+DEFN,0))
+3 IF '$LENGTH(X)
QUIT "1^Cannot find query definition"
+4 SET X=$PIECE(X,U,3)
+5 IF X
IF X'=DUZ
QUIT "2^Insufficient privilege"
+6 DO DDL2(DEFN,+$GET(FLAG))
+7 IF $DATA(FDA)>1
DO UPDATE^DIE(,"FDA",,"ERR")
+8 IF $GET(DIERR)
QUIT "3^"_$GET(ERR("DIERR","1","TEXT",1))
+9 QUIT 0
DDL2(DEFN,FLAG) ;
+1 NEW SUB,IEN,LNK,ITM
+2 IF 'FLAG
SET FDA(19950.41,DEFN_",",.01)="@"
+3 FOR SUB=20,30,40
Begin DoDot:1
+4 SET IEN=0
+5 FOR
SET IEN=$ORDER(^CIAZG(19950.41,DEFN,SUB,IEN))
IF 'IEN
QUIT
SET ITM=$PIECE(^(IEN,0),U,2)
Begin DoDot:2
+6 SET LNK=$PIECE(^CIAZG(19950.42,ITM,0),U,6)
+7 IF LNK
DO DDL2(LNK,0)
+8 SET FDA(19950.42,ITM_",",.01)="@"
End DoDot:2
End DoDot:1
+9 QUIT
+10 ; Delete orphaned child definitions
DEFNDLO ; EP
+1 NEW DEFN
+2 SET DEFN=0
+3 FOR
SET DEFN=$ORDER(^CIAZG(19950.41,DEFN))
IF 'DEFN
QUIT
IF '$PIECE(^(DEFN,0),U,3)
Begin DoDot:1
+4 IF '$DATA(^CIAZG(19950.42,"ALINK",DEFN))
IF $$DEFNDEL(DEFN)
End DoDot:1
+5 QUIT
+6 ; Create a new query definition
DEFNNEW(NAME,SOURCE,OWNER,ACCESS,DESC) ; EP
+1 NEW FDA,IEN
+2 SET FDA=$NAME(FDA(19950.41,"+1,"))
+3 SET @FDA@(.01)=NAME
+4 SET @FDA@(1)=SOURCE
+5 SET @FDA@(2)=OWNER
+6 SET @FDA@(3)=ACCESS
+7 IF $DATA(DESC)
SET @FDA@(99)="DESC"
+8 DO UPDATE^DIE(,"FDA","IEN")
+9 IF $QUIT
QUIT $GET(IEN(1))
+10 QUIT
+11 ; Create a child query definition
DEFNSUB(DEFN,FLD,SOURCE) ; EP
+1 NEW IEN,DESC,PNAM
+2 SET PNAM=$PIECE(^CIAZG(19950.41,DEFN,0),U)
SET DESC(1,0)="Child definition of "_PNAM
SET PNAM=PNAM_"."_FLD
+3 FOR
IF $LENGTH(PNAM)'>80
QUIT
SET PNAM=$PIECE(PNAM,".",2,999)
+4 SET IEN=$$DEFNNEW(PNAM,SOURCE,"","",.DESC)
+5 IF $QUIT
QUIT IEN
+6 QUIT
+7 ; Find a definition by name
DEFNFND(NAME) ; EP
+1 NEW X,IEN
+2 SET X=$EXTRACT(NAME,1,30)
SET IEN=0
+3 FOR
SET IEN=$ORDER(^CIAZG(19950.41,"B",X,IEN))
IF 'IEN
QUIT
IF $PIECE($GET(^CIAZG(19950.41,IEN,0)),U)=NAME
QUIT
+4 QUIT +IEN
+5 ; Clone a query definition
DEFNCLN(DEFN) ; EP
+1 NEW DEFN2,SUB,X,Y
+2 SET OLD=^CIAZG(19950.41,DEFN,0)
SET X=$PIECE(OLD,U)
+3 IF X?1.E1"_"1.N
SET X=$PIECE(X,"_",1,$LENGTH(X,"_")-1)
+4 FOR Y=1:1
SET DEFN2=X_"_"_Y
IF '$$DEFNFND(DEFN2)
QUIT
+5 SET DEFN2=$$DEFNNEW(DEFN2,$PIECE(OLD,U,2),$SELECT($PIECE(OLD,U,3):DUZ,1:""),$PIECE(OLD,U,4))
+6 IF DEFN2
Begin DoDot:1
+7 NEW ITM,LNK
+8 SET OLD=^CIAZG(19950.41,DEFN2,0)
+9 KILL ^CIAZG(19950.41,DEFN2)
+10 MERGE ^(DEFN2)=^(DEFN)
+11 SET ^(DEFN2,0)=OLD
+12 FOR SUB=20,30,40
DO DC2(SUB)
+13 DO REINDEX(19950.41,DEFN2)
End DoDot:1
+14 IF $QUIT
QUIT DEFN2
+15 QUIT
+16 ; Clone all items in multiple
DC2(SUB) NEW ITMX,ITM0
+1 SET ITMX=0
+2 FOR
SET ITMX=$ORDER(^CIAZG(19950.41,DEFN2,SUB,ITMX))
IF 'ITMX
QUIT
SET ITM=$PIECE(^(ITMX,0),U,2)
Begin DoDot:1
+3 SET LNK=$PIECE(^CIAZG(19950.42,ITM,0),U,6)
+4 IF LNK
IF '$GET(LNK(LNK))
SET LNK(LNK)=$$DEFNCLN(LNK)
+5 IF '$GET(ITM(ITM))
SET ITM(ITM)=$$ITEMCLN(ITM,DEFN2,$SELECT(LNK:LNK(LNK),1:""))
+6 SET $PIECE(^CIAZG(19950.41,DEFN2,SUB,ITMX,0),U,2)=ITM(ITM)
End DoDot:1
+7 QUIT
+8 ; Reindex an entry in a file
REINDEX(DIK,DA) ;
+1 SET DIK=$$ROOT^DILFD(DIK)
+2 DO IX1^DIK
+3 QUIT
+4 ; Clone an item entry
ITEMCLN(ITEM,DEFN,LNK) ; EP
+1 NEW FDA,IEN
+2 SET FDA=$NAME(FDA(19950.42,"+1,"))
+3 SET @FDA@(.01)=$PIECE(^CIAZG(19950.42,ITEM,0),U)
+4 DO UPDATE^DIE(,"FDA","IEN")
+5 SET IEN=$GET(IEN(1))
+6 IF IEN
Begin DoDot:1
+7 MERGE ^CIAZG(19950.42,IEN)=^CIAZG(19950.42,ITEM)
+8 SET $PIECE(^CIAZG(19950.42,IEN,0),U,2)=DEFN
SET $PIECE(^(0),U,6)=LNK
+9 DO REINDEX(19950.42,IEN)
End DoDot:1
+10 IF $QUIT
QUIT IEN
+11 QUIT
+12 ; Delete orphaned items
+13 ; ITEMS: List of items to check (optional)
ITEMDLO(ITEMS) ; EP
+1 NEW ITEM,XREF,FDA,ALL,OK
+2 SET ITEM=0
SET ALL=$DATA(ITEMS)<10
+3 FOR
SET ITEM=$SELECT(ALL:$ORDER(^CIAZG(19950.42,ITEM)),1:$ORDER(ITEMS(ITEM)))
IF 'ITEM
QUIT
Begin DoDot:1
+4 SET OK=1
+5 FOR XREF="AITEMC","AITEMS","AITEME"
IF $DATA(^CIAZG(19950.41,XREF,ITEM))
SET OK=0
QUIT
+6 IF OK
SET FDA(19950.42,ITEM_",",.01)="@"
End DoDot:1
+7 IF $DATA(FDA)
DO UPDATE^DIE(,"FDA")
+8 QUIT
