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

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

initial load of WorldVistAEHR
File size: 5.7 KB
Line 
1DICM0 ;SF/XAK,TKW - LOOKUP WHEN INPUT MUST BE TRANSFORMED ;2/15/00 14:40
2 ;;22.0;VA FileMan;**16,4,20,31**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5P ;Pointers, called by ^DICM1
6 S D="" N DICODE,DIASKOK,DIPTRIX
7 S DICR(DICR,1)=DIC,DIC=U_$P(DS,U,3),Y=DIC(0),DIC(0)=$TR(Y,"L","")
8 S DICR(DICR,2)=$S($$OKTOADD(.DIFILEI,.DINDEX,.DIFINDER):Y,1:DIC(0))
9 S DICR(DICR,2.1)=$S($P(DS,U,2)["'":DIC(0),1:Y)
10 N:'$D(DIVPSEL) DIVPSEL S DIVPSEL(DICR)=0
11 I DIC(0)["B" S DIC(0)=$TR(DIC(0),"M",""),DICR(DICR,2.1)=$TR(DICR(DICR,2.1),"M","")
12 S DIC(0)=$TR(DIC(0),"NV","")
13 F Y="DR","S","P","W" I $D(DIC(Y)) M DICR(DICR,Y)=DIC(Y) K DIC(Y)
14 S DIPTRIX=$G(DIC("PTRIX",DIFILEI,+DINDEX(1,"FIELD"),+$P($P(DS,U,2),"P",2)))
15AST ; Process screens on pointers.
16 I $P(DS,U,2)["*",DICR(DICR,2)["L" N DID,DF D
17 . F DICODE=" D ^DIC"," D IX^DIC"," D MIX^DIC1" D
18 . . S Y=$F(DS,DICODE) Q:'Y
19 . . N I S I=$P($E(DS,1,Y-$L(DICODE)-1),U,5,99)
20 . . D SETSCR(I,.DICR,.DIC,.D,DICODE,.DID,.DF,+$P($P(DS,U,2),"P",2)) Q
21 . Q
22P1 ; Build screen to make sure selected entry is pointed-to.
23 S Y="("_DICR(DICR,1) G L1:'$D(DO) K DO I @("$O"_Y_"0))'>0") G L1
24 S I="DIC"_DICR,DICODE="X ""I 0"" N "_I D
25 . I DINDEX("#")=1,$D(DICR(DICR,"S")) S DICODE=DICODE_",%Y"_DICR
26 . S DICODE=DICODE_" F "_I_"=0:0 S "_I_"=$O"_Y,%=""""_%_""""
27 D G:DICODE="" L1
28 . I $G(DINDEX("#"))>1 D BLDC(Y,%,DINDEX("#"),DIFILEI,"",.DICODE,.DICR) Q
29 . I @("$O"_Y_%_",0))>0") S DICODE=DICODE_%_",Y,"_I_")) Q:"_I_"'>0 I $D"_Y_I_",0))"_$$CHKTMP(.DIC,DICR,DIFILEI,I) Q
30 . I DS["DINUM=X" S DICODE="I $D"_Y_"Y,0))"_$$CHKTMP(.DIC,DICR,DIFILEI,"Y")_" S "_I_"=Y" Q
31 . I $P(DS,U,4)="0;1" S DICODE=DICODE_I_")) Q:"_I_"'>0 I $P(^("_I_",0),U)=Y"_$$CHKTMP(.DIC,DICR,DIFILEI,I) Q
32 . S DICODE="" Q
33 I DINDEX("#")=1,$D(DICR(DICR,"S")) S DICODE=DICODE_" S %Y"_DICR_"=Y,Y="_I_" X DICR("_DICR_",""S"") S Y=%Y"_DICR_" I "
34 S DIC("S")=DICODE_" Q"
35 ; If user passed list of indexes for lookup on pointed-to file, set-up.
36 I DIPTRIX]"" S D=DIPTRIX D SETIX(.D,.DIC,.DID,.DF,.DICR,+$P($P(DS,U,2),"P",2))
37 S:$G(D)="" D="B" S Y=0
38 N DS,DINDEX,DIFILEI D X^DIC
39L1 K DIC("S"),@("DIC"_DICR)
40 I Y'>0 I $G(DTOUT)!($G(DIROUT)) G R
41 I Y'>0,'$D(DICR(DICR,8)) D G RETRY
42 . I $G(DICR(DICR,31.2)) S DIC("S")="I Y-"_DICR(DICR,31.2)
43 . Q:'$D(DICR(DICR,31))
44 . S DIC("S")=$S($D(DIC("S")):DIC("S")_" ",1:"")_DICR(DICR,31) Q
45 I DICR(DICR,2)["L",DICR(DICR,2)["E",@("$P("_DIC_"0),U,2)'[""O"""),$P(@(DICR(DICR,1)_"0)"),U,2)'["O",'DIVPSEL(DICR) D G:%-1 L2
46 . N I F I=(DICR-1):-1 Q:'$D(DIVPSEL(I)) S DIVPSEL(I)=1
47 . S DST=" ...OK",%=1 D Y^DICN W:'$D(DDS) ! Q
48R K DICS,DICW,DO,DIC("W"),DIC("S")
49 S DIC=DICR(DICR,1),%=DICR(DICR,2),DIC(0)=$P(%,"M")_$P(%,"M",2)
50 F X="DR","S","P","W" I $D(DICR(DICR,X)) M DIC(X)=DICR(DICR,X)
51 I $D(DIC("P")),+DIC("P")=.12 S DIC(0)=DIC(0)_"X"
52 D DO^DIC1 S X=+Y K:X'>0 X Q
53 ;
54L2 G NO:%-2 S DIC("S")="I Y-"_+Y_$S($D(DICR(DICR,31)):" "_DICR(DICR,31),1:""),X=DICR(DICR) W:'$D(DDS) " "_X I $D(DDS),$G(DDH) D LIST^DDSU
55 K DST ;
56RETRY D DO^DIC1 K DICR(U,+DO(2))
57 S D=$G(DICR(DICR,2.2)) S:D]"" DF=D S:D="" D="B"
58 S DIC(0)=DICR(DICR,2.1) S:"^"[X X=DICR(DICR)
59 I $D(DIFILEI) N DS,DINDEX,DIFILEI
60 I $D(DICR(DICR,31)),$G(DA(1)),'$G(DA) M DS=DA N DA M DA=DS S DA=DA(1) K DS
61 I $D(DICR(DICR,31.1)) S DID=DICR(DICR,31.1),DID(1)=2,DF=D
62 D X^DIC K DICR(DICR,6)
63 G R
64 ;
65BLDC(DIGBL,DIXNAM,DIXNO,DIFILEI,DIPGBL,DICODE,DICR) ; Build screening logic to loop through compound index, making sure pointed-to file is pointed-to by entry in index
66 N %,I,C,X,Y,DISB S Y="Y"
67 I $G(DIPGBL)]"" S Y="(+Y_"";"_$E(DIPGBL,2,99)_""")"
68 S %=DIGBL_DIXNAM_","_Y
69 S DICODE="N DICROUT,DIC"_DICR D
70 . I $D(DICR(DICR,"S")) S DICODE=DICODE_",%Y"_DICR
71 . S DICODE=DICODE_" X ""I 0"" I $D"_%_")) S DICROUT=0 X DICR("_DICR_",""SUB"",2)" Q
72 F I=2:1:DIXNO S C="N DISB"_I_" S DISB"_I_"="""" " D
73 . S C=C_"F S DISB"_I_"=$O"_%_",DISB"_I_")) Q:DISB"_I_"="""" X DICR("_DICR_",""SUB"","_(I+1)_") Q:DICROUT"
74 . S DICR(DICR,"SUB",I)=C
75 . S %=%_",DISB"_I Q
76 S I="DIC"_DICR
77 S X="S "_I_"=0 F S "_I_"=$O"_%_","_I_")) Q:'"_I_" I $D"_DIGBL_I_",0))"_$$CHKTMP(.DIC,DICR,DIFILEI,I)
78 I $D(DICR(DICR,"S")) S X=X_" S %Y"_DICR_"=Y,Y="_I_" X DICR("_DICR_",""S"") S Y=%Y"_DICR_" I"
79 S DICR(DICR,"SUB",DIXNO+1)=X_" S DICROUT=1 Q"
80 Q
81 ;
82CHKTMP(DIC,DICR,DIFILEI,DIVAR) ; If DIC(0)["T", add check to make sure entry hasn't already been presented once before.
83 I DIC(0)'["T"!(DICR'=1) Q ""
84 Q ",'$D(^TMP($J,""DICSEEN"","_DIFILEI_","_DIVAR_"))"
85 ;
86SETSCR(DICODE,DICR,DIC,D,DICALL,DID,DF,DIFILEI) ; Execute screening logic for screened pointers and var.ptrs.
87 N DISAV0 S DISAV0=DIC(0) D S DIC(0)=DISAV0
88 . N DISAV0 X DICODE Q
89 S:DIC(0)["B" D="B"
90 I $D(DIC("S")) S DICR(DICR,31)=DIC("S")
91 Q:$G(D)=""
92 I $P(D,U,2)="",DICALL["IX^DIC",DIC(0)["M" D SETIX(.D,.DIC,.DID,.DF,.DICR,DIFILEI) Q
93 I $P(D,U,2)]"",DICALL["MIX^DIC1" D SETIX(.D,.DIC,.DID,.DF,.DICR,DIFILEI) Q
94 S DICR(DICR,2.2)=D
95 Q
96 ;
97SETIX(D,DIC,DID,DF,DICR,DIFILEI) ; If user passes list of indexes to use on pointed-to file, set up to use them.
98 I '$G(DICR) N DICR S DICR=0
99 I DICR D
100 . N % S %=DICR(DICR,2.1)
101 . I %["L",(U_D_U)'["^B^" N D S D=I_"^B"
102 . I $P(D,U,2)="" D
103 . . I %["M" S DICR(DICR,2.1)=$TR(%,"M")
104 . . K DICR(DICR,31.1) Q
105 . I $P(D,U,2)]"" D
106 . . I %'["M" S DICR(DICR,2.1)=%_"M"
107 . . S DICR(DICR,31.1)=D_"^-1" Q
108 . S DICR(DICR,2.2)=$P(D,U) Q
109 I DIC(0)["L",(U_D_U)'["^B^" S D=D_"^B"
110 I $P(D,U,2)="" D
111 . I DIC(0)["M" S DIC(0)=$TR(DIC(0),"M")
112 . S (D,DF)=$P(D,U) K DID Q
113 I $P(D,U,2)]"" D
114 . S DID=D_"^-1",DID(1)=2,(D,DF)=$P(D,U)
115 . S:DIC(0)'["M" DIC(0)=DIC(0)_"M" Q
116 Q
117 ;
118NO S Y=-1 G R
119 ;
120OKTOADD(DIFILEI,DINDEX,DIFINDER) ; Return 1 if index is OK for LAYGO.
121 Q:$G(DINDEX(1,"TRANCODE"))]"" 0
122 Q:$G(DIFINDER)="p" 1
123 Q:DINDEX="B" 1
124 Q:DINDEX("#")=1 0
125 Q:$D(DICR("^",DIFILEI,.01,"B")) 0
126 Q:DINDEX(1,"FILE")'=DIFILEI 0
127 Q:DINDEX(1,"FIELD")'=.01 0
128 Q 1
129 ;
Note: See TracBrowser for help on using the repository browser.