DIFROMSD ;SFISC/DCL-DIFROM SERVER DD LIST(KIDS/BUILD FILE) ;16JAN2012
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;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.
;
;
DD(DIFRFILE,DIFRFLG,DIFRTA) ;FILENUMBER, TARGET ARRAY ROOT FOR SUB DD NRS
;FILE, FLAGS, TARGET ARRAY
;FILE = File number
;FLAG = "W" Include Word Processing DD numbers
;DIFRTA = Target Array in closed array root format where informaiton
; is returned.
; Returns a list of sub DD numbers. A flag allows wp DD
; numbers to also be returned.
N DIFRFD,DIFRFE,DIFRFW,DIFRNM,DIFRX
S DIFRFW=$G(DIFRFLG)'["W"
F S @DIFRTA@(DIFRFILE,DIFRFILE)=$O(^DD(DIFRFILE,0,"NM",""))_" "_$S($D(^DIC(DIFRFILE,0)):"(File-top level)",1:"(sub-file)"),DIFRFE=0
E F S DIFRFE=$O(@DIFRTA@(DIFRFILE,DIFRFE)) Q:DIFRFE'>0 D
.S DIFRFD=0
.F S DIFRFD=$O(^DD(DIFRFE,"SB",DIFRFD)) Q:DIFRFD'>0 D
..I DIFRFW,$P($G(^DD(DIFRFD,.01,0)),"^",2)["W" Q
..I DIFRFILE-DIFRFE!'$D(DIFRFA) S @DIFRTA@(DIFRFILE,DIFRFD)=$O(^DD(DIFRFD,0,"NM",""))_" (sub-file)"
..Q
.Q
Q
;
DDIOLDD(DIFRFILE,DIFRFLG) ;
;FILE,FLAGS
;FILE = File number
;FLAGS = None
; Returns a list of all the valid DD numbers within a file
; via a call to DDIOL.
N I,X,Y
K ^TMP("DIFROMSP",$J)
D DD(DIFRFILE,"","^TMP(""DIFROMSP"",$J)")
S (I,X)=0 F S I=$O(^TMP("DIFROMSP",$J,DIFRFILE,I)) Q:I'>0 S Y=^(I),X=X+1,^TMP("DIFROMSP",$J,"DDIOL",X,0)=I_$J("",(20-$L(I)))_Y
D EN^DDIOL("","^TMP(""DIFROMSP"",$J,""DDIOL"")")
K ^TMP("DIFROMSP",$J)
Q
;
CHKDD(DIFRFILE,DIFRDD,DIFRFLG) ; $$ EXTRINSIC FUNCTION $$
;Extrinsic; Pass file and DD numbers returns 1 if OK
; and 0 if not DD not part of File
;FILE,DD#
;FILE = File number
;DD# = File or sub-file number.
; Used to determine if
; the value in DD# is valid for FILE.
;FLAGS = "N"umber_"^"_"N"ame of field returned
; Default returns a 1 (true) or 0 (false).
Q:$G(DIFRDD)="" 0
Q:$G(DIFRFILE)="" 0
N DIFRARAY,N
S N=$G(DIFRFLG)["N"
D DD(DIFRFILE,"","DIFRARAY")
I $D(DIFRARAY(DIFRFILE,DIFRDD)) Q:N DIFRDD_"^"_DIFRARAY(DIFRFILE,DIFRDD) Q 1
Q 0
;
DDIOLFLD(DIFRDD,DIFRFLG) ;
;FILE/SUB_FILE,FLAGS
;FILE = File or sub-file number
;FLAGS = "M"ultiple fields excluded
; "W"ord processing fields excluded
; Returns a list of valid field numbers within a file or
; sub-file via a call to DDIOL.
N I,M,W,X,Y,Z
S M=$G(DIFRFLG)["M",W=$G(DIFRFLG)["W"
K ^TMP("DIFROMSP",$J)
S (I,X)=0 F S X=$O(^DD(DIFRDD,X)) Q:X'>0 S Y=$G(^(X,0)) D
.I $P(Y,"^",2) D Q:Y=""
..S Z=$P(^DD(+$P(Y,"^",2),.01,0),"^",2)
..I M,Z'["W" S Y="" Q
..I W,Z["W" S Y="" Q
..S $P(Y,"^")=$P(Y,"^")_$S(Z["W":" (word-processing)",1:" (multiple)")
..Q
.S I=I+1,^TMP("DIFROMSP",$J,I,0)=X_$J("",(12-$L(X)))_$P(Y,"^")
D EN^DDIOL("","^TMP(""DIFROMSP"",$J)")
K ^TMP("DIFROMSP",$J)
Q
;
FLDCHK(DIFRDD,DIFRFLD,DIFRFLG) ; $$ EXTRINSIC FUNCTION $$
;Check if field exist; return 1/FIELD#_NAME, true, or 0, false.
;FILE/SUB_FILE,FIELD,FLAGS
;FILE/SUB_FILE = File or sub-file number
;FIELD = Field number
; If FIELD is valid, returns 1; Otherwise 0 is returned.
;FLAGS = "M"ultiple fields excluded
; "W"ord processing fields excluded
; "N"umber_"^"_"N"ame of field returned.
; Default is to return 1 or 0.
;
Q:$G(DIFRDD)="" 0
Q:$G(DIFRFLD)="" 0
N M,N,W,Z
S M=$G(DIFRFLG)["M",W=$G(DIFRFLG)["W",N=$G(DIFRFLG)["N"
I $P($G(^DD(DIFRDD,DIFRFLD,0)),"^",2) S Z=$P(^DD(+$P(^(0),"^",2),.01,0),"^",2) D Q:N $S(Z:DIFRFLD_"^"_$P(^DD(DIFRDD,DIFRFLD,0),"^"),1:Z) Q Z
.I M,Z'["W" S Z=0 Q
.I W,Z["W" S Z=0 Q
.S Z=1
.Q
I $D(^DD(DIFRDD,DIFRFLD,0))#2 Q:N DIFRFLD_"^"_$P(^(0),"^") Q 1
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFROMSD 3958 printed Dec 13, 2024@02:48:19 Page 2
DIFROMSD ;SFISC/DCL-DIFROM SERVER DD LIST(KIDS/BUILD FILE) ;16JAN2012
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+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 ;
DD(DIFRFILE,DIFRFLG,DIFRTA) ;FILENUMBER, TARGET ARRAY ROOT FOR SUB DD NRS
+1 ;FILE, FLAGS, TARGET ARRAY
+2 ;FILE = File number
+3 ;FLAG = "W" Include Word Processing DD numbers
+4 ;DIFRTA = Target Array in closed array root format where informaiton
+5 ; is returned.
+6 ; Returns a list of sub DD numbers. A flag allows wp DD
+7 ; numbers to also be returned.
+8 NEW DIFRFD,DIFRFE,DIFRFW,DIFRNM,DIFRX
+9 SET DIFRFW=$GET(DIFRFLG)'["W"
F SET @DIFRTA@(DIFRFILE,DIFRFILE)=$ORDER(^DD(DIFRFILE,0,"NM",""))_" "_$SELECT($DATA(^DIC(DIFRFILE,0)):"(File-top level)",1:"(sub-file)")
SET DIFRFE=0
E FOR
SET DIFRFE=$ORDER(@DIFRTA@(DIFRFILE,DIFRFE))
if DIFRFE'>0
QUIT
Begin DoDot:1
+1 SET DIFRFD=0
+2 FOR
SET DIFRFD=$ORDER(^DD(DIFRFE,"SB",DIFRFD))
if DIFRFD'>0
QUIT
Begin DoDot:2
+3 IF DIFRFW
IF $PIECE($GET(^DD(DIFRFD,.01,0)),"^",2)["W"
QUIT
+4 IF DIFRFILE-DIFRFE!'$DATA(DIFRFA)
SET @DIFRTA@(DIFRFILE,DIFRFD)=$ORDER(^DD(DIFRFD,0,"NM",""))_" (sub-file)"
+5 QUIT
End DoDot:2
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
DDIOLDD(DIFRFILE,DIFRFLG) ;
+1 ;FILE,FLAGS
+2 ;FILE = File number
+3 ;FLAGS = None
+4 ; Returns a list of all the valid DD numbers within a file
+5 ; via a call to DDIOL.
+6 NEW I,X,Y
+7 KILL ^TMP("DIFROMSP",$JOB)
+8 DO DD(DIFRFILE,"","^TMP(""DIFROMSP"",$J)")
+9 SET (I,X)=0
FOR
SET I=$ORDER(^TMP("DIFROMSP",$JOB,DIFRFILE,I))
if I'>0
QUIT
SET Y=^(I)
SET X=X+1
SET ^TMP("DIFROMSP",$JOB,"DDIOL",X,0)=I_$JUSTIFY("",(20-$LENGTH(I)))_Y
+10 DO EN^DDIOL("","^TMP(""DIFROMSP"",$J,""DDIOL"")")
+11 KILL ^TMP("DIFROMSP",$JOB)
+12 QUIT
+13 ;
CHKDD(DIFRFILE,DIFRDD,DIFRFLG) ; $$ EXTRINSIC FUNCTION $$
+1 ;Extrinsic; Pass file and DD numbers returns 1 if OK
+2 ; and 0 if not DD not part of File
+3 ;FILE,DD#
+4 ;FILE = File number
+5 ;DD# = File or sub-file number.
+6 ; Used to determine if
+7 ; the value in DD# is valid for FILE.
+8 ;FLAGS = "N"umber_"^"_"N"ame of field returned
+9 ; Default returns a 1 (true) or 0 (false).
+10 if $GET(DIFRDD)=""
QUIT 0
+11 if $GET(DIFRFILE)=""
QUIT 0
+12 NEW DIFRARAY,N
+13 SET N=$GET(DIFRFLG)["N"
+14 DO DD(DIFRFILE,"","DIFRARAY")
+15 IF $DATA(DIFRARAY(DIFRFILE,DIFRDD))
if N
QUIT DIFRDD_"^"_DIFRARAY(DIFRFILE,DIFRDD)
QUIT 1
+16 QUIT 0
+17 ;
DDIOLFLD(DIFRDD,DIFRFLG) ;
+1 ;FILE/SUB_FILE,FLAGS
+2 ;FILE = File or sub-file number
+3 ;FLAGS = "M"ultiple fields excluded
+4 ; "W"ord processing fields excluded
+5 ; Returns a list of valid field numbers within a file or
+6 ; sub-file via a call to DDIOL.
+7 NEW I,M,W,X,Y,Z
+8 SET M=$GET(DIFRFLG)["M"
SET W=$GET(DIFRFLG)["W"
+9 KILL ^TMP("DIFROMSP",$JOB)
+10 SET (I,X)=0
FOR
SET X=$ORDER(^DD(DIFRDD,X))
if X'>0
QUIT
SET Y=$GET(^(X,0))
Begin DoDot:1
+11 IF $PIECE(Y,"^",2)
Begin DoDot:2
+12 SET Z=$PIECE(^DD(+$PIECE(Y,"^",2),.01,0),"^",2)
+13 IF M
IF Z'["W"
SET Y=""
QUIT
+14 IF W
IF Z["W"
SET Y=""
QUIT
+15 SET $PIECE(Y,"^")=$PIECE(Y,"^")_$SELECT(Z["W":" (word-processing)",1:" (multiple)")
+16 QUIT
End DoDot:2
if Y=""
QUIT
+17 SET I=I+1
SET ^TMP("DIFROMSP",$JOB,I,0)=X_$JUSTIFY("",(12-$LENGTH(X)))_$PIECE(Y,"^")
End DoDot:1
+18 DO EN^DDIOL("","^TMP(""DIFROMSP"",$J)")
+19 KILL ^TMP("DIFROMSP",$JOB)
+20 QUIT
+21 ;
FLDCHK(DIFRDD,DIFRFLD,DIFRFLG) ; $$ EXTRINSIC FUNCTION $$
+1 ;Check if field exist; return 1/FIELD#_NAME, true, or 0, false.
+2 ;FILE/SUB_FILE,FIELD,FLAGS
+3 ;FILE/SUB_FILE = File or sub-file number
+4 ;FIELD = Field number
+5 ; If FIELD is valid, returns 1; Otherwise 0 is returned.
+6 ;FLAGS = "M"ultiple fields excluded
+7 ; "W"ord processing fields excluded
+8 ; "N"umber_"^"_"N"ame of field returned.
+9 ; Default is to return 1 or 0.
+10 ;
+11 if $GET(DIFRDD)=""
QUIT 0
+12 if $GET(DIFRFLD)=""
QUIT 0
+13 NEW M,N,W,Z
+14 SET M=$GET(DIFRFLG)["M"
SET W=$GET(DIFRFLG)["W"
SET N=$GET(DIFRFLG)["N"
+15 IF $PIECE($GET(^DD(DIFRDD,DIFRFLD,0)),"^",2)
SET Z=$PIECE(^DD(+$PIECE(^(0),"^",2),.01,0),"^",2)
Begin DoDot:1
+16 IF M
IF Z'["W"
SET Z=0
QUIT
+17 IF W
IF Z["W"
SET Z=0
QUIT
+18 SET Z=1
+19 QUIT
End DoDot:1
if N
QUIT $SELECT(Z:DIFRFLD_"^"_$PIECE(^DD(DIFRDD,DIFRFLD,0),"^"),1:Z)
QUIT Z
+20 IF $DATA(^DD(DIFRDD,DIFRFLD,0))#2
if N
QUIT DIFRFLD_"^"_$PIECE(^(0),"^")
QUIT 1
+21 QUIT 0
