DIFROM1 ;SFISC/XAK-CREATES RTNS WITH DD'S ;02:23 PM 28 Nov 1994 [ 04/02/2003 8:23 AM ]
;;22.0;VA FileMan;**1001**;APR 1, 2003
;;22.0;VA FileMan;;Mar 30, 1999
;THIS ROUTINE CONTAINS AN IHS MODIFICATION BY IHS/MFD
;Per VHA Directive 10-93-142, this routine should not be modified.
;----- BEGIN IHS MODIFICATION
;THE LINE BELOW IS COMMENTED OUT AND REPLACED BY THE NEXT LINE
;TO REPLACE 5,99 WITH 5,999 ORIGINAL MODIFICATION BY IHS/MFD
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,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y",F=$O(F(F))
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))
;----- END IHS MODIFICATION
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
F E="%","%D" S %X="^DIC("_F_","""_E_""",",E=0 D %XY
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))
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
DIFROM1 ;SFISC/XAK-CREATES RTNS WITH DD'S ;02:23 PM 28 Nov 1994 [ 04/02/2003 8:23 AM ]
+1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
+2 ;;22.0;VA FileMan;;Mar 30, 1999
+3 ;THIS ROUTINE CONTAINS AN IHS MODIFICATION BY IHS/MFD
+4 ;Per VHA Directive 10-93-142, this routine should not be modified.
+5 ;----- BEGIN IHS MODIFICATION
+6 ;THE LINE BELOW IS COMMENTED OUT AND REPLACED BY THE NEXT LINE
+7 ;TO REPLACE 5,99 WITH 5,999 ORIGINAL MODIFICATION BY IHS/MFD
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,99) S:$A(Y)=61 Y=$E(Y,2,999) X NO E S @X=Y",F=$O(F(F))
+1 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))
+2 ;----- END IHS MODIFICATION
+3 IF F'>0
IF DSEC
DO SEC
KILL ^UTILITY("DI",$JOB)
GOTO ^DIFROM11
+4 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
+5 SET DH=" Q:'DIFQ("_F_") "_DH
+6 FOR E="%","%D"
SET %X="^DIC("_F_","""_E_""","
SET E=0
DO %XY
+7 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)
+8 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
+9 DO FILE^DIFROM3
IF '$DATA(DRN)
GOTO EQ^DIFROM11
IF $PIECE(F(F,-222),U,7)'="y"
GOTO L
+10 SET DL=DL+1
SET E="%Z#2=0"
SET %X=F(F,0)
SET @("D="_%X_"0)")
+11 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
+12 DO N
SET DH=$PIECE(DH,"DIFQ")_"DIFQR"_$PIECE(DH,"DIFQ",2,99)
+13 DO FILE^DIFROM3
IF '$DATA(DRN)
GOTO EQ^DIFROM11
GOTO L
+14 ;
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
