- 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 Feb 19, 2025@00:19:50 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