- 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 Jan 18, 2025@03:50:12 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