| 1 | DIKZ0 ;SFISC/XAK-XREF COMPILER ;23AUG2004
|
---|
| 2 | ;;22.0;VA FileMan;**140**;Mar 30, 1999
|
---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
---|
| 4 | S DIK0=" I X'=""""" D DD^DIK,A,SD Q:DIKZQ
|
---|
| 5 | RET I $D(DK1) S A=A+1,DIKA=1,DH=0 F S DH=$O(DK1(DH)) Q:DH'>0 D E^DIK
|
---|
| 6 | S:DH="" DH=-1 I $D(DK1) K DK1 D SD Q:DIKZQ G RET
|
---|
| 7 | Q
|
---|
| 8 | 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)
|
---|
| 9 | Q
|
---|
| 10 | 0 ;
|
---|
| 11 | D SV^DIKZ Q:DIKZQ S DIK1=""
|
---|
| 12 | I $D(DIKA) S DIK1=" S DA("_A_")=DA"_$S(A=1:"",1:"("_(A-1)_")")
|
---|
| 13 | F DIKL2=A-1:-1:1 S DIK1=DIK1_" S DA("_DIKL2_")=0"
|
---|
| 14 | S ^UTILITY($J,DIKR+1)=DIK1_" S DA=0",DIKR=DIKR+2,^(DIKR)="A1 ;"
|
---|
| 15 | D ^DIKZ2 K DIKA S DIKLW=1
|
---|
| 16 | S DIKR=DIKR+1,DIK=DIK2_DIK8(DH),^UTILITY($J,DIKR)=A_" ;",DIKR=DIKR+1
|
---|
| 17 | A ;
|
---|
| 18 | 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
|
---|
| 19 | I $G(DIKVR)="DIKILL",$D(^UTILITY("DIK",$J,DH,.01)) S DIKQ=.01,%=^(.01) S:+%'=% %=""""_%_"""" D PUT
|
---|
| 20 | D INDEX
|
---|
| 21 | K ^UTILITY("DIK",$J),DIK6
|
---|
| 22 | Q
|
---|
| 23 | PUT N DIKSET I '$D(DIK6(%)) S ^UTILITY($J,DIKR)=" S DIKZ("_%_")=$G("_DIK_"DA,"_%_"))",DIK6(%)=""
|
---|
| 24 | S DIKR=DIKR+1,(DIKSET,^UTILITY($J,DIKR))=" "_$P(^UTILITY("DIK",$J,DH,DIKQ,0),"^(X)")_"DIKZ("_%_")"_$P(^(0),"^(X)",2,9)
|
---|
| 25 | F DIKC=0:0 S DIKC=$O(^UTILITY("DIK",$J,DH,DIKQ,DIKC)) S DIKR=DIKR+1 Q:DIKC'>0 D
|
---|
| 26 | .S %=^(DIKC) S:$O(^(0))'=DIKC ^UTILITY($J,DIKR)=DIKSET,DIKR=DIKR+1
|
---|
| 27 | .I %["Q:"!(%[" Q") K DIK6 S ^UTILITY($J,DIKR)=DIK0_" X ^DD("_DH_","_DIKQ_",1,"_DIKC_","_X_")" Q
|
---|
| 28 | .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
|
---|
| 29 | .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
|
---|
| 30 | .S ^UTILITY($J,DIKR)=DIK0_" "_$S(%[" AUDIT":"S DH="_DH_",DV="_DIKQ_",DU="_A_" ",1:"")_%_$S(%[" AUDIT":"^DIK1",1:"")
|
---|
| 31 | Q
|
---|
| 32 | ;
|
---|
| 33 | ;
|
---|
| 34 | INDEX ;Loop through ^TMP and pick up cross references for file DH
|
---|
| 35 | N DIKO,DIKCTAG
|
---|
| 36 | S DIKCTAG=0
|
---|
| 37 | ;
|
---|
| 38 | ;Build code for each xref
|
---|
| 39 | S DIKC=0 F S DIKC=$O(^TMP("DIKC",$J,DH,DIKC)) Q:'DIKC D GETINDEX
|
---|
| 40 | D:DIKCTAG LINE("CR"_(DIKCTAG+1)_" K X")
|
---|
| 41 | Q
|
---|
| 42 | ;
|
---|
| 43 | GETINDEX ;Get code for one index DIKC in file DH
|
---|
| 44 | I DIKVR="DIKILL",$G(^TMP("DIKC",$J,DH,DIKC,"K"))?."^" Q
|
---|
| 45 | I DIKVR="DISET",$G(^TMP("DIKC",$J,DH,DIKC,"S"))?."^" Q
|
---|
| 46 | ;
|
---|
| 47 | N DIKF,DIKCOD,DIKO,DIK01
|
---|
| 48 | S DIKCTAG=DIKCTAG+1
|
---|
| 49 | D LINE("CR"_DIKCTAG_" S DIXR="_DIKC)
|
---|
| 50 | ;
|
---|
| 51 | ;Build code to set X array
|
---|
| 52 | S DIKF=$O(^TMP("DIKC",$J,DH,DIKC,0)) Q:'DIKF
|
---|
| 53 | D LINE(" K X")
|
---|
| 54 | S DIKO=0 F S DIKO=$O(^TMP("DIKC",$J,DH,DIKC,DIKO)) Q:'DIKO D XARR
|
---|
| 55 | D LINE(" S X=$G(X("_DIKF_"))")
|
---|
| 56 | ;
|
---|
| 57 | ;Build code to check for null subscripts
|
---|
| 58 | S DIKCOD="",DIKO=0
|
---|
| 59 | F S DIKO=$O(^TMP("DIKC",$J,DH,DIKC,DIKO)) Q:'DIKO D:$G(^(DIKO,"SS"))
|
---|
| 60 | . S DIKCOD=DIKCOD_$E(",",DIKCOD]"")_"$G(X("_DIKO_"))]"""""
|
---|
| 61 | D LINE($S(DIKCOD]"":" I "_DIKCOD_" D",1:" D")) ;**GFT -- NOIS ISL-0604-50146 **
|
---|
| 62 | D LINE(" . K X1,X2 M X1=X,X2=X")
|
---|
| 63 | ;
|
---|
| 64 | I DIKVR="DIKILL" D
|
---|
| 65 | . ;Adjust .01 values X2 array if we're deleting a record
|
---|
| 66 | . I $D(DIK01) D
|
---|
| 67 | ..S DIKCOD="",DIKO=0 F S DIKO=$O(DIK01(DIKO)) Q:'DIKO D ;**GFT -- NOIS ISL-0604-50146 **
|
---|
| 68 | ... S DIKCOD=DIKCOD_$E(",",DIKCOD]"")_"X2("_DIKO_")"
|
---|
| 69 | .. Q:DIKCOD=""
|
---|
| 70 | .. S:DIKF=$O(DIK01(0)) DIKCOD="X2,"_DIKCOD
|
---|
| 71 | .. S:DIKCOD["," DIKCOD="("_DIKCOD_")"
|
---|
| 72 | .. D LINE(" . S:$D(DIKIL) "_DIKCOD_"=""""")
|
---|
| 73 | . ;
|
---|
| 74 | . ;Get kill condition code
|
---|
| 75 | . S DIKCOD=$G(^TMP("DIKC",$J,DH,DIKC,"KC"))
|
---|
| 76 | . I DIKCOD'?."^" D
|
---|
| 77 | .. D LINE(" . N DIKXARR M DIKXARR=X S DIKCOND=1")
|
---|
| 78 | .. D LINE(" . "_DIKCOD)
|
---|
| 79 | .. D LINE(" . S DIKCOND=$G(X) K X M X=DIKXARR")
|
---|
| 80 | .. D LINE(" . Q:'DIKCOND")
|
---|
| 81 | . ;Get kill logic
|
---|
| 82 | . D LINE(" . "_$G(^TMP("DIKC",$J,DH,DIKC,"K")))
|
---|
| 83 | ;
|
---|
| 84 | I DIKVR="DISET" D
|
---|
| 85 | . ;Get set condition code
|
---|
| 86 | . S DIKCOD=$G(^TMP("DIKC",$J,DH,DIKC,"SC"))
|
---|
| 87 | . I DIKCOD'?."^" D
|
---|
| 88 | .. D LINE(" . N DIKXARR M DIKXARR=X S DIKCOND=1")
|
---|
| 89 | .. D LINE(" . "_DIKCOD)
|
---|
| 90 | .. D LINE(" . S DIKCOND=$G(X) K X M X=DIKXARR")
|
---|
| 91 | .. D LINE(" . Q:'DIKCOND")
|
---|
| 92 | . ;Get set logic
|
---|
| 93 | . D LINE(" . "_$G(^TMP("DIKC",$J,DH,DIKC,"S")))
|
---|
| 94 | K DIK6 Q
|
---|
| 95 | ;
|
---|
| 96 | XARR ;Build code to set X array
|
---|
| 97 | ;Also return DIK01(order#)="" if crv is .01 field
|
---|
| 98 | N CODE,NODE,REF,LINE,TRANS
|
---|
| 99 | ;K DIK01
|
---|
| 100 | ;
|
---|
| 101 | ;Build data extraction code
|
---|
| 102 | S CODE=$G(^TMP("DIKC",$J,DH,DIKC,DIKO)) Q:CODE?."^"
|
---|
| 103 | I $D(^TMP("DIKC",$J,DH,DIKC,DIKO,"F"))#2 D
|
---|
| 104 | . S DIK01(DIKO)=""
|
---|
| 105 | . S REF=$P($P(CODE,",",1,$L(CODE,",")-2),"(",2,999)
|
---|
| 106 | . S NODE=$P($P(REF,",",$L(REF,",")),"))")
|
---|
| 107 | . I '$D(DIK6(NODE)) D
|
---|
| 108 | .. D LINE(" S DIKZ("_NODE_")="_REF)
|
---|
| 109 | .. S DIK6(NODE)=""
|
---|
| 110 | . S LINE=" "_$P(CODE,REF)_"DIKZ("_NODE_")"_$P(CODE,REF,2,999)
|
---|
| 111 | E S LINE=" "_CODE
|
---|
| 112 | ;
|
---|
| 113 | S TRANS=$G(^TMP("DIKC",$J,DH,DIKC,DIKO,"T"))
|
---|
| 114 | I TRANS'?."^" D
|
---|
| 115 | . D LINE(LINE)
|
---|
| 116 | . D DOTLINE(" I $G(X)]"""" "_TRANS)
|
---|
| 117 | . D LINE(" S:$D(X)#2 X("_DIKO_")=X")
|
---|
| 118 | E I $G(NODE)]"",LINE?1" S X=".E D
|
---|
| 119 | . D LINE(" S X("_DIKO_")"_$E(LINE,5,999))
|
---|
| 120 | E D
|
---|
| 121 | . D LINE(LINE)
|
---|
| 122 | . D LINE(" S:$D(X)#2 X("_DIKO_")=X")
|
---|
| 123 | Q
|
---|
| 124 | ;
|
---|
| 125 | DOTLINE(CODE) ;Add code to ^UTILITY. If the code looks like it contains
|
---|
| 126 | ;a Quit command, put the code under a do-dot structure.
|
---|
| 127 | I CODE[" Q"!(CODE["Q:") D
|
---|
| 128 | . D LINE(" D")
|
---|
| 129 | . D LINE(" . "_CODE)
|
---|
| 130 | E D LINE(CODE)
|
---|
| 131 | Q
|
---|
| 132 | ;
|
---|
| 133 | LINE(CODE) ;Add line of code to ^UTILITY, increment DIKR
|
---|
| 134 | S ^UTILITY($J,DIKR)=CODE
|
---|
| 135 | S DIKR=DIKR+1
|
---|
| 136 | Q
|
---|