DIE9 ;SFISC/GFT-JUMPING, FILING, MULTIPLES ;8:03 AM 13 Aug 1997
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIE9 2878 printed Dec 13, 2024@02:47:05 Page 2
DIE9 ;SFISC/GFT-JUMPING, FILING, MULTIPLES ;8:03 AM 13 Aug 1997
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
+7 if $ASCII(X)-94
if '$PIECE(DW,";E",2)
GOTO X
GOTO @("T^"_DNM)
+8 IF $DATA(DIE("NO^"))
IF DIE("NO^")="OUTOK"'&(X=U)
WRITE $CHAR(7),!?3,"Sorry, ""^"" is not allowed!"
GOTO B
+9 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
