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