DIKZ2 ;SFISC/XAK-XREF COMPILER ;1:52 PM 7 Jan 2000 [ 04/02/2003 8:25 AM ]
;;22.0;VA FileMan;**1001**;APR 1, 2003
;;22.0;VA FileMan;**27**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
S DIKR=DIKR+1
S DIK1=" I $D("_DIKVR_") K DIKLM S:DIKM1="_A_" DIKLM=1"
I A>1 D
. S DIK1=DIK1_" S:DIKM1'="_A_"&'$G(DIKPUSH("_A_")) DIKPUSH("_A_")=1,"
. F DIK4=A:-1:2 S DIK8=DIK4-1,DIK1=DIK1_"DA("_DIK4_")=DA("_DIK8_"),"
. S DIK1=DIK1_"DA(1)=DA,DA=0"
. F DIK4=2:1:A-1 S DIK1=DIK1_" S:DIKM1<"_DIK4_" DA("_(A-DIK4)_")=0"
S ^UTILITY($J,DIKR)=DIK1_" G @DIKM1"
S DIKR=DIKR+1,DIKCT=0 I A>1 D DAR
S ^UTILITY($J,DIKR)=A-1_" ;",DIKR=DIKR+1
D:DIKVR="DIKILL" WFK
S DIKCT=DIKCT+1,DIKL2=A-1,DIK1=$C(64+DIKCT)_" S DA=$O("_DIK2_DIK8(DH)_"DA))"
S ^UTILITY($J,DIKR)=DIK1_" I DA'>0 S DA=0 "_$S(DIKL2=0:"",1:"Q:DIKM1="_DIKL2_" ")_"G "_$S(A'<2:$C(64+A-1),1:"END"),DIKR=DIKR+1
K DIK6
Q
CRT ;
I '$D(^DD(DV,"IX")),'$D(^TMP("DIKC",$J,DV)) K DU(DV) Q
S DIK(X,DV)="",DIK4(DV)=DW,DIK2(DV)="DA("_A_"),,DIKM1="_A_",DIKUM'<"_A
I A=1 S DIK8(DV)=$P(DIK2(DV),",",1,2)_DIK4(DV)_","
E I $D(DIK2(DH)) S DIKC=DV,DIK8(DV)="" F DIK8=1:1:A D
. S DIK8(DV)="DA("_DIK8_"),"_DIK4(DIKC)_","_DIK8(DV)
. S DIKC=^DD(DIKC,0,"UP")
Q
DAR ;
S (DIKC,DIK1,%,DIKL2)=1,DIKQ=0
F DIK8=A-1:-1:1 S DIKC=DIKC+2,DIKCT=DIKCT+1,DIK4=" S DA("_DIK8_")=$O("_DIK2_$P(DIK8(DH),",",1,DIKC)_"))" S:'$D(%) ^UTILITY($J,DIKR)=DIKL2_" ;",DIKR=DIKR+1,DIKL2=DIKL2+1 K % D DAR2 K DIK1
Q
DAR2 ;
S ^UTILITY($J,DIKR)=$C(64+DIKCT)_DIK4_" I DA("_DIK8_")'>0 S DA("_DIK8_")=0 "_$S($D(DIK6)&('$D(DIK1)):"Q:DIKM1="_DIKQ_" ",1:"")_"G "_$S($D(DIK1):"END",1:$C(64+DIKCT-1)),DIKR=DIKR+1,DIKQ=DIKQ+1,DIK6=1
Q
;
WFK ;Get whole file kill xrefs
N DIKXR,DIKKW,DIKKW0,DIKCODE
S DIKXR=0 F S DIKXR=$O(^TMP("DIKC",$J,"KW",DH,DIKXR)) Q:'DIKXR D
. S DIKKW=$G(^TMP("DIKC",$J,"KW",DH,DIKXR))
. Q:DIKKW?."^"!(DIKKW="Q")
. S DIKKW0=$G(^TMP("DIKC",$J,"KW",DH,DIKXR,0))
. I DIKKW0="" D DOTLINE^DIKZ0(" "_DIKKW) Q
. Q:$P(DIKKW0,U)'="W"
. ;
. ;Build code to push down DA array
. S DIKCODE=$$BCPDA(A,$P(DIKKW0,U,2))
. I DIKCODE]"" D LINE^DIKZ0(" "_DIKCODE)
. D DOTLINE^DIKZ0(" "_DIKKW)
. I DIKCODE]"" D LINE^DIKZ0(" K DA M DA=DIKSVDA")
Q
;
BCPDA(LEV,RFILE) ;Build code to push down DA array
N DIFF,COD,I,RLEV
S RLEV=$$FLEV^DIKCU(RFILE)
S DIFF=RLEV-LEV
Q:DIFF<1 ""
;
S COD=""
F I=RLEV:-1:DIFF S COD=COD_"DA("_I_")=DA("_(I-DIFF)_"),"
F I=DIFF-1:-1:0 S COD=COD_"DA("_I_")=0,"
I COD]"" D
. S COD=$E(COD,1,$L(COD)-1)
. F Q:COD'["DA(0)" S COD=$P(COD,"DA(0)")_"DA"_$P(COD,"DA(0)",2,999)
. S COD="K DIKSVDA M DIKSVDA=DA S "_COD
Q COD
DIKZ2 ;SFISC/XAK-XREF COMPILER ;1:52 PM 7 Jan 2000 [ 04/02/2003 8:25 AM ]
+1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
+2 ;;22.0;VA FileMan;**27**;Mar 30, 1999
+3 ;Per VHA Directive 10-93-142, this routine should not be modified.
+4 SET DIKR=DIKR+1
+5 SET DIK1=" I $D("_DIKVR_") K DIKLM S:DIKM1="_A_" DIKLM=1"
+6 IF A>1
Begin DoDot:1
+7 SET DIK1=DIK1_" S:DIKM1'="_A_"&'$G(DIKPUSH("_A_")) DIKPUSH("_A_")=1,"
+8 FOR DIK4=A:-1:2
SET DIK8=DIK4-1
SET DIK1=DIK1_"DA("_DIK4_")=DA("_DIK8_"),"
+9 SET DIK1=DIK1_"DA(1)=DA,DA=0"
+10 FOR DIK4=2:1:A-1
SET DIK1=DIK1_" S:DIKM1<"_DIK4_" DA("_(A-DIK4)_")=0"
End DoDot:1
+11 SET ^UTILITY($JOB,DIKR)=DIK1_" G @DIKM1"
+12 SET DIKR=DIKR+1
SET DIKCT=0
IF A>1
DO DAR
+13 SET ^UTILITY($JOB,DIKR)=A-1_" ;"
SET DIKR=DIKR+1
+14 IF DIKVR="DIKILL"
DO WFK
+15 SET DIKCT=DIKCT+1
SET DIKL2=A-1
SET DIK1=$CHAR(64+DIKCT)_" S DA=$O("_DIK2_DIK8(DH)_"DA))"
+16 SET ^UTILITY($JOB,DIKR)=DIK1_" I DA'>0 S DA=0 "_$SELECT(DIKL2=0:"",1:"Q:DIKM1="_DIKL2_" ")_"G "_$SELECT(A'<2:$CHAR(64+A-1),1:"END")
SET DIKR=DIKR+1
+17 KILL DIK6
+18 QUIT
CRT ;
+1 IF '$DATA(^DD(DV,"IX"))
IF '$DATA(^TMP("DIKC",$JOB,DV))
KILL DU(DV)
QUIT
+2 SET DIK(X,DV)=""
SET DIK4(DV)=DW
SET DIK2(DV)="DA("_A_"),,DIKM1="_A_",DIKUM'<"_A
+3 IF A=1
SET DIK8(DV)=$PIECE(DIK2(DV),",",1,2)_DIK4(DV)_","
+4 IF '$TEST
IF $DATA(DIK2(DH))
SET DIKC=DV
SET DIK8(DV)=""
FOR DIK8=1:1:A
Begin DoDot:1
+5 SET DIK8(DV)="DA("_DIK8_"),"_DIK4(DIKC)_","_DIK8(DV)
+6 SET DIKC=^DD(DIKC,0,"UP")
End DoDot:1
+7 QUIT
DAR ;
+1 SET (DIKC,DIK1,%,DIKL2)=1
SET DIKQ=0
+2 FOR DIK8=A-1:-1:1
SET DIKC=DIKC+2
SET DIKCT=DIKCT+1
SET DIK4=" S DA("_DIK8_")=$O("_DIK2_$PIECE(DIK8(DH),",",1,DIKC)_"))"
IF '$DATA(%)
SET ^UTILITY($JOB,DIKR)=DIKL2_" ;"
SET DIKR=DIKR+1
SET DIKL2=DIKL2+1
KILL %
DO DAR2
KILL DIK1
+3 QUIT
DAR2 ;
+1 SET ^UTILITY($JOB,DIKR)=$CHAR(64+DIKCT)_DIK4_" I DA("_DIK8_")'>0 S DA("_DIK8_")=0 "_$SELECT($DATA(DIK6)&('$DATA(DIK1)):"Q:DIKM1="_DIKQ_" ",1:"")_"G "_$SELECT($DATA(DIK1):"END",1:$CHAR(64+DIKCT-1))
SET DIKR=DIKR+1
SET DIKQ=DIKQ+1
SET DIK6=1
+2 QUIT
+3 ;
WFK ;Get whole file kill xrefs
+1 NEW DIKXR,DIKKW,DIKKW0,DIKCODE
+2 SET DIKXR=0
FOR
SET DIKXR=$ORDER(^TMP("DIKC",$JOB,"KW",DH,DIKXR))
IF 'DIKXR
QUIT
Begin DoDot:1
+3 SET DIKKW=$GET(^TMP("DIKC",$JOB,"KW",DH,DIKXR))
+4 IF DIKKW?."^"!(DIKKW="Q")
QUIT
+5 SET DIKKW0=$GET(^TMP("DIKC",$JOB,"KW",DH,DIKXR,0))
+6 IF DIKKW0=""
DO DOTLINE^DIKZ0(" "_DIKKW)
QUIT
+7 IF $PIECE(DIKKW0,U)'="W"
QUIT
+8 ;
+9 ;Build code to push down DA array
+10 SET DIKCODE=$$BCPDA(A,$PIECE(DIKKW0,U,2))
+11 IF DIKCODE]""
DO LINE^DIKZ0(" "_DIKCODE)
+12 DO DOTLINE^DIKZ0(" "_DIKKW)
+13 IF DIKCODE]""
DO LINE^DIKZ0(" K DA M DA=DIKSVDA")
End DoDot:1
+14 QUIT
+15 ;
BCPDA(LEV,RFILE) ;Build code to push down DA array
+1 NEW DIFF,COD,I,RLEV
+2 SET RLEV=$$FLEV^DIKCU(RFILE)
+3 SET DIFF=RLEV-LEV
+4 IF DIFF<1
QUIT ""
+5 ;
+6 SET COD=""
+7 FOR I=RLEV:-1:DIFF
SET COD=COD_"DA("_I_")=DA("_(I-DIFF)_"),"
+8 FOR I=DIFF-1:-1:0
SET COD=COD_"DA("_I_")=0,"
+9 IF COD]""
Begin DoDot:1
+10 SET COD=$EXTRACT(COD,1,$LENGTH(COD)-1)
+11 FOR
IF COD'["DA(0)"
QUIT
SET COD=$PIECE(COD,"DA(0)")_"DA"_$PIECE(COD,"DA(0)",2,999)
+12 SET COD="K DIKSVDA M DIKSVDA=DA S "_COD
End DoDot:1
+13 QUIT COD
