Return to DIE1.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    1: DIE1	;SFISC/GFT-FILE DATA, XREF IT, GO UP AND DOWN MULTIPLES ;09:14 AM  7 Nov 1994
    2: 	;;21.0;VA FileMan;;Dec 28, 1994
    3: 	;Per VHA Directive 10-93-142, this routine should not be modified.
    4: 	K DQ,DB G E1:$D(DG)<9 I DP<0 K DG S DQ=0 Q
    5: 	S DQ="",DU=-2,DG="$D("_DIE_DA_",DU))"
    6: Y	S DQ=$O(DG(DQ)),DW=$P(DQ,";",2) G DE:$P(DQ,";",1)=DU
    7: 	I DU'<0 S ^(DU)=DV,DU=-2
    8: 	G IX:DQ="" S DU=$P(DQ,";",1),DV="" I @DG S DV=^(DU)
    9: DE	I 'DW S DW=$E(DW,2,99),DE=DW-$L(DV)-1,%=$P(DW,",",2)+1,X=$E(DV,%,999),DV=$E(DV,0,DW-1)_$J("",$S(DE>0:DE,1:0))_DG(DQ) S:X'?." " DV=DV_$J("",%-DW-$L(DG(DQ)))_X G Y
   10: PC	S $P(DV,"^",DW)=DG(DQ) G Y
   11: 	;
   12: IX	S DQ=$O(DE(" ")) G E1:DQ="",E1:'$D(DG(DQ)) I $D(DE(DE(DQ)))#2 F DG=1:1 Q:'$D(DE(DQ,DG))  S DIC=DIE,X=DE(DE(DQ)) X DE(DQ,DG,2)
   13: 	S X="" I DG(DQ)]"" F DG=1:1 Q:'$D(DE(DQ,DG))  S DIC=DIE,X=DG(DQ) X DE(DQ,DG,1)
   14: E1	K DIFLD,DG,DB,DE,DIANUM S DQ=0 Q
   15: 	;
   16: B	;
   17: 	I '$D(DB(DQ)) S X="?BAD" G ^DIEQ
   18: 	S DC=DQ,DIK="",DL=1
   19: OUT	;
   20: 	D DIE1 S Y(DC)=DIK G UP:DL>1,Q:DC=0,QY
   21: 	;
   22: E	;
   23: 	I DP'<0 S DC=$S($D(X)#2:X,1:"") D DIE1 S X=DC G G:DI>0,UP:DL>1
   24: Q	K Y
   25: QY	I $D(DTOUT),$D(DIEDA) D
   26: 	. N % K DA
   27: 	. F %=1:1 Q:'$D(DIEDA(%))  S DA(%)=DIEDA(%)
   28: 	. S DA=DIEDA
   29: 	. Q
   30: 	K:$D(DTOUT) DG,DQ
   31: 	K DIP,DB,DE,DM,DK,DL,DH,DU,DV,DW,DP,DC,DIK,DOV,DIEL,DIFLD Q
   32: 	;
   33: M	;
   34: 	S DD=X,DIC(0)=$P("QE","^",'$D(DB(DQ)))_"LM",DO(2)=$P(DC,"^",2),DO=$E($P(DQ(DQ),"^",1),8,99)_"^"_DO(2)_"^"_$P(DC,"^",4,5) D DOWN I @("'$D("_DIC_"0))") S ^(0)="^"_DO(2)
   35: 	E  I DO(2)["I" S %=0,DIC("W")="" D W^DIC1
   36: 	K DICR S D="B",DLAYGO=DP\1,X=DD D X^DIC
   37: 	I Y>0 S DA=+Y,DI=0,X=$P(Y,U,2) S:+DR=.01!(DR="")&$P(Y,U,3) DI=.01,DK=1,DM=$P($P(DR,";",1),":",2),DM=$S(DR="":9999999,DM="":+DR,1:DM) G D1
   38: 	S DI(DL-1)=DI(DL-1)_U K DUOUT,DTOUT G U1
   39: 	;
   40: DOWN	D S,DIE1,DDA S DIE=DIC Q
   41: 	;
   42: S	S DIOV(DL)=$S('$D(DOV):0,1:DOV) K DOV
   43: 	S DP(DL)=DP,DP=+$P(DC,"^",2),DI(DL)=$S(DV'["M":DI,$D(DSC(DP))!$D(DB(DQ)):DI,1:DI_U),DIE(DL)=DIE,DK(DL)=DK,DR(DL)=DR,DM(DL)=DM,DK=0,DL=DL+1,DIEL=DIEL+1,DM=9999999,DR="" I $D(DR(DL,DP)) S DM=0,DR=DR(DL,DP)
   44: 	Q
   45: 	;
   46: DDA	F X=DL+1:-1:1 I $D(DA(X)) S DA(X+1)=DA(X)
   47: 	S DA(1)=DA,DIC=DIE_DA_","""_$P(DC,U,3)_"""," Q
   48: 	;
   49: UDA	S DA=DA(1) F X=2:1 Q:'$D(DA(X))  S DA(X-1)=DA(X) K DA(X)
   50: 	K DA(DL)
   51: 	Q
   52: N	;
   53: 	D DOWN S DA=$P(DC,U,4),DI=.01 S ^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_DA
   54: D1	S @("D"_DIEL)=DA
   55: G	G MORE^DIE
   56: 	;
   57: UP	;
   58: 	Q:$D(DTOUT)  S DP(0)=DP I $D(DIEC(DL)) D DIEC G U
   59: U1	D UDA S DIEL=DIEL-1
   60: U	S DQ=0,DL=DL-1,DIE=DIE(DL),DM=DM(DL),DI=DI(DL),DP=DP(DL),DR=DR(DL),DK=DK(DL) I $D(DIOV(DL)) S DOV=DIOV(DL) K DIOV(DL)
   61: 	G G
   62: 	;
   63: DIEC	K DA S DA=DIEC(DL) F %=1:1 Q:'$D(DIEC(DL,%))  S DA(%)=DIEC(DL,%)
   64: 	F DIEL=0:1 Q:'$D(DIEC(DL,0,DIEL))  S @("D"_DIEL)=DIEC(DL,0,DIEL)
   65: 	S DIEL=DIEL-1 K DIEC(DL)