Return to DICQ1.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DICQ1.m, revision 1.1.1.1

1.1       snw         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