Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DIFROMS1

DIFROMS1.m

Go to the documentation of this file.
  1. DIFROMS1 ;SFISC/DCL/TKW-MOVE DD TO TARGET ARRAY ;17APR2003
  1. ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
  1. ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
  1. ;;Licensed under the terms of the Apache License, Version 2.0.
  1. ;
  1. Q
  1. EN ;
  1. I '$D(@DIFRFIA) D ERR(1) Q
  1. G:$G(DIFRFILE) FCHK
  1. S DIFRFILE=0 F S DIFRFILE=$O(@DIFRFIA@(DIFRFILE)) Q:DIFRFILE'>0 D FILE
  1. Q
  1. FCHK I '$D(@DIFRFIA@(DIFRFILE)) D ERR(2) Q
  1. FILE N DSEC,DIFRD,DIFRX,DIFR01,DIFRFDD
  1. N DIFRQ,DIFRTART,DIFRK,R,R1,R2,R3,C,F,G,I,DIFRPFD
  1. S DIFR01=$G(@DIFRFIA@(DIFRFILE,0,1))
  1. S DIFRFDD=$TR($P(DIFR01,"^",3),"FP","fp")'="p"
  1. S DSEC=$TR($P(DIFR01,"^",2),"y","Y")="Y"
  1. S DIFRPFD=@DIFRFIA@(DIFRFILE,DIFRFILE)=0
  1. I DIFRFDD!DIFRPFD D
  1. .M @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,"%")=^DIC(DIFRFILE,"%")
  1. .M @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,"%D")=^DIC(DIFRFILE,"%D")
  1. .S @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,0)=$P(^DIC(DIFRFILE,0),"^",1,2)
  1. .S @DIFRTA@("^DIC",DIFRFILE,DIFRFILE,0,"GL")=^DIC(DIFRFILE,0,"GL")
  1. .S @DIFRTA@("^DIC",DIFRFILE,"B",$E(@DIFRFIA@(DIFRFILE),1,30),DIFRFILE)=""
  1. .Q
  1. I DSEC,(DIFRFDD!(DIFRPFD)) D
  1. .D XY^%RCR("^DIC("_DIFRFILE_",0,",$$OREF^DILF($NA(@DIFRTA@("SEC","^DIC",DIFRFILE,DIFRFILE,0))))
  1. .K @DIFRTA@("SEC","^DIC",DIFRFILE,DIFRFILE,0,"GL")
  1. .Q
  1. S DIFRD=0
  1. ; * * Go through each DD and sub-DD * *
  1. F S DIFRD=$O(@DIFRFIA@(DIFRFILE,DIFRD)) Q:DIFRD'>0 S DIFRPFD=^(DIFRD)=0 D
  1. .S DIFRX=0
  1. .; * * Merge each field DD to transport structure * *
  1. .;F S DIFRX=$O(^DD(DIFRD,DIFRX)) Q:DIFRX'>0 I $D(@DIFRFIA@(DIFRFILE,DIFRD))<9!($D(@DIFRFIA@(DIFRFILE,DIFRD,DIFRX))) D
  1. .F S DIFRX=$O(^DD(DIFRD,DIFRX)) Q:DIFRX'>0 I DIFRPFD!($D(@DIFRFIA@(DIFRFILE,DIFRD,DIFRX))) D
  1. ..M @DIFRTA@("^DD",DIFRFILE,DIFRD,DIFRX)=^DD(DIFRD,DIFRX)
  1. ..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
  1. ...I DSEC S @DIFRTA@("SEC","^DD",DIFRFILE,DIFRD,DIFRX,SEC)=^DD(DIFRD,DIFRX,SEC)
  1. ...K @DIFRTA@("^DD",DIFRFILE,DIFRD,DIFRX,SEC)
  1. ...Q
  1. ..; If multiple field sent, send ^DD(SUBFILE#,0) and ^("NM",multiple name) for partial DDs
  1. ..I 'DIFRPFD D
  1. ...N SUBNUM S SUBNUM=$$SUBNUM(DIFRD,DIFRX)
  1. ...I 'SUBNUM Q
  1. ...S @DIFRTA@("^DD",DIFRFILE,SUBNUM,0)=^DD(SUBNUM,0)
  1. ...S @DIFRTA@("^DD",DIFRFILE,SUBNUM,0,"NM",$O(^DD(SUBNUM,0,"NM","")))=""
  1. ...Q
  1. ..Q
  1. .; * * Clean up x-refs in DDs * *
  1. .S DIFRQ=$NA(@DIFRTA@("^DD",DIFRFILE,DIFRD))
  1. .S DIFRTART=$$OREF^DILF(DIFRQ)
  1. .F S DIFRQ=$Q(@DIFRQ) Q:$P(DIFRQ,DIFRTART)]""!(DIFRQ="") D:$P(DIFRQ,DIFRTART,2,99)[""""
  1. ..S DIFRK=1
  1. ..S R2=$P(DIFRQ,DIFRTART,2,99),$E(R2,$L(R2))="",C=$L(R2,","),F=1,R1=0
  1. ..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
  1. ..Q:DIFRK
  1. ..K @DIFRK
  1. ..Q
  1. .; * * Build DD 0 node after x-ref clean up * *
  1. .; for full DD or full sub-DD
  1. .I DIFRFDD!(DIFRPFD) D
  1. ..M @DIFRTA@("^DD",DIFRFILE,DIFRD,0)=^DD(DIFRD,0)
  1. ..K @DIFRTA@("^DD",DIFRFILE,DIFRD,0,"VR")
  1. ..Q
  1. .Q
  1. IXKEY ; Send entries from KEY and INDEX file
  1. S DIFRD=0
  1. F S DIFRD=$O(@DIFRFIA@(DIFRFILE,DIFRD)) Q:DIFRD'>0 D
  1. . I $O(^DD("IX","B",DIFRD,0)) D DDIXOUT^DIFROMSX(DIFRFILE,DIFRD,DIFRFDD,DIFRTA)
  1. . I $O(^DD("KEY","B",DIFRD,0)) D DDKEYOUT^DIFROMSY(DIFRFILE,DIFRD,DIFRTA)
  1. . Q
  1. Q
  1. ;
  1. Q
  1. SUBNUM(F,FD) ;
  1. ;Returns 0 if FielD in File is not multiple, otherwise subfile#.
  1. N SUBNUM S SUBNUM=+$P($G(^DD(F,FD,0)),U,2)
  1. I 'SUBNUM Q 0
  1. I $P($G(^DD(SUBNUM,.01,0)),U,2)["W" Q 0
  1. Q SUBNUM
  1. ;
  1. ERR(X) D BLD^DIALOG($P($T(ERR+X),";",5)) Q
  1. ;;FIA Array Does Not Exist;1;9501
  1. ;;FIA File Number Invalid;2;9502