AGGUTB ;VNGT/HS/ALA-Table utilities ; 08 Apr 2010 3:45 PM
;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
;
;
Q
;
TBL(DATA,FILE,INAC) ;EP - Generic table retrieve function
;
;Description
; Return the values in a table
;Input
; FILE - FileMan file number where table resides
; INAC - If file has an inactive field to check, contains
; the node and piece in 'NODE;PIECE' format
;
NEW GLBREF,IEN,LENGTH,TEST1,DLEN,PEC,NODE,X,TXT
S INAC=$G(INAC,"")
;
S II=0
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGUTB D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
I '$$VFILE^DILFD(FILE) S BMXSEC="Table doesn't exist in RPMS" Q
;
S GLBREF=$$ROOT^DILFD(FILE,"",1)
S LENGTH=$$GET1^DID(FILE,.01,"","FIELD LENGTH","TEST1","ERR")
S DLEN=$E("00000",$L(LENGTH)+1,5)_LENGTH
S @DATA@(II)="I00010IEN^T"_DLEN_$C(30)
;
I INAC'="" S NODE=$P(INAC,";",1),PEC=$P(INAC,";",2)
S IEN=0
F S IEN=$O(@GLBREF@(IEN)) Q:'IEN D
. I $G(@GLBREF@(IEN,0))="" Q
. I INAC'="",$P($G(@GLBREF@(IEN,NODE)),"^",PEC)'="" Q
. S TXT=$$GET1^DIQ(FILE,IEN_",",.01,"E")
. S II=II+1,@DATA@(II)=IEN_"^"_TXT_$C(30)
;
DONE S II=II+1,@DATA@(II)=$C(31)
Q
;
TAB(DATA,TEXT) ; PEP -- AGG GET TABLE
;
;Description
; Get the values of a table, including the internal entry
; number and the text
;Input
; TEXT - Value from parameter definition
;
NEW UID,II,X
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGTABLE",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^AGGUTB D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
I TEXT="PROV" D USR(.DATA,"P")
;
I TEXT="COMM" D COMM(.DATA,9999999.05,0)
I TEXT="COMMALL" D COMM(.DATA,9999999.05,1)
;
I TEXT="CLIN" D TBL(.DATA,40.7,"")
;
I TEXT="USER" D USR(.DATA,"")
;
I TEXT="ILOC" D TBL(.DATA,9999999.06,"0;21")
;
;I TEXT="VFILE" D VFL(.DATA,"V")
I TEXT="WINDOW" D VFL(.DATA,"C")
;
I TEXT="COMMTX" D COMMTX(.DATA)
;
I TEXT="BEN" D BEN(.DATA)
;
I TEXT="FH9999999.36" D FHREL(.DATA)
;
I TEXT="INS" D INS(.DATA)
;
K TEXT
Q
;
USR(DATA,TYPE) ;EP - Go through the User File
;
;Input
; TYPE - "P" is for provider, otherwise it's a regular user
;
S II=0
S LENGTH=$$GET1^DID(200,.01,"","FIELD LENGTH","TEST1","ERR")
S DLEN=$E("00000",$L(LENGTH)+1,5)_LENGTH
S @DATA@(II)="I00010IEN^T"_DLEN_"^T00001PROVIDER"_$C(30)
;
I TYPE="P" D G DONE
. NEW NAME,IEN
. S NAME=""
. F S NAME=$O(^VA(200,"AK.PROVIDER",NAME)) Q:NAME="" D
.. S IEN=""
.. F S IEN=$O(^VA(200,"AK.PROVIDER",NAME,IEN)) Q:IEN="" D
... I $G(^VA(200,IEN,0))="" Q
... I IEN\1'=IEN Q
... I $P($G(^VA(200,IEN,"PS")),U,4)'="",DT'>$P(^("PS"),U,4) Q
... I +$P($G(^VA(200,IEN,0)),U,11)'>0,$P(^(0),U,11)'>DT D
.... S II=II+1,@DATA@(II)=IEN_"^"_NAME_$C(30)
;
NEW IEN,NAME,PFLAG
S IEN=.6
F S IEN=$O(^VA(200,IEN)) Q:'IEN D
. I $G(^VA(200,IEN,0))="" Q
. I IEN\1'=IEN Q
. I +$P($G(^VA(200,IEN,0)),U,11)'>0,$P(^(0),U,11)'>DT D
.. S NAME=$$GET1^DIQ(200,IEN_",",.01,"E")
.. I NAME="" Q
.. S PFLAG=$S($D(^VA(200,"AK.PROVIDER",NAME,IEN)):"P",1:"")
.. S II=II+1,@DATA@(II)=IEN_"^"_NAME_"^"_PFLAG_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
COMM(DATA,FILE,FLAG) ;EP - Get the Community Table
NEW CIEN
S II=0
S @DATA@(II)="I00010IEN^T00050"_$C(30)
;
S CIEN=0
F S CIEN=$O(^AUTTCOM(CIEN)) Q:'CIEN D
. I $P(^AUTTCOM(CIEN,0),U,18)'="" Q
. S II=II+1,@DATA@(II)=CIEN_U_$P(^AUTTCOM(CIEN,0),U,1)_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
INS(DATA) ; EP - Get Insurance Table
NEW IIEN,IENS,II
S II=0
S @DATA@(II)="I00010IEN^T00030NAME^T00030STREET^T00015CITY^T00030STATE^T00010ZIP^T00025TYPE^T00013PHONE"_$C(30)
S IIEN=0
F S IIEN=$O(^AUTNINS(IIEN)) Q:'IIEN D
. I $P($G(^AUTNINS(IIEN,1)),"^",7)=0 Q
. S INS=^AUTNINS(IIEN,0)
. S ST=$P(INS,U,4) I ST'="" S ST=$P(^DIC(5,ST,0),U,1)
. S II=II+1,@DATA@(II)=IIEN_U_$P(INS,U,1)_U_$P(INS,U,2)_U_$P(INS,U,3)_U_ST_U_$P(INS,U,5)_U_$P($G(^AUTNINS(IIEN,2)),U,1)_U_$P(INS,U,6)_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
FHREL(DATA) ;EP - Get the Family History Version Subset of File 9999999.36
;
NEW IEN,II,REL
;
S II=0
;
S @DATA@(II)="I00010IEN^T00070"_$C(30)
;
S REL="" F S REL=$O(^AUTTRLSH("B",REL)) Q:REL="" S IEN="" F S IEN=$O(^AUTTRLSH("B",REL,IEN)) Q:'IEN D
. N N,PCC
. S N=$G(^AUTTRLSH(IEN,0))
. I $P(N,U,6)=1 Q ; Quit if inactive
. S PCC=$P($G(^AUTTRLSH(IEN,21)),U) Q:PCC'=1 ;Filter on USE FOR PCC FAMILY HISTORY field
. S II=II+1,@DATA@(II)=IEN_U_$P(N,U)_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
COMMTX(DATA) ;EP - Get list of Community Taxonomies
N TAXIEN,TYPE,COM,ITEM,OK,COMTXNM
S TAXIEN=0
S @DATA@(II)="I00010IEN^T00050COMM_TAX_NAME"_$C(30)
F S TAXIEN=$O(^ATXAX(TAXIEN)) Q:'TAXIEN D
. S TYPE=$P($G(^ATXAX(TAXIEN,0)),"^",15) Q:TYPE'=9999999.05
. S ITEM=0,OK=0
. F S ITEM=$O(^ATXAX(TAXIEN,21,ITEM)) Q:'ITEM D Q:OK
.. S COM=$P(^ATXAX(TAXIEN,21,ITEM,0),U) Q:COM=""
.. I '$D(^AUTTCOM("B",COM)) Q
.. S COMTXNM=$$GET1^DIQ(9002226,TAXIEN,.01,"I"),OK=1
.. S II=II+1,@DATA@(II)=TAXIEN_"^"_COMTXNM_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
BEN(DATA) ;EP - Get list of Beneficiary Codes
N BENIEN,NAME,CODE
S BENIEN=0
S @DATA@(II)="I00010IEN^T00050"_$C(30)
F S BENIEN=$O(^AUTTBEN(BENIEN)) Q:'BENIEN D
. I '$D(^AUTTBEN(BENIEN,0)) Q
. S NAME=$P(^AUTTBEN(BENIEN,0),"^")
. S II=II+1,@DATA@(II)=BENIEN_"^"_NAME_$C(30) ;_"^"_CODE_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
VFL(DATA,FTYP) ;EP - Get list of Vfiles
S II=0
S @DATA@(II)="I00010IEN^T00030^T00100SORT_ORDER^T00100SORT_DIR^T00001FILTER"_$C(30)
NEW IEN,IACT,SORT,SN,SIEN,COLMN,SDIR,DIR
S IEN=0
F S IEN=$O(^AGG(9009068.3,"D",FTYP,IEN)) Q:'IEN D
. ; If Window entry is flagged 'Do not display or extract', quit
. I +$$GET1^DIQ(90506.3,IEN_",",.05,"I") Q
. S II=II+1
. S IACT=$$GET1^DIQ(90506.3,IEN_",",.03,"I")
. S NAME=$$GET1^DIQ(90506.3,IEN_",",.01,"E")
. ; If a sub-definition, do not pull
. I $$GET1^DIQ(90506.3,IEN_",",.07,"I")=1 Q
. S FILTER=$S($D(^AGG(9009068.3,IEN,7)):"Y",1:"N")
. ;
. ; Get Sort Order
. S SORT="",SN="",SDIR=""
. F S SN=$O(^AGG(9009068.3,IEN,10,"D",SN)) Q:SN="" D
.. S SIEN=""
.. F S SIEN=$O(^AGG(9009068.3,IEN,10,"D",SN,SIEN)) Q:SIEN="" D
... ; If the field is inactive, quit
... I $P(^AGG(9009068.3,IEN,10,SIEN,0),U,11)=1 Q
... S COLMN=$P(^AGG(9009068.3,IEN,10,SIEN,0),U,2)
... S DIR=$P(^AGG(9009068.3,IEN,10,SIEN,0),U,13)
... ; Strip off the size and only keep the name
... S COLMN=$E(COLMN,7,$L(COLMN))
... S SORT=SORT_COLMN_$C(29)
... S SDIR=SDIR_DIR_$C(29)
. S SORT=$$TKO^AGGUL1(SORT,$C(29))
. S SDIR=$$TKO^AGGUL1(SDIR,$C(29))
. S @DATA@(II)=IEN_U_$S(IACT=1:"*",1:"")_NAME_U_SORT_U_SDIR_U_FILTER_$C(30)
S II=II+1,@DATA@(II)=$C(31)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(II),$D(DATA) S II=II+1,@DATA@(II)=$C(31)
Q
AGGUTB ;VNGT/HS/ALA-Table utilities ; 08 Apr 2010 3:45 PM
+1 ;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
+2 ;
+3 ;
+4 QUIT
+5 ;
TBL(DATA,FILE,INAC) ;EP - Generic table retrieve function
+1 ;
+2 ;Description
+3 ; Return the values in a table
+4 ;Input
+5 ; FILE - FileMan file number where table resides
+6 ; INAC - If file has an inactive field to check, contains
+7 ; the node and piece in 'NODE;PIECE' format
+8 ;
+9 NEW GLBREF,IEN,LENGTH,TEST1,DLEN,PEC,NODE,X,TXT
+10 SET INAC=$GET(INAC,"")
+11 ;
+12 SET II=0
+13 ;
+14 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGUTB D UNWIND^%ZTER"
+15 ;
+16 IF '$$VFILE^DILFD(FILE)
SET BMXSEC="Table doesn't exist in RPMS"
QUIT
+17 ;
+18 SET GLBREF=$$ROOT^DILFD(FILE,"",1)
+19 SET LENGTH=$$GET1^DID(FILE,.01,"","FIELD LENGTH","TEST1","ERR")
+20 SET DLEN=$EXTRACT("00000",$LENGTH(LENGTH)+1,5)_LENGTH
+21 SET @DATA@(II)="I00010IEN^T"_DLEN_$CHAR(30)
+22 ;
+23 IF INAC'=""
SET NODE=$PIECE(INAC,";",1)
SET PEC=$PIECE(INAC,";",2)
+24 SET IEN=0
+25 FOR
SET IEN=$ORDER(@GLBREF@(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+26 IF $GET(@GLBREF@(IEN,0))=""
QUIT
+27 IF INAC'=""
IF $PIECE($GET(@GLBREF@(IEN,NODE)),"^",PEC)'=""
QUIT
+28 SET TXT=$$GET1^DIQ(FILE,IEN_",",.01,"E")
+29 SET II=II+1
SET @DATA@(II)=IEN_"^"_TXT_$CHAR(30)
End DoDot:1
+30 ;
DONE SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
TAB(DATA,TEXT) ; PEP -- AGG GET TABLE
+1 ;
+2 ;Description
+3 ; Get the values of a table, including the internal entry
+4 ; number and the text
+5 ;Input
+6 ; TEXT - Value from parameter definition
+7 ;
+8 NEW UID,II,X
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("AGGTABLE",UID))
+11 KILL @DATA
+12 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+13 ;
+14 SET II=0
+15 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^AGGUTB D UNWIND^%ZTER"
+16 ;
+17 IF TEXT="PROV"
DO USR(.DATA,"P")
+18 ;
+19 IF TEXT="COMM"
DO COMM(.DATA,9999999.05,0)
+20 IF TEXT="COMMALL"
DO COMM(.DATA,9999999.05,1)
+21 ;
+22 IF TEXT="CLIN"
DO TBL(.DATA,40.7,"")
+23 ;
+24 IF TEXT="USER"
DO USR(.DATA,"")
+25 ;
+26 IF TEXT="ILOC"
DO TBL(.DATA,9999999.06,"0;21")
+27 ;
+28 ;I TEXT="VFILE" D VFL(.DATA,"V")
+29 IF TEXT="WINDOW"
DO VFL(.DATA,"C")
+30 ;
+31 IF TEXT="COMMTX"
DO COMMTX(.DATA)
+32 ;
+33 IF TEXT="BEN"
DO BEN(.DATA)
+34 ;
+35 IF TEXT="FH9999999.36"
DO FHREL(.DATA)
+36 ;
+37 IF TEXT="INS"
DO INS(.DATA)
+38 ;
+39 KILL TEXT
+40 QUIT
+41 ;
USR(DATA,TYPE) ;EP - Go through the User File
+1 ;
+2 ;Input
+3 ; TYPE - "P" is for provider, otherwise it's a regular user
+4 ;
+5 SET II=0
+6 SET LENGTH=$$GET1^DID(200,.01,"","FIELD LENGTH","TEST1","ERR")
+7 SET DLEN=$EXTRACT("00000",$LENGTH(LENGTH)+1,5)_LENGTH
+8 SET @DATA@(II)="I00010IEN^T"_DLEN_"^T00001PROVIDER"_$CHAR(30)
+9 ;
+10 IF TYPE="P"
Begin DoDot:1
+11 NEW NAME,IEN
+12 SET NAME=""
+13 FOR
SET NAME=$ORDER(^VA(200,"AK.PROVIDER",NAME))
IF NAME=""
QUIT
Begin DoDot:2
+14 SET IEN=""
+15 FOR
SET IEN=$ORDER(^VA(200,"AK.PROVIDER",NAME,IEN))
IF IEN=""
QUIT
Begin DoDot:3
+16 IF $GET(^VA(200,IEN,0))=""
QUIT
+17 IF IEN\1'=IEN
QUIT
+18 IF $PIECE($GET(^VA(200,IEN,"PS")),U,4)'=""
IF DT'>$PIECE(^("PS"),U,4)
QUIT
+19 IF +$PIECE($GET(^VA(200,IEN,0)),U,11)'>0
IF $PIECE(^(0),U,11)'>DT
Begin DoDot:4
+20 SET II=II+1
SET @DATA@(II)=IEN_"^"_NAME_$CHAR(30)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
GOTO DONE
+21 ;
+22 NEW IEN,NAME,PFLAG
+23 SET IEN=.6
+24 FOR
SET IEN=$ORDER(^VA(200,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+25 IF $GET(^VA(200,IEN,0))=""
QUIT
+26 IF IEN\1'=IEN
QUIT
+27 IF +$PIECE($GET(^VA(200,IEN,0)),U,11)'>0
IF $PIECE(^(0),U,11)'>DT
Begin DoDot:2
+28 SET NAME=$$GET1^DIQ(200,IEN_",",.01,"E")
+29 IF NAME=""
QUIT
+30 SET PFLAG=$SELECT($DATA(^VA(200,"AK.PROVIDER",NAME,IEN)):"P",1:"")
+31 SET II=II+1
SET @DATA@(II)=IEN_"^"_NAME_"^"_PFLAG_$CHAR(30)
End DoDot:2
End DoDot:1
+32 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+33 QUIT
+34 ;
COMM(DATA,FILE,FLAG) ;EP - Get the Community Table
+1 NEW CIEN
+2 SET II=0
+3 SET @DATA@(II)="I00010IEN^T00050"_$CHAR(30)
+4 ;
+5 SET CIEN=0
+6 FOR
SET CIEN=$ORDER(^AUTTCOM(CIEN))
IF 'CIEN
QUIT
Begin DoDot:1
+7 IF $PIECE(^AUTTCOM(CIEN,0),U,18)'=""
QUIT
+8 SET II=II+1
SET @DATA@(II)=CIEN_U_$PIECE(^AUTTCOM(CIEN,0),U,1)_$CHAR(30)
End DoDot:1
+9 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+10 QUIT
+11 ;
INS(DATA) ; EP - Get Insurance Table
+1 NEW IIEN,IENS,II
+2 SET II=0
+3 SET @DATA@(II)="I00010IEN^T00030NAME^T00030STREET^T00015CITY^T00030STATE^T00010ZIP^T00025TYPE^T00013PHONE"_$CHAR(30)
+4 SET IIEN=0
+5 FOR
SET IIEN=$ORDER(^AUTNINS(IIEN))
IF 'IIEN
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^AUTNINS(IIEN,1)),"^",7)=0
QUIT
+7 SET INS=^AUTNINS(IIEN,0)
+8 SET ST=$PIECE(INS,U,4)
IF ST'=""
SET ST=$PIECE(^DIC(5,ST,0),U,1)
+9 SET II=II+1
SET @DATA@(II)=IIEN_U_$PIECE(INS,U,1)_U_$PIECE(INS,U,2)_U_$PIECE(INS,U,3)_U_ST_U_$PIECE(INS,U,5)_U_$PIECE($GET(^AUTNINS(IIEN,2)),U,1)_U_$PIECE(INS,U,6)_$CHAR(30)
End DoDot:1
+10 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+11 QUIT
+12 ;
FHREL(DATA) ;EP - Get the Family History Version Subset of File 9999999.36
+1 ;
+2 NEW IEN,II,REL
+3 ;
+4 SET II=0
+5 ;
+6 SET @DATA@(II)="I00010IEN^T00070"_$CHAR(30)
+7 ;
+8 SET REL=""
FOR
SET REL=$ORDER(^AUTTRLSH("B",REL))
IF REL=""
QUIT
SET IEN=""
FOR
SET IEN=$ORDER(^AUTTRLSH("B",REL,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+9 NEW N,PCC
+10 SET N=$GET(^AUTTRLSH(IEN,0))
+11 ; Quit if inactive
IF $PIECE(N,U,6)=1
QUIT
+12 ;Filter on USE FOR PCC FAMILY HISTORY field
SET PCC=$PIECE($GET(^AUTTRLSH(IEN,21)),U)
IF PCC'=1
QUIT
+13 SET II=II+1
SET @DATA@(II)=IEN_U_$PIECE(N,U)_$CHAR(30)
End DoDot:1
+14 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+15 QUIT
+16 ;
COMMTX(DATA) ;EP - Get list of Community Taxonomies
+1 NEW TAXIEN,TYPE,COM,ITEM,OK,COMTXNM
+2 SET TAXIEN=0
+3 SET @DATA@(II)="I00010IEN^T00050COMM_TAX_NAME"_$CHAR(30)
+4 FOR
SET TAXIEN=$ORDER(^ATXAX(TAXIEN))
IF 'TAXIEN
QUIT
Begin DoDot:1
+5 SET TYPE=$PIECE($GET(^ATXAX(TAXIEN,0)),"^",15)
IF TYPE'=9999999.05
QUIT
+6 SET ITEM=0
SET OK=0
+7 FOR
SET ITEM=$ORDER(^ATXAX(TAXIEN,21,ITEM))
IF 'ITEM
QUIT
Begin DoDot:2
+8 SET COM=$PIECE(^ATXAX(TAXIEN,21,ITEM,0),U)
IF COM=""
QUIT
+9 IF '$DATA(^AUTTCOM("B",COM))
QUIT
+10 SET COMTXNM=$$GET1^DIQ(9002226,TAXIEN,.01,"I")
SET OK=1
+11 SET II=II+1
SET @DATA@(II)=TAXIEN_"^"_COMTXNM_$CHAR(30)
End DoDot:2
IF OK
QUIT
End DoDot:1
+12 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+13 QUIT
+14 ;
BEN(DATA) ;EP - Get list of Beneficiary Codes
+1 NEW BENIEN,NAME,CODE
+2 SET BENIEN=0
+3 SET @DATA@(II)="I00010IEN^T00050"_$CHAR(30)
+4 FOR
SET BENIEN=$ORDER(^AUTTBEN(BENIEN))
IF 'BENIEN
QUIT
Begin DoDot:1
+5 IF '$DATA(^AUTTBEN(BENIEN,0))
QUIT
+6 SET NAME=$PIECE(^AUTTBEN(BENIEN,0),"^")
+7 ;_"^"_CODE_$C(30)
SET II=II+1
SET @DATA@(II)=BENIEN_"^"_NAME_$CHAR(30)
End DoDot:1
+8 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+9 QUIT
+10 ;
VFL(DATA,FTYP) ;EP - Get list of Vfiles
+1 SET II=0
+2 SET @DATA@(II)="I00010IEN^T00030^T00100SORT_ORDER^T00100SORT_DIR^T00001FILTER"_$CHAR(30)
+3 NEW IEN,IACT,SORT,SN,SIEN,COLMN,SDIR,DIR
+4 SET IEN=0
+5 FOR
SET IEN=$ORDER(^AGG(9009068.3,"D",FTYP,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+6 ; If Window entry is flagged 'Do not display or extract', quit
+7 IF +$$GET1^DIQ(90506.3,IEN_",",.05,"I")
QUIT
+8 SET II=II+1
+9 SET IACT=$$GET1^DIQ(90506.3,IEN_",",.03,"I")
+10 SET NAME=$$GET1^DIQ(90506.3,IEN_",",.01,"E")
+11 ; If a sub-definition, do not pull
+12 IF $$GET1^DIQ(90506.3,IEN_",",.07,"I")=1
QUIT
+13 SET FILTER=$SELECT($DATA(^AGG(9009068.3,IEN,7)):"Y",1:"N")
+14 ;
+15 ; Get Sort Order
+16 SET SORT=""
SET SN=""
SET SDIR=""
+17 FOR
SET SN=$ORDER(^AGG(9009068.3,IEN,10,"D",SN))
IF SN=""
QUIT
Begin DoDot:2
+18 SET SIEN=""
+19 FOR
SET SIEN=$ORDER(^AGG(9009068.3,IEN,10,"D",SN,SIEN))
IF SIEN=""
QUIT
Begin DoDot:3
+20 ; If the field is inactive, quit
+21 IF $PIECE(^AGG(9009068.3,IEN,10,SIEN,0),U,11)=1
QUIT
+22 SET COLMN=$PIECE(^AGG(9009068.3,IEN,10,SIEN,0),U,2)
+23 SET DIR=$PIECE(^AGG(9009068.3,IEN,10,SIEN,0),U,13)
+24 ; Strip off the size and only keep the name
+25 SET COLMN=$EXTRACT(COLMN,7,$LENGTH(COLMN))
+26 SET SORT=SORT_COLMN_$CHAR(29)
+27 SET SDIR=SDIR_DIR_$CHAR(29)
End DoDot:3
End DoDot:2
+28 SET SORT=$$TKO^AGGUL1(SORT,$CHAR(29))
+29 SET SDIR=$$TKO^AGGUL1(SDIR,$CHAR(29))
+30 SET @DATA@(II)=IEN_U_$SELECT(IACT=1:"*",1:"")_NAME_U_SORT_U_SDIR_U_FILTER_$CHAR(30)
End DoDot:1
+31 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+32 QUIT
+33 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(II)
IF $DATA(DATA)
SET II=II+1
SET @DATA@(II)=$CHAR(31)
+6 QUIT
