Return to DICQ1.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DICQ1.m, revision 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