Return to DICQ1.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    1: DICQ1	;SFISC/GFT-HELP FOR LOOKUPS ;6/24/94  13:47
    2: 	;;21.0;VA FileMan;;Dec 28, 1994
    3: 	;Per VHA Directive 10-93-142, this routine should not be modified.
    4: EN	K DDD I $D(DDH)>10 S:$D(DDS) DDD=1 D LIST^DDSU Q:$D(DDSQ)
    5: 	S Y=$S('$D(%Y):0,%Y:%Y-.00000001,1:%Y)
    6: 	I $L(DS)+$L(X)<240 S DS=DS_X G N
    7: 	E  S DS=DS_" X DS(3)",DS(3)=$S($E(X)=" ":$E(X,2,999),1:X)
    8: N	S X="" I DIZ S DIY=$L($P(DO,U,3))+DIY+5 S:Y="" Y=0
    9: 	E  S X=$S(Y=0:"",1:Y),Y=0
   10: 	D:$D(DIC("W")) ID S DDD=5,DIY=99,DIEQ="",$P(DIEQ," ",40)=" ",DIZ=DDC
   11: 	I '$D(DDS) D Z^DDSU
   12: 	;
   13: L	X DIX I  D BK^DIEQ S:'$D(DDS) DDD=3 D LIST^DDSU K DDH Q:$D(DDSQ)  G 0
   14: 	X DS I $D(DICQ1Q) K DICQ1Q Q:$D(DTOUT)!$D(DDSQ)  G:'$D(DDH) 0
   15: 	I $D(DDS),DDH'<DIZ S DIZ=DDH+DDC D LIST^DDSU Q:$D(DDSQ)
   16: 	I '$D(DDS),DDH'<DDC D LIST^DDSU Q:$D(DTOUT)  G:'$D(DDH) 0
   17: 	G L
   18: CHK	;Called by code in DS at line L+1 when we're doing a lookup with
   19: 	;a DIC("S") and/or DIC("W") defined.
   20: 	I $D(DDS),DDH'<DIZ S DIZ=DDH+DDC D LIST^DDSU I $D(DDSQ) S DICQ1Q=1
   21: 	I '$D(DDS),DDH'<DDC D LIST^DDSU I $D(DTOUT)!'$D(DDH) S DICQ1Q=1
   22: 	Q
   23: 	;
   24: ID	S DIY="I $D("_DIC_"Y,0)) "
   25: 	I $L(DIC("W"))+$L(DIY)<240 S DDH("ID")=DIY_DIC("W") Q
   26: 	S DDH("ID")=DIY_"X DDH(""ID"",1)" S DDH("ID",1)=DIC("W") Q
   27: 	;
   28: WOV	S %DIC=DIC,%WW=Y,DIC=%Z,Y=%Y,%X=0
   29: W1	S %X=$O(^DD(%W,0,"ID",%X)) I %X]"" S %=^(%X) X "W ""  "",$E("_%Z_%Y_",0),0)",% G W1
   30: 	S DIC=%DIC,Y=%WW K %DIC,%W,%X,%YY,%Z,%WW Q
   31: 	;
   32: S	S DS(1)=X,DS(2)=Y I 1 X:$D(DIC("S")) DIC("S")
   33: 	I $T S Y=DS(2) D SCR:$D(DO("SCR"))
   34: 	S X=DS(1),Y=DS(2) Q
   35: 	;
   36: SCR	I @("$D("_DIC_"Y,0))") X DO("SCR")
   37: 	Q
   38: 	;
   39: DT	S A2=$P(%,U,2),%=$P(%,U),A1="" ;I $G(DUZ("LANG"))>1 S A1=$$OUT^DIALOGU(%,"DD"),DDH(DDH,Y)=$S(A2:DDH(DDH,Y),1:"")_A1 Q
   40: 	;S:$E(%,4,5) A1=$E(%,4,5)_"-" S:$E(%,6,7) A1=A1_$E(%,6,7)_"-" S A1=A1_($E(%,1,3)+1700)
   41: 	;S:%["." A1=A1_" @ "_$E(%_0,9,10)_":"_$E(%_"000",11,12)_$S(+$E(%,13,14):":"_$E(%_0,13,14),1:"   ")
   42: 	S DDH(DDH,Y)=$S(A2:DDH(DDH,Y),1:"")_$$FMTE^DILIBF(%,6) Q
   43: 	;
   44: 0	;
   45: 	K DDC,DIEQ,DIW,DS G:DIC(0)'["L" QQ
   46: 	S DDH=$S($D(DDH):DDH,1:0) K A1
   47: 	I $D(%Y) S:%Y="??" DZ=%Y S:%Y?1P DZ="?"
   48: 	I $S($D(DLAYGO):DO(2)-DLAYGO\1,1:1),DUZ(0)'="@",'$D(^DD(+DO(2),0,"UP")) G JMP
   49: 10	I DZ="?" S DST=$$EZBLD^DIALOG(8069,$P(DO,U)) D DS^DIEQ,HP
   50: 	D H
   51: 	I $D(DZ),DO(2)["S" S DST=$$EZBLD^DIALOG(8068)_" " D %^DICQ F X=1:1 S Y=$P($P(^DD(+DO(2),.01,0),U,3),";",X) Q:Y=""  S A2="",$P(A2," ",15-$L(Y))=" ",DST="  "_$P(Y,":",1)_A2_" "_$P(Y,":",2) D DS^DIEQ
   52: 	I DO(2)["V" S DU=+DO(2),D=.01 D V^DIEQ
   53: 	;
   54: RCR	G:DO(2)'["P"!($G(DZ(1))=0) QQ
   55: 	N D,DIC
   56: 	S D="B",DS=^DD(+DO(2),.01,0),DIC=U_$P(DS,U,3),DIC(0)=$E("L",$P(DS,U,2)'["'")
   57: 	I $P(DS,U,2)["*" F DILCV=" D ^DIC"," D IX^DIC"," D MIX^DIC1" S DICP=$F(DS,DILCV) I DICP X $P($E(DS,1,DICP-$L(DILCV)-1),U,5,99) Q
   58: 	K DICP,DILCV,DO D DQ^DICQ K DICW,DICS,DO
   59: QQ	K A1,A2,DST Q:$D(DDH)'>10
   60: 	S:$D(DDS) DDC=-1 D LIST^DDSU K DDC Q
   61: 	;
   62: HP	F DG=3,12 I $D(^DD(+DO(2),.01,DG)) S X=^(DG) F %=$L(X," "):-1:1 I $L($P(X," ",1,%))<70 S DST=$P(X," ",1,%) D DS^DIEQ,P1 Q
   63: 	Q
   64: 	;
   65: P1	I %'=$L(X," ") S DST=$P(X," ",%+1,99) D DS^DIEQ
   66: 	Q
   67: 	;
   68: H	S %=DIC,X=DZ N DIC,D,DP S DIC=%,D=.01,DP=+DO(2) D H^DIEQ Q
   69: 	;
   70: JMP	S DIFILE=+DO(2),DIAC="LAYGO" D ^DIAC K DIAC,DIFILE G RCR:'%,10
   71: 	;
   72: Q	K A1,A2 Q
   73: 	;
   74: 	;#8069  You may enter a new |filename|, if you wish
   75: 	;#8068  Choose from