DIE0 ;SFISC/GFT-BRANCHING, UP-ARROWING ;23DEC2005
;;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 Q^DIE1:$D(DTOUT) G:X'?1"^".E T^DIED:$P($P(DQ(DQ),U,4),";E",2),X
I $D(DIE("NO^")),X=U,DIE("NO^")'["OUTOK" W !?3,$$EZBLD^DIALOG(3095) G X ;**
I $D(DIE("NO^")),X?1"^"1E.E,DIE("NO^")'["BACK" W !?3,$$EZBLD^DIALOG(3096) G X ;**
I $L(X,"^")-1>1 S X=$E(X,2,99) G DIE0
S X=$P(X,U,2),DIC(0)="E"
OUT I X=""!(DP<0) S DIK=X,DC=$S($D(DQ(DQ))#2:$P(DQ(DQ),U,4),1:DQ) G OUT^DIE1
I DR]"" G A:X?1"@".N S DIC("S")="D S^DIE0" S:'$D(DR(DIE1,DP)) DR(DIE1,DP)=DR
S DDBK=0,DIC="^DD("_DP_"," D ^DIC I Y>0 D S
E W:DDBK !?3,$$EZBLD^DIALOG(3097)
K DTOUT,DIC,DDBK,DDFND,DDONE,A0,A1,A2
I Y<0 S DG=DK,DH=":"_DM G X
S DI=$S(DH[":":+Y,1:DH),DK=DG D ^DIE1:$D(DG)>9 K DG,DB,DE,DQ,DIFLD S DQ=0 G JMP^DIE
X W:X'["?"&'$D(ZTQUEUED) $C(7),"??" G B^DIED:'$D(DB(DQ)),B^DIE1
;
BR ;From ^DIED
S Y=U,X=$G(X) X DQ(0,DQ) D:$D(DIEFIRE)#2 FIREREC^DIE1 G A^DIED:$D(Y)[0,A^DIED:Y=U S D=$S(+Y=Y:9999,1:DQ),X="" I 0[Y S DQ=0 G OUT ;MAKE SURE 'X' EXISTS, AFTER W-P
D S D=D+1 I '$D(DQ(D)) G D:$D(DQ(0,D)) S DQ=9999,X=Y,DIC(0)="FO" G OUT
G D:$P(DQ(D),Y,1)]"" S DQ=D G RE^DIED
;
O ;From ^DIE
K DQ S (DI,DV,DM)=0 I X]"",$D(@(U_$P(DC,U,3)_X_",0)"))#2 D S^DIE1,DIEC
S DQ=0 G MORE^DIE
;
DIEC S DIE=U_$P(DC,U,3),DIEC(DL)=DA F %=1:1 Q:'$D(DA(%)) S DIEC(DL,%)=DA(%)
K DA,DB,DE,DG F %=0:1:DIEL-1 S DA="D"_%,DIEC(DL,0,%)=@DA K @DA
S:$D(DIETMP)#2 DIEC(DL,"IENS")=DIIENS,DIIENS=X_","
S DIEL=0,(D0,DA)=X Q
;
DIEZ ;
I X="" G @("A"_U_DNM)
S D=0,DL=DL+1,DNM(DL)=DNM,DNM(DL,0)=DQ,DIEL=DIEL+1 D DIEC G @DGO
;
A I $D(DR(DIE1,DP))>9 D OA ;Branching to "@N"
E F DG=1:1 S DH=$P(DR(DIE1,DP),";",DG) G X:DH="" I DH=X S:$D(DOV) DOV=0 S DR=DR(DIE1,DP) Q
S DK=DG,DI=X D ^DIE1 G JMP^DIE
OA S %=0 F S %=$O(DR(DIE1,DP,%)) Q:%="" F DG=1:1 S DH=$P(DR(DIE1,DP,%),";",DG) Q:DH="" I DH=X S DR=DR(DIE1,DP,%),DOV=%,%=9999 Q
S %=-1 Q
;
E ;UNEDITABLE & DINUM fields
I X="@" Q:DV'["I" G NO
Q:X[U!(X?."?")!DV!$D(DITC)
NO W:'$D(DB(DQ)) $C(7)," NO EDITING!!" K X
Q Q
;
;
;
S ;SCREEN fields; out= $T
N DDR S (%,DDFND)=0,DDR=DR(DIE1,DP),DDBK=0,Y=+Y
I $D(DIE("NO^")),DIE("NO^")["BACK" S DDBK=1
D S1 I DDFND Q
I 'DDONE,$D(DR(DL,DP))>9 F %=-1:0 S %=$O(DR(DIE1,DP,%)) Q:%="" S DDR=DR(DIE1,DP,%) D S1 Q:DDONE!DDFND
Q
S1 ;selectable?
S DDONE=0 F DG=1:1 D S2 Q:DDFND!DDONE!(DH="")
I DDFND S DOV=%,DR=$G(DR(DIE1,DP,%),$G(DR(DIE1,DP)))
Q
S2 ;parse for ;-piece
S DH=$P(DDR,";",DG) Q:(DH["///"&(DIC(0)'["F"))!'DH
;list
I 'DDBK,+DH=Y S DDFND=1 Q
I DDBK,+DH=DIFLD,+DH'=Y S DDONE=1 Q
I DDBK,+DH=Y S DDFND=1 Q
Q:$P(DH,"//")'[":"
;range
S A0=+$P(DH,":",1),A1=+$P(DH,":",2)
I 'DDBK,Y'<A0,Y'>A1 S DDFND=1 Q
F A2=A0-.000001:0 S A2=$O(^DD(DP,A2)) Q:A2>A1!'A2 S:A2=DIFLD&(A2'=Y)&DDBK DDONE=1 Q:DDONE I A2=Y,(A2'>DIFLD) S DDFND=1 Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIE0 3107 printed Oct 16, 2024@18:47:33 Page 2
DIE0 ;SFISC/GFT-BRANCHING, UP-ARROWING ;23DEC2005
+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 $DATA(DTOUT)
GOTO Q^DIE1
if X'?1"^".E
if $PIECE($PIECE(DQ(DQ),U,4),";E",2)
GOTO T^DIED
GOTO X
+8 ;**
IF $DATA(DIE("NO^"))
IF X=U
IF DIE("NO^")'["OUTOK"
WRITE !?3,$$EZBLD^DIALOG(3095)
GOTO X
+9 ;**
IF $DATA(DIE("NO^"))
IF X?1"^"1E.E
IF DIE("NO^")'["BACK"
WRITE !?3,$$EZBLD^DIALOG(3096)
GOTO X
+10 IF $LENGTH(X,"^")-1>1
SET X=$EXTRACT(X,2,99)
GOTO DIE0
+11 SET X=$PIECE(X,U,2)
SET DIC(0)="E"
OUT IF X=""!(DP<0)
SET DIK=X
SET DC=$SELECT($DATA(DQ(DQ))#2:$PIECE(DQ(DQ),U,4),1:DQ)
GOTO OUT^DIE1
+1 IF DR]""
if X?1"@".N
GOTO A
SET DIC("S")="D S^DIE0"
if '$DATA(DR(DIE1,DP))
SET DR(DIE1,DP)=DR
+2 SET DDBK=0
SET DIC="^DD("_DP_","
DO ^DIC
IF Y>0
DO S
+3 IF '$TEST
if DDBK
WRITE !?3,$$EZBLD^DIALOG(3097)
+4 KILL DTOUT,DIC,DDBK,DDFND,DDONE,A0,A1,A2
+5 IF Y<0
SET DG=DK
SET DH=":"_DM
GOTO X
+6 SET DI=$SELECT(DH[":":+Y,1:DH)
SET DK=DG
if $DATA(DG)>9
DO ^DIE1
KILL DG,DB,DE,DQ,DIFLD
SET DQ=0
GOTO JMP^DIE
X if X'["?"&'$DATA(ZTQUEUED)
WRITE $CHAR(7),"??"
if '$DATA(DB(DQ))
GOTO B^DIED
GOTO B^DIE1
+1 ;
BR ;From ^DIED
+1 ;MAKE SURE 'X' EXISTS, AFTER W-P
SET Y=U
SET X=$GET(X)
XECUTE DQ(0,DQ)
if $DATA(DIEFIRE)#2
DO FIREREC^DIE1
if $DATA(Y)[0
GOTO A^DIED
if Y=U
GOTO A^DIED
SET D=$SELECT(+Y=Y:9999,1:DQ)
SET X=""
IF 0[Y
SET DQ=0
GOTO OUT
D SET D=D+1
IF '$DATA(DQ(D))
if $DATA(DQ(0,D))
GOTO D
SET DQ=9999
SET X=Y
SET DIC(0)="FO"
GOTO OUT
+1 if $PIECE(DQ(D),Y,1)]""
GOTO D
SET DQ=D
GOTO RE^DIED
+2 ;
O ;From ^DIE
+1 KILL DQ
SET (DI,DV,DM)=0
IF X]""
IF $DATA(@(U_$PIECE(DC,U,3)_X_",0)"))#2
DO S^DIE1
DO DIEC
+2 SET DQ=0
GOTO MORE^DIE
+3 ;
DIEC SET DIE=U_$PIECE(DC,U,3)
SET DIEC(DL)=DA
FOR %=1:1
if '$DATA(DA(%))
QUIT
SET DIEC(DL,%)=DA(%)
+1 KILL DA,DB,DE,DG
FOR %=0:1:DIEL-1
SET DA="D"_%
SET DIEC(DL,0,%)=@DA
KILL @DA
+2 if $DATA(DIETMP)#2
SET DIEC(DL,"IENS")=DIIENS
SET DIIENS=X_","
+3 SET DIEL=0
SET (D0,DA)=X
QUIT
+4 ;
DIEZ ;
+1 IF X=""
GOTO @("A"_U_DNM)
+2 SET D=0
SET DL=DL+1
SET DNM(DL)=DNM
SET DNM(DL,0)=DQ
SET DIEL=DIEL+1
DO DIEC
GOTO @DGO
+3 ;
A ;Branching to "@N"
IF $DATA(DR(DIE1,DP))>9
DO OA
+1 IF '$TEST
FOR DG=1:1
SET DH=$PIECE(DR(DIE1,DP),";",DG)
if DH=""
GOTO X
IF DH=X
if $DATA(DOV)
SET DOV=0
SET DR=DR(DIE1,DP)
QUIT
+2 SET DK=DG
SET DI=X
DO ^DIE1
GOTO JMP^DIE
OA SET %=0
FOR
SET %=$ORDER(DR(DIE1,DP,%))
if %=""
QUIT
FOR DG=1:1
SET DH=$PIECE(DR(DIE1,DP,%),";",DG)
if DH=""
QUIT
IF DH=X
SET DR=DR(DIE1,DP,%)
SET DOV=%
SET %=9999
QUIT
+1 SET %=-1
QUIT
+2 ;
E ;UNEDITABLE & DINUM fields
+1 IF X="@"
if DV'["I"
QUIT
GOTO NO
+2 if X[U!(X?."?")!DV!$DATA(DITC)
QUIT
NO if '$DATA(DB(DQ))
WRITE $CHAR(7)," NO EDITING!!"
KILL X
Q QUIT
+1 ;
+2 ;
+3 ;
S ;SCREEN fields; out= $T
+1 NEW DDR
SET (%,DDFND)=0
SET DDR=DR(DIE1,DP)
SET DDBK=0
SET Y=+Y
+2 IF $DATA(DIE("NO^"))
IF DIE("NO^")["BACK"
SET DDBK=1
+3 DO S1
IF DDFND
QUIT
+4 IF 'DDONE
IF $DATA(DR(DL,DP))>9
FOR %=-1:0
SET %=$ORDER(DR(DIE1,DP,%))
if %=""
QUIT
SET DDR=DR(DIE1,DP,%)
DO S1
if DDONE!DDFND
QUIT
+5 QUIT
S1 ;selectable?
+1 SET DDONE=0
FOR DG=1:1
DO S2
if DDFND!DDONE!(DH="")
QUIT
+2 IF DDFND
SET DOV=%
SET DR=$GET(DR(DIE1,DP,%),$GET(DR(DIE1,DP)))
+3 QUIT
S2 ;parse for ;-piece
+1 SET DH=$PIECE(DDR,";",DG)
if (DH["///"&(DIC(0)'["F"))!'DH
QUIT
+2 ;list
+3 IF 'DDBK
IF +DH=Y
SET DDFND=1
QUIT
+4 IF DDBK
IF +DH=DIFLD
IF +DH'=Y
SET DDONE=1
QUIT
+5 IF DDBK
IF +DH=Y
SET DDFND=1
QUIT
+6 if $PIECE(DH,"//")'["
QUIT
+7 ;range
+8 SET A0=+$PIECE(DH,":",1)
SET A1=+$PIECE(DH,":",2)
+9 IF 'DDBK
IF Y'<A0
IF Y'>A1
SET DDFND=1
QUIT
+10 FOR A2=A0-.000001:0
SET A2=$ORDER(^DD(DP,A2))
if A2>A1!'A2
QUIT
if A2=DIFLD&(A2'=Y)&DDBK
SET DDONE=1
if DDONE
QUIT
IF A2=Y
IF (A2'>DIFLD)
SET DDFND=1
QUIT
+11 QUIT
