| [613] | 1 | DIE0 ;SFISC/GFT-BRANCHING, UP-ARROWING ;27MAR2006
|
|---|
| 2 | ;;22.0;VA FileMan;**60,159**;Mar 30, 1999;Build 8
|
|---|
| 3 | ;Per VHA Directive 2004-038, this routine should not be modified.
|
|---|
| 4 | G Q^DIE1:$D(DTOUT) G:X'?1"^".E T^DIED:$P($P(DQ(DQ),U,4),";E",2),X
|
|---|
| 5 | I $D(DIE("NO^")),X=U,DIE("NO^")'["OUTOK" W !?3,"EXIT NOT ALLOWED " G X
|
|---|
| 6 | I $D(DIE("NO^")),X?1"^"1E.E,DIE("NO^")'["BACK" W !?3,"JUMPING NOT ALLOWED " G X
|
|---|
| 7 | I $L(X,"^")-1>1 S X=$E(X,2,99) G DIE0
|
|---|
| 8 | S X=$P(X,U,2),DIC(0)="E"
|
|---|
| 9 | OUT I X=""!(DP<0) S DIK=X,DC=$S($D(DQ(DQ))#2:$P(DQ(DQ),U,4),1:DQ) G OUT^DIE1
|
|---|
| 10 | I DR]"" G A:X?1"@".N S DIC("S")="D S^DIE0" S:'$D(DR(DIE1,DP)) DR(DIE1,DP)=DR
|
|---|
| 11 | S DDBK=0,DIC="^DD("_DP_"," D ^DIC I Y>0 D S
|
|---|
| 12 | E W:DDBK !?3,"JUMPING FORWARD NOT ALLOWED "
|
|---|
| 13 | K DTOUT,DIC,DDBK,DDFND,DDONE,A0,A1,A2
|
|---|
| 14 | I Y<0 S DG=DK,DH=":"_DM G X
|
|---|
| 15 | 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
|
|---|
| 16 | X W:X'["?"&'$D(ZTQUEUED) $C(7),"??" G B^DIED:'$D(DB(DQ)),B^DIE1
|
|---|
| 17 | ;
|
|---|
| 18 | BR ;From ^DIED
|
|---|
| 19 | 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
|
|---|
| 20 | 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
|
|---|
| 21 | G D:$P(DQ(D),Y,1)]"" S DQ=D G RE^DIED
|
|---|
| 22 | ;
|
|---|
| 23 | O ;From ^DIE
|
|---|
| 24 | K DQ S (DI,DV,DM)=0 I X]"",$D(@(U_$P(DC,U,3)_X_",0)"))#2 D S^DIE1,DIEC
|
|---|
| 25 | S DQ=0 G MORE^DIE
|
|---|
| 26 | ;
|
|---|
| 27 | DIEC S DIE=U_$P(DC,U,3),DIEC(DL)=DA F %=1:1 Q:'$D(DA(%)) S DIEC(DL,%)=DA(%)
|
|---|
| 28 | K DA,DB,DE,DG F %=0:1:DIEL-1 S DA="D"_%,DIEC(DL,0,%)=@DA K @DA
|
|---|
| 29 | S:$D(DIETMP)#2 DIEC(DL,"IENS")=DIIENS,DIIENS=X_","
|
|---|
| 30 | S DIEL=0,(D0,DA)=X Q
|
|---|
| 31 | ;
|
|---|
| 32 | DIEZ ;
|
|---|
| 33 | I X="" G @("A"_U_DNM)
|
|---|
| 34 | S D=0,DL=DL+1,DNM(DL)=DNM,DNM(DL,0)=DQ,DIEL=DIEL+1 D DIEC G @DGO
|
|---|
| 35 | ;
|
|---|
| 36 | A I $D(DR(DIE1,DP))>9 D OA ;Branching to "@N"
|
|---|
| 37 | 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
|
|---|
| 38 | S DK=DG,DI=X D ^DIE1 G JMP^DIE
|
|---|
| 39 | 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
|
|---|
| 40 | S %=-1 Q
|
|---|
| 41 | ;
|
|---|
| 42 | E ;UNEDITABLE & DINUM fields
|
|---|
| 43 | I X="@" Q:DV'["I" G NO
|
|---|
| 44 | Q:X[U!(X?."?")!DV!$D(DITC)
|
|---|
| 45 | NO W:'$D(DB(DQ)) $C(7)," NO EDITING!!" K X
|
|---|
| 46 | Q Q
|
|---|
| 47 | ;
|
|---|
| 48 | ;
|
|---|
| 49 | ;
|
|---|
| 50 | S ;SCREEN fields; out= $T
|
|---|
| 51 | N DDR S (%,DDFND)=0,DDR=DR(DIE1,DP),DDBK=0,Y=+Y
|
|---|
| 52 | I $D(DIE("NO^")),DIE("NO^")["BACK" S DDBK=1
|
|---|
| 53 | D S1 I DDFND Q
|
|---|
| 54 | 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
|
|---|
| 55 | Q
|
|---|
| 56 | S1 ;selectable?
|
|---|
| 57 | S DDONE=0 F DG=1:1 D S2 Q:DDFND!DDONE!(DH="")
|
|---|
| 58 | I DDFND S DOV=%,DR=$G(DR(DIE1,DP,%),$G(DR(DIE1,DP)))
|
|---|
| 59 | Q
|
|---|
| 60 | S2 ;parse for ;-piece
|
|---|
| 61 | S DH=$P(DDR,";",DG) Q:(DH["///"&(DIC(0)'["F"))!'DH
|
|---|
| 62 | ;list
|
|---|
| 63 | I 'DDBK,+DH=Y S DDFND=1 Q
|
|---|
| 64 | I DDBK,+DH=DIFLD,+DH'=Y S DDONE=1 Q
|
|---|
| 65 | I DDBK,+DH=Y S DDFND=1 Q
|
|---|
| 66 | Q:$P(DH,"//")'[":"
|
|---|
| 67 | ;range
|
|---|
| 68 | S A0=+$P(DH,":",1),A1=+$P(DH,":",2)
|
|---|
| 69 | I 'DDBK,Y'<A0,Y'>A1 S DDFND=1 Q
|
|---|
| 70 | 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
|
|---|
| 71 | Q
|
|---|
