DIFROMS1 ;SFISC/DCL/TKW-MOVE DD TO TARGET ARRAY ;17APR2003
;;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.
;
Q
EN ;
I '$D(@DIFRFIA) D ERR(1) Q
G:$G(DIFRFILE) FCHK
S DIFRFILE=0 F S DIFRFILE=$O(@DIFRFIA@(DIFRFILE)) Q:DIFRFILE'>0 D FILE
Q
FCHK I '$D(@DIFRFIA@(DIFRFILE)) D ERR(2) Q
FILE N DSEC,DIFRD,DIFRX,DIFR01,DIFRFDD
N DIFRQ,DIFRTART,DIFRK,R,R1,R2,R3,C,F,G,I,DIFRPFD
S DIFR01=$G(@DIFRFIA@(DIFRFILE,0,1))
S DIFRFDD=$TR($P(DIFR01,"^",3),"FP","fp")'="p"
S DSEC=$TR($P(DIFR01,"^",2),"y","Y")="Y"
S DIFRPFD=@DIFRFIA@(DIFRFILE,DIFRFILE)=0
I DIFRFDD!DIFRPFD D
.M @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,"%")=^DIC(DIFRFILE,"%")
.M @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,"%D")=^DIC(DIFRFILE,"%D")
.S @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,0)=$P(^DIC(DIFRFILE,0),"^",1,2)
.S @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,0,"GL")=^DIC(DIFRFILE,0,"GL")
.S @DIFRTA@("^DIC",DIFRFILE,"B",$E(@DIFRFIA@(DIFRFILE),1,30),DIFRFILE)=""
.Q
I DSEC,(DIFRFDD!(DIFRPFD)) D
.D XY^%RCR("^DIC("_DIFRFILE_",0,",$$OREF^DILF($NA(@DIFRTA@("SEC","^DIC",DIFRFILE,DIFRFILE,0))))
.K @DIFRTA@("SEC","^DIC",DIFRFILE,DIFRFILE,0,"GL")
.Q
S DIFRD=0
; * * Go through each DD and sub-DD * *
F S DIFRD=$O(@DIFRFIA@(DIFRFILE,DIFRD)) Q:DIFRD'>0 S DIFRPFD=^(DIFRD)=0 D
.S DIFRX=0
.; * * Merge each field DD to transport structure * *
.;F S DIFRX=$O(^DD(DIFRD,DIFRX)) Q:DIFRX'>0 I $D(@DIFRFIA@(DIFRFILE,DIFRD))<9!($D(@DIFRFIA@(DIFRFILE,DIFRD,DIFRX))) D
.F S DIFRX=$O(^DD(DIFRD,DIFRX)) Q:DIFRX'>0 I DIFRPFD!($D(@DIFRFIA@(DIFRFILE,DIFRD,DIFRX))) D
..M @DIFRTA@("^DD",DIFRFILE,DIFRD,DIFRX)=^DD(DIFRD,DIFRX)
..N SEC F SEC=8,8.5,9 I $D(^DD(DIFRD,DIFRX,SEC)) D:SEC=8 I SEC>8,^(SEC)'="^",$P(^(0),"^",2)'["K",^(SEC)'="@" D
...I DSEC S @DIFRTA@("SEC","^DD",DIFRFILE,DIFRD,DIFRX,SEC)=^DD(DIFRD,DIFRX,SEC)
...K @DIFRTA@("^DD",DIFRFILE,DIFRD,DIFRX,SEC)
...Q
..; If multiple field sent, send ^DD(SUBFILE#,0) and ^("NM",multiple name) for partial DDs
..I 'DIFRPFD D
...N SUBNUM S SUBNUM=$$SUBNUM(DIFRD,DIFRX)
...I 'SUBNUM Q
...S @DIFRTA@("^DD",DIFRFILE,SUBNUM,0)=^DD(SUBNUM,0)
...S @DIFRTA@("^DD",DIFRFILE,SUBNUM,0,"NM",$O(^DD(SUBNUM,0,"NM","")))=""
...Q
..Q
.; * * Clean up x-refs in DDs * *
.S DIFRQ=$NA(@DIFRTA@("^DD",DIFRFILE,DIFRD))
.S DIFRTART=$$OREF^DILF(DIFRQ)
.F S DIFRQ=$Q(@DIFRQ) Q:$P(DIFRQ,DIFRTART)]""!(DIFRQ="") D:$P(DIFRQ,DIFRTART,2,99)[""""
..S DIFRK=1
..S R2=$P(DIFRQ,DIFRTART,2,99),$E(R2,$L(R2))="",C=$L(R2,","),F=1,R1=0
..F I=1:1 Q:I'<C S G=$P(R2,",",F,I) Q:G="" I G'[""""!($L(G,"""")#2&($E(G)="""")&($E(G,$L(G))="""")) S F=F+$L(G,","),I=F-1,R1=R1+1,C=C+($L(G,",")-1) I 'G,G'?1"0".E,R1#2 S DIFRK=DIFRTART_$P(R2,",",1,I)_")" Q
..Q:DIFRK
..K @DIFRK
..Q
.; * * Build DD 0 node after x-ref clean up * *
.; for full DD or full sub-DD
.I DIFRFDD!(DIFRPFD) D
..M @DIFRTA@("^DD",DIFRFILE,DIFRD,0)=^DD(DIFRD,0)
..K @DIFRTA@("^DD",DIFRFILE,DIFRD,0,"VR")
..Q
.Q
IXKEY ; Send entries from KEY and INDEX file
S DIFRD=0
F S DIFRD=$O(@DIFRFIA@(DIFRFILE,DIFRD)) Q:DIFRD'>0 D
. I $O(^DD("IX","B",DIFRD,0)) D DDIXOUT^DIFROMSX(DIFRFILE,DIFRD,DIFRFDD,DIFRTA)
. I $O(^DD("KEY","B",DIFRD,0)) D DDKEYOUT^DIFROMSY(DIFRFILE,DIFRD,DIFRTA)
. Q
Q
;
Q
SUBNUM(F,FD) ;
;Returns 0 if FielD in File is not multiple, otherwise subfile#.
N SUBNUM S SUBNUM=+$P($G(^DD(F,FD,0)),U,2)
I 'SUBNUM Q 0
I $P($G(^DD(SUBNUM,.01,0)),U,2)["W" Q 0
Q SUBNUM
;
ERR(X) D BLD^DIALOG($P($T(ERR+X),";",5)) Q
;;FIA Array Does Not Exist;1;9501
;;FIA File Number Invalid;2;9502
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFROMS1 3840 printed Apr 09, 2024@21:54:08 Page 2
DIFROMS1 ;SFISC/DCL/TKW-MOVE DD TO TARGET ARRAY ;17APR2003
+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 QUIT
EN ;
+1 IF '$DATA(@DIFRFIA)
DO ERR(1)
QUIT
+2 if $GET(DIFRFILE)
GOTO FCHK
+3 SET DIFRFILE=0
FOR
SET DIFRFILE=$ORDER(@DIFRFIA@(DIFRFILE))
if DIFRFILE'>0
QUIT
DO FILE
+4 QUIT
FCHK IF '$DATA(@DIFRFIA@(DIFRFILE))
DO ERR(2)
QUIT
FILE NEW DSEC,DIFRD,DIFRX,DIFR01,DIFRFDD
+1 NEW DIFRQ,DIFRTART,DIFRK,R,R1,R2,R3,C,F,G,I,DIFRPFD
+2 SET DIFR01=$GET(@DIFRFIA@(DIFRFILE,0,1))
+3 SET DIFRFDD=$TRANSLATE($PIECE(DIFR01,"^",3),"FP","fp")'="p"
+4 SET DSEC=$TRANSLATE($PIECE(DIFR01,"^",2),"y","Y")="Y"
+5 SET DIFRPFD=@DIFRFIA@(DIFRFILE,DIFRFILE)=0
+6 IF DIFRFDD!DIFRPFD
Begin DoDot:1
+7 MERGE @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,"%")=^DIC(DIFRFILE,"%")
+8 MERGE @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,"%D")=^DIC(DIFRFILE,"%D")
+9 SET @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,0)=$PIECE(^DIC(DIFRFILE,0),"^",1,2)
+10 SET @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,0,"GL")=^DIC(DIFRFILE,0,"GL")
+11 SET @DIFRTA@("^DIC",DIFRFILE,"B",$EXTRACT(@DIFRFIA@(DIFRFILE),1,30),DIFRFILE)=""
+12 QUIT
End DoDot:1
+13 IF DSEC
IF (DIFRFDD!(DIFRPFD))
Begin DoDot:1
+14 DO XY^%RCR("^DIC("_DIFRFILE_",0,",$$OREF^DILF($NAME(@DIFRTA@("SEC","^DIC",DIFRFILE,DIFRFILE,0))))
+15 KILL @DIFRTA@("SEC","^DIC",DIFRFILE,DIFRFILE,0,"GL")
+16 QUIT
End DoDot:1
+17 SET DIFRD=0
+18 ; * * Go through each DD and sub-DD * *
+19 FOR
SET DIFRD=$ORDER(@DIFRFIA@(DIFRFILE,DIFRD))
if DIFRD'>0
QUIT
SET DIFRPFD=^(DIFRD)=0
Begin DoDot:1
+20 SET DIFRX=0
+21 ; * * Merge each field DD to transport structure * *
+22 ;F S DIFRX=$O(^DD(DIFRD,DIFRX)) Q:DIFRX'>0 I $D(@DIFRFIA@(DIFRFILE,DIFRD))<9!($D(@DIFRFIA@(DIFRFILE,DIFRD,DIFRX))) D
+23 FOR
SET DIFRX=$ORDER(^DD(DIFRD,DIFRX))
if DIFRX'>0
QUIT
IF DIFRPFD!($DATA(@DIFRFIA@(DIFRFILE,DIFRD,DIFRX)))
Begin DoDot:2
+24 MERGE @DIFRTA@("^DD",DIFRFILE,DIFRD,DIFRX)=^DD(DIFRD,DIFRX)
+25 NEW SEC
FOR SEC=8,8.5,9
IF $DATA(^DD(DIFRD,DIFRX,SEC))
if SEC=8
Begin DoDot:3
+26 IF DSEC
SET @DIFRTA@("SEC","^DD",DIFRFILE,DIFRD,DIFRX,SEC)=^DD(DIFRD,DIFRX,SEC)
+27 KILL @DIFRTA@("^DD",DIFRFILE,DIFRD,DIFRX,SEC)
+28 QUIT
End DoDot:3
IF SEC>8
IF ^(SEC)'="^"
IF $PIECE(^(0),"^",2)'["K"
IF ^(SEC)'="@"
Begin DoDot:3
End DoDot:3
+29 ; If multiple field sent, send ^DD(SUBFILE#,0) and ^("NM",multiple name) for partial DDs
+30 IF 'DIFRPFD
Begin DoDot:3
+31 NEW SUBNUM
SET SUBNUM=$$SUBNUM(DIFRD,DIFRX)
+32 IF 'SUBNUM
QUIT
+33 SET @DIFRTA@("^DD",DIFRFILE,SUBNUM,0)=^DD(SUBNUM,0)
+34 SET @DIFRTA@("^DD",DIFRFILE,SUBNUM,0,"NM",$ORDER(^DD(SUBNUM,0,"NM","")))=""
+35 QUIT
End DoDot:3
+36 QUIT
End DoDot:2
+37 ; * * Clean up x-refs in DDs * *
+38 SET DIFRQ=$NAME(@DIFRTA@("^DD",DIFRFILE,DIFRD))
+39 SET DIFRTART=$$OREF^DILF(DIFRQ)
+40 FOR
SET DIFRQ=$QUERY(@DIFRQ)
if $PIECE(DIFRQ,DIFRTART)]""!(DIFRQ="")
QUIT
if $PIECE(DIFRQ,DIFRTART,2,99)[""""
Begin DoDot:2
+41 SET DIFRK=1
+42 SET R2=$PIECE(DIFRQ,DIFRTART,2,99)
SET $EXTRACT(R2,$LENGTH(R2))=""
SET C=$LENGTH(R2,",")
SET F=1
SET R1=0
+43 FOR I=1:1
if I'<C
QUIT
SET G=$PIECE(R2,",",F,I)
if G=""
QUIT
IF G'[""""!($LENGTH(G,"""")#2&($EXTRACT(G)="""")&($EXTRACT(G,$LENGTH(G))=""""))
SET F=F+$LENGTH(G,",")
SET I=F-1
SET R1=R1+1
SET C=C+($LENGTH(G,",")-1)
IF 'G
IF G'?1"0".E
IF R1#2
SET DIFRK=DIFRTART_$PIECE(R2,",",1,I)_")"
QUIT
+44 if DIFRK
QUIT
+45 KILL @DIFRK
+46 QUIT
End DoDot:2
+47 ; * * Build DD 0 node after x-ref clean up * *
+48 ; for full DD or full sub-DD
+49 IF DIFRFDD!(DIFRPFD)
Begin DoDot:2
+50 MERGE @DIFRTA@("^DD",DIFRFILE,DIFRD,0)=^DD(DIFRD,0)
+51 KILL @DIFRTA@("^DD",DIFRFILE,DIFRD,0,"VR")
+52 QUIT
End DoDot:2
+53 QUIT
End DoDot:1
IXKEY ; Send entries from KEY and INDEX file
+1 SET DIFRD=0
+2 FOR
SET DIFRD=$ORDER(@DIFRFIA@(DIFRFILE,DIFRD))
if DIFRD'>0
QUIT
Begin DoDot:1
+3 IF $ORDER(^DD("IX","B",DIFRD,0))
DO DDIXOUT^DIFROMSX(DIFRFILE,DIFRD,DIFRFDD,DIFRTA)
+4 IF $ORDER(^DD("KEY","B",DIFRD,0))
DO DDKEYOUT^DIFROMSY(DIFRFILE,DIFRD,DIFRTA)
+5 QUIT
End DoDot:1
+6 QUIT
+7 ;
+8 QUIT
SUBNUM(F,FD) ;
+1 ;Returns 0 if FielD in File is not multiple, otherwise subfile#.
+2 NEW SUBNUM
SET SUBNUM=+$PIECE($GET(^DD(F,FD,0)),U,2)
+3 IF 'SUBNUM
QUIT 0
+4 IF $PIECE($GET(^DD(SUBNUM,.01,0)),U,2)["W"
QUIT 0
+5 QUIT SUBNUM
+6 ;
ERR(X) DO BLD^DIALOG($PIECE($TEXT(ERR+X),";",5))
QUIT
+1 ;;FIA Array Does Not Exist;1;9501
+2 ;;FIA File Number Invalid;2;9502
