DIQGDD ;SFISC/DCL - DATA DICTIONARY ATTRIBUTE RETRIEVER ;7FEB2017
;;22.2;VA FileMan;**2**;Jan 05, 2015;Build 139
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
;
GET(DIQGR,DA,DR,DIQGPARM,DIQGETA,DIQGERRA,DIQGIPAR) ;
EN3 I $G(U)'="^" N U S U="^" ;COME HERE FROM GET1^DID
I $G(DIQGIPAR)'["A" K DIERR,^TMP("DIERR",$J)
I $G(DIQGR)'>0 N X S X(1)="FILE" Q $$F^DIQG(.X,1)
I DIQGR=1,DA]"" S DIQGR=DA,DA="" ; BACKWARD COMPATIBILITY TO HANDLE FILE 1 $$GET1^DID(1,62.3,"","GLOBAL NAME") ;p7
N DIFILE I $G(DA)="" S DA=DIQGR,DIQGR=1,DIFILE=1 I '$D(^DIC(DA,0)) S X(1)="FILE" Q $$F^DIQG(.X,1) ;LOOK IT UP IN FILE OF FILES (#1)
;S DIQGPARM=$G(DIQGPARM)_"D"
I DA'?.N,$D(^DD(DIQGR,"B",DA)) S DA=$O(^(DA,"")) I $O(^(DA)) D 200 Q ""
I DA'>0 D 200 Q ""
I DR="REQUIRED IDENTIFIERS" G RI^DIQGDDU
N DIQGSAL ;N DRSV S DRSV=DR N DR
D BLDSAL($G(DIFILE),DR,.DIQGSAL) I $D(DIQGSAL)<9 D 202("ATTRIBUTE") Q ""
S DIQGSAL=DR
I '$G(DIFILE) N DR S DIQGPARM=$G(DIQGPARM)_"D" Q $$ONEATT(DIQGR,DA,.DIQGSAL,.DIQGETA) ;WE'RE GETTING AN ATTRIBUTE OF A FIELD
;
S DR=$$ATRBT(1,DR) I 'DR D 202("ATTRIBUTE") Q ""
G DDENTRY^DIQG ;WE'RE GETTING AN ATTRIBUTE OF AN ENTIRE FILE
;
;
FIELD(DIQGR,DA,DR,DIQGPARM,DIQGTA,DIQGERRA,DIQGIPAR) ;
EN1 N DIQGERR,DIQGEY,DIQGSAL,DIQGFNUL,DIQGSALX ;FROM FIELD^DID
S DIQGEY(1)=$G(DIQGR)
I $G(U)'="^" N U S U="^"
I $G(DIQGIPAR)'["A" K DIERR,^TMP("DIERR",$J)
I $G(DIQGR)'>0 D 202("FILE") Q
I $G(DA)']"" D 202("FIELD") Q
I $D(^DD(DIQGR,0))[0 D 202("FILE") Q
I $G(DIQGTA)']"" D 202("TARGET ARRAY") Q
S DIQGPARM=$G(DIQGPARM)_"D",DIQGFNUL=DIQGPARM["N" ;DO WE WANT NULL VALUES?
I DA'?.N,$D(^DD(DIQGR,"B",DA)) S DA=$O(^(DA,"")) I $O(^(DA)) N X S X(1)=DA,X("FILE")=DIQGR D BLD^DIALOG(505,.X),FE Q
I DA'>0 S DIQGEY(3)=DA D 200 Q
I $D(^DD(DIQGR,DA,0))[0 S DIQGEY(3)=DA D 200 Q
D BLDSAL(0,.DR,.DIQGSAL)
I '$D(DIQGSAL),'$D(DIERR) D 200 Q
I '$D(DIQGSAL) Q
S DIQGSAL="" F S DIQGSAL=$O(DIQGSAL(DIQGSAL)) Q:DIQGSAL="" D ;NOW DIQGSAL HOLDS LIST OF ATTRIBUTES FOR WHICH WE WANT VALUES
.S DIQGSALX=$$ONEATT(DIQGR,DA,.DIQGSAL,.DIQGTA)
.I DIQGSALX]"" S @DIQGTA@(DIQGSAL)=DIQGSALX Q
.Q:DIQGFNUL
.S @DIQGTA@(DIQGSAL)=DIQGSALX
.Q
Q
;
;
ONEATT(DIQGR,DA,DIQGSAL,DIQGTA) ;FOR FIELD DA IN FILE DIQGR, GET ATTRIBUTE 'DIQGSAL'
N A,T,DIQGSALX,DIQGTAXX
S:$G(DIQGTA)]"" DIQGTAXX=$S('$D(DIQGSAL(DIQGSAL,"#(word-processing)")):DIQGTA,1:$$OREF(DIQGTA)_$$Q(DIQGSAL)_")")
I '$D(^DD(DIQGR,DA,0)) D BLD^DIALOG(601),FE Q ""
I $P($P(^DD(DIQGR,DA,0),U,2),"t",2) D I $G(DIQGSALX)]"" Q DIQGSALX ;GFT: IS THIS AN EXTENDED DATA TYPE?
.S A=$$GETMETH^DIETLIBF(DIQGR,DA,DIQGSAL) I A]"" S DIQGSALX=A Q ;FIND THE ATTRIBUTE AS A 'METHOD'
.S A=$$GETPROP^DIETLIBF(DIQGR,DA,DIQGSAL) I A]"" S DIQGSALX=A ;FIND THE ATTRIBUTE AS A 'PROPERTY'
.I DIQGSAL="TYPE" S DIQGSALX=$P(^DI(.81,+$P($P(^DD(DIQGR,DA,0),U,2),"t",2),0),U) ;'TYPE' EQUALS AN ENTRY IN FILE .81
S A=$P(^DD(DIQGR,DA,0),U,2),T=$P(^(0),U,5,99)
;This line temporarily removed until functionality can be documented in the Developer Guide
;I DIQGSAL="POINTER" I A'["P",A'["p" Q "" ;DON'T SHOW A 'SET OF CODES' FOR A 'POINTER'
I DIQGSAL="SET OF CODES",A["S" Q $P(^(0),U,3)
I DIQGSAL="LAYGO",A["P" Q $S(A["'":"NO",1:"YES")
I DIQGSAL="EARLIEST DATE",A["D" N Y S Y="<X!(",Y=$S(T'[Y:"",1:+$P($P(T,Y,2),">X")) X ^DD("DD") Q Y
I DIQGSAL="SECONDS ALLOWED",A["D" Q $P("NO^YES",U,$P(T,"""",2)["S"+1)
I DIQGSAL="TIME OF DAY",A["D" Q $P("NO^YES",U,$P(T,"""",2)["T"+1)
I DIQGSAL="TIME REQUIRED",A["D" Q $P("NO^YES",U,$P(T,"""",2)["R"+1)
I DIQGSAL="IMPRECISE DATE",A["D" Q $P("YES^NO",U,$P(T,"""",2)["X"+1)
I DIQGSAL="CODE TO SET POINTER SCREEN",A["P" Q $G(^(12.1))
I DIQGSAL="FIELD LENGTH" Q $$FL^DIQGDDU(DIQGR,DA)
I $D(DIQGSAL(DIQGSAL))#2 Q $$GET^DIQG("^DD("_DIQGR_",",DA,DIQGSAL(DIQGSAL),DIQGPARM,.DIQGTAXX,"","1A") ;GET ATTRIBUTES FROM DATA DICTIONARY
Q $G(DIQGSALX)
;
;
;
BLDSAL(DIQGTYPE,DIQGDR,DIQGVALA) ;DIQGTYPE=1 for FILE and 0 for FIELD, DIQGDR=string/array, DIQGVALA= OUTPUT: valid attribute list array
; If DIQGDR is an array pass by reference
I $G(DIQGDR)="*" D LIST^DIQGDDT($S(DIQGTYPE=1:"FILETXT",1:"FIELDTXT"),.DIQGVALA,"",3) M:DIQGTYPE'=1 DIQGVALA=^DI(.86,"B"),DIQGVALA=^DI(.87,"B") Q ;GET ALL ATTRIBUTE NAMES, INCLUDING METHODS AND PROPERTIES
N DIQGER,DIQGI,DIQGX,DIQGY D LIST^DIQGDDT($S(DIQGTYPE=1:"FILETXT",1:"FIELDTXT"),.DIQGX,"",3) ;PUT LIST OF ATTRIBUTES INTO DIQGX ARRAY!
M DIQGX=^DI(.86,"B"),DIQGX=^DI(.87,"B") ;MOVE PROPERTY AND METHOD NAMES INTO THE ARRAY, TOO!
I $G(DIQGDR)]"" F DIQGI=1:1 S DIQGY=$P(DIQGDR,";",DIQGI) Q:DIQGY="" D
.I '$D(DIQGX(DIQGY)) S DIQGER(4)=DIQGY D 200 Q
.S DIQGVALA(DIQGY)=$G(DIQGX(DIQGY)) S:$D(DIQGX(DIQGY,"#(word-processing)")) DIQGVALA(DIQGY,"#(word-processing)")=DIQGX(DIQGY)
Q:$D(DIQGVALA)
S DIQGY="" F S DIQGY=$O(DIQGDR(DIQGY)) Q:DIQGY="" D
.I '$D(DIQGX(DIQGY)) S DIQGER(4)=DIQGY D 200 Q
.S DIQGVALA(DIQGY)=DIQGX(DIQGY) S:$D(DIQGX(DIQGY,"#(word-processing)")) DIQGVALA(DIQGY,"#(word-processing)")=DIQGX(DIQGY)
.Q
Q
;
XDR(DIQGR,DR,DIQGERR) ;DIQGR DD FILE NUMBER EITHER 1 OR 0
;DR IS DR STRING TO CONVERT TO NUMERIC DR STRING
S DIQGR=+$G(DIQGR),DR=$G(DR)
N I,X,XDR D LIST^DIQGDDT($S(DIQGR=1:"FILETXT",1:"FIELDTXT"),.X,4,3)
I $G(DR)]"" S (X,XDR)="" F I=1:1 S X=$P(DR,";",I) Q:X="" D
.I '$D(X(X)) S DIQGERR(X)="" Q
.S XDR=XDR_X(X)_";" Q
I $D(DR)>1 S (X,XDR)="" F S X=$O(DR(X)) Q:X="" D:'$D(X(X)) S:X]"" XDR=XDR_X(X)_";"
.I '$D(X(X)) S DIQGERR(X)="" Q
.S XDR=XDR_X(X)_";" Q
Q XDR
;
ATRBT(TYPE,ATRIB) ;EXTRINSIC FUNCTION $$TEST IF VALID ATTRIBUTE
;TYPE 0 OR 1 - FIELD=0, FILE=1 (^DD(0) OR ^DD(1))
;ATRIB=ATTRIBUTE BEING REQUESTED
Q:ATRIB']"" 0
N X D LIST^DIQGDDT($S(TYPE=1:"FILETXT",1:"FIELDTXT"),.X,,3)
Q $G(X(ATRIB))
;
;
DR(TYPE) ;TYPE=1,FILE OR 0,FIELD AND RETURNS DR STRING FOR ALL ATTRIBUTES IN INTERNAL FORM (ATTRIBUTE FIELD NUMBERS 3RD ;-PIECE
S TYPE=+$G(TYPE)
N X,Y
D LIST^DIQGDDT($S(TYPE=1:"FILETXT",1:"FIELDTXT"),.X,3)
S (X,Y)=.01 F S Y=$O(X(Y)) Q:Y'>0 S X=X_";"_Y
Q X
;
FILELST(DIDARRAY) ;PASS TARGET ARRAY BY REFERENCE * * LIST FILE ATTRIBUTES * *
EN4 N EQL,TP,TYPE,DIQGDFLG
S TYPE="FILETXT",DIQGDFLG="L"
G ENLST^DIQGDDT
;
FIELDLST(DIDARRAY) ;PASS TARGET ARRAY BY REFERENCE * * LIST FIELD ATTRIBUTES * *
EN5 N EQL,TP,TYPE,DIQGDFLG
S TYPE="FIELDTXT",DIQGDFLG="L"
G ENLST^DIQGDDT
;
OREF(X) N X1,X2 S X1=$P(X,"(")_"(",X2=$$OR2($P(X,"(",2)) Q:X2="" X1 Q X1_X2_","
;
OR2(%) Q:%=")"!(%=",") "" Q:$L(%)=1 % S:"),"[$E(%,$L(%)) %=$E(%,1,$L(%)-1) Q %
;
Q(%Z) S %Z(%Z)="",%Z=$Q(%Z("")) Q $E(%Z,4,$L(%Z)-1)
;
200 D BLD^DIALOG(200),FE Q ;ERROR MESSAGE
;
202(E) N X S X(1)=E
D BLD^DIALOG(202,.X),FE
Q
FE I $G(DIQGERRA)]"" D CALLOUT^DIEFU(DIQGERRA)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIQGDD 6962 printed Dec 13, 2024@02:53:35 Page 2
DIQGDD ;SFISC/DCL - DATA DICTIONARY ATTRIBUTE RETRIEVER ;7FEB2017
+1 ;;22.2;VA FileMan;**2**;Jan 05, 2015;Build 139
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 ;
GET(DIQGR,DA,DR,DIQGPARM,DIQGETA,DIQGERRA,DIQGIPAR) ;
EN3 ;COME HERE FROM GET1^DID
IF $GET(U)'="^"
NEW U
SET U="^"
+1 IF $GET(DIQGIPAR)'["A"
KILL DIERR,^TMP("DIERR",$JOB)
+2 IF $GET(DIQGR)'>0
NEW X
SET X(1)="FILE"
QUIT $$F^DIQG(.X,1)
+3 ; BACKWARD COMPATIBILITY TO HANDLE FILE 1 $$GET1^DID(1,62.3,"","GLOBAL NAME") ;p7
IF DIQGR=1
IF DA]""
SET DIQGR=DA
SET DA=""
+4 ;LOOK IT UP IN FILE OF FILES (#1)
NEW DIFILE
IF $GET(DA)=""
SET DA=DIQGR
SET DIQGR=1
SET DIFILE=1
IF '$DATA(^DIC(DA,0))
SET X(1)="FILE"
QUIT $$F^DIQG(.X,1)
+5 ;S DIQGPARM=$G(DIQGPARM)_"D"
+6 IF DA'?.N
IF $DATA(^DD(DIQGR,"B",DA))
SET DA=$ORDER(^(DA,""))
IF $ORDER(^(DA))
DO 200
QUIT ""
+7 IF DA'>0
DO 200
QUIT ""
+8 IF DR="REQUIRED IDENTIFIERS"
GOTO RI^DIQGDDU
+9 ;N DRSV S DRSV=DR N DR
NEW DIQGSAL
+10 DO BLDSAL($GET(DIFILE),DR,.DIQGSAL)
IF $DATA(DIQGSAL)<9
DO 202("ATTRIBUTE")
QUIT ""
+11 SET DIQGSAL=DR
+12 ;WE'RE GETTING AN ATTRIBUTE OF A FIELD
IF '$GET(DIFILE)
NEW DR
SET DIQGPARM=$GET(DIQGPARM)_"D"
QUIT $$ONEATT(DIQGR,DA,.DIQGSAL,.DIQGETA)
+13 ;
+14 SET DR=$$ATRBT(1,DR)
IF 'DR
DO 202("ATTRIBUTE")
QUIT ""
+15 ;WE'RE GETTING AN ATTRIBUTE OF AN ENTIRE FILE
GOTO DDENTRY^DIQG
+16 ;
+17 ;
FIELD(DIQGR,DA,DR,DIQGPARM,DIQGTA,DIQGERRA,DIQGIPAR) ;
EN1 ;FROM FIELD^DID
NEW DIQGERR,DIQGEY,DIQGSAL,DIQGFNUL,DIQGSALX
+1 SET DIQGEY(1)=$GET(DIQGR)
+2 IF $GET(U)'="^"
NEW U
SET U="^"
+3 IF $GET(DIQGIPAR)'["A"
KILL DIERR,^TMP("DIERR",$JOB)
+4 IF $GET(DIQGR)'>0
DO 202("FILE")
QUIT
+5 IF $GET(DA)']""
DO 202("FIELD")
QUIT
+6 IF $DATA(^DD(DIQGR,0))[0
DO 202("FILE")
QUIT
+7 IF $GET(DIQGTA)']""
DO 202("TARGET ARRAY")
QUIT
+8 ;DO WE WANT NULL VALUES?
SET DIQGPARM=$GET(DIQGPARM)_"D"
SET DIQGFNUL=DIQGPARM["N"
+9 IF DA'?.N
IF $DATA(^DD(DIQGR,"B",DA))
SET DA=$ORDER(^(DA,""))
IF $ORDER(^(DA))
NEW X
SET X(1)=DA
SET X("FILE")=DIQGR
DO BLD^DIALOG(505,.X)
DO FE
QUIT
+10 IF DA'>0
SET DIQGEY(3)=DA
DO 200
QUIT
+11 IF $DATA(^DD(DIQGR,DA,0))[0
SET DIQGEY(3)=DA
DO 200
QUIT
+12 DO BLDSAL(0,.DR,.DIQGSAL)
+13 IF '$DATA(DIQGSAL)
IF '$DATA(DIERR)
DO 200
QUIT
+14 IF '$DATA(DIQGSAL)
QUIT
+15 ;NOW DIQGSAL HOLDS LIST OF ATTRIBUTES FOR WHICH WE WANT VALUES
SET DIQGSAL=""
FOR
SET DIQGSAL=$ORDER(DIQGSAL(DIQGSAL))
if DIQGSAL=""
QUIT
Begin DoDot:1
+16 SET DIQGSALX=$$ONEATT(DIQGR,DA,.DIQGSAL,.DIQGTA)
+17 IF DIQGSALX]""
SET @DIQGTA@(DIQGSAL)=DIQGSALX
QUIT
+18 if DIQGFNUL
QUIT
+19 SET @DIQGTA@(DIQGSAL)=DIQGSALX
+20 QUIT
End DoDot:1
+21 QUIT
+22 ;
+23 ;
ONEATT(DIQGR,DA,DIQGSAL,DIQGTA) ;FOR FIELD DA IN FILE DIQGR, GET ATTRIBUTE 'DIQGSAL'
+1 NEW A,T,DIQGSALX,DIQGTAXX
+2 if $GET(DIQGTA)]""
SET DIQGTAXX=$SELECT('$DATA(DIQGSAL(DIQGSAL,"#(word-processing)")):DIQGTA,1:$$OREF(DIQGTA)_$$Q(DIQGSAL)_")")
+3 IF '$DATA(^DD(DIQGR,DA,0))
DO BLD^DIALOG(601)
DO FE
QUIT ""
+4 ;GFT: IS THIS AN EXTENDED DATA TYPE?
IF $PIECE($PIECE(^DD(DIQGR,DA,0),U,2),"t",2)
Begin DoDot:1
+5 ;FIND THE ATTRIBUTE AS A 'METHOD'
SET A=$$GETMETH^DIETLIBF(DIQGR,DA,DIQGSAL)
IF A]""
SET DIQGSALX=A
QUIT
+6 ;FIND THE ATTRIBUTE AS A 'PROPERTY'
SET A=$$GETPROP^DIETLIBF(DIQGR,DA,DIQGSAL)
IF A]""
SET DIQGSALX=A
+7 ;'TYPE' EQUALS AN ENTRY IN FILE .81
IF DIQGSAL="TYPE"
SET DIQGSALX=$PIECE(^DI(.81,+$PIECE($PIECE(^DD(DIQGR,DA,0),U,2),"t",2),0),U)
End DoDot:1
IF $GET(DIQGSALX)]""
QUIT DIQGSALX
+8 SET A=$PIECE(^DD(DIQGR,DA,0),U,2)
SET T=$PIECE(^(0),U,5,99)
+9 ;This line temporarily removed until functionality can be documented in the Developer Guide
+10 ;I DIQGSAL="POINTER" I A'["P",A'["p" Q "" ;DON'T SHOW A 'SET OF CODES' FOR A 'POINTER'
+11 IF DIQGSAL="SET OF CODES"
IF A["S"
QUIT $PIECE(^(0),U,3)
+12 IF DIQGSAL="LAYGO"
IF A["P"
QUIT $SELECT(A["'":"NO",1:"YES")
+13 IF DIQGSAL="EARLIEST DATE"
IF A["D"
NEW Y
SET Y="<X!("
SET Y=$SELECT(T'[Y:"",1:+$PIECE($PIECE(T,Y,2),">X"))
XECUTE ^DD("DD")
QUIT Y
+14 IF DIQGSAL="SECONDS ALLOWED"
IF A["D"
QUIT $PIECE("NO^YES",U,$PIECE(T,"""",2)["S"+1)
+15 IF DIQGSAL="TIME OF DAY"
IF A["D"
QUIT $PIECE("NO^YES",U,$PIECE(T,"""",2)["T"+1)
+16 IF DIQGSAL="TIME REQUIRED"
IF A["D"
QUIT $PIECE("NO^YES",U,$PIECE(T,"""",2)["R"+1)
+17 IF DIQGSAL="IMPRECISE DATE"
IF A["D"
QUIT $PIECE("YES^NO",U,$PIECE(T,"""",2)["X"+1)
+18 IF DIQGSAL="CODE TO SET POINTER SCREEN"
IF A["P"
QUIT $GET(^(12.1))
+19 IF DIQGSAL="FIELD LENGTH"
QUIT $$FL^DIQGDDU(DIQGR,DA)
+20 ;GET ATTRIBUTES FROM DATA DICTIONARY
IF $DATA(DIQGSAL(DIQGSAL))#2
QUIT $$GET^DIQG("^DD("_DIQGR_",",DA,DIQGSAL(DIQGSAL),DIQGPARM,.DIQGTAXX,"","1A")
+21 QUIT $GET(DIQGSALX)
+22 ;
+23 ;
+24 ;
BLDSAL(DIQGTYPE,DIQGDR,DIQGVALA) ;DIQGTYPE=1 for FILE and 0 for FIELD, DIQGDR=string/array, DIQGVALA= OUTPUT: valid attribute list array
+1 ; If DIQGDR is an array pass by reference
+2 ;GET ALL ATTRIBUTE NAMES, INCLUDING METHODS AND PROPERTIES
IF $GET(DIQGDR)="*"
DO LIST^DIQGDDT($SELECT(DIQGTYPE=1:"FILETXT",1:"FIELDTXT"),.DIQGVALA,"",3)
if DIQGTYPE'=1
MERGE DIQGVALA=^DI(.86,"B"),DIQGVALA=^DI(.87,"B")
QUIT
+3 ;PUT LIST OF ATTRIBUTES INTO DIQGX ARRAY!
NEW DIQGER,DIQGI,DIQGX,DIQGY
DO LIST^DIQGDDT($SELECT(DIQGTYPE=1:"FILETXT",1:"FIELDTXT"),.DIQGX,"",3)
+4 ;MOVE PROPERTY AND METHOD NAMES INTO THE ARRAY, TOO!
MERGE DIQGX=^DI(.86,"B"),DIQGX=^DI(.87,"B")
+5 IF $GET(DIQGDR)]""
FOR DIQGI=1:1
SET DIQGY=$PIECE(DIQGDR,";",DIQGI)
if DIQGY=""
QUIT
Begin DoDot:1
+6 IF '$DATA(DIQGX(DIQGY))
SET DIQGER(4)=DIQGY
DO 200
QUIT
+7 SET DIQGVALA(DIQGY)=$GET(DIQGX(DIQGY))
if $DATA(DIQGX(DIQGY,"#(word-processing)"))
SET DIQGVALA(DIQGY,"#(word-processing)")=DIQGX(DIQGY)
End DoDot:1
+8 if $DATA(DIQGVALA)
QUIT
+9 SET DIQGY=""
FOR
SET DIQGY=$ORDER(DIQGDR(DIQGY))
if DIQGY=""
QUIT
Begin DoDot:1
+10 IF '$DATA(DIQGX(DIQGY))
SET DIQGER(4)=DIQGY
DO 200
QUIT
+11 SET DIQGVALA(DIQGY)=DIQGX(DIQGY)
if $DATA(DIQGX(DIQGY,"#(word-processing)"))
SET DIQGVALA(DIQGY,"#(word-processing)")=DIQGX(DIQGY)
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
XDR(DIQGR,DR,DIQGERR) ;DIQGR DD FILE NUMBER EITHER 1 OR 0
+1 ;DR IS DR STRING TO CONVERT TO NUMERIC DR STRING
+2 SET DIQGR=+$GET(DIQGR)
SET DR=$GET(DR)
+3 NEW I,X,XDR
DO LIST^DIQGDDT($SELECT(DIQGR=1:"FILETXT",1:"FIELDTXT"),.X,4,3)
+4 IF $GET(DR)]""
SET (X,XDR)=""
FOR I=1:1
SET X=$PIECE(DR,";",I)
if X=""
QUIT
Begin DoDot:1
+5 IF '$DATA(X(X))
SET DIQGERR(X)=""
QUIT
+6 SET XDR=XDR_X(X)_";"
QUIT
End DoDot:1
+7 IF $DATA(DR)>1
SET (X,XDR)=""
FOR
SET X=$ORDER(DR(X))
if X=""
QUIT
if '$DATA(X(X))
Begin DoDot:1
+8 IF '$DATA(X(X))
SET DIQGERR(X)=""
QUIT
+9 SET XDR=XDR_X(X)_";"
QUIT
End DoDot:1
if X]""
SET XDR=XDR_X(X)_";"
+10 QUIT XDR
+11 ;
ATRBT(TYPE,ATRIB) ;EXTRINSIC FUNCTION $$TEST IF VALID ATTRIBUTE
+1 ;TYPE 0 OR 1 - FIELD=0, FILE=1 (^DD(0) OR ^DD(1))
+2 ;ATRIB=ATTRIBUTE BEING REQUESTED
+3 if ATRIB']""
QUIT 0
+4 NEW X
DO LIST^DIQGDDT($SELECT(TYPE=1:"FILETXT",1:"FIELDTXT"),.X,,3)
+5 QUIT $GET(X(ATRIB))
+6 ;
+7 ;
DR(TYPE) ;TYPE=1,FILE OR 0,FIELD AND RETURNS DR STRING FOR ALL ATTRIBUTES IN INTERNAL FORM (ATTRIBUTE FIELD NUMBERS 3RD ;-PIECE
+1 SET TYPE=+$GET(TYPE)
+2 NEW X,Y
+3 DO LIST^DIQGDDT($SELECT(TYPE=1:"FILETXT",1:"FIELDTXT"),.X,3)
+4 SET (X,Y)=.01
FOR
SET Y=$ORDER(X(Y))
if Y'>0
QUIT
SET X=X_";"_Y
+5 QUIT X
+6 ;
FILELST(DIDARRAY) ;PASS TARGET ARRAY BY REFERENCE * * LIST FILE ATTRIBUTES * *
EN4 NEW EQL,TP,TYPE,DIQGDFLG
+1 SET TYPE="FILETXT"
SET DIQGDFLG="L"
+2 GOTO ENLST^DIQGDDT
+3 ;
FIELDLST(DIDARRAY) ;PASS TARGET ARRAY BY REFERENCE * * LIST FIELD ATTRIBUTES * *
EN5 NEW EQL,TP,TYPE,DIQGDFLG
+1 SET TYPE="FIELDTXT"
SET DIQGDFLG="L"
+2 GOTO ENLST^DIQGDDT
+3 ;
OREF(X) NEW X1,X2
SET X1=$PIECE(X,"(")_"("
SET X2=$$OR2($PIECE(X,"(",2))
if X2=""
QUIT X1
QUIT X1_X2_","
+1 ;
OR2(%) if %=")"!(%=",")
QUIT ""
if $LENGTH(%)=1
QUIT %
if "),"[$EXTRACT(%,$LENGTH(%))
SET %=$EXTRACT(%,1,$LENGTH(%)-1)
QUIT %
+1 ;
Q(%Z) SET %Z(%Z)=""
SET %Z=$QUERY(%Z(""))
QUIT $EXTRACT(%Z,4,$LENGTH(%Z)-1)
+1 ;
200 ;ERROR MESSAGE
DO BLD^DIALOG(200)
DO FE
QUIT
+1 ;
202(E) NEW X
SET X(1)=E
+1 DO BLD^DIALOG(202,.X)
DO FE
+2 QUIT
FE IF $GET(DIQGERRA)]""
DO CALLOUT^DIEFU(DIQGERRA)
+1 QUIT
