source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIKZ0.m@ 1450

Last change on this file since 1450 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.2 KB
RevLine 
[613]1DIKZ0 ;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
5RET 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
8SD 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
100 ;
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
17A ;
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
23PUT 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 ;
34INDEX ;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 ;
43GETINDEX ;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 ;
96XARR ;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 ;
125DOTLINE(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 ;
133LINE(CODE) ;Add line of code to ^UTILITY, increment DIKR
134 S ^UTILITY($J,DIKR)=CODE
135 S DIKR=DIKR+1
136 Q
Note: See TracBrowser for help on using the repository browser.