- 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/DIA.m
r613 r623 1 DIA ;SFISC/GFT-SELECT FIELDS TO EDIT ;4JUNE2008 2 ;;22.0;VA FileMan;**159**;Mar 30, 1999;Build 8 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 D DICS 5 1 D F W !?F*3,"EDIT WHICH "_X I $S(DB:DIAT="",1:1) R ": ALL// ",X:DTIME S:'$T X=U,DTOUT=1 G ALL^DIA1:X=""!(X="ALL"),TEMP^DIA1:X?1"[".E&'F,L 6 ED G NDB:DIAT="" 7 GDB S Y=$P(DIAT,";",DB) I "Q"[Y G NDB:Y="" D DB G GDB 8 I Y?.NP,$P(Y,":",2),Y'["/" S Y=+Y_"-"_$P(Y,":",2) 9 S %=$G(DI(DB,DIARTLVL-1,DI,DIAO)) I %]"" S Y=% 10 E I Y?1"^"1N1"."1.2N S DB=DB+1 G GDB ;WPB-0804-30857 11 W ": "_Y D RW 12 I X="" S X=Y I X="ALL" G ALL^DIA1 13 L S DSC=X?1"^".E I DSC S X=$E(X,2,999) I U[X K DR Q 14 I $A(X)=64 G X:X'?1P.N,P:$L(X)>1,X:'DB S DB=DB+1 G 2 15 K DIC,DIAB D DICS S DV="",J=$P(X,"-",2) I +J=J,$P(X,"-",1)=+X,J>X S D(F)=J K DA D RANGE^DIA1 K D S Y=DA G X:Y="" D DB G 2 16 DIC ; 17 S DIC(0)="EZI",DIC="^DD(DI,",Y=-1 G X^DIA3:X[";" S DIC("W")="S %=$P(^(0),U,2) I % W $S($P(^DD(+%,.01,0),U,2)[""W"":"" (word-processing)"",1:"" (multiple)"")" D ^DIC Q:$D(DTOUT) 18 I Y>0 D SET S Y=$P(Y(0),U,2) G 2:'Y S L=L+1,(DI,J(L))=+Y,I(L)=""""_$P($P(Y(0),U,4),";")_"""" G DOWN 19 I $E(X)="]" S DRS=9,X=$E(X,2,999) G DIC:X]"",2 20 G DIA^DIQQQ:X?."?" I $D(^DD(DI,"GR")) K Y S Y=-1 D:$L(X)<31 21 . N I,DIGRP,DTOUT,DUOUT,DIRUT,DIROUT,DIYN S DIGRP=X,DIYN=0 22 . D:$D(^DD(DI,"GR",DIGRP)) Q:DIYN F S DIGRP=$O(^DD(DI,"GR",DIGRP)) Q:$E(DIGRP,1,$L(X))'=X D Q:DIYN 23 .. N X,I 24 .. F I=0:0 S I=$O(^DD(DI,"GR",DIGRP,I)) Q:'I I $G(^DD(DI,I,0))]"" S I(I)=I_U_$P(^(0),U) 25 .. Q:'$O(I(0)) 26 .. W !!,"Fields in Group: ",DIGRP F I=0:0 S I=$O(I(I)) Q:'I W !,?2,I,?10,$P(I(I),U,2) 27 .. D Q:DIYN'=1 28 ... N X,Y S DIR(0)="Y",DIR("A")="Edit this GROUP of fields",DIR("B")="YES" D ^DIR S DIYN=$S(Y=1:1,$G(DIRUT):2,1:0) Q 29 .. M Y=I S Y=0 Q 30 . Q 31 K DIYN G X^DIA3 32 ; 33 F S X=$P(^DD(DI,0),U) I F,X="FIELD" S X=$O(^(0,"NM",0))_" "_X 34 Q 35 ; 36 X ; 37 W $C(7),"??" D DICS 38 2 ; 39 G 1:'$D(DR(F+1,DI)) D F W !?F*3,"THEN EDIT "_X G ED:DB 40 R R ": ",X:DTIME E W $C(7) S X=U,DTOUT=1 41 I X]"" G L 42 UP ; 43 G ^DIA1:'F K I(L),J(L) S L=L-1 I '$D(J(L)) F L=L-99:1 Q:'$D(J(L+1)) 44 I DB S DB=DB(F),DIARTLVL=DIARTLVL(F),DIAO=DIAO(F),DIAT=$S(DIAO<0:"",DIAO:$G(^DIE(DIAA,"DR",DIARTLVL,J(L),DIAO)),$D(^DIE(DIAA,"DR",DIARTLVL,J(L))):^(J(L)),1:"") 45 S DIARLVL=DIARLVL(F),DIAP=DIAP(F),DI=J(L),F=F-1 G 2 46 ; 47 NDB I DB,DIAO'<0 S DIAO=DIAO+1 I $D(^DIE(DIAA,"DR",DIARLVL,DI,DIAO)) S DIAT=^(DIAO),DB=1 G GDB 48 S DIAO=-1 G R 49 ; 50 ; 51 ; 52 EN ;Entry point from DIB routine 53 N DIARTLVL,DIARLVL,DIAL,DIESP,DRR D OS^DII:'$D(DISYS) 54 FILETOP D DICS ;Enter from DIA3 when there is a file jump 55 DOWN S F=F+1,DIAL(F)=+$G(DIAL),DIARLVL(F)=+$G(DIARLVL) F %=F+1:.01 I '$D(DR(%,DI)) Q ;Find 2.01 if we have already gone down to DR(2,DI) -- WPB-0804-30857 56 S:%["." @DRR=@DRR_U_%_";",DIAP=DIAP+1 S DIARLVL=% 57 S DIAP(F)=DIAP,DIAP=0 58 I DB S DIARTLVL(F)=DIARTLVL D S DB(F)=DB,DB=1,DIAO(F)=DIAO,DIAO=0,DIAT=$G(^DIE(DIAA,"DR",DIARTLVL,DI)),DIARTLVL(DIARTLVL,DI)="" 59 .S %=$P(DIAT,";",DB) I %?1"^"1.NP S DIARTLVL=$P(%,U,2),DB=DB+1 Q 60 .F DIARTLVL=F+1:.01 I '$D(DIARTLVL(DIARTLVL,DI)) Q 61 G 1:$P(^DD(DI,.01,0),U,2)'["W",1:L#100=0,UP 62 ; 63 DICS ; 64 S DIC("S")="I Y>.001,$P(^(0),U,2)'[""C"""_$S(DUZ(0)="@":"",1:",$P(^(0),U,2)'[""K""")_" Q:'$D(^(9)) I ^(9)'=U"_$S(DUZ(0)'="@":" F DW=1:1:$L(^(9)) I DUZ(0)[$E(^(9),DW) Q",1:"") Q 65 ; 66 P ; 67 S DRS=99,Y=X D DB G 2 68 ; 69 SET S Y=+Y_DV 70 DB ; 71 I DB,'DSC S DB=DB+1 72 D ;takes 'Y' and puts it into 'DR' array -- Also called from DIA3 73 N %,B 74 S (DRR,B)=$NA(DR(DIARLVL,DI)),%=$O(@DRR@(""),-1) 75 I % S DRR=$NA(@DRR@(%)) 76 I '$D(@DRR) S @DRR="",DIAP=0 77 E I $L(Y)+$L(@DRR)>230 S DRR=$NA(@B@(%+1)),DIAP=DIAP\1000+1*1000,@DRR="" 78 S @DRR=@DRR_Y_";",DRS=$G(DRS)+1 79 S DIAP=DIAP+1 80 DIAB I $D(DIAB) S ^UTILITY($J,DIAP#1000,DIARLVL-1,DI,DIAP\1000)=DIAB K DIAB 81 Q 82 ; 83 RW I $L(Y)>19 D RW^DIR2 Q 84 W "// " R X:DTIME I '$T S X=U,DTOUT=1 W $C(7) 1 DIA ;SFISC/GFT-SELECT FIELDS TO EDIT ;7/10/97 11:37 2 ;;22.0;VA FileMan;;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 ;12999;7752413;3179; 5 ; 6 D DICS 7 1 D F W !?F*3,"EDIT WHICH "_X I $S(DB:DIAT="",1:1) R ": ALL// ",X:DTIME S:'$T X=U,DTOUT=1 G ALL^DIA1:X=""!(X="ALL"),TEMP^DIA1:X?1"[".E&'F,L 8 ED G NDB:DIAT="" 9 GDB S Y=$P(DIAT,";",DB) I "Q"[Y G NDB:Y="" D DB G GDB 10 I Y?.NP,$P(Y,":",2),Y'["/" S Y=+Y_"-"_$P(Y,":",2) 11 I $D(DI(DB)),$D(DI(DB,F,DI,DIAO)) S Y=DI(DB,F,DI,DIAO) 12 W ": "_Y D RW 13 I X="" S X=Y I X="ALL" G ALL^DIA1 14 L S DSC=X?1"^".E I DSC S X=$E(X,2,999) I U[X K DR Q 15 I $A(X)=64 G X:X'?1P.N,P:$L(X)>1,X:'DB S DB=DB+1 G 2 16 K DIC,DIAB D DICS S DV="",J=$P(X,"-",2) I +J=J,$P(X,"-",1)=+X,J>X S D(F)=J K DA D RANGE^DIA1 K D S Y=DA G X:Y="" D DB G 2 17 DIC ; 18 S DIC(0)="EZI",DIC="^DD(DI,",Y=-1 G X^DIA3:X[";" S DIC("W")="S %=$P(^(0),U,2) I % W $S($P(^DD(+%,.01,0),U,2)[""W"":"" (word-processing)"",1:"" (multiple)"")" D ^DIC Q:$D(DTOUT) 19 I Y>0 D SET S Y=$P(Y(0),U,2) G 2:'Y S L=L+1,(DI,J(L))=+Y,I(L)=""""_$P($P(Y(0),U,4),";",1)_"""" G DOWN 20 I $E(X)="]" S DRS=9,X=$E(X,2,999) G DIC:X]"",2 21 G DIA^DIQQQ:X?."?" I $D(^DD(DI,"GR")) K Y S Y=-1 D:$L(X)<31 22 . N I,DIGRP,DTOUT,DUOUT,DIRUT,DIROUT,DIYN S DIGRP=X,DIYN=0 23 . D:$D(^DD(DI,"GR",DIGRP)) Q:DIYN F S DIGRP=$O(^DD(DI,"GR",DIGRP)) Q:$E(DIGRP,1,$L(X))'=X D Q:DIYN 24 .. N X,I 25 .. F I=0:0 S I=$O(^DD(DI,"GR",DIGRP,I)) Q:'I I $G(^DD(DI,I,0))]"" S I(I)=I_U_$P(^(0),U) 26 .. Q:'$O(I(0)) 27 .. W !!,"Fields in Group: ",DIGRP F I=0:0 S I=$O(I(I)) Q:'I W !,?2,I,?10,$P(I(I),U,2) 28 .. D Q:DIYN'=1 29 ... N X,Y S DIR(0)="Y",DIR("A")="Edit this GROUP of fields",DIR("B")="YES" D ^DIR S DIYN=$S(Y=1:1,$G(DIRUT):2,1:0) Q 30 .. M Y=I S Y=0 Q 31 . Q 32 K DIYN G X^DIA3 33 ; 34 F S X=$P(^DD(DI,0),U,1) I F,X="FIELD" S X=$O(^(0,"NM",0))_" "_X 35 Q 36 ; 37 X ; 38 W $C(7),"??" D DICS 39 2 ; 40 G 1:'$D(DR(F+1,DI)) D F W !?F*3,"THEN EDIT "_X G ED:DB 41 R R ": ",X:DTIME E W $C(7) S X=U,DTOUT=1 42 I X]"" G L 43 UP ; 44 G ^DIA1:'F K I(L),J(L) S L=L-1 I '$D(J(L)) F L=L-99:1 Q:'$D(J(L+1)) 45 I DB S DB=DB(F),DIAO=DIAO(F),DIAT=$S(DIAO<0:"",DIAO:^DIE(DIAA,"DR",F,J(L),DIAO),$D(^DIE(DIAA,"DR",F,J(L))):^(J(L)),1:"") 46 S DIAP=DIAP(F),DI=J(L),F=F-1 G 2 47 ; 48 NDB I DB,DIAO'<0 S DIAO=DIAO+1 I $D(^DIE(DIAA,"DR",F+1,DI,DIAO)) S DIAT=^(DIAO),DB=1 G GDB 49 S DIAO=-1 G R 50 ; 51 EN ; 52 D OS^DII:'$D(DISYS),DICS 53 DOWN S F=F+1,DIAP(F)=DIAP,DIAP=0 I DB S DB(F)=DB,DB=1,DIAO(F)=DIAO,DIAO=0,DIAT=$S($D(^DIE(DIAA,"DR",F+1,DI)):^(DI),1:"") 54 G 1:$P(^DD(DI,.01,0),U,2)'["W",1:L#100=0,UP 55 DICS ; 56 S DIC("S")="I Y>.001,$P(^(0),U,2)'[""C"""_$S(DUZ(0)="@":"",1:",$P(^(0),U,2)'[""K""")_" Q:'$D(^(9)) I ^(9)'=U"_$S(DUZ(0)'="@":" F DW=1:1:$L(^(9)) I DUZ(0)[$E(^(9),DW) Q",1:"") Q 57 ; 58 P ; 59 S DRS=99,Y=X D DB G 2 60 ; 61 SET S Y=+Y_DV 62 DB ; 63 I DB,'DSC S DB=DB+1 64 D ; 65 I '$D(DR(F+1,DI)) S DR(F+1,DI)="",DIAP=0 66 E I $L(DR(F+1,DI))+$L(Y)>230 F %=0:1 I '$D(DW(DI,%)) S DIAP=DIAP\1000+1*1000,DW(DI)=F+1,DW(DI,%)=DR(F+1,DI),DR(F+1,DI)="" Q 67 S DR(F+1,DI)=DR(F+1,DI)_Y_";",DRS=DRS+1,DIAP=DIAP+1 I $D(DIAB) S ^UTILITY($J,DIAP#1000,F,DI,DIAP\1000)=DIAB K DIAB 68 Q 69 RW I $L(Y)>19 D RW^DIR2 Q 70 W "// " R X:DTIME I '$T S X=U,DTOUT=1 W $C(7)
Note:
See TracChangeset
for help on using the changeset viewer.