- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIE0.m
r613 r623 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 1 DIE0 ;SFISC/GFT-BRANCHING, UP-ARROWING ;5:49 AM 21 Sep 2000 2 ;;22.0;VA FileMan;**60**;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, 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(DL,DP)) DR(DL,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,DDR,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 ; 19 S Y=U 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 ; 24 K DQ S (DI,DV,DM)=0 D DUZ 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 DUZ Q:X=""!(DUZ(0)="@") 33 ;S DIFILE=$P(DC,U,2),DIAC="WR" D ^DIAC K DIAC,DIFILE G:'% 3 34 Q 35 3 ;W $C(7),!?7,"(YOU DO NOT HAVE 'WRITE ACCESS' TO THE '"_$P(^DIC($P(DC,U,2),0),U)_"' FILE)" S X="" 36 Q 37 ; 38 DIEZ ; 39 D DUZ I X="" G @("A"_U_DNM) 40 S D=0,DL=DL+1,DNM(DL)=DNM,DNM(DL,0)=DQ,DIEL=DIEL+1 D DIEC G @DGO 41 ; 42 A I $D(DR(DL,DP))>9 D OA 43 E F DG=1:1 S DH=$P(DR(DL,DP),";",DG) G X:DH="" I DH=X S:$D(DOV) DOV=0 S DR=DR(DL,DP) Q 44 S DK=DG,DI=X D ^DIE1 G JMP^DIE 45 OA S %=0 F S %=$O(DR(DL,DP,%)) Q:%="" F DG=1:1 S DH=$P(DR(DL,DP,%),";",DG) Q:DH="" I DH=X S DR=DR(DL,DP,%),DOV=%,%=9999 Q 46 S %=-1 Q 47 ; 48 E ; 49 I X="@" Q:DV'["I" G NO 50 Q:X[U!(X?."?")!DV!$D(DITC) 51 NO W:'$D(DB(DQ)) $C(7)," NO EDITING!!" K X 52 Q Q 53 S ;reg or ovfl, out= $T 54 S (%,DDFND)=0,DDR=DR(DL,DP),DDBK=0,Y=+Y 55 I $D(DIE("NO^")),DIE("NO^")["BACK" S DDBK=1 56 D S1 I DDFND Q 57 I 'DDONE,$D(DR(DL,DP))>9 F %=-1:0 S %=$O(DR(DL,DP,%)) Q:%="" S DDR=DR(DL,DP,%) D S1 Q:DDONE!DDFND 58 Q 59 S1 ;selectable? 60 S DDONE=0 F DG=1:1 D S2 Q:DDFND!DDONE!(DH="") 61 I DDFND S DOV=%,DR=$S($D(DR(DL,DP,%)):DR(DL,DP,%),$D(DR(DL,DP)):DR(DL,DP),1:"") 62 Q 63 S2 ;parse for ;-piece 64 S DH=$P(DDR,";",DG) Q:(DH["///"&(DIC(0)'["F"))!'DH 65 ;list 66 I 'DDBK,+DH=Y S DDFND=1 Q 67 I DDBK,+DH=DIFLD,+DH'=Y S DDONE=1 Q 68 I DDBK,+DH=Y S DDFND=1 Q 69 Q:$P(DH,"//")'[":" 70 ;range 71 S A0=+$P(DH,":",1),A1=+$P(DH,":",2) 72 I 'DDBK,Y'<A0,Y'>A1 S DDFND=1 Q 73 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 74 Q
Note:
See TracChangeset
for help on using the changeset viewer.