XBLFSETS ;IHS/SET/GTH - LISTS FILE SETS ; [ 04/18/2003 9:06 AM ]
;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997
;IHS/SET/GTH XB*3*9 10/29/2002 New Routine.
; This routine lists the following file information, useful for
; moving to a spreadsheet, or other desktop ap, for database
; Reference Terminology Modeling (RTM) activities:
; CodeSetID;Acronym;Name;Requirement;Source;Information;
; Note;DataType;MinSize;MaxSize;File #;Field #
; The output is one line of data per field, semi-colon delimited.
; Only fields of type SET are reported. Y/N fields are skipped.
; (See routine for more info.)
MORE ;
; CodeSetID: This is an identifier that is used to uniquely identify
; the codeset. Some of these codeset ids are the formal
; standard identifier such as "ICD 9-CM" or "ISO 3166";
; others have been assigned an unofficial codeset id.
; Acronym: This is an abbreviated name for the codeset.
; Name: This is the name of the codeset.
; Requirement: This is an indicator that specifies the codeset is
; required by regulation. An "H" denotes that the codeset
; is required for HIPAA; an "O" denotes a requirement by
; the Office of Management and Budget (OMB).
; Source: This is the originating source of the codeset.
; Information: This is information about the codeset or the location
; of information about the codeset.
; Note: This contains notes that may assist in locating, using,
; documenting, etc., the codeset.
; DateType: This is the datatype of the codeset.
; MinSize: This is the maximum character size of the coded value.
; MaxSize: This is the minimum character size of the coded value.
;
START ;
; --- Display routine description.
D HOME^%ZIS,DT^DICRW
KILL ^UTILITY($J)
S ^UTILITY($J,"XBLFSETS")=""
D EN^XBRPTL
KILL ^UTILITY($J)
; --- Get file(s).
D ^XBDSET
Q:'$D(^UTILITY("XBDSET",$J))
S XBIHS=$$DIR^XBDIR("N^500:999:0","Enter the beginning CodeSet ID number",500,"The response must be a number")
Q:Y="^"
; --- Select device.
W !
S %ZIS="Q",ZTSAVE("^UTILITY(""XBDSET"",$J,")="",ZTSAVE("XBIHS")=""
D EN^XUTMDEVQ("EN^XBLFSETS","List File Sets",.ZTSAVE,.%ZIS)
D EN^XBVK("ZT")
Q
;
EN ;EP - from TaskMan.
VARS ;;F,N,X,W;Single-char work vars.
; F:File #
NEW XBQFLG,@($P($T(VARS),";",3))
S (XBQFLG,F)=0
F S F=$O(^UTILITY("XBDSET",$J,F)) Q:F'=+F D PAGE Q:XBQFLG D FIELDS(F) Q:XBQFLG
D ^%ZISC
Q
;
FIELDS(F) ; Process fields in File F.
NEW X,XB
S XB=0
F S XB=$O(^DD(F,XB)) Q:'(XB=+XB) D D:$Y>(IOSL-3) PAGE Q:XBQFLG
. I $E($P($G(^DD(F,XB,0)),"^",1))="*" Q ; field is deprecated.
. I $P(^DD(F,XB,0),"^",2) D FIELDS($P(^(0),"^",2)) Q ; Recurse sub-file.
. S X=$$TYPE($P($G(^DD(F,XB,0)),"^",2))
. I X'="SET" Q ; Process only SETs.
. I $P($$FINFO(F,XB),"<",2)="1:YES|0:NO|>" Q ; Skip Y/N fields.
. ; CodeSetID;Acronym;Name;Requirement;Source
. S XBIHS=XBIHS+1
. W "IHS"_$J(XBIHS,3,0)_";;"_$P($G(^DD(F,XB,0)),"^",1)_";;;"
. ; Information;Note;DataType;MinSize;MaxSize;File #;Field #
. W $$DESC(F,XB)_";"_$$FINFO(F,XB)_";"_$$TYPE($P($G(^DD(F,XB,0)),"^",2))_";;;"_F_";"_XB_";"
. W !
. Q
Q
;
DESC(N,F) ; Field DESCRIPTION and Help-Prompt. N=File, F=Field
NEW X,XB
S X=""
S X="File Number "_N_", '"_$$FNAME^XBFUNC(N)_"', Field # "_F_", In Global "_$$FGLOB^XBFUNC(N)_", DESCRIPTION <"
F XB=0:0 S XB=$O(^DD(N,F,21,XB)) Q:'XB S X=X_$G(^(XB,0))
S X=X_"> HELP-PROMPT <"_$G(^DD(N,F,3))_">"
Q X
;
TYPE(P) ; Return TYPE of field. Input is the 2nd piece of the 0th node.
NEW W
F W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","K","Z" I P[$E(W) Q
Q $S(W'="Z":W,1:"?")
;
FINFO(N,F) ; Return SET values, or Pointed-To. N=File, F=Field
NEW T
S T=$$TYPE($P(^DD(N,F,0),"^",2))
I T="SET" Q "Values <"_$TR($P($G(^DD(N,F,0)),"^",3),";","|")_">"
I T="POINTER" Q " Points to "_$$FNAME^XBFUNC(+$P($P(^DD(N,F,0),"^",2),"P",2))_" file"
Q "?"
;
PAGE ; PAGE BREAK
NEW F,G,N,X
I IO=IO(0),$E(IOST,1,2)="C-" S XBQFLG='$$DIR^XBDIR("E") I 'XBQFLG W @IOF
Q
;
XBLFSETS ;IHS/SET/GTH - LISTS FILE SETS ; [ 04/18/2003 9:06 AM ]
+1 ;;3.0;IHS/VA UTILITIES;**9**;FEB 07, 1997
+2 ;IHS/SET/GTH XB*3*9 10/29/2002 New Routine.
+3 ; This routine lists the following file information, useful for
+4 ; moving to a spreadsheet, or other desktop ap, for database
+5 ; Reference Terminology Modeling (RTM) activities:
+6 ; CodeSetID;Acronym;Name;Requirement;Source;Information;
+7 ; Note;DataType;MinSize;MaxSize;File #;Field #
+8 ; The output is one line of data per field, semi-colon delimited.
+9 ; Only fields of type SET are reported. Y/N fields are skipped.
+10 ; (See routine for more info.)
MORE ;
+1 ; CodeSetID: This is an identifier that is used to uniquely identify
+2 ; the codeset. Some of these codeset ids are the formal
+3 ; standard identifier such as "ICD 9-CM" or "ISO 3166";
+4 ; others have been assigned an unofficial codeset id.
+5 ; Acronym: This is an abbreviated name for the codeset.
+6 ; Name: This is the name of the codeset.
+7 ; Requirement: This is an indicator that specifies the codeset is
+8 ; required by regulation. An "H" denotes that the codeset
+9 ; is required for HIPAA; an "O" denotes a requirement by
+10 ; the Office of Management and Budget (OMB).
+11 ; Source: This is the originating source of the codeset.
+12 ; Information: This is information about the codeset or the location
+13 ; of information about the codeset.
+14 ; Note: This contains notes that may assist in locating, using,
+15 ; documenting, etc., the codeset.
+16 ; DateType: This is the datatype of the codeset.
+17 ; MinSize: This is the maximum character size of the coded value.
+18 ; MaxSize: This is the minimum character size of the coded value.
+19 ;
START ;
+1 ; --- Display routine description.
+2 DO HOME^%ZIS
DO DT^DICRW
+3 KILL ^UTILITY($JOB)
+4 SET ^UTILITY($JOB,"XBLFSETS")=""
+5 DO EN^XBRPTL
+6 KILL ^UTILITY($JOB)
+7 ; --- Get file(s).
+8 DO ^XBDSET
+9 IF '$DATA(^UTILITY("XBDSET",$JOB))
QUIT
+10 SET XBIHS=$$DIR^XBDIR("N^500:999:0","Enter the beginning CodeSet ID number",500,"The response must be a number")
+11 IF Y="^"
QUIT
+12 ; --- Select device.
+13 WRITE !
+14 SET %ZIS="Q"
SET ZTSAVE("^UTILITY(""XBDSET"",$J,")=""
SET ZTSAVE("XBIHS")=""
+15 DO EN^XUTMDEVQ("EN^XBLFSETS","List File Sets",.ZTSAVE,.%ZIS)
+16 DO EN^XBVK("ZT")
+17 QUIT
+18 ;
EN ;EP - from TaskMan.
VARS ;;F,N,X,W;Single-char work vars.
+1 ; F:File #
+2 NEW XBQFLG,@($PIECE($TEXT(VARS),";",3))
+3 SET (XBQFLG,F)=0
+4 FOR
SET F=$ORDER(^UTILITY("XBDSET",$JOB,F))
IF F'=+F
QUIT
DO PAGE
IF XBQFLG
QUIT
DO FIELDS(F)
IF XBQFLG
QUIT
+5 DO ^%ZISC
+6 QUIT
+7 ;
FIELDS(F) ; Process fields in File F.
+1 NEW X,XB
+2 SET XB=0
+3 FOR
SET XB=$ORDER(^DD(F,XB))
IF '(XB=+XB)
QUIT
Begin DoDot:1
+4 ; field is deprecated.
IF $EXTRACT($PIECE($GET(^DD(F,XB,0)),"^",1))="*"
QUIT
+5 ; Recurse sub-file.
IF $PIECE(^DD(F,XB,0),"^",2)
DO FIELDS($PIECE(^(0),"^",2))
QUIT
+6 SET X=$$TYPE($PIECE($GET(^DD(F,XB,0)),"^",2))
+7 ; Process only SETs.
IF X'="SET"
QUIT
+8 ; Skip Y/N fields.
IF $PIECE($$FINFO(F,XB),"<",2)="1:YES|0:NO|>"
QUIT
+9 ; CodeSetID;Acronym;Name;Requirement;Source
+10 SET XBIHS=XBIHS+1
+11 WRITE "IHS"_$JUSTIFY(XBIHS,3,0)_";;"_$PIECE($GET(^DD(F,XB,0)),"^",1)_";;;"
+12 ; Information;Note;DataType;MinSize;MaxSize;File #;Field #
+13 WRITE $$DESC(F,XB)_";"_$$FINFO(F,XB)_";"_$$TYPE($PIECE($GET(^DD(F,XB,0)),"^",2))_";;;"_F_";"_XB_";"
+14 WRITE !
+15 QUIT
End DoDot:1
IF $Y>(IOSL-3)
DO PAGE
IF XBQFLG
QUIT
+16 QUIT
+17 ;
DESC(N,F) ; Field DESCRIPTION and Help-Prompt. N=File, F=Field
+1 NEW X,XB
+2 SET X=""
+3 SET X="File Number "_N_", '"_$$FNAME^XBFUNC(N)_"', Field # "_F_", In Global "_$$FGLOB^XBFUNC(N)_", DESCRIPTION <"
+4 FOR XB=0:0
SET XB=$ORDER(^DD(N,F,21,XB))
IF 'XB
QUIT
SET X=X_$GET(^(XB,0))
+5 SET X=X_"> HELP-PROMPT <"_$GET(^DD(N,F,3))_">"
+6 QUIT X
+7 ;
TYPE(P) ; Return TYPE of field. Input is the 2nd piece of the 0th node.
+1 NEW W
+2 FOR W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","K","Z"
IF P[$EXTRACT(W)
QUIT
+3 QUIT $SELECT(W'="Z":W,1:"?")
+4 ;
FINFO(N,F) ; Return SET values, or Pointed-To. N=File, F=Field
+1 NEW T
+2 SET T=$$TYPE($PIECE(^DD(N,F,0),"^",2))
+3 IF T="SET"
QUIT "Values <"_$TRANSLATE($PIECE($GET(^DD(N,F,0)),"^",3),";","|")_">"
+4 IF T="POINTER"
QUIT " Points to "_$$FNAME^XBFUNC(+$PIECE($PIECE(^DD(N,F,0),"^",2),"P",2))_" file"
+5 QUIT "?"
+6 ;
PAGE ; PAGE BREAK
+1 NEW F,G,N,X
+2 IF IO=IO(0)
IF $EXTRACT(IOST,1,2)="C-"
SET XBQFLG='$$DIR^XBDIR("E")
IF 'XBQFLG
WRITE @IOF
+3 QUIT
+4 ;
