DIQGDD ;SFISC/DCL-DATA DICTIONARY ATTRIBUTE RETRIEVER ;10:55 AM 8 Nov 2000 [ 04/02/2003 8:25 AM ]
;;22.0;VA FileMan;**1001**;APR 1, 2003
;;22.0;VA FileMan;**65**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
GET(DIQGR,DA,DR,DIQGPARM,DIQGETA,DIQGERRA,DIQGIPAR) ;
EN3 I $G(U)'="^" N U S U="^"
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 $G(DA)']"" S DA=DIQGR,DIQGR=1 I '$D(^DIC(DA,0)) S X(1)="FILE" Q $$F^DIQG(.X,1)
S:DIQGR>1 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="FIELD LENGTH" Q $$FL^DIQGDDU(DIQGR,DA)
I DR="REQUIRED IDENTIFIERS" G RI^DIQGDDU
N DRSV S DRSV=DR N DR
S DR=$$ATRBT(DIQGR=1,$G(DRSV)) I 'DR D 202("ATTRIBUTE") Q ""
G DDENTRY^DIQG
;
FIELD(DIQGR,DA,DR,DIQGPARM,DIQGTA,DIQGERRA,DIQGIPAR) ;
EN1 N DIQGERR,DIQGEY,DIQGSAL,DIQGFNUL,DIQGSALX,DIQGTAXX
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"
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
.S DIQGTAXX=$S('$D(DIQGSAL(DIQGSAL,"#(word-processing)")):DIQGTA,1:$$OREF(DIQGTA)_$$Q(DIQGSAL)_")")
.I DIQGSAL="FIELD LENGTH" S DIQGSALX=$$FL^DIQGDDU(DIQGR,DA) G SET
.S DIQGSALX=$$GET^DIQG("^DD("_DIQGR_",",DA,DIQGSAL(DIQGSAL),DIQGPARM,DIQGTAXX,"","1A")
SET .I DIQGSALX]"" S @DIQGTA@(DIQGSAL)=DIQGSALX Q
.Q:DIQGFNUL
.S @DIQGTA@(DIQGSAL)=DIQGSALX
.Q
Q
;
BLDSAL(DIQGTYPE,DIQGDR,DIQGVALA) ;DIQGTYPE=1 for FILE and 0 for FIELD, DIQGDR=string/array, DIQGVALA=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) Q
N DIQGER,DIQGI,DIQGX,DIQGY D LIST^DIQGDDT($S(DIQGTYPE=1:"FILETXT",1:"FIELDTXT"),.DIQGX,"",3)
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)=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
202(E) N X S X(1)=E
D BLD^DIALOG(202,.X),FE
Q
FE I $G(DIQGERRA)]"" D CALLOUT^DIEFU(DIQGERRA)
Q
DIQGDD ;SFISC/DCL-DATA DICTIONARY ATTRIBUTE RETRIEVER ;10:55 AM 8 Nov 2000 [ 04/02/2003 8:25 AM ]
+1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
+2 ;;22.0;VA FileMan;**65**;Mar 30, 1999
+3 ;Per VHA Directive 10-93-142, this routine should not be modified.
GET(DIQGR,DA,DR,DIQGPARM,DIQGETA,DIQGERRA,DIQGIPAR) ;
EN3 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 IF $GET(DA)']""
SET DA=DIQGR
SET DIQGR=1
IF '$DATA(^DIC(DA,0))
SET X(1)="FILE"
QUIT $$F^DIQG(.X,1)
+4 IF DIQGR>1
SET DIQGPARM=$GET(DIQGPARM)_"D"
+5 IF DA'?.N
IF $DATA(^DD(DIQGR,"B",DA))
SET DA=$ORDER(^(DA,""))
IF $ORDER(^(DA))
DO 200
QUIT ""
+6 IF DA'>0
DO 200
QUIT ""
+7 IF DR="FIELD LENGTH"
QUIT $$FL^DIQGDDU(DIQGR,DA)
+8 IF DR="REQUIRED IDENTIFIERS"
GOTO RI^DIQGDDU
+9 NEW DRSV
SET DRSV=DR
NEW DR
+10 SET DR=$$ATRBT(DIQGR=1,$GET(DRSV))
IF 'DR
DO 202("ATTRIBUTE")
QUIT ""
+11 GOTO DDENTRY^DIQG
+12 ;
FIELD(DIQGR,DA,DR,DIQGPARM,DIQGTA,DIQGERRA,DIQGIPAR) ;
EN1 NEW DIQGERR,DIQGEY,DIQGSAL,DIQGFNUL,DIQGSALX,DIQGTAXX
+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 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 SET DIQGSAL=""
FOR
SET DIQGSAL=$ORDER(DIQGSAL(DIQGSAL))
IF DIQGSAL=""
QUIT
Begin DoDot:1
+16 SET DIQGTAXX=$SELECT('$DATA(DIQGSAL(DIQGSAL,"#(word-processing)")):DIQGTA,1:$$OREF(DIQGTA)_$$Q(DIQGSAL)_")")
+17 IF DIQGSAL="FIELD LENGTH"
SET DIQGSALX=$$FL^DIQGDDU(DIQGR,DA)
GOTO SET
+18 SET DIQGSALX=$$GET^DIQG("^DD("_DIQGR_",",DA,DIQGSAL(DIQGSAL),DIQGPARM,DIQGTAXX,"","1A")
SET IF DIQGSALX]""
SET @DIQGTA@(DIQGSAL)=DIQGSALX
QUIT
+1 IF DIQGFNUL
QUIT
+2 SET @DIQGTA@(DIQGSAL)=DIQGSALX
+3 QUIT
End DoDot:1
+4 QUIT
+5 ;
BLDSAL(DIQGTYPE,DIQGDR,DIQGVALA) ;DIQGTYPE=1 for FILE and 0 for FIELD, DIQGDR=string/array, DIQGVALA=valid attribute list array
+1 ; * If DIQGDR is an array pass by reference *
+2 IF $GET(DIQGDR)="*"
DO LIST^DIQGDDT($SELECT(DIQGTYPE=1:"FILETXT",1:"FIELDTXT"),.DIQGVALA,"",3)
QUIT
+3 NEW DIQGER,DIQGI,DIQGX,DIQGY
DO LIST^DIQGDDT($SELECT(DIQGTYPE=1:"FILETXT",1:"FIELDTXT"),.DIQGX,"",3)
+4 IF $GET(DIQGDR)]""
FOR DIQGI=1:1
SET DIQGY=$PIECE(DIQGDR,";",DIQGI)
IF DIQGY=""
QUIT
Begin DoDot:1
+5 IF '$DATA(DIQGX(DIQGY))
SET DIQGER(4)=DIQGY
DO 200
QUIT
+6 SET DIQGVALA(DIQGY)=DIQGX(DIQGY)
IF $DATA(DIQGX(DIQGY,"#(word-processing)"))
SET DIQGVALA(DIQGY,"#(word-processing)")=DIQGX(DIQGY)
End DoDot:1
+7 IF $DATA(DIQGVALA)
QUIT
+8 SET DIQGY=""
FOR
SET DIQGY=$ORDER(DIQGDR(DIQGY))
IF DIQGY=""
QUIT
Begin DoDot:1
+9 IF '$DATA(DIQGX(DIQGY))
SET DIQGER(4)=DIQGY
DO 200
QUIT
+10 SET DIQGVALA(DIQGY)=DIQGX(DIQGY)
IF $DATA(DIQGX(DIQGY,"#(word-processing)"))
SET DIQGVALA(DIQGY,"#(word-processing)")=DIQGX(DIQGY)
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
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))
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_","
OR2(%) IF %=")"!(%=",")
QUIT ""
IF $LENGTH(%)=1
QUIT %
IF "),"[$EXTRACT(%,$LENGTH(%))
SET %=$EXTRACT(%,1,$LENGTH(%)-1)
QUIT %
Q(%Z) SET %Z(%Z)=""
SET %Z=$QUERY(%Z(""))
QUIT $EXTRACT(%Z,4,$LENGTH(%Z)-1)
200 DO BLD^DIALOG(200)
DO FE
QUIT
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
