- 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
