- DIE0 ;SFISC/GFT-BRANCHING, UP-ARROWING ;27MAR2006
- ;;22.0;VA FileMan;**60,159**;Mar 30, 1999;Build 8
- ;Per VHA Directive 2004-038, this routine should not be modified.
- 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,"EXIT NOT ALLOWED " G X
- I $D(DIE("NO^")),X?1"^"1E.E,DIE("NO^")'["BACK" W !?3,"JUMPING NOT ALLOWED " 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,"JUMPING FORWARD NOT ALLOWED "
- 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
- 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
- DIE0 ;SFISC/GFT-BRANCHING, UP-ARROWING ;27MAR2006
- +1 ;;22.0;VA FileMan;**60,159**;Mar 30, 1999;Build 8
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 IF $DATA(DTOUT)
- GOTO Q^DIE1
- IF X'?1"^".E
- IF $PIECE($PIECE(DQ(DQ),U,4),";E",2)
- GOTO T^DIED
- GOTO X
- +4 IF $DATA(DIE("NO^"))
- IF X=U
- IF DIE("NO^")'["OUTOK"
- WRITE !?3,"EXIT NOT ALLOWED "
- GOTO X
- +5 IF $DATA(DIE("NO^"))
- IF X?1"^"1E.E
- IF DIE("NO^")'["BACK"
- WRITE !?3,"JUMPING NOT ALLOWED "
- GOTO X
- +6 IF $LENGTH(X,"^")-1>1
- SET X=$EXTRACT(X,2,99)
- GOTO DIE0
- +7 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,"JUMPING FORWARD NOT ALLOWED "
- +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 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
