Return to DIP22.m CVS log

Up to [Coherent Logic Development] / freem_fileman

Annotation of freem_fileman/DIP22.m, revision 1.1

1.1     ! snw         1: DIP22  ;SFISC/GFT-EDIT PRINT TEMPLATE ;12/16/92  09:12
        !             2:        ;;21.0;VA FileMan;;Dec 28, 1994
        !             3:        ;Per VHA Directive 10-93-142, this routine should not be modified.
        !             4:        S DC(1)=$O(^DIPT(DC(0),"F",DC(1))),DC=0 S:DC(1)="" DC(1)=-1 Q:DC(1)<0  S DC=2,DY=^(DC(1)),Y=2
        !             5: Y      S X=$P(DY,$C(126),1),DY=$P(DY,$C(126),2,99) I X="" G DIP22:'$D(DC(2)) Q
        !             6:        I D9]"" G UP:$P(X,D9,1)]"" S X=$P(X,D9,2,99)
        !             7: R      I X'>0 G 0:$E(X,2)'=C&'X S:+X D9=D9_+X_C,DRK=-X G M
        !             8:        I X[C S DA=$P(X,C,1) I +DA=DA S:DA<0 DA=-DA G Y:'$D(^DD(DRK,DA,0)) S X=$P(X,C,2,99),DC(Y)=$P(^(0),U,1),%=+X,D=+$P(^(0),U,2) G Y:'$D(^DD(D,.01,0)),W:$P(^(0),U,2)["W" S DRK=D,Y=Y+1,D9=D9_DA_C G R
        !             9:        S %=+X,D=DRK_U_% D DCL
        !            10:        G Y:'$D(^DD(DRK,%,0))
        !            11: W      S X=$P(^(0),U,1)_$E(X,$L(%)+1,999)
        !            12: P      S DC(Y)=X,Y=Y+1 G Y
        !            13: 0      S:X?1"0".E X=$S($D(^DD(DRK,.001,0)):$P(^(0),U,1),1:"NUMBER")_$E(X,2,999) S D=DRK_"^0" D DCL
        !            14: M      S %=$F(X,";Z;""") G P:'% S %=%-$L($P(X,";",1)),X=";"_$P(X,";",2,99) F D=%:0 S D=$F(X,Q,D) I ";"[$E(X,D) S X=$E(X,%,D-2)_$E(X,1,%-5)_$E(X,D,999) G P
        !            15:        ;
        !            16: UP     S DRK=J(0),%=D9,DA=""
        !            17: DOWN   I X[C,+X=$P(X,C,1),$P(D9,DA_+X_C,1)="" S DA=DA_+X_C,%=$P(%,C,2,99),DRK=$S(X'>0:-X,1:+$P(^DD(DRK,+X,0),U,2)),X=$P(X,C,2,99) G DOWN
        !            18: NUL    S D9=DA,DC(Y)="",Y=Y+1,%=$P(%,C,2,99) G NUL:%]"",R
        !            19:        ;
        !            20: X      ;
        !            21:        S DC(1)=DD D Y F D=2:1 Q:'$D(DC(D))  S X=DC(D) X DICMX I '$D(D) K DD Q
        !            22:        Q
        !            23:        ;
        !            24: HARD   ;
        !            25:        S DM=X,DQI="DIP(",DA="DXS("_DXS_C,S=S_";Z;"""_X_Q,DICOMP=DIL_$E("?",''L)_"TI"
        !            26:        S DICOMPX=""
        !            27:        I X'?.E1":" S DICMX="X DICMX" D EN^DICOMP G QQ:'$D(X)&'$D(FLDS) D FLY G S^DIP2
        !            28:        S DICMX="S DIXX=DIXX("_DL_") D M" D ^DICOMPW
        !            29:        I $D(X) S %=Y D OVFL,F S S=U_$P(DP,U,2)_U_$E(1,%["m")_U_S,X=1,P="",DIL(DL)=DIL,DV(DL)=DV,DL(DL)=DK,DK=+DP,DV=DV_-DP_C,Y=0,DL=DL+1,DIL=+% K P G S^DIP2
        !            30: QQ     ;
        !            31:        W $C(7),"??" G F^DIP2
        !            32:        ;
        !            33: FLY    ;
        !            34:        S:'$D(X) X=DM S %=Y["D"
        !            35:        I %,S'[";R",S'[";L",$G(DDXP)'=2 S S=S_";L18"
        !            36:        I Y["W",S'[";X" S S=S_";X"
        !            37:        I Y["m" S:S'[";m" S=S_";m" I Y["w",S'[";w" S S=S_";w"
        !            38:        D OVFL I P="",Y'["X" S X=X_$S(S[";W":"",%:" S Y=X D DT",1:" W X")_" K DIP"
        !            39: F      S S=X_S S:P]"" S=S_";"_P
        !            40: DXS    F Y=0:0 S Y=$O(X(Y)) S:Y="" Y=-1 Q:Y=-1  S @(DA_"Y)")=X(Y)
        !            41:        S DXS=$D(X)>1+DXS K DATE,X Q
        !            42:        ;
        !            43: OVFL   I $L(X)+$L(S)>180 S X(9)=X,X="X DXS("_DXS_",9)"
        !            44:        Q
        !            45: DIC    I X="NUMBER" G B:'$D(DIAR),B:DIAR'=4,B:'$D(DC(DC)) S Y=X
        !            46:        E  D ^DIC G E:'$D(DIAR),E:DIAR'=4,E:'$D(DC(DC)),RTN^DIP2:$E(X)="?"
        !            47:        G E:'DC,E:$P(X,";")=$P(DC(DC),";"),E:$P($P(Y,U,2),";")=$P(DC(DC),";")
        !            48: Z      W !,$C(7),"Because this is an ARCHIVING process:"
        !            49:        W !!,"You may ADD fields to output or CHANGE PREDEFINED FIELD formats"
        !            50:        W !,"but NOT change, delete or do calculations on predefined fields.",!
        !            51:        G 2^DIP2
        !            52: E      I $D(Y) G GF^DIP2:Y>0
        !            53:        G UP^DIP2:X="",^DIP21:X?1"[".E&(DE="")
        !            54: B      S %=$L(X) F D="+","#","*","&","!" S Y=$S($E(X)=D:$E(X,2,999),$E(X,%)=D:$E(X,1,%-1),1:"") I Y]"" S P=D,X=Y G DIC
        !            55:        I X[";" S S=";"_$P(X,";",2,99)_S,X=$P(X,";") G DIC
        !            56:        I $E(X)="]" S X=$E(X,2,999),DALL(1)=1 G DIC
        !            57:        G RTN^DIP2
        !            58:        ;
        !            59: DCL    I $D(^DIPT(DC(0),"DCL",D)) S X=X_$E(^(D),$L(^(D)))
        !            60:        Q