- DIFROM1 ;SFISC/XAK-CREATES RTNS WITH DD'S ;29OCT2012
- ;;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.
- ;
- L S DH=" F I=1:2 S X=$T(Q+I) Q:X="""" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y",F=$O(F(F))
- I F'>0 D:DSEC SEC K ^UTILITY("DI",$J) G ^DIFROM11
- S ^UTILITY($J,DL+1,0)="^DIC("_F_",0,""GL"")",^UTILITY($J,DL+2,0)="="_F(F,0),^UTILITY($J,DL+3,0)="^DIC(""B"","""_F(F)_""","_F_")",^UTILITY($J,DL+4,0)="=",DL=DL+4
- S DH=" Q:'DIFQ("_F_") "_DH
- EGP F E="ALANG","%","%D" S %X="^DIC("_F_","""_E_""",",E=0 D %XY ;**CCO/NI TO TRANSPORT FOREIGN-LANGUAGE FILE NAMES
- I DSEC S E="" F DSEC=DSEC:1 S E=$O(^DIC(F,0,E)) Q:E="" I E'="GL" S ^UTILITY("DI",$J,DSEC,0)="^DIC("_F_",0,"""_E_""")" S DSEC=DSEC+1 S ^UTILITY("DI",$J,DSEC,0)="="_^DIC(F,0,E)
- F D=0:0 S D=$O(F(F,D)),E=0,%X="^DD("_D_",0" Q:D'>0 S ^UTILITY($J,DL+1,0)=%X_")",DL=DL+2,^UTILITY($J,DL,0)="="_^DD(D,0),%X=%X_"," D V F X=0:0 S X=$O(^DD(D,X)) Q:X'>0 S %X="^DD("_D_","_X_",",E="%Z#2" D SAVE:$D(F(F,D))<9!$D(F(F,D,X))
- ;
- KEYSNIX ; TRANSPORT INDEXES AND KEYS; VEN/SMH for FM V22.2 (fallthrough)
- ; FIA array has same format as F currently has. We will just reuse F.
- ; But we need to store it in a global as DIFROMS* uses naked refs.
- K ^UTILITY("FIA",$J),^UTILITY("KX",$J) ; FIA, Keys and Index output.
- M ^UTILITY("FIA",$J)=F ; Load FIA.
- ;
- ; Export DD from KIDS. Includes ^DD and ^DIC.
- ; New Style Indexes and Keys get exported too.
- ; Unfortunately, Indexes and Keys code expects DIFROM Server Style ^DD array.
- ; So this is the easiest way to get them out from the Server.
- D DDOUT^DIFROMS(F,"",$NA(^UTILITY("FIA",$J)),$NA(^UTILITY("KX",$J)))
- ;
- ; We don't need this any more.
- K ^UTILITY("FIA",$J)
- ;
- ; Remove ^DD and ^DIC from the output array.
- K ^UTILITY("KX",$J,"^DD")
- K ^UTILITY("KX",$J,"^DIC")
- ;
- ; Now we loop through output global and store in ^UTILITY($J) so that DIFROM
- ; will store the global in the outputted routines
- N GREF S GREF=$NA(^UTILITY("KX",$J)) ; Global reference for $Q
- N LREF S LREF=$E(GREF,1,$L(GREF)-1) ; Last reference -- w/o the comma.
- F S GREF=$Q(@GREF) Q:GREF'[LREF D ; Loop until the Global doesn't match itself.
- . S DL=DL+1 ; next line
- . N REF2STORE S REF2STORE=GREF ; We need to change the stored reference for the destination system.
- . S $P(REF2STORE,",",2)="$J" ; Remove our job number, and just put $J. Destination system will resolve it.
- . S ^UTILITY($J,DL,0)=REF2STORE ; Store ref
- . S DL=DL+1 ; next line
- . S ^UTILITY($J,DL,0)="="_@GREF ; store the value.
- ;
- ; We don't need this anymore.
- K ^UTILITY("KX",$J)
- ;
- ; This dumps the routines out for all of the above (^DD, ^DIC, and ^UTILITY("KX")
- ; Last part (IFff) says if data doesn't come with file do the next file.
- D FILE^DIFROM3 G:'$D(DRN) EQ^DIFROM11 I $P(F(F,-222),U,7)'="y" G L
- ;
- S DL=DL+1,E="%Z#2=0",%X=F(F,0),@("D="_%X_"0)")
- S ^UTILITY($J,DL+1,0)="^UTILITY(U,$J,"_F_")",^UTILITY($J,DL+2,0)="="_%X,^UTILITY($J,DL+3,0)="^UTILITY(U,$J,"_F_",0)",^UTILITY($J,DL+4,0)="="_D,%Y="^UTILITY(U,$J,"_F_",",%Z=0,%C(-1)=0,%B=0,%A="",DL=DL+5
- D N S DH=$P(DH,"DIFQ")_"DIFQR"_$P(DH,"DIFQ",2,99)
- D FILE^DIFROM3 G:'$D(DRN) EQ^DIFROM11 G L
- SAVE K DSV I $D(^(X,8)) S DSV(8)=^(8) K ^(8)
- F %Z=8.5,9 I $D(^(%Z)),^(%Z)'=U,'($P(^(0),U,2)["K"&(^(%Z)="@")) S DSV(%Z)=^(%Z) K ^(%Z)
- D %XY
- F %Z=8,8.5,9 I $D(DSV(%Z)),DSV(%Z)]"" S ^DD(D,X,%Z)=DSV(%Z) I DSEC S ^UTILITY("DI",$J,DSEC,0)="^DD("_D_","_X_","_%Z_")",DSEC=DSEC+1,^UTILITY("DI",$J,DSEC,0)="="_DSV(%Z),DSEC=DSEC+1
- Q
- ;
- SEC S DH=" I DSEC"_DH,%X="^UTILITY(""DI"",$J,",%Y="^UTILITY($J," D %XY^%RCR
- D FILE^DIFROM3:$O(^UTILITY($J,0))>0 G:'$D(DRN) EQ^DIFROM11 S DH=$E(DH,8,999) Q
- ;
- %XY ;
- W "." S %Z=0,%A="",%C(-1)=0,%Y=%X
- S S %B=""
- N S @("%B=$O("_%X_%A_"%B))"),%C(%Z)=%C(%Z-1) I '%B,%B'?1"0".E,@E S %B=""
- I %B["," F %C=0:0 S %C=$F(%B,",",%C) Q:'%C S %C(%Z)=%C(%Z)+1
- I %B="" G Q:'%Z S @("%B="_$P(%A,",",%Z+%C(%Z-2),%Z+%C(%Z-1))),%Z=%Z-1,%A=$P(%A,",",1,%Z+%C(%Z-1))_$E(",",%Z>0) G N
- I @("$D("_%X_%A_"%B))#2=1") S %V=^(%B) D W:%V'?.ANP S %=$P("""",U,+%B'=%B),%=%Y_%A_%_%B_%_")" D B:$L(%V)>240 S DL=DL+1,^UTILITY($J,DL,0)=%,DL=DL+1,^UTILITY($J,DL,0)="="_%V
- I @("$D("_%X_%A_"%B))<9") G N
- G D:+%B=%B F %C=0:0 S %C=$F(%B,"""",%C) Q:'%C S %B=$E(%B,1,%C-1)_""""_$E(%B,%C,999),%C=%C+1
- S %B=""""_%B_""""
- D S %A=%A_%B_",",%Z=%Z+1 G S
- ;
- B I $L(%V)>255 W !,"WARNING--DATA TOO LONG: " D X
- S DL=DL+1,^UTILITY($J,DL,0)=%,%=$C(126)_$E(%V,1,160),%V=$E(%V,161,999) Q
- ;
- W W !,"WARNING--CONTROL CHARACTER IN DATA: "
- X W $C(7),%X,%A,%B,")--",!?3,%V
- Q Q
- V K DSV I $D(^DD(D,0,"VR"))#2 S DSV=^("VR") K ^("VR")
- D %XY
- I $D(DSV)#2 S ^DD(D,0,"VR")=DSV K DSV
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIFROM1 5022 printed Feb 19, 2025@00:14:14 Page 2
- DIFROM1 ;SFISC/XAK-CREATES RTNS WITH DD'S ;29OCT2012
- +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 ;
- L SET DH=" F I=1:2 S X=$T(Q+I) Q:X="""" S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y"
- SET F=$ORDER(F(F))
- +1 IF F'>0
- if DSEC
- DO SEC
- KILL ^UTILITY("DI",$JOB)
- GOTO ^DIFROM11
- +2 SET ^UTILITY($JOB,DL+1,0)="^DIC("_F_",0,""GL"")"
- SET ^UTILITY($JOB,DL+2,0)="="_F(F,0)
- SET ^UTILITY($JOB,DL+3,0)="^DIC(""B"","""_F(F)_""","_F_")"
- SET ^UTILITY($JOB,DL+4,0)="="
- SET DL=DL+4
- +3 SET DH=" Q:'DIFQ("_F_") "_DH
- EGP ;**CCO/NI TO TRANSPORT FOREIGN-LANGUAGE FILE NAMES
- FOR E="ALANG","%","%D"
- SET %X="^DIC("_F_","""_E_""","
- SET E=0
- DO %XY
- +1 IF DSEC
- SET E=""
- FOR DSEC=DSEC:1
- SET E=$ORDER(^DIC(F,0,E))
- if E=""
- QUIT
- IF E'="GL"
- SET ^UTILITY("DI",$JOB,DSEC,0)="^DIC("_F_",0,"""_E_""")"
- SET DSEC=DSEC+1
- SET ^UTILITY("DI",$JOB,DSEC,0)="="_^DIC(F,0,E)
- +2 FOR D=0:0
- SET D=$ORDER(F(F,D))
- SET E=0
- SET %X="^DD("_D_",0"
- if D'>0
- QUIT
- SET ^UTILITY($JOB,DL+1,0)=%X_")"
- SET DL=DL+2
- SET ^UTILITY($JOB,DL,0)="="_^DD(D,0)
- SET %X=%X_","
- DO V
- FOR X=0:0
- SET X=$ORDER(^DD(D,X))
- if X'>0
- QUIT
- SET %X="^DD("_D_","_X_","
- SET E="%Z#2"
- if $DATA(F(F,D))<9!$DATA(F(F,D,X))
- DO SAVE
- +3 ;
- KEYSNIX ; TRANSPORT INDEXES AND KEYS; VEN/SMH for FM V22.2 (fallthrough)
- +1 ; FIA array has same format as F currently has. We will just reuse F.
- +2 ; But we need to store it in a global as DIFROMS* uses naked refs.
- +3 ; FIA, Keys and Index output.
- KILL ^UTILITY("FIA",$JOB),^UTILITY("KX",$JOB)
- +4 ; Load FIA.
- MERGE ^UTILITY("FIA",$JOB)=F
- +5 ;
- +6 ; Export DD from KIDS. Includes ^DD and ^DIC.
- +7 ; New Style Indexes and Keys get exported too.
- +8 ; Unfortunately, Indexes and Keys code expects DIFROM Server Style ^DD array.
- +9 ; So this is the easiest way to get them out from the Server.
- +10 DO DDOUT^DIFROMS(F,"",$NAME(^UTILITY("FIA",$JOB)),$NAME(^UTILITY("KX",$JOB)))
- +11 ;
- +12 ; We don't need this any more.
- +13 KILL ^UTILITY("FIA",$JOB)
- +14 ;
- +15 ; Remove ^DD and ^DIC from the output array.
- +16 KILL ^UTILITY("KX",$JOB,"^DD")
- +17 KILL ^UTILITY("KX",$JOB,"^DIC")
- +18 ;
- +19 ; Now we loop through output global and store in ^UTILITY($J) so that DIFROM
- +20 ; will store the global in the outputted routines
- +21 ; Global reference for $Q
- NEW GREF
- SET GREF=$NAME(^UTILITY("KX",$JOB))
- +22 ; Last reference -- w/o the comma.
- NEW LREF
- SET LREF=$EXTRACT(GREF,1,$LENGTH(GREF)-1)
- +23 ; Loop until the Global doesn't match itself.
- FOR
- SET GREF=$QUERY(@GREF)
- if GREF'[LREF
- QUIT
- Begin DoDot:1
- +24 ; next line
- SET DL=DL+1
- +25 ; We need to change the stored reference for the destination system.
- NEW REF2STORE
- SET REF2STORE=GREF
- +26 ; Remove our job number, and just put $J. Destination system will resolve it.
- SET $PIECE(REF2STORE,",",2)="$J"
- +27 ; Store ref
- SET ^UTILITY($JOB,DL,0)=REF2STORE
- +28 ; next line
- SET DL=DL+1
- +29 ; store the value.
- SET ^UTILITY($JOB,DL,0)="="_@GREF
- End DoDot:1
- +30 ;
- +31 ; We don't need this anymore.
- +32 KILL ^UTILITY("KX",$JOB)
- +33 ;
- +34 ; This dumps the routines out for all of the above (^DD, ^DIC, and ^UTILITY("KX")
- +35 ; Last part (IFff) says if data doesn't come with file do the next file.
- +36 DO FILE^DIFROM3
- if '$DATA(DRN)
- GOTO EQ^DIFROM11
- IF $PIECE(F(F,-222),U,7)'="y"
- GOTO L
- +37 ;
- +38 SET DL=DL+1
- SET E="%Z#2=0"
- SET %X=F(F,0)
- SET @("D="_%X_"0)")
- +39 SET ^UTILITY($JOB,DL+1,0)="^UTILITY(U,$J,"_F_")"
- SET ^UTILITY($JOB,DL+2,0)="="_%X
- SET ^UTILITY($JOB,DL+3,0)="^UTILITY(U,$J,"_F_",0)"
- SET ^UTILITY($JOB,DL+4,0)="="_D
- SET %Y="^UTILITY(U,$J,"_F_","
- SET %Z=0
- SET %C(-1)=0
- SET %B=0
- SET %A=""
- SET DL=DL+5
- +40 DO N
- SET DH=$PIECE(DH,"DIFQ")_"DIFQR"_$PIECE(DH,"DIFQ",2,99)
- +41 DO FILE^DIFROM3
- if '$DATA(DRN)
- GOTO EQ^DIFROM11
- GOTO L
- SAVE KILL DSV
- IF $DATA(^(X,8))
- SET DSV(8)=^(8)
- KILL ^(8)
- +1 FOR %Z=8.5,9
- IF $DATA(^(%Z))
- IF ^(%Z)'=U
- IF '($PIECE(^(0),U,2)["K"&(^(%Z)="@"))
- SET DSV(%Z)=^(%Z)
- KILL ^(%Z)
- +2 DO %XY
- +3 FOR %Z=8,8.5,9
- IF $DATA(DSV(%Z))
- IF DSV(%Z)]""
- SET ^DD(D,X,%Z)=DSV(%Z)
- IF DSEC
- SET ^UTILITY("DI",$JOB,DSEC,0)="^DD("_D_","_X_","_%Z_")"
- SET DSEC=DSEC+1
- SET ^UTILITY("DI",$JOB,DSEC,0)="="_DSV(%Z)
- SET DSEC=DSEC+1
- +4 QUIT
- +5 ;
- SEC SET DH=" I DSEC"_DH
- SET %X="^UTILITY(""DI"",$J,"
- SET %Y="^UTILITY($J,"
- DO %XY^%RCR
- +1 if $ORDER(^UTILITY($JOB,0))>0
- DO FILE^DIFROM3
- if '$DATA(DRN)
- GOTO EQ^DIFROM11
- SET DH=$EXTRACT(DH,8,999)
- QUIT
- +2 ;
- %XY ;
- +1 WRITE "."
- SET %Z=0
- SET %A=""
- SET %C(-1)=0
- SET %Y=%X
- S SET %B=""
- N SET @("%B=$O("_%X_%A_"%B))")
- SET %C(%Z)=%C(%Z-1)
- IF '%B
- IF %B'?1"0".E
- IF @E
- SET %B=""
- +1 IF %B[","
- FOR %C=0:0
- SET %C=$FIND(%B,",",%C)
- if '%C
- QUIT
- SET %C(%Z)=%C(%Z)+1
- +2 IF %B=""
- if '%Z
- GOTO Q
- SET @("%B="_$PIECE(%A,",",%Z+%C(%Z-2),%Z+%C(%Z-1)))
- SET %Z=%Z-1
- SET %A=$PIECE(%A,",",1,%Z+%C(%Z-1))_$EXTRACT(",",%Z>0)
- GOTO N
- +3 IF @("$D("_%X_%A_"%B))#2=1")
- SET %V=^(%B)
- if %V'?.ANP
- DO W
- SET %=$PIECE("""",U,+%B'=%B)
- SET %=%Y_%A_%_%B_%_")"
- if $LENGTH(%V)>240
- DO B
- SET DL=DL+1
- SET ^UTILITY($JOB,DL,0)=%
- SET DL=DL+1
- SET ^UTILITY($JOB,DL,0)="="_%V
- +4 IF @("$D("_%X_%A_"%B))<9")
- GOTO N
- +5 if +%B=%B
- GOTO D
- FOR %C=0:0
- SET %C=$FIND(%B,"""",%C)
- if '%C
- QUIT
- SET %B=$EXTRACT(%B,1,%C-1)_""""_$EXTRACT(%B,%C,999)
- SET %C=%C+1
- +6 SET %B=""""_%B_""""
- D SET %A=%A_%B_","
- SET %Z=%Z+1
- GOTO S
- +1 ;
- B IF $LENGTH(%V)>255
- WRITE !,"WARNING--DATA TOO LONG: "
- DO X
- +1 SET DL=DL+1
- SET ^UTILITY($JOB,DL,0)=%
- SET %=$CHAR(126)_$EXTRACT(%V,1,160)
- SET %V=$EXTRACT(%V,161,999)
- QUIT
- +2 ;
- W WRITE !,"WARNING--CONTROL CHARACTER IN DATA: "
- X WRITE $CHAR(7),%X,%A,%B,")--",!?3,%V
- Q QUIT
- V KILL DSV
- IF $DATA(^DD(D,0,"VR"))#2
- SET DSV=^("VR")
- KILL ^("VR")
- +1 DO %XY
- +2 IF $DATA(DSV)#2
- SET ^DD(D,0,"VR")=DSV
- KILL DSV
- +3 QUIT
