- DIE9 ;SFISC/GFT-JUMPING, FILING, MULTIPLES ;8:03 AM 13 Aug 1997
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- G:$A(X)-94 X:'$P(DW,";E",2),@("T^"_DNM)
- I $D(DIE("NO^")),DIE("NO^")="OUTOK"'&(X=U) W $C(7),!?3,"Sorry, ""^"" is not allowed!" G B
- S X=$P(X,U,2),DIC(0)="E"
- OUT I 0[X S DM=DW D FILE G ABORT:DL=1,R
- I X?1"@".N,$D(^DIE("AF",X,DIEZ)) S DNM=^(DIEZ)
- E S DIC="^DD("_DP_",",DIC("S")="I $D(^DIE(""AF"","_DP_",Y,DIEZ))" D ^DIC K DIC S DIC=DIE G X:Y<0 S DNM=^DIE("AF",DP,+Y,DIEZ)
- D FILE S Y=DNM,DNM=$P(Y,U,2),DQ=+Y,D=0 D @("DE^"_DNM) G @Y
- ;
- F ;
- S DC=$S($D(X)#2:X,1:0) D FILE S X=DC Q
- FILE ;
- K DQ Q:$D(DG)<9 S DQ="",DU=-2,DG="$D("_DIE_DA_",DU))"
- Y S DQ=$O(DG(DQ)),DW=$P(DQ,";",2) G DE:$P(DQ,";",1)=DU
- I DU'<0 S ^(DU)=DV,DU=-2
- G E1:DQ="" S DU=$P(DQ,";",1),DV="" I @DG S DV=^(DU)
- 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
- PC S $P(DV,U,DW)=DG(DQ) G Y
- ;
- IX 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)
- 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)
- K K DE(DQ)
- E1 S DQ=$O(DE(" ")) I DQ'="" G IX:$D(DG(DQ)),K
- K DG,DE,DIFLD S DQ=0 Q
- ;
- AST S E=DQ(DQ),Y=$F(E," D ^DIC"),%=8
- I 'Y S Y=$F(E," D IX^DIC"),%=10 G V^DIED:'Y
- S %DD=Y+1 X $P($E(E,1,Y-%),U,5,99) G V^DIED:'$D(DIC("S"))
- S DICSS=DIC("S") D ^DIC S X=+Y
- I $P(Y,U,3) S Y=+Y X:$D(@(DIC_Y_",0)")) DICSS I '$T S D=DA,DA=Y,DIK=DIC D ^DIK K DICSS S DA=D,DV=$P(E,U,2),DU=$P(E,U,3) G X^DIED
- K DICSS X:Y>0 $E(E,%DD,999) K %DD G X^DIED:'$D(X),X^DIED:X<0,Z^DIED
- 1 ;
- D FILE
- R D UP G @("R"_DQ_U_DNM)
- ;
- UP S DNM=DNM(DL),DQ=DNM(DL,0),%=2 I $D(DIEC(DL)) D DIEC^DIE1 G U
- S DA=DA(1) K DA(1)
- DA I $D(DA(%)) S DA(%-1)=DA(%) K DA(%) S %=%+1 G DA
- S:$D(DIEZTMP)#2 DIIENS=$P(DIIENS,",",2,999)
- U K DTOUT,DNM(DL) S DL=DL-1 Q
- ;
- X W:'$D(ZTQUEUED) $C(7),"??"
- B G @(DQ_U_DNM)
- ;
- N D DOWN S DA=$P(DC,U,4),D=0,^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_DA
- D1 S @("D"_(DL-1))=DA G @(DGO)
- ;
- M S DD=X D DOWN S DO(2)=$P(DC,"^",2),DO=DOW_"^"_DO(2)_"^"_$P(DC,"^",4,5),DIC(0)=$P("QE",U,'$D(DB(DNM(DL,0))))_"LM" I @("'$D("_DIC_"0))") S ^(0)="^"_DO(2)
- E I DO(2)["I" S %=0,DIC("W")="" D W^DIC1
- K DICR S D="B",DLAYGO=DP\1,X=DD D X^DIC I Y'>0 D UP G @(DQ_U_DNM)
- S DA=+Y,X=$P(Y,U,2),D=$P(Y,U,3) G D1
- ;
- DOWN S DL=DL+1,DNM(DL)=DNM,DNM(DL,0)=DQ D FILE
- DDA F %=DL+1:-1:1 I $D(DA(%)) S DA(%+1)=DA(%)
- S DA(1)=DA,DIC=DIE_DA_","""_$P(DC,U,3)_"""," Q
- ;
- ABORT D E S Y(DM)="" Q
- ;
- 0 ;
- D FILE
- E K DIP,Y,DE,DB,DP,DW,DU,DC,DV,DH,DIL,DNM,DIEZ,DLB
- DIE9 ;SFISC/GFT-JUMPING, FILING, MULTIPLES ;8:03 AM 13 Aug 1997
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 IF $ASCII(X)-94
- IF '$PIECE(DW,";E",2)
- GOTO X
- GOTO @("T^"_DNM)
- +4 IF $DATA(DIE("NO^"))
- IF DIE("NO^")="OUTOK"'&(X=U)
- WRITE $CHAR(7),!?3,"Sorry, ""^"" is not allowed!"
- GOTO B
- +5 SET X=$PIECE(X,U,2)
- SET DIC(0)="E"
- OUT IF 0[X
- SET DM=DW
- DO FILE
- IF DL=1
- GOTO ABORT
- GOTO R
- +1 IF X?1"@".N
- IF $DATA(^DIE("AF",X,DIEZ))
- SET DNM=^(DIEZ)
- +2 IF '$TEST
- SET DIC="^DD("_DP_","
- SET DIC("S")="I $D(^DIE(""AF"","_DP_",Y,DIEZ))"
- DO ^DIC
- KILL DIC
- SET DIC=DIE
- IF Y<0
- GOTO X
- SET DNM=^DIE("AF",DP,+Y,DIEZ)
- +3 DO FILE
- SET Y=DNM
- SET DNM=$PIECE(Y,U,2)
- SET DQ=+Y
- SET D=0
- DO @("DE^"_DNM)
- GOTO @Y
- +4 ;
- F ;
- +1 SET DC=$SELECT($DATA(X)#2:X,1:0)
- DO FILE
- SET X=DC
- QUIT
- FILE ;
- +1 KILL DQ
- IF $DATA(DG)<9
- QUIT
- SET DQ=""
- SET DU=-2
- SET DG="$D("_DIE_DA_",DU))"
- Y SET DQ=$ORDER(DG(DQ))
- SET DW=$PIECE(DQ,";",2)
- IF $PIECE(DQ,";",1)=DU
- GOTO DE
- +1 IF DU'<0
- SET ^(DU)=DV
- SET DU=-2
- +2 IF DQ=""
- GOTO E1
- SET DU=$PIECE(DQ,";",1)
- SET DV=""
- IF @DG
- SET DV=^(DU)
- DE IF 'DW
- SET DW=$EXTRACT(DW,2,99)
- SET DE=DW-$LENGTH(DV)-1
- SET %=$PIECE(DW,",",2)+1
- SET X=$EXTRACT(DV,%,999)
- SET DV=$EXTRACT(DV,0,DW-1)_$JUSTIFY("",$SELECT(DE>0:DE,1:0))_DG(DQ)
- IF X'?." "
- SET DV=DV_$JUSTIFY("",%-DW-$LENGTH(DG(DQ)))_X
- GOTO Y
- PC SET $PIECE(DV,U,DW)=DG(DQ)
- GOTO Y
- +1 ;
- IX IF $DATA(DE(DE(DQ)))#2
- FOR DG=1:1
- IF '$DATA(DE(DQ,DG))
- QUIT
- SET DIC=DIE
- SET X=DE(DE(DQ))
- XECUTE DE(DQ,DG,2)
- +1 SET X=""
- IF DG(DQ)]""
- FOR DG=1:1
- IF '$DATA(DE(DQ,DG))
- QUIT
- SET DIC=DIE
- SET X=DG(DQ)
- XECUTE DE(DQ,DG,1)
- K KILL DE(DQ)
- E1 SET DQ=$ORDER(DE(" "))
- IF DQ'=""
- IF $DATA(DG(DQ))
- GOTO IX
- GOTO K
- +1 KILL DG,DE,DIFLD
- SET DQ=0
- QUIT
- +2 ;
- AST SET E=DQ(DQ)
- SET Y=$FIND(E," D ^DIC")
- SET %=8
- +1 IF 'Y
- SET Y=$FIND(E," D IX^DIC")
- SET %=10
- IF 'Y
- GOTO V^DIED
- +2 SET %DD=Y+1
- XECUTE $PIECE($EXTRACT(E,1,Y-%),U,5,99)
- IF '$DATA(DIC("S"))
- GOTO V^DIED
- +3 SET DICSS=DIC("S")
- DO ^DIC
- SET X=+Y
- +4 IF $PIECE(Y,U,3)
- SET Y=+Y
- IF $DATA(@(DIC_Y_",0)"))
- XECUTE DICSS
- IF '$TEST
- SET D=DA
- SET DA=Y
- SET DIK=DIC
- DO ^DIK
- KILL DICSS
- SET DA=D
- SET DV=$PIECE(E,U,2)
- SET DU=$PIECE(E,U,3)
- GOTO X^DIED
- +5 KILL DICSS
- IF Y>0
- XECUTE $EXTRACT(E,%DD,999)
- KILL %DD
- IF '$DATA(X)
- GOTO X^DIED
- IF X<0
- GOTO X^DIED
- GOTO Z^DIED
- 1 ;
- +1 DO FILE
- R DO UP
- GOTO @("R"_DQ_U_DNM)
- +1 ;
- UP SET DNM=DNM(DL)
- SET DQ=DNM(DL,0)
- SET %=2
- IF $DATA(DIEC(DL))
- DO DIEC^DIE1
- GOTO U
- +1 SET DA=DA(1)
- KILL DA(1)
- DA IF $DATA(DA(%))
- SET DA(%-1)=DA(%)
- KILL DA(%)
- SET %=%+1
- GOTO DA
- +1 IF $DATA(DIEZTMP)#2
- SET DIIENS=$PIECE(DIIENS,",",2,999)
- U KILL DTOUT,DNM(DL)
- SET DL=DL-1
- QUIT
- +1 ;
- X IF '$DATA(ZTQUEUED)
- WRITE $CHAR(7),"??"
- B GOTO @(DQ_U_DNM)
- +1 ;
- N DO DOWN
- SET DA=$PIECE(DC,U,4)
- SET D=0
- SET ^DISV(DUZ,$EXTRACT(DIC,1,28))=$EXTRACT(DIC,29,999)_DA
- D1 SET @("D"_(DL-1))=DA
- GOTO @(DGO)
- +1 ;
- M SET DD=X
- DO DOWN
- SET DO(2)=$PIECE(DC,"^",2)
- SET DO=DOW_"^"_DO(2)_"^"_$PIECE(DC,"^",4,5)
- SET DIC(0)=$PIECE("QE",U,'$DATA(DB(DNM(DL,0))))_"LM"
- IF @("'$D("_DIC_"0))")
- SET ^(0)="^"_DO(2)
- +1 IF '$TEST
- IF DO(2)["I"
- SET %=0
- SET DIC("W")=""
- DO W^DIC1
- +2 KILL DICR
- SET D="B"
- SET DLAYGO=DP\1
- SET X=DD
- DO X^DIC
- IF Y'>0
- DO UP
- GOTO @(DQ_U_DNM)
- +3 SET DA=+Y
- SET X=$PIECE(Y,U,2)
- SET D=$PIECE(Y,U,3)
- GOTO D1
- +4 ;
- DOWN SET DL=DL+1
- SET DNM(DL)=DNM
- SET DNM(DL,0)=DQ
- DO FILE
- DDA FOR %=DL+1:-1:1
- IF $DATA(DA(%))
- SET DA(%+1)=DA(%)
- +1 SET DA(1)=DA
- SET DIC=DIE_DA_","""_$PIECE(DC,U,3)_""","
- QUIT
- +2 ;
- ABORT DO E
- SET Y(DM)=""
- QUIT
- +1 ;
- 0 ;
- +1 DO FILE
- E KILL DIP,Y,DE,DB,DP,DW,DU,DC,DV,DH,DIL,DNM,DIEZ,DLB
