DIKZ2 ;SFISC/XAK-XREF COMPILER ;1:52 PM 7 Jan 2000
;;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.
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIKZ2 2798 printed Oct 16, 2024@18:49:47 Page 2
DIKZ2 ;SFISC/XAK-XREF COMPILER ;1:52 PM 7 Jan 2000
+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 SET DIKR=DIKR+1
+8 SET DIK1=" I $D("_DIKVR_") K DIKLM S:DIKM1="_A_" DIKLM=1"
+9 IF A>1
Begin DoDot:1
+10 SET DIK1=DIK1_" S:DIKM1'="_A_"&'$G(DIKPUSH("_A_")) DIKPUSH("_A_")=1,"
+11 FOR DIK4=A:-1:2
SET DIK8=DIK4-1
SET DIK1=DIK1_"DA("_DIK4_")=DA("_DIK8_"),"
+12 SET DIK1=DIK1_"DA(1)=DA,DA=0"
+13 FOR DIK4=2:1:A-1
SET DIK1=DIK1_" S:DIKM1<"_DIK4_" DA("_(A-DIK4)_")=0"
End DoDot:1
+14 SET ^UTILITY($JOB,DIKR)=DIK1_" G @DIKM1"
+15 SET DIKR=DIKR+1
SET DIKCT=0
IF A>1
DO DAR
+16 SET ^UTILITY($JOB,DIKR)=A-1_" ;"
SET DIKR=DIKR+1
+17 if DIKVR="DIKILL"
DO WFK
+18 SET DIKCT=DIKCT+1
SET DIKL2=A-1
SET DIK1=$CHAR(64+DIKCT)_" S DA=$O("_DIK2_DIK8(DH)_"DA))"
+19 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
+20 KILL DIK6
+21 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
