DIKZ0.m

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