Return to DIE2.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DIE2.m, revision 1.1

1.1     ! snw         1: DIE2   ;SFISC/GFT,XAK-DELETE AND ENTRY ;2/8/94  09:26
        !             2:        ;;21.0;VA FileMan;;Dec 28, 1994
        !             3:        ;Per VHA Directive 10-93-142, this routine should not be modified.
        !             4:        D F,DL Q:$D(DTOUT)  G B^DIED:Y=2,A^DIED:Y,UP^DIE1:DL>1,Q^DIE1
        !             5:        ;
        !             6: F      S D=$P(DQ(DQ),U,4) S:DP+1 D=DIFLD Q
        !             7:        ;
        !             8: Z      D DL S DU="" I Y=2 G @(DQ_U_DNM)
        !             9:        I Y G @("A^"_DNM)
        !            10:        G R^DIE9:DL>1,E^DIE9
        !            11: DL     ;
        !            12:        S %=DP,X=D,Y=$P(DQ(DQ),U,4)="0;1"
        !            13:        G X:$D(DE(DQ))[0,X:DV["R"&'Y,S:DP<0,DD:DUZ(0)="@" I DV S %=+$P(DC,U,2),X=.01
        !            14:        G DD:DP<2 I $D(DIDEL),DIDEL\1=(DP\1) G DD
        !            15:        I Y,$S($D(^VA(200,"AFOF")):1,1:$D(^DIC(3,"AFOF"))) G DD:$D(^DD(DP,0,"UP"))!DV,DAR:'$S($D(^VA(200,DUZ,"FOF",DP)):1,1:$D(^DIC(3,DUZ,"FOF",DP))),DAR:'$P(^(DP,0),U,3),DD
        !            16:        I Y,$D(^DIC(%,0,"DEL")) S X=^("DEL")
        !            17:        E  G DD:'$D(^DD(%,X,8.5)) S X=^(8.5)
        !            18:        G DD:X="" F %=1:1:$L(X) G DD:DUZ(0)[$E(X,%)
        !            19: DAR    W !,"'DELETE ACCESS' REQUIRED!!"
        !            20: X      I $D(DB(DQ)) D N G A
        !            21:        W:'$D(DIER) $C(7),"??" W:DV["R"&'$D(DIER) "  Required" G R
        !            22: DD     G MD:DV S DH=0,DU=0 F  S DH=$O(^DD(DP,D,"DEL",DH)) Q:DH=""  I $D(^(DH,0)) X ^(0) Q:$D(DTOUT)  G X:$T
        !            23:        S DH=-1,X=DQ(DQ) I Y,$E(@(DIE_"0)"))'=U S X=^(0)
        !            24:        D D G R:X I Y S X=DE(DQ) D DEL:$D(DIU(0)) K DE,DG,DQ,DB S DIK=DIE D ^DIK S Y=0 K:DL<2 DA Q
        !            25: S      S X="",DG($P(DQ(DQ),U,4))=""
        !            26: A      S Y=1 Q
        !            27:        ;
        !            28: D      I $D(DB(DQ)) S X=0 Q
        !            29:        W $C(7),!?3,"SURE YOU WANT TO DELETE"
        !            30:        I Y W " THE ENTIRE " W:DV'["D"&(DV'["P")&(DV'["V") "'"_DE(DQ)_"' " W $P(X,U,1)
        !            31:        S %=0,X=0 D YN^DICN Q:%=1  S X=1 W:$X>55 !?9
        !            32: N      I $D(DE(DQ))#2,'$D(DDS) W:'$D(ZTQUEUED) $C(7),"  <NOTHING DELETED>"
        !            33:        Q
        !            34:        ;
        !            35: MD     G X:DV["R"&($P(DC,U,5)=1) S DH=0,DU=0 F  S DH=$O(^DD(+$P(DC,U,2),.01,"DEL",DH)) Q:DH=""  I $D(^(DH,0)) D DDA X ^(0) D UDA G X:$T
        !            36:        S DH=-1,Y=DC>1,X=$E(DQ(DQ),8,99) D D
        !            37:        I 'X D DDA S DIK=DIC D ^DIK,UDA K DE(DQ) S X=$P(@(DIK_"0)"),U,3,4),DC=$P(DC,U,1,3)_U_X,DIC=DIE S:$D(^(+X,0)) DE(DQ)=$P(^(0),U,1)
        !            38: R      S Y=2 Q
        !            39:        ;
        !            40: DDA    F X=DL+1:-1:1 I $D(DA(X)) S DA(X+1)=DA(X)
        !            41:        K DA(DL+2) S DA(1)=DA,DIC=DIE_DA_","""_$P(DC,U,3)_""",",DA=$P(DC,U,4) Q
        !            42:        ;
        !            43: UDA    S DA=DA(1) F X=2:1 Q:'$D(DA(X))  S DA(X-1)=DA(X) K DA(X)
        !            44:        Q
        !            45: QS     ;
        !            46:        G ^DIEQ
        !            47: QQ     ;
        !            48:        G QQ^DIEQ
        !            49:        Q
        !            50: DEL    I '$S($D(^VA(200,"AFOF",DA)):1,1:$D(^DIC(3,"AFOF",DA))) Q
        !            51:        S DA(1)="",DIFOF=DA
        !            52:        F P=0:0 S DA(1)=$S($D(^VA(200,"AFOF")):$O(^VA(200,"AFOF",DA,DA(1))),1:$O(^DIC(3,"AFOF",DA,DA(1)))) Q:'DA(1)  I $S($D(^VA(200,DA(1),"FOF",DA)):1,1:$D(^DIC(3,DA(1),"FOF",DA))) S DIK=$S($D(^VA(200)):"^VA(200,",1:"^DIC(3,")_DA(1)_",""FOF""," D ^DIK
        !            53:        K DA S DA=DIFOF K DIFOF
        !            54:        Q
        !            55: V      ;
        !            56:        G ^DIE3