DIKZ0 ;SFISC/XAK-XREF COMPILER ;23AUG2004
;;22.0;VA FileMan;**140**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
S DIK0=" I X'=""""" D DD^DIK,A,SD Q:DIKZQ
RET I $D(DK1) S A=A+1,DIKA=1,DH=0 F S DH=$O(DK1(DH)) Q:DH'>0 D E^DIK
S:DH="" DH=-1 I $D(DK1) K DK1 D SD Q:DIKZQ G RET
Q
SD F DH=DH(1):0 S DH=$O(DU(DH)) Q:DH'>0 S:$D(^DD(DH,"SB")) DK1(DH)="" D DD1^DIK,0 Q:DIKZQ S:$D(^DD(DH,"IX"))!$D(^TMP("DIKC",$J,DH)) DIK(X,DH)="A1^"_DNM_DRN K:'$D(^DD(DH,"IX"))&'$D(^TMP("DIKC",$J,DH)) DIK(X,DH) K DU(DH)
Q
0 ;
D SV^DIKZ Q:DIKZQ S DIK1=""
I $D(DIKA) S DIK1=" S DA("_A_")=DA"_$S(A=1:"",1:"("_(A-1)_")")
F DIKL2=A-1:-1:1 S DIK1=DIK1_" S DA("_DIKL2_")=0"
S ^UTILITY($J,DIKR+1)=DIK1_" S DA=0",DIKR=DIKR+2,^(DIKR)="A1 ;"
D ^DIKZ2 K DIKA S DIKLW=1
S DIKR=DIKR+1,DIK=DIK2_DIK8(DH),^UTILITY($J,DIKR)=A_" ;",DIKR=DIKR+1
A ;
K DIK6 F DIKQ=0:0 S DIKQ=$O(^UTILITY("DIK",$J,DH,DIKQ)) Q:DIKQ'>0 I $G(DIKVR)="DISET"!(DIKQ'=.01) S %=^(DIKQ) S:+%'=% %=""""_%_"""" D PUT
I $G(DIKVR)="DIKILL",$D(^UTILITY("DIK",$J,DH,.01)) S DIKQ=.01,%=^(.01) S:+%'=% %=""""_%_"""" D PUT
D INDEX
K ^UTILITY("DIK",$J),DIK6
Q
PUT N DIKSET I '$D(DIK6(%)) S ^UTILITY($J,DIKR)=" S DIKZ("_%_")=$G("_DIK_"DA,"_%_"))",DIK6(%)=""
S DIKR=DIKR+1,(DIKSET,^UTILITY($J,DIKR))=" "_$P(^UTILITY("DIK",$J,DH,DIKQ,0),"^(X)")_"DIKZ("_%_")"_$P(^(0),"^(X)",2,9)
F DIKC=0:0 S DIKC=$O(^UTILITY("DIK",$J,DH,DIKQ,DIKC)) S DIKR=DIKR+1 Q:DIKC'>0 D
.S %=^(DIKC) S:$O(^(0))'=DIKC ^UTILITY($J,DIKR)=DIKSET,DIKR=DIKR+1
.I %["Q:"!(%[" Q") K DIK6 S ^UTILITY($J,DIKR)=DIK0_" X ^DD("_DH_","_DIKQ_",1,"_DIKC_","_X_")" Q
.I %["D RCR" K DIK6 S ^UTILITY($J,DIKR)=DIK0_" D",DIKR=DIKR+2,^(DIKR-1)=" .N DIK,DIV,DIU,DIN",^UTILITY($J,DIKR)=" ."_^UTILITY("DIK",$J,DH,DIKQ,DIKC,0) Q
.I %["S XMB=" S ^UTILITY($J,DIKR)=DIK0_",$D(DIK(0)),DIK(0)[""B"" S DIKZR="_DIKC_",DIKZZ="_DIKQ_" D BUL^"_DNM,DIKR=DIKR+1,^UTILITY($J,DIKR)=DIK0_",'$D(DIKOZ) "_$S($L(%)<225:%,1:"X ^DD("_DH_","_DIKQ_",1,"_DIKC_","_X_")") Q
.S ^UTILITY($J,DIKR)=DIK0_" "_$S(%[" AUDIT":"S DH="_DH_",DV="_DIKQ_",DU="_A_" ",1:"")_%_$S(%[" AUDIT":"^DIK1",1:"")
Q
;
;
INDEX ;Loop through ^TMP and pick up cross references for file DH
N DIKO,DIKCTAG
S DIKCTAG=0
;
;Build code for each xref
S DIKC=0 F S DIKC=$O(^TMP("DIKC",$J,DH,DIKC)) Q:'DIKC D GETINDEX
D:DIKCTAG LINE("CR"_(DIKCTAG+1)_" K X")
Q
;
GETINDEX ;Get code for one index DIKC in file DH
I DIKVR="DIKILL",$G(^TMP("DIKC",$J,DH,DIKC,"K"))?."^" Q
I DIKVR="DISET",$G(^TMP("DIKC",$J,DH,DIKC,"S"))?."^" Q
;
N DIKF,DIKCOD,DIKO,DIK01
S DIKCTAG=DIKCTAG+1
D LINE("CR"_DIKCTAG_" S DIXR="_DIKC)
;
;Build code to set X array
S DIKF=$O(^TMP("DIKC",$J,DH,DIKC,0)) Q:'DIKF
D LINE(" K X")
S DIKO=0 F S DIKO=$O(^TMP("DIKC",$J,DH,DIKC,DIKO)) Q:'DIKO D XARR
D LINE(" S X=$G(X("_DIKF_"))")
;
;Build code to check for null subscripts
S DIKCOD="",DIKO=0
F S DIKO=$O(^TMP("DIKC",$J,DH,DIKC,DIKO)) Q:'DIKO D:$G(^(DIKO,"SS"))
. S DIKCOD=DIKCOD_$E(",",DIKCOD]"")_"$G(X("_DIKO_"))]"""""
D LINE($S(DIKCOD]"":" I "_DIKCOD_" D",1:" D")) ;**GFT -- NOIS ISL-0604-50146 **
D LINE(" . K X1,X2 M X1=X,X2=X")
;
I DIKVR="DIKILL" D
. ;Adjust .01 values X2 array if we're deleting a record
. I $D(DIK01) D
..S DIKCOD="",DIKO=0 F S DIKO=$O(DIK01(DIKO)) Q:'DIKO D ;**GFT -- NOIS ISL-0604-50146 **
... S DIKCOD=DIKCOD_$E(",",DIKCOD]"")_"X2("_DIKO_")"
.. Q:DIKCOD=""
.. S:DIKF=$O(DIK01(0)) DIKCOD="X2,"_DIKCOD
.. S:DIKCOD["," DIKCOD="("_DIKCOD_")"
.. D LINE(" . S:$D(DIKIL) "_DIKCOD_"=""""")
. ;
. ;Get kill condition code
. S DIKCOD=$G(^TMP("DIKC",$J,DH,DIKC,"KC"))
. I DIKCOD'?."^" D
.. D LINE(" . N DIKXARR M DIKXARR=X S DIKCOND=1")
.. D LINE(" . "_DIKCOD)
.. D LINE(" . S DIKCOND=$G(X) K X M X=DIKXARR")
.. D LINE(" . Q:'DIKCOND")
. ;Get kill logic
. D LINE(" . "_$G(^TMP("DIKC",$J,DH,DIKC,"K")))
;
I DIKVR="DISET" D
. ;Get set condition code
. S DIKCOD=$G(^TMP("DIKC",$J,DH,DIKC,"SC"))
. I DIKCOD'?."^" D
.. D LINE(" . N DIKXARR M DIKXARR=X S DIKCOND=1")
.. D LINE(" . "_DIKCOD)
.. D LINE(" . S DIKCOND=$G(X) K X M X=DIKXARR")
.. D LINE(" . Q:'DIKCOND")
. ;Get set logic
. D LINE(" . "_$G(^TMP("DIKC",$J,DH,DIKC,"S")))
K DIK6 Q
;
XARR ;Build code to set X array
;Also return DIK01(order#)="" if crv is .01 field
N CODE,NODE,REF,LINE,TRANS
;K DIK01
;
;Build data extraction code
S CODE=$G(^TMP("DIKC",$J,DH,DIKC,DIKO)) Q:CODE?."^"
I $D(^TMP("DIKC",$J,DH,DIKC,DIKO,"F"))#2 D
. S DIK01(DIKO)=""
. S REF=$P($P(CODE,",",1,$L(CODE,",")-2),"(",2,999)
. S NODE=$P($P(REF,",",$L(REF,",")),"))")
. I '$D(DIK6(NODE)) D
.. D LINE(" S DIKZ("_NODE_")="_REF)
.. S DIK6(NODE)=""
. S LINE=" "_$P(CODE,REF)_"DIKZ("_NODE_")"_$P(CODE,REF,2,999)
E S LINE=" "_CODE
;
S TRANS=$G(^TMP("DIKC",$J,DH,DIKC,DIKO,"T"))
I TRANS'?."^" D
. D LINE(LINE)
. D DOTLINE(" I $G(X)]"""" "_TRANS)
. D LINE(" S:$D(X)#2 X("_DIKO_")=X")
E I $G(NODE)]"",LINE?1" S X=".E D
. D LINE(" S X("_DIKO_")"_$E(LINE,5,999))
E D
. D LINE(LINE)
. D LINE(" S:$D(X)#2 X("_DIKO_")=X")
Q
;
DOTLINE(CODE) ;Add code to ^UTILITY. If the code looks like it contains
;a Quit command, put the code under a do-dot structure.
I CODE[" Q"!(CODE["Q:") D
. D LINE(" D")
. D LINE(" . "_CODE)
E D LINE(CODE)
Q
;
LINE(CODE) ;Add line of code to ^UTILITY, increment DIKR
S ^UTILITY($J,DIKR)=CODE
S DIKR=DIKR+1
Q
DIKZ0 ;SFISC/XAK-XREF COMPILER ;23AUG2004
+1 ;;22.0;VA FileMan;**140**;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 SET DIK0=" I X'="""""
DO DD^DIK
DO A
DO SD
IF DIKZQ
QUIT
RET IF $DATA(DK1)
SET A=A+1
SET DIKA=1
SET DH=0
FOR
SET DH=$ORDER(DK1(DH))
IF DH'>0
QUIT
DO E^DIK
+1 IF DH=""
SET DH=-1
IF $DATA(DK1)
KILL DK1
DO SD
IF DIKZQ
QUIT
GOTO RET
+2 QUIT
SD FOR DH=DH(1):0
SET DH=$ORDER(DU(DH))
IF DH'>0
QUIT
IF $DATA(^DD(DH,"SB"))
SET DK1(DH)=""
DO DD1^DIK
DO 0
IF DIKZQ
QUIT
IF $DATA(^DD(DH,"IX"))!$DATA(^TMP("DIKC",$JOB,DH))
SET DIK(X,DH)="A1^"_DNM_DRN
IF '$DATA(^DD(DH,"IX"))&'$DATA(^TMP("DIKC",$JOB,DH))
KILL DIK(X,DH)
KILL DU(DH)
+1 QUIT
0 ;
+1 DO SV^DIKZ
IF DIKZQ
QUIT
SET DIK1=""
+2 IF $DATA(DIKA)
SET DIK1=" S DA("_A_")=DA"_$SELECT(A=1:"",1:"("_(A-1)_")")
+3 FOR DIKL2=A-1:-1:1
SET DIK1=DIK1_" S DA("_DIKL2_")=0"
+4 SET ^UTILITY($JOB,DIKR+1)=DIK1_" S DA=0"
SET DIKR=DIKR+2
SET ^(DIKR)="A1 ;"
+5 DO ^DIKZ2
KILL DIKA
SET DIKLW=1
+6 SET DIKR=DIKR+1
SET DIK=DIK2_DIK8(DH)
SET ^UTILITY($JOB,DIKR)=A_" ;"
SET DIKR=DIKR+1
A ;
+1 KILL DIK6
FOR DIKQ=0:0
SET DIKQ=$ORDER(^UTILITY("DIK",$JOB,DH,DIKQ))
IF DIKQ'>0
QUIT
IF $GET(DIKVR)="DISET"!(DIKQ'=.01)
SET %=^(DIKQ)
IF +%'=%
SET %=""""_%_""""
DO PUT
+2 IF $GET(DIKVR)="DIKILL"
IF $DATA(^UTILITY("DIK",$JOB,DH,.01))
SET DIKQ=.01
SET %=^(.01)
IF +%'=%
SET %=""""_%_""""
DO PUT
+3 DO INDEX
+4 KILL ^UTILITY("DIK",$JOB),DIK6
+5 QUIT
PUT NEW DIKSET
IF '$DATA(DIK6(%))
SET ^UTILITY($JOB,DIKR)=" S DIKZ("_%_")=$G("_DIK_"DA,"_%_"))"
SET DIK6(%)=""
+1 SET DIKR=DIKR+1
SET (DIKSET,^UTILITY($JOB,DIKR))=" "_$PIECE(^UTILITY("DIK",$JOB,DH,DIKQ,0),"^(X)")_"DIKZ("_%_")"_$PIECE(^(0),"^(X)",2,9)
+2 FOR DIKC=0:0
SET DIKC=$ORDER(^UTILITY("DIK",$JOB,DH,DIKQ,DIKC))
SET DIKR=DIKR+1
IF DIKC'>0
QUIT
Begin DoDot:1
+3 SET %=^(DIKC)
IF $ORDER(^(0))'=DIKC
SET ^UTILITY($JOB,DIKR)=DIKSET
SET DIKR=DIKR+1
+4 IF %["Q:"!(%[" Q")
KILL DIK6
SET ^UTILITY($JOB,DIKR)=DIK0_" X ^DD("_DH_","_DIKQ_",1,"_DIKC_","_X_")"
QUIT
+5 IF %["D RCR"
KILL DIK6
SET ^UTILITY($JOB,DIKR)=DIK0_" D"
SET DIKR=DIKR+2
SET ^(DIKR-1)=" .N DIK,DIV,DIU,DIN"
SET ^UTILITY($JOB,DIKR)=" ."_^UTILITY("DIK",$JOB,DH,DIKQ,DIKC,0)
QUIT
+6 IF %["S XMB="
SET ^UTILITY($JOB,DIKR)=DIK0_",$D(DIK(0)),DIK(0)[""B"" S DIKZR="_DIKC_",DIKZZ="_DIKQ_" D BUL^"_DNM
SET DIKR=DIKR+1
SET ^UTILITY($JOB,DIKR)=DIK0_",'$D(DIKOZ) "_$SELECT($LENGTH(%)<225:%,1:"X ^DD("_DH_","_DIKQ_",1,"_DIKC_","_X_")")
QUIT
+7 SET ^UTILITY($JOB,DIKR)=DIK0_" "_$SELECT(%[" AUDIT":"S DH="_DH_",DV="_DIKQ_",DU="_A_" ",1:"")_%_$SELECT(%[" AUDIT":"^DIK1",1:"")
End DoDot:1
+8 QUIT
+9 ;
+10 ;
INDEX ;Loop through ^TMP and pick up cross references for file DH
+1 NEW DIKO,DIKCTAG
+2 SET DIKCTAG=0
+3 ;
+4 ;Build code for each xref
+5 SET DIKC=0
FOR
SET DIKC=$ORDER(^TMP("DIKC",$JOB,DH,DIKC))
IF 'DIKC
QUIT
DO GETINDEX
+6 IF DIKCTAG
DO LINE("CR"_(DIKCTAG+1)_" K X")
+7 QUIT
+8 ;
GETINDEX ;Get code for one index DIKC in file DH
+1 IF DIKVR="DIKILL"
IF $GET(^TMP("DIKC",$JOB,DH,DIKC,"K"))?."^"
QUIT
+2 IF DIKVR="DISET"
IF $GET(^TMP("DIKC",$JOB,DH,DIKC,"S"))?."^"
QUIT
+3 ;
+4 NEW DIKF,DIKCOD,DIKO,DIK01
+5 SET DIKCTAG=DIKCTAG+1
+6 DO LINE("CR"_DIKCTAG_" S DIXR="_DIKC)
+7 ;
+8 ;Build code to set X array
+9 SET DIKF=$ORDER(^TMP("DIKC",$JOB,DH,DIKC,0))
IF 'DIKF
QUIT
+10 DO LINE(" K X")
+11 SET DIKO=0
FOR
SET DIKO=$ORDER(^TMP("DIKC",$JOB,DH,DIKC,DIKO))
IF 'DIKO
QUIT
DO XARR
+12 DO LINE(" S X=$G(X("_DIKF_"))")
+13 ;
+14 ;Build code to check for null subscripts
+15 SET DIKCOD=""
SET DIKO=0
+16 FOR
SET DIKO=$ORDER(^TMP("DIKC",$JOB,DH,DIKC,DIKO))
IF 'DIKO
QUIT
IF $GET(^(DIKO,"SS"))
Begin DoDot:1
+17 SET DIKCOD=DIKCOD_$EXTRACT(",",DIKCOD]"")_"$G(X("_DIKO_"))]"""""
End DoDot:1
+18 ;**GFT -- NOIS ISL-0604-50146 **
DO LINE($SELECT(DIKCOD]"":" I "_DIKCOD_" D",1:" D"))
+19 DO LINE(" . K X1,X2 M X1=X,X2=X")
+20 ;
+21 IF DIKVR="DIKILL"
Begin DoDot:1
+22 ;Adjust .01 values X2 array if we're deleting a record
+23 IF $DATA(DIK01)
Begin DoDot:2
+24 ;**GFT -- NOIS ISL-0604-50146 **
SET DIKCOD=""
SET DIKO=0
FOR
SET DIKO=$ORDER(DIK01(DIKO))
IF 'DIKO
QUIT
Begin DoDot:3
+25 SET DIKCOD=DIKCOD_$EXTRACT(",",DIKCOD]"")_"X2("_DIKO_")"
End DoDot:3
+26 IF DIKCOD=""
QUIT
+27 IF DIKF=$ORDER(DIK01(0))
SET DIKCOD="X2,"_DIKCOD
+28 IF DIKCOD[","
SET DIKCOD="("_DIKCOD_")"
+29 DO LINE(" . S:$D(DIKIL) "_DIKCOD_"=""""")
End DoDot:2
+30 ;
+31 ;Get kill condition code
+32 SET DIKCOD=$GET(^TMP("DIKC",$JOB,DH,DIKC,"KC"))
+33 IF DIKCOD'?."^"
Begin DoDot:2
+34 DO LINE(" . N DIKXARR M DIKXARR=X S DIKCOND=1")
+35 DO LINE(" . "_DIKCOD)
+36 DO LINE(" . S DIKCOND=$G(X) K X M X=DIKXARR")
+37 DO LINE(" . Q:'DIKCOND")
End DoDot:2
+38 ;Get kill logic
+39 DO LINE(" . "_$GET(^TMP("DIKC",$JOB,DH,DIKC,"K")))
End DoDot:1
+40 ;
+41 IF DIKVR="DISET"
Begin DoDot:1
+42 ;Get set condition code
+43 SET DIKCOD=$GET(^TMP("DIKC",$JOB,DH,DIKC,"SC"))
+44 IF DIKCOD'?."^"
Begin DoDot:2
+45 DO LINE(" . N DIKXARR M DIKXARR=X S DIKCOND=1")
+46 DO LINE(" . "_DIKCOD)
+47 DO LINE(" . S DIKCOND=$G(X) K X M X=DIKXARR")
+48 DO LINE(" . Q:'DIKCOND")
End DoDot:2
+49 ;Get set logic
+50 DO LINE(" . "_$GET(^TMP("DIKC",$JOB,DH,DIKC,"S")))
End DoDot:1
+51 KILL DIK6
QUIT
+52 ;
XARR ;Build code to set X array
+1 ;Also return DIK01(order#)="" if crv is .01 field
+2 NEW CODE,NODE,REF,LINE,TRANS
+3 ;K DIK01
+4 ;
+5 ;Build data extraction code
+6 SET CODE=$GET(^TMP("DIKC",$JOB,DH,DIKC,DIKO))
IF CODE?."^"
QUIT
+7 IF $DATA(^TMP("DIKC",$JOB,DH,DIKC,DIKO,"F"))#2
Begin DoDot:1
+8 SET DIK01(DIKO)=""
+9 SET REF=$PIECE($PIECE(CODE,",",1,$LENGTH(CODE,",")-2),"(",2,999)
+10 SET NODE=$PIECE($PIECE(REF,",",$LENGTH(REF,",")),"))")
+11 IF '$DATA(DIK6(NODE))
Begin DoDot:2
+12 DO LINE(" S DIKZ("_NODE_")="_REF)
+13 SET DIK6(NODE)=""
End DoDot:2
+14 SET LINE=" "_$PIECE(CODE,REF)_"DIKZ("_NODE_")"_$PIECE(CODE,REF,2,999)
End DoDot:1
+15 IF '$TEST
SET LINE=" "_CODE
+16 ;
+17 SET TRANS=$GET(^TMP("DIKC",$JOB,DH,DIKC,DIKO,"T"))
+18 IF TRANS'?."^"
Begin DoDot:1
+19 DO LINE(LINE)
+20 DO DOTLINE(" I $G(X)]"""" "_TRANS)
+21 DO LINE(" S:$D(X)#2 X("_DIKO_")=X")
End DoDot:1
+22 IF '$TEST
IF $GET(NODE)]""
IF LINE?1" S X=".E
Begin DoDot:1
+23 DO LINE(" S X("_DIKO_")"_$EXTRACT(LINE,5,999))
End DoDot:1
+24 IF '$TEST
Begin DoDot:1
+25 DO LINE(LINE)
+26 DO LINE(" S:$D(X)#2 X("_DIKO_")=X")
End DoDot:1
+27 QUIT
+28 ;
DOTLINE(CODE) ;Add code to ^UTILITY. If the code looks like it contains
+1 ;a Quit command, put the code under a do-dot structure.
+2 IF CODE[" Q"!(CODE["Q:")
Begin DoDot:1
+3 DO LINE(" D")
+4 DO LINE(" . "_CODE)
End DoDot:1
+5 IF '$TEST
DO LINE(CODE)
+6 QUIT
+7 ;
LINE(CODE) ;Add line of code to ^UTILITY, increment DIKR
+1 SET ^UTILITY($JOB,DIKR)=CODE
+2 SET DIKR=DIKR+1
+3 QUIT
