- Timestamp:
- Dec 4, 2009, 12:11:15 AM (16 years ago)
- Location:
- WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR
- Files:
-
- 24 edited
-
DIA.m (modified) (1 diff)
-
DIA1.m (modified) (1 diff)
-
DIA3.m (modified) (1 diff)
-
DIC3.m (modified) (1 diff)
-
DIC5.m (modified) (1 diff)
-
DICATT2.m (modified) (1 diff)
-
DICM.m (modified) (1 diff)
-
DICOMP0.m (modified) (1 diff)
-
DICOMP1.m (modified) (1 diff)
-
DICOMPZ.m (modified) (1 diff)
-
DID1.m (modified) (1 diff)
-
DIE.m (modified) (1 diff)
-
DIE0.m (modified) (1 diff)
-
DIE1.m (modified) (1 diff)
-
DIETED.m (modified) (1 diff)
-
DIEZ.m (modified) (1 diff)
-
DIEZ0.m (modified) (1 diff)
-
DIEZ2.m (modified) (1 diff)
-
DIL11.m (modified) (1 diff)
-
DINIT0F0.m (modified) (1 diff)
-
DINIT0F5.m (modified) (1 diff)
-
DIWE1.m (modified) (1 diff)
-
DIWP.m (modified) (1 diff)
-
DIWW.m (modified) (1 diff)
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) -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIA1.m
r613 r623 1 DIA1 ;SFISC/GFT-PROCESS TEMPLATES, RANGES FOR INPUT ;20MAR2006 2 ;;22.0;VA FileMan;**159**;Mar 30, 1999;Build 8 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 S D NOW^%DTC S DIADT=+$J(%,0,4) K %,DW G Q:DRS<5 R !,"STORE THESE FIELDS IN TEMPLATE: ",X:DTIME S:'$T DTOUT=1 G Q:X="" S DIC(0)="LZSEQ",DLAYGO=0 D T K DLAYGO,DIC I Y<0 G S:X'[U K DR G Q 5 S X=$P(^(0),U,6) I DUZ(0)'["@",X]"" F %=1:1 I DUZ(0)[$E(X,%) Q:%'>$L(X) W !?7,$C(7),"YOU HAVE NO 'WRITE ACCESS' TO THIS TEMPLATE",! G S 6 S DW=$S('$D(^("ROU")):1,^("ROU")'[U:1,$D(^("ROUOLD")):^("ROUOLD"),1:1),%=0,X=$P(Y,U,2) 7 I $O(^(0))]"" W $C(7),!,X_" TEMPLATE ALREADY EXISTS.... OK TO REPLACE" D YN^DICN W ! G S:%-1 L +^DIE(+Y) S %Y="" F %X=0:0 S %Y=$O(^DIE(+Y,%Y)) Q:%Y="" K:",%D,ROUOLD,W,"'[(","_%Y_",") ^(%Y) 8 S ^DIE(+Y,0)=X_U_DIADT_U_$S('%:DUZ(0),1:$P(Y(0),U,3))_U_DI_U_DUZ_U_$S('%:DUZ(0),1:$P(Y(0),U,6))_U_DT,^DIE("F"_DI,X,+Y)=1 L -^DIE(+Y) 9 M S %X="DR(",%Y="^DIE(+Y,""DR""," D %XY^%RCR M ^DIE(+Y,"DIAB")=^UTILITY($J) 10 S X=DW,DP=DIA("P"),DMAX=^DD("ROU") I X'=1,$D(^DD("OS",DISYS,"ZS")) D EN^DIEZ S DR(1,DIA("P"))=U_DNM 11 Q K DNM,DIAO,DI,DIAP,%,%I,DIADT,DIAT,DIE,DMAX,%X,%Y Q 12 ; 13 ALL ;Called by DIETED, DIA 14 S %=DI,^UTILITY($J,1,F,%,DIAP\1000)="ALL" K DA D G UP^DIA:F,S:$D(DRS) Q 15 .N DIA1 S DIA1=DIARLVL D A 16 ; 17 RANGE ;called by DIA, DIE17, DIETED 18 N DIA1 S DIA1=F+1 S %=DI I X>0 S Y=X-.000001 G B 19 A S Y=0 20 B S DA="",X=0 21 G S DG=Y 22 DR S Y=$O(^DD(%,Y)) S:Y="" Y=-1 I $D(D(F)),Y'>0!(Y>D(F)) D DG:X Q 23 I Y'>0 D DG:X S:$D(DR(DIA1,%))[0 DR(DIA1,%)=DA Q 24 I $D(^(Y,0)),X X DIC("S") G G:$T D DG G DR 25 X DIC("S") E G DR 26 S X=Y G G 27 ; 28 DG S DA=DA_$E(";",1,$L(DA))_X_$P(":"_DG,U,X'=DG) 29 S DQ=0 F S DQ=$O(^DD(%,"SB",DQ)) Q:DQ="" S DP=$O(^(DQ,0)) I DP'<X,DP'>DG S Y(F,DQ)="" 30 S DQ=-1 31 Y S X=$O(Y(F,0)) I X>0 K Y(F,X) S DA(F)=DA,Y(F)=Y,%(F)=%,F=F+1,DIA1=DIA1+1,%=X D A S F=F-1,DIA1=DIA1-1,%=%(F),Y=Y(F),DA=DA(F) G Y 32 S X="",DG=0 K DP Q 33 ; 34 TEMP ; 35 S DIC(0)="ZSEQ" D T K DIC Q:$D(DTOUT) G DB:Y<0 36 S %=$P(Y(0),U,6) G ED:DUZ(0)="@"!'$L(%) F X=1:1:$L(%) I DUZ(0)[$E(%,X) G ED 37 GT I $G(^("ROU"))[U S DR(1,DIA("P"))=^("ROU") 38 E S:$D(^("W")) DIE("W")=^("W") S %X="^DIE(+Y,""DR"",",%Y="DR(" D %XY^%RCR 39 S $P(^DIE(+Y,0),U,7)=DT 40 Q 41 ; 42 T K DIC("W") S D="F"_DI,X=$P(X,"]",1),X=$P(X,"[",1)_$P(X,"[",2),DIC="^DIE(",DIC("S")="I $P(^(0),U,4)=DI"_$P(" S %=$P(^(0),U,3) F DW=1:1:$L(%) I DUZ(0)[$E(%,DW) Q",9,DUZ(0)'="@") G IX^DIC 43 ; 44 ED I Y<1 G GT 45 S %=2 W !,"WANT TO EDIT '",$P(Y,U,2),"' INPUT TEMPLATE" D YN^DICN G GT:%-1 46 S DIE="^DIE(",DA=+Y,DR=".01;3;6" D ^DIE K DR I '$D(DA) S DB=0 G DB 47 S:$D(^DIE(DA,"DR"))#2 ^("DR",1,J(0))=^("DR") 48 S DIAA=DA,DRS=9,DIAT=$S($D(^DIE(DA,"DR",1,J(0))):^(J(0)),1:"") 49 M DI=^DIE(DA,"DIAB") 50 S F=0,(DIARTLVL,DB)=1,DIAO=0 F DXS=1:1 Q:'$D(DR(99,DXS)) 51 DB S DI=J(0) G ^DIA 1 DIA1 ;SFISC/GFT-PROCESS TEMPLATES, RANGES FOR INPUT ;2/22/93 3:29 PM 2 ;;22.0;VA FileMan;;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 S X="" F S X=$O(DW(X)) Q:X'>0 S F=DW(X),J=DR(F,X),DR(F,X)=DW(X,0),I=1 D OV 5 S D NOW^%DTC S DIADT=+$J(%,0,4) K %,DW G Q:DRS<5 R !,"STORE THESE FIELDS IN TEMPLATE: ",X:DTIME S:'$T DTOUT=1 G Q:X="" S DIC(0)="LZSEQ",DLAYGO=0 D T K DLAYGO,DIC I Y<0 G S:X'[U K DR G Q 6 S X=$P(^(0),U,6) I DUZ(0)'["@",X]"" F %=1:1 I DUZ(0)[$E(X,%) Q:%'>$L(X) W !?7,$C(7),"YOU HAVE NO 'WRITE ACCESS' TO THIS TEMPLATE",! G S 7 S DW=$S('$D(^("ROU")):1,^("ROU")'[U:1,$D(^("ROUOLD")):^("ROUOLD"),1:1),%=0,X=$P(Y,U,2) 8 I $O(^(0))]"" W $C(7),!,X_" TEMPLATE ALREADY EXISTS.... OK TO REPLACE" D YN^DICN W ! G S:%-1 L +^DIE(+Y) S %Y="" F %X=0:0 S %Y=$O(^DIE(+Y,%Y)) Q:%Y="" K:",%D,ROUOLD,W,"'[(","_%Y_",") ^(%Y) 9 S ^DIE(+Y,0)=X_U_DIADT_U_$S('%:DUZ(0),1:$P(Y(0),U,3))_U_DI_U_DUZ_U_$S('%:DUZ(0),1:$P(Y(0),U,6))_U_DT,^DIE("F"_DI,X,+Y)=1 L -^DIE(+Y) 10 S %X="DR(",%Y="^DIE(+Y,""DR""," D %XY^%RCR S %X="^UTILITY($J,",%Y="^DIE(+Y,""DIAB""," D %XY^%RCR S X=DW,DP=DIA("P"),DMAX=^DD("ROU") I X'=1,$D(^DD("OS",DISYS,"ZS")) D EN^DIEZ S DR(1,DIA("P"))=U_DNM 11 Q K DNM,DIAO,DI,DIAP,%,%I,DIADT,DIAT,DIE,DMAX,%X,%Y Q 12 ; 13 ALL ; 14 S %=DI,^UTILITY($J,1,F,%,DIAP\1000)="ALL" K DA D A G UP^DIA:F,S:$D(DRS) Q 15 ; 16 RANGE ; 17 S %=DI I X>0 S Y=X-.000001 G B 18 A S Y=0 19 B S DA="",X=0 20 G S DG=Y 21 DR S Y=$O(^DD(%,Y)) S:Y="" Y=-1 I $D(D(F)),Y'>0!(Y>D(F)) D DG:X Q 22 I Y'>0 D DG:X S:$D(DR(F+1,%))[0 DR(F+1,%)=DA Q 23 I $D(^(Y,0)),X X DIC("S") G G:$T D DG G DR 24 X DIC("S") E G DR 25 S X=Y G G 26 ; 27 DG S DA=DA_$E(";",1,$L(DA))_X_$P(":"_DG,U,X'=DG) 28 S DQ=0 F S DQ=$O(^DD(%,"SB",DQ)) Q:DQ="" S DP=$O(^(DQ,0)) I DP'<X,DP'>DG S Y(F,DQ)="" 29 S DQ=-1 30 Y S X=$O(Y(F,0)) I X>0 K Y(F,X) S DA(F)=DA,Y(F)=Y,%(F)=%,F=F+1,%=X D A S F=F-1,%=%(F),Y=Y(F),DA=DA(F) G Y 31 S X="",DG=0 K DP Q 32 ; 33 TEMP ; 34 S DIC(0)="ZSEQ" D T K DIC Q:$D(DTOUT) G DB:Y<0 35 S %=$P(Y(0),U,6) G ED:DUZ(0)="@"!'$L(%) F X=1:1:$L(%) I DUZ(0)[$E(%,X) G ED 36 GT I $D(^("ROU")),^("ROU")[U S DR(1,DIA("P"))=^("ROU") 37 E S:$D(^("W")) DIE("W")=^("W") S:$D(^("DR"))#2 ^("DR",1,DIA("P"))=^("DR") S %X="^DIE(+Y,""DR"",",%Y="DR(" D %XY^%RCR 38 S $P(^DIE(+Y,0),U,7)=DT 39 Q 40 ; 41 T K DIC("W") S D="F"_DI,X=$P(X,"]",1),X=$P(X,"[",1)_$P(X,"[",2),DIC="^DIE(",DIC("S")="I $P(^(0),U,4)=DI"_$P(" S %=$P(^(0),U,3) F DW=1:1:$L(%) I DUZ(0)[$E(%,DW) Q",9,DUZ(0)'="@") G IX^DIC 42 ; 43 ED I Y<1 G GT 44 S %=2 W !,"WANT TO EDIT '",$P(Y,U,2),"' INPUT TEMPLATE" D YN^DICN G GT:%-1 45 S DIE="^DIE(",DA=+Y,DR=".01;3;6" D ^DIE K DR I '$D(DA) S DB=0 G DB 46 S:$D(^DIE(DA,"DR"))#2 ^("DR",1,J(0))=^("DR") 47 S DIAA=DA,DRS=9,DIAT=$S($D(^DIE(DA,"DR",1,J(0))):^(J(0)),1:"") 48 I $D(^DIE(DA,"DIAB")) S %X="^DIE(DA,""DIAB"",",%Y="DI(" D %XY^%RCR 49 S F=0,DB=1,DIAO=0 F DXS=1:1 Q:'$D(DR(99,DXS)) 50 DB S DI=J(0) G ^DIA 51 ; 52 OV I '$D(DW(X,I)) S DR(F,X,I)=J Q 53 S DR(F,X,I)=DW(X,I),I=I+1 G OV -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIA3.m
r613 r623 1 DIA3 ;SFISC/GFT-UPDATE POINTERS, CHECK CODE IN INPUT STRING, CHECK FILE ACCESS ;19SEP2004 2 ;;22.0;VA FileMan;**159**;Mar 30, 1999;Build 8 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 S Y=DIA("P"),DH=1,DTO=DIA D PTS^DIT:'$D(^UTILITY("DIT",$J,0)) S ^UTILITY("DIT",$J,0)=0 Q:$D(^(0))<9 5 D ASK^DITP Q:%-1 6 S Y=0 I @("$O("_DIC_"0))'>0") G D 7 C W !,"WHICH DO YOU WANT TO DO? --",!?4,"1) DELETE ALL SUCH POINTERS",!?4,"2) CHANGE ALL SUCH POINTERS TO POINT TO A DIFFERENT '"_$P(^(0),U,1)_"' ENTRY",!!,"CHOOSE 1) OR 2): " R %:DTIME G F:U[%,W:%=2,C:%'=1 8 D W !,"DELETE ALL POINTERS" D YN^DICN G F:%<0,C:%-1,DITP 9 W W !,"THEN PLEASE INDICATE WHICH ENTRY SHOULD BE POINTED TO" D L^DIA2 G DITP:Y>0 10 F W $C(7),!,"OK... FORGET IT... LET'S GO ON TO EDIT ANOTHER ENTRY" Q 11 DITP S (^UTILITY("DIT",$J,DIA(1)),^(DIA(1)_";"_$E(DIA,2,999)))=+Y_";"_$E(DIA,2,999) 12 W !?4,"("_$P("DELETION^RE-POINTING",U,''Y+1)_" WILL OCCUR WHEN YOU LEAVE 'ENTER/EDIT' OPTION)" 13 Q 14 ; 15 FIXPT(DIFLG,DIFILE,DIDELIEN,DIPTIEN) ;DELETE OR REPOINT POINTERS 16 ;In V21, will just delete pointers. Later, DIPTIEN will be record to repoint to. 17 ;DIFLG="D" (delete), DIFILE=File# previously pointed to, DIDELIEN=Record# previously pointed to, DIPTIEN=New pointed-to record(future) 18 N %X,%Y,X,Y,DIPTIEN,DIFIXPT,DIFIXPTC,DIFIXPTH D I $G(X)]"" D BLD^DIALOG(201,X) Q 19 . S X="DIFLG" Q:$G(DIFLG)'="D" S X="DIDELIEN" Q:'$G(DIDELIEN) S X="DIFILE" Q:'$G(DIFILE) Q:$G(^DIC(DIFILE,0,"GL"))="" 20 . S X="DIPTIEN" I $G(DIPTIEN) S Y=$G(^DD(DIFILE,0,"GL")) Q:Y="" I '$D(@(Y_DIPTIEN_",0)")) Q 21 . K X Q 22 S DIPTIEN=+$G(DIPTIEN),(DIFIXPT,DIFIXPTC)=1 23 N %,BY,D,DHD,DHIT,DIA,DIC,DISTOP,DL,DR,DTO,FLDS,FR,IOP,L,TO,X,Y,Z K ^UTILITY("DIT",$J),^TMP("DIFIXPT",$J) 24 S (DIFILE,DIA("P"),Y)=+DIFILE,(DIA,DTO)=^DIC(DIFILE,0,"GL"),DIA(1)=DIDELIEN 25 D PTS^DIT S ^UTILITY("DIT",$J,0)=0 G:$D(^(0))<9 QFIXPT 26 S (^UTILITY("DIT",$J,DIA(1)),^(DIA(1)_";"_$E(DIA,2,999)))=DIPTIEN_";"_$E(DIA,2,999) 27 D P^DITP 28 QFIXPT K ^UTILITY("DIT",$J),DIFLG,DIFILE,DIDELIEN,DIIOP,DIPTIEN Q 29 ; 30 X ; 31 I 'Y S:'DSC&DB DB=DB+1 S Y=0 F S Y=$O(Y(Y)) D D^DIA:Y'="" I Y="" S Y=-1 G 2^DIA 32 S Y=X I DUZ(0)="@",X'?.E1":" S X=$S(X["//^":$P(X,"//^",2),1:X),X=$S(X[";":$P(X,";"),1:X) D ^DIM G:$D(X) P^DIA:X=Y I Y["//^",'$D(X) G BAD 33 I Y[";" F %=2:1 S D=$P(Y,";",%) Q:D="" S D=$S(D="DUP":"d",D="REQ":"R","""R""d"""[D:"",$A(D)=34:$E(D,2,$F(D,"""",2)-2),D="T":D,1:"") G BAD:D="",DIA3^DIQQQ:$A(D)>45&($A(D)<58)!(D[":") S DV=D_$C(126)_DV 34 I Y[";" S X=$P(Y,";",1) S:'$D(DIAB) DIAB=Y G DIC^DIA 35 F DK="///+","//+","///","//" I Y[DK S DP=$P(Y,DK,2,9) I DP'?1"/".E&(DP'?1"^".E)!(DUZ(0)="@") G DEF 36 G BAD:Y'?.E1":" 37 E K X S:'$D(DIAB) DIAB=Y S DICOMP=L_"WE?",DQI="Y(",DA="DR(99,"_DXS_",",X=Y,DICMX=1 D ^DICOMPW I '$D(X) K DIAB G BAD:'$D(DP),ACC 38 L I $D(X)>1 S DXS=DXS+1,%=0 F S %=$O(X(%)) Q:%="" S @(DA_"%)=X(%)") 39 S %=-1 S L=$S(Y>L:+Y,1:L\100+1*100),Y=U_DP_U_U_X_" S X=$S(D(0)>0:D(0),1:"""")",DRS=99 K X D DB^DIA S DI=+DP G FILETOP^DIA 40 ; 41 DEF S X="DA,DV,DWLC,0)=X" F J=L:-1 Q:I(J)[U S X="DA("_(L-J+1)_"),"_I(J)_","_X 42 S DICMX="S DWLC=DWLC+1,"_DIA_X,DA="DR(99,"_DXS_",",DHIT=Y,X=DP,DQI="X(",DICOMP=L_"T?" D EN^DICOMP,DICS^DIA,XEC K X S X=$P(DHIT,DK,1),DV=DV_DK_DP G DIC^DIA:DV'[";" 43 BAD Q:$D(DTOUT) G X^DIA 44 ACC K DIAB W !?9,"YOU HAVE NO WRITE ACCESS TO FILE "_+DP G BAD 45 Q 46 ; 47 XEC I $D(X),Y["m" S DIC("S")="S %=$P(^(0),U,2) I %,$D(^DD(+%,.01,0)),$P(^(0),U,2)[""W"",$D(^DD(DI,Y,0)) "_DIC("S") 48 S Y=0 F S Y=$O(X(Y)) Q:Y="" S @(DA_"Y)=X(Y)") 49 S Y=-1 I $D(X) S %=1,Y="DO YOU MEAN '"_DP_"' AS A VARIABLE" W !?63-$L(Y),Y D YN^DICN Q:%-1 S Y="Q",DXS=DXS+1,DP=U_X,DRS=99 D D^DIA:$S(DIAP:$P(DR(F+1,DI),";",DIAP#1000)'="Q",1:1) S:'$D(DIAB) DIAB=DHIT 50 Q:DP'="@" I DK="//" S DA=U_U Q 51 W !,$C(7)," WARNING: THIS MEANS AUTOMATIC DELETION!!" 1 DIA3 ;SFISC/GFT-UPDATE POINTERS, CHECK CODE IN INPUT STRING, CHECK FILE ACCESS ;9/7/94 09:57 2 ;;22.0;VA FileMan;;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 S Y=DIA("P"),DH=1,DTO=DIA D PTS^DIT:'$D(^UTILITY("DIT",$J,0)) S ^UTILITY("DIT",$J,0)=0 Q:$D(^(0))<9 5 D ASK^DITP Q:%-1 6 S Y=0 I @("$O("_DIC_"0))'>0") G D 7 C W !,"WHICH DO YOU WANT TO DO? --",!?4,"1) DELETE ALL SUCH POINTERS",!?4,"2) CHANGE ALL SUCH POINTERS TO POINT TO A DIFFERENT '"_$P(^(0),U,1)_"' ENTRY",!!,"CHOOSE 1) OR 2): " R %:DTIME G F:U[%,W:%=2,C:%'=1 8 D W !,"DELETE ALL POINTERS" D YN^DICN G F:%<0,C:%-1,DITP 9 W W !,"THEN PLEASE INDICATE WHICH ENTRY SHOULD BE POINTED TO" D L^DIA2 G DITP:Y>0 10 F W $C(7),!,"OK... FORGET IT... LET'S GO ON TO EDIT ANOTHER ENTRY" Q 11 DITP S (^UTILITY("DIT",$J,DIA(1)),^(DIA(1)_";"_$E(DIA,2,999)))=+Y_";"_$E(DIA,2,999) 12 W !?4,"("_$P("DELETION^RE-POINTING",U,''Y+1)_" WILL OCCUR WHEN YOU LEAVE 'ENTER/EDIT' OPTION)" 13 Q 14 ; 15 FIXPT(DIFLG,DIFILE,DIDELIEN,DIPTIEN) ;DELETE OR REPOINT POINTERS 16 ;In V21, will just delete pointers. Later, DIPTIEN will be record to repoint to. 17 ;DIFLG="D" (delete), DIFILE=File# previously pointed to, DIDELIEN=Record# previously pointed to, DIPTIEN=New pointed-to record(future) 18 N %X,%Y,X,Y,DIPTIEN,DIFIXPT,DIFIXPTC,DIFIXPTH D I $G(X)]"" D BLD^DIALOG(201,X) Q 19 . S X="DIFLG" Q:$G(DIFLG)'="D" S X="DIDELIEN" Q:'$G(DIDELIEN) S X="DIFILE" Q:'$G(DIFILE) Q:$G(^DIC(DIFILE,0,"GL"))="" 20 . S X="DIPTIEN" I $G(DIPTIEN) S Y=$G(^DD(DIFILE,0,"GL")) Q:Y="" I '$D(@(Y_DIPTIEN_",0)")) Q 21 . K X Q 22 S DIPTIEN=+$G(DIPTIEN),(DIFIXPT,DIFIXPTC)=1 23 N %,BY,D,DHD,DHIT,DIA,DIC,DISTOP,DL,DR,DTO,FLDS,FR,IOP,L,TO,X,Y,Z K ^UTILITY("DIT",$J),^TMP("DIFIXPT",$J) 24 S (DIFILE,DIA("P"),Y)=+DIFILE,(DIA,DTO)=^DIC(DIFILE,0,"GL"),DIA(1)=DIDELIEN 25 D PTS^DIT S ^UTILITY("DIT",$J,0)=0 G:$D(^(0))<9 QFIXPT 26 S (^UTILITY("DIT",$J,DIA(1)),^(DIA(1)_";"_$E(DIA,2,999)))=DIPTIEN_";"_$E(DIA,2,999) 27 D P^DITP 28 QFIXPT K ^UTILITY("DIT",$J),DIFLG,DIFILE,DIDELIEN,DIIOP,DIPTIEN Q 29 ; 30 X ; 31 I 'Y S:'DSC&DB DB=DB+1 S Y=0 F S Y=$O(Y(Y)) D D^DIA:Y'="" I Y="" S Y=-1 G 2^DIA 32 S Y=X I DUZ(0)="@",X'?.E1":" S X=$S(X["//^":$P(X,"//^",2),1:X),X=$S(X[";":$P(X,";"),1:X) D ^DIM G:$D(X) P^DIA:X=Y I Y["//^",'$D(X) G BAD 33 I Y[";" F %=2:1 S D=$P(Y,";",%) Q:D="" S D=$S(D="DUP":"d",D="REQ":"R","""R""d"""[D:"",$A(D)=34:$E(D,2,$F(D,"""",2)-2),1:D) G BAD:D="",DIA3^DIQQQ:$A(D)>45&($A(D)<58)!(D[":") S DV=D_$C(126)_DV 34 I Y[";" S X=$P(Y,";",1) S:'$D(DIAB) DIAB=Y G DIC^DIA 35 F DK="///+","//+","///","//" I Y[DK S DP=$P(Y,DK,2,9) I DP'?1"/".E&(DP'?1"^".E)!(DUZ(0)="@") G DEF 36 G BAD:Y'?.E1":" 37 E K X S:'$D(DIAB) DIAB=Y S DICOMP=L_"WE?",DQI="Y(",DA="DR(99,"_DXS_",",X=Y,DICMX=1 D ^DICOMPW I '$D(X) K DIAB G BAD:'$D(DP),ACC 38 ;G L:DUZ(0)="@" 39 ;I $D(^DIC(3,"AFOF")) G ACC:'$D(^DIC(3,DUZ,"FOF",+DP,0)),ACC:'$P(^(0),U,6),L 40 ;I $D(^DIC(+DP,0,"WR")) F D=1:1 S %=$E(^("WR"),D) I DUZ(0)[% Q:%]"" G ACC 41 L I $D(X)>1 S DXS=DXS+1,%=0 F S %=$O(X(%)) Q:%="" S @(DA_"%)=X(%)") 42 S %=-1 S L=$S(Y>L:+Y,1:L\100+1*100),Y=U_DP_U_U_X_" S X=$S(D(0)>0:D(0),1:"""")",DRS=99 K X D DB^DIA S DI=+DP G EN^DIA 43 ; 44 DEF S X="DA,DV,DWLC,0)=X" F J=L:-1 Q:I(J)[U S X="DA("_(L-J+1)_"),"_I(J)_","_X 45 S DICMX="S DWLC=DWLC+1,"_DIA_X,DA="DR(99,"_DXS_",",DHIT=Y,X=DP,DQI="X(",DICOMP=L_"T?" D EN^DICOMP,DICS^DIA,XEC K X S X=$P(DHIT,DK,1),DV=DV_DK_DP G DIC^DIA:DV'[";" 46 BAD Q:$D(DTOUT) G X^DIA 47 ACC K DIAB W !?9,"YOU HAVE NO WRITE ACCESS TO FILE "_+DP G BAD 48 Q 49 ; 50 XEC I $D(X),Y["m" S DIC("S")="S %=$P(^(0),U,2) I %,$D(^DD(+%,.01,0)),$P(^(0),U,2)[""W"",$D(^DD(DI,Y,0)) "_DIC("S") 51 S Y=0 F S Y=$O(X(Y)) Q:Y="" S @(DA_"Y)=X(Y)") 52 S Y=-1 I $D(X) S %=1,Y="DO YOU MEAN '"_DP_"' AS A VARIABLE" W !?63-$L(Y),Y D YN^DICN Q:%-1 S Y="Q",DXS=DXS+1,DP=U_X,DRS=99 D D^DIA:$S(DIAP:$P(DR(F+1,DI),";",DIAP#1000)'="Q",1:1) S:'$D(DIAB) DIAB=DHIT 53 Q:DP'="@" I DK="//" S DA=U_U Q 54 W !,$C(7)," WARNING: THIS MEANS AUTOMATIC DELETION!!" -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIC3.m
r613 r623 1 DIC3 ;SFISC/XAK,TKW,SEA/TOAD-VA FileMan: Lookup, Part 1 (called from DIC) ;31JUL2007 2 ;;22.0;VA FileMan;**1,16,4,17,20,28,40,86,70,159**;Mar 30, 1999;Build 8 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 SEARCH ; Begin search through x-refs. 6 I DIC(0)["T",'$G(DICR) N:'$D(DICR(1)) DICR S DICR=0 D:DIC(0)["O" 7 . I DIC(0)'["X" S DIC(0)=DIC(0)_"X" Q 8 . S DIC(0)=$TR(DIC(0),"X") Q 9 I X?1"`".NP D ^DICM Q 10 I $L(X)>100,'$G(DILONGX) D ^DICM Q 11 N DIOK,DIEXACTN K % I $G(DISKIPIX)=D K DISKIPIX G M 12 EXACT ; Find all exact matches to the lookup values 13 S DISAVDS=DS,DIEXACTN=0 14 I $G(DILONGX) G:$L(DICR(DICR,"ORG"))'>DINDEX(1,"LENGTH") M D 15 . S (X,X(1),DIVAL,DIVAL(1))=$E(DICR(DICR,"ORG"),1,DINDEX(1,"LENGTH")) Q 16 I DINDEX("#")>1,($G(DIALLVAL)!($G(DICR))),(DIC(0)["X"!(DIC(0)["O")) D EXACT^DIC4,SET^DIC4 17 I DINDEX("#")'>1 S Y=0,DIX=X F D MOREX Q:Y=-1!(DS(0)) 18 I DS(0) Q:DIC(0)'["T" Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) S DS(0)=0 19 I DIC(0)["T",DIC(0)["E",$G(DUOUT) D ;22*70 20 . ; Set up variables for next index lookup 21 . K DS,DUOUT 22 . S (DS,DS(0),DS("DD"))=0 23 . S X=DIVAL(1) 24 . Q 25 I DISAVDS=0,DS=1,DIC(0)["O"!(DIC(0)'["E"),DIC(0)'["T" D Q:Y>0!($D(DIROUT)) ;Good IEN returned or user bailed out 26 . I DINDEX("#")'>1,DIEXACTN>1,DINDEX'="B" S Y=-1 Q 27 . S Y=+DS(1),DS("DD")=1 28 . I DINDEX("#")'>1,DIEXACTN'>1 S DIY=1 D C^DIC2 Q 29 . D G^DIC2 Q 30 ; 31 PARTIAL ; Find all partial matches to the lookup values 32 I DIC(0)'["X",DINDEX("#")>1 D PARTIAL^DIC4,SET^DIC4 33 I DIC(0)'["X",DINDEX("#")'>1 F D Q:$G(DIX)=""!(DS(0)) 34 . N DITYP S DITYP=$G(DINDEX(1,"TYPE")) 35 . D 36 . . I DIC(0)["E",(DITYP["F"!(DITYP["S")) Q:DIC(0)["n" 37 . . I $TR(X,"-.")?.N,DO(2)'["D",'$D(DIDA) S DIX=$O(@(DIC_"D,DIX_"" "")"),-1) 38 . . Q 39 . S DIX=$O(@(DIC_"D,DIX)")) 40 . Q:DIX="" 41 . I $P(DIX,X)'="" D Q:DIX="" 42 . . I +$P(X,"E")'=X!(DIC(0)'["E") S DIX="" Q 43 . . I DIC(0)'["n"!(DITYP'["F"&(DITYP'["S")) S DIX="" Q 44 . . D FINDMORE^DICLIX0(1,.DIX,X,.DINDEX) 45 . . S:$P(DIX,X)'="" DIX="" Q 46 . S Y=0 F D MOREX Q:Y=-1!(DS(0)) 47 . Q 48 I DS(0) Q:DIC(0)'["T" Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) S DS(0)=0 49 I DIC(0)["T",DIC(0)["E",$G(DUOUT) D ;22*70 50 . ; Set up variables for next index lookup 51 . K DS,DUOUT 52 . S (DS,DS(0),DS("DD"))=0 53 . S X=DIVAL(1) 54 . Q 55 ; 56 M ; Find the next index. At end, display the rest 57 I DIC(0)["T" D KEEPON^DIC5 I DS(0) Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) 58 I DIC(0)["M" S DIOK=0 F D Q:DIOK 59 . N Y S Y=DINDEX("START") K DINDEX S DINDEX("WAY")=1,DINDEX("START")=Y,DINDEX("#")=1 60 . S (D,DINDEX)=$S($D(DID):$P(DID,U,DID(1)),1:$O(@(DIC_"D)"))) 61 . S:$D(DID) DID(1)=DID(1)+1 62 . I D=""!(D=-1) S D="",DIOK=1 Q 63 . I $D(@(DIC_"D)"))-10 Q 64 . ; Check Index, build index info 65 . D IXCHK^DIC4(.DIFILEI,.DINDEX,.DIOK,.DIALLVAL,.DIVAL,$G(DID)) Q 66 I DIC(0)["M",D]"" G EXACT 67 D:DIC(0)["M" D^DIC0 68 I DS=1 S DS("DD")=1 D G^DIC2 Q 69 I DS D Y^DIC1 Q:DS(0) I DINDEX("#")'>1 D:DO(2)["O"&(DO(2)'["A") L^DICM Q 70 I $G(DILONGX) S X=$E(DICR(DICR,"ORG"),1,30) 71 I DIC(0)["T",'$G(DICR),DIC(0)["O",DIC(0)["X" G SEARCH 72 I DINDEX("#")>1,'$G(DICR) D:DIC(0)["L" D:Y=-1 BAD^DIC1 Q 73 . S Y=-1 I $G(DICR)="" N DICR S DICR=0 74 . I $A(X)=34,X?.E1"""" D N^DICM Q 75 . K DD D L^DICM Q 76 D ^DICM Q 77 ; 78 ; 79 MOREX ; Find more exact matches to lookup value DIX 80 S Y=$O(@(DIC_"D,DIX,Y)")) I 'Y S Y=-1 Q 81 I $D(DIEXACTN)#2 S DIEXACTN=DIEXACTN+1 82 D MN Q:'$T D K Q:$G(DS(0)) 83 I DS>1,DIC(0)'["E",DIC(0)'["Y" K DS S DS=0,DS(0)=1,Y=-1 84 Q 85 ; 86 MN N DZ S DZ=$S((DIC(0)["D"&(DINDEX="B")):1,$G(DINDEX("#"))>1:0,$G(@(DIC_"D,DIX,Y)")):1,1:0) S DIYX=0 87 D:'$D(DO) GETFA^DIC1(.DIC,.DO) 88 I D="B",'DZ,'($D(@(DIC_"D,DIX,Y)"))#2) D 89 . N I S I=Y F S DZ=$G(^(I)),I=$O(^(I,0)) Q:I="" 90 . Q 91 S DIY="" I '$D(@(DIC_"Y,0)")) X "I 0" Q 92 I D="B",'DZ,'$D(DO("SCR")),$L(DIX)<30,'$D(DIC("S")),'$D(@(DIC_"Y,-9)")),'$G(DINDEX("OLDSUB")) D ADDKEY I 1 Q 93 D S I D 94 . I DINDEX("FLISTD")["^.01^",DINDEX("#")=1,'DZ,$P(DIY,DIX)="",'$G(DINDEX("OLDSUB")) D Q 95 . . N I S I=$S($G(DILONGX):DICR(DICR,"ORG"),1:DIX) 96 . . S DIY=$P(DIY,I,2,9),DIYX=1 D ADDKEY Q 97 . Q:DIC(0)["Y" 98 . I ($G(DINDEX("#"))>1)!($G(DINDEX("OLDSUB"))) D Q 99 . . D ADDIX^DIC4(.DIFILEI,Y,.DINDEX,.DIX,.DISCREEN) 100 . . D ADDKEY Q 101 . D ADDKEY 102 . I DINDEX("FLISTD")["^.01^",'DZ S DIY="" 103 . Q 104 Q 105 ; 106 S D:'$D(DO) GETFA^DIC1(.DIC,.DO) 107 I $D(@(DIC_"Y,0)")),'$D(^(-9)) S DIY=$P(^(0),U) 108 E S DIY="" Q 109 I '$D(DIC("S")),'$D(DO("SCR")) Q 110 I $G(DINDEX("#"))>1!($G(DINDEX("OLDSUB"))) Q 111 I $G(DILONGX) N DI0NODE,DIVAL D 112 . N % S %=DINDEX(1,"GET") 113 . I %="DIVAL=DINDEX(DISUB)" S DIVAL=X Q 114 . I %["DI0NODE" S DI0NODE=@(DIC_"Y,0)") 115 . N DIFILE S DIFILE=DIFILEI,DIFILE(DIFILE)=DIFILEI(DIFILEI) 116 . N DIEN S DIEN=Y_DIENS 117 . S @% Q 118 N DIAC,DIFILE,DISAVEX,DISAVEY,DISAVED 119 M DISAVEX=X,DISAVEY=Y S DISAVED=D I $D(@(DIC_"Y,0)")) 120 I $D(DIVAL(1)),$D(DIVAL)=10 S DIVAL=DIVAL(1) ;*159 121 I 1 X:$D(DIC("S")) DIC("S") K DIAC,DIFILE D:$D(DIC("S")) SX Q:'$T 122 I $D(DO("SCR")),$D(@(DIC_"Y,0)")) X DO("SCR") D SX Q:'$T 123 I 1 Q 124 ; 125 SX M X=DISAVEX,Y=DISAVEY S D=DISAVED Q 126 ; 127 ADDKEY ; Put KEY values into output array for display 128 S DIX("F")="" I DIC(0)'["U" S DIX("F")=$G(DINDEX("FLISTD")) 129 Q:'$D(DIFILEI(DIFILEI,"KEY")) Q:DIC(0)["S" 130 N DIKX,DII,DIFLD,DIERR,I 131 M DIKX=DIFILEI(DIFILEI,"KEY",DIFILEI) Q:'$D(DIKX) 132 K DIX("K") 133 F I=0:0 S I=$O(DIKX(I)) Q:'I F DIFLD=0:0 S DIFLD=$O(DIKX(I,DIFLD)) Q:'DIFLD D 134 . I DIFLD=.01,$G(DZ)=0 S DIY="" 135 . S DIX("K",I,DIFLD)=$$GET1^DIQ(DIFILEI,Y_DIFILEI(DIFILEI,"KEY","IEN"),DIFLD,"","","DIERR") Q 136 Q 137 ; 138 K ; Put an IEN into the DS array for display 139 N DZ,I S DZ=$O(DS(0)) F I=DZ:1:DS I +$G(DS(I))=Y,DIC(0)'["C" S I=-1 Q 140 I I'=-1,DIC(0)["T" D 141 . Q:'$D(^TMP($J,"DICSEEN",DIFILEI)) 142 . I $D(^TMP($J,"DICSEEN",DIFILEI,Y)) S I=-1 Q 143 . S ^TMP($J,"DICSEEN",DIFILEI,Y)="" Q 144 I I=-1 S I=DIX K DIX S DIX=I,I=-1 Q 145 I DS-DZ>100 D 146 . N D1,D2 S D2=DZ+19 F D1=DZ:1:D2 K DS(D1),DIY(D1),DIYX(D1) 147 . Q 148 S DS=DS+1 D 149 . S I=DS M DS(DS)=DIX S DS=I,I=DIX K DIX S DIX=I 150 . S DS(DS)=Y_"^"_$P(DIX,X,2,99) Q 151 S DIY(DS)=DIY S:DIY]""&$G(DIYX) DIYX(DS)=1 152 I DS#5-1!(DS=1)!(DIC(0)["Y") Q 153 D Y^DIC1 Q 154 ; 155 ; 1 DIC3 ;SFISC/XAK,TKW,SEA/TOAD-VA FileMan: Lookup, Part 1 (called from DIC) ;7:29 AM 23 Sep 2002 2 ;;22.0;VA FileMan;**1,16,4,17,20,28,40,86,70**;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 SEARCH ; Begin search through x-refs. 6 I DIC(0)["T",'$G(DICR) N:'$D(DICR(1)) DICR S DICR=0 D:DIC(0)["O" 7 . I DIC(0)'["X" S DIC(0)=DIC(0)_"X" Q 8 . S DIC(0)=$TR(DIC(0),"X") Q 9 I X?1"`".NP D ^DICM Q 10 I $L(X)>100,'$G(DILONGX) D ^DICM Q 11 N DIOK,DIEXACTN K % I $G(DISKIPIX)=D K DISKIPIX G M 12 EXACT ; Find all exact matches to the lookup values 13 S DISAVDS=DS,DIEXACTN=0 14 I $G(DILONGX) G:$L(DICR(DICR,"ORG"))'>DINDEX(1,"LENGTH") M D 15 . S (X,X(1),DIVAL,DIVAL(1))=$E(DICR(DICR,"ORG"),1,DINDEX(1,"LENGTH")) Q 16 I DINDEX("#")>1,($G(DIALLVAL)!($G(DICR))),(DIC(0)["X"!(DIC(0)["O")) D EXACT^DIC4,SET^DIC4 17 I DINDEX("#")'>1 S Y=0,DIX=X F D MOREX Q:Y=-1!(DS(0)) 18 I DS(0) Q:DIC(0)'["T" Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) S DS(0)=0 19 I DIC(0)["T",DIC(0)["E",$G(DUOUT) D ;22*70 20 . ; Set up variables for next index lookup 21 . K DS,DUOUT 22 . S (DS,DS(0),DS("DD"))=0 23 . S X=DIVAL(1) 24 . Q 25 I DISAVDS=0,DS=1,DIC(0)["O"!(DIC(0)'["E"),DIC(0)'["T" D Q:Y>0!($D(DIROUT)) ;Good IEN returned or user bailed out 26 . I DINDEX("#")'>1,DIEXACTN>1,DINDEX'="B" S Y=-1 Q 27 . S Y=+DS(1),DS("DD")=1 28 . I DINDEX("#")'>1,DIEXACTN'>1 S DIY=1 D C^DIC2 Q 29 . D G^DIC2 Q 30 ; 31 PARTIAL ; Find all partial matches to the lookup values 32 I DIC(0)'["X",DINDEX("#")>1 D PARTIAL^DIC4,SET^DIC4 33 I DIC(0)'["X",DINDEX("#")'>1 F D Q:$G(DIX)=""!(DS(0)) 34 . N DITYP S DITYP=$G(DINDEX(1,"TYPE")) 35 . D 36 . . I DIC(0)["E",(DITYP["F"!(DITYP["S")) Q:DIC(0)["n" 37 . . I $TR(X,"-.")?.N,DO(2)'["D",'$D(DIDA) S DIX=$O(@(DIC_"D,DIX_"" "")"),-1) 38 . . Q 39 . S DIX=$O(@(DIC_"D,DIX)")) 40 . Q:DIX="" 41 . I $P(DIX,X)'="" D Q:DIX="" 42 . . I +$P(X,"E")'=X!(DIC(0)'["E") S DIX="" Q 43 . . I DIC(0)'["n"!(DITYP'["F"&(DITYP'["S")) S DIX="" Q 44 . . D FINDMORE^DICLIX0(1,.DIX,X,.DINDEX) 45 . . S:$P(DIX,X)'="" DIX="" Q 46 . S Y=0 F D MOREX Q:Y=-1!(DS(0)) 47 . Q 48 I DS(0) Q:DIC(0)'["T" Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) S DS(0)=0 49 I DIC(0)["T",DIC(0)["E",$G(DUOUT) D ;22*70 50 . ; Set up variables for next index lookup 51 . K DS,DUOUT 52 . S (DS,DS(0),DS("DD"))=0 53 . S X=DIVAL(1) 54 . Q 55 ; 56 M ; Find the next index. At end, display the rest 57 I DIC(0)["T" D KEEPON^DIC5 I DS(0) Q:$P(DS(0),U,2)'="U"!($G(DIROUT)) 58 I DIC(0)["M" S DIOK=0 F D Q:DIOK 59 . N Y S Y=DINDEX("START") K DINDEX S DINDEX("WAY")=1,DINDEX("START")=Y,DINDEX("#")=1 60 . S (D,DINDEX)=$S($D(DID):$P(DID,U,DID(1)),1:$O(@(DIC_"D)"))) 61 . S:$D(DID) DID(1)=DID(1)+1 62 . I D=""!(D=-1) S D="",DIOK=1 Q 63 . I $D(@(DIC_"D)"))-10 Q 64 . ; Check Index, build index info 65 . D IXCHK^DIC4(.DIFILEI,.DINDEX,.DIOK,.DIALLVAL,.DIVAL,$G(DID)) Q 66 I DIC(0)["M",D]"" G EXACT 67 D:DIC(0)["M" D^DIC0 68 I DS=1 S DS("DD")=1 D G^DIC2 Q 69 I DS D Y^DIC1 Q:DS(0) I DINDEX("#")'>1 D:DO(2)["O"&(DO(2)'["A") L^DICM Q 70 I $G(DILONGX) S X=$E(DICR(DICR,"ORG"),1,30) 71 I DIC(0)["T",'$G(DICR),DIC(0)["O",DIC(0)["X" G SEARCH 72 I DINDEX("#")>1,'$G(DICR) D:DIC(0)["L" D:Y=-1 BAD^DIC1 Q 73 . S Y=-1 I $G(DICR)="" N DICR S DICR=0 74 . I $A(X)=34,X?.E1"""" D N^DICM Q 75 . K DD D L^DICM Q 76 D ^DICM Q 77 ; 78 ; 79 MOREX ; Find more exact matches to lookup value DIX 80 S Y=$O(@(DIC_"D,DIX,Y)")) I 'Y S Y=-1 Q 81 I $D(DIEXACTN)#2 S DIEXACTN=DIEXACTN+1 82 D MN Q:'$T D K Q:$G(DS(0)) 83 I DS>1,DIC(0)'["E",DIC(0)'["Y" K DS S DS=0,DS(0)=1,Y=-1 84 Q 85 ; 86 MN N DZ S DZ=$S((DIC(0)["D"&(DINDEX="B")):1,$G(DINDEX("#"))>1:0,$G(@(DIC_"D,DIX,Y)")):1,1:0) S DIYX=0 87 D:'$D(DO) GETFA^DIC1(.DIC,.DO) 88 I D="B",'DZ,'($D(@(DIC_"D,DIX,Y)"))#2) D 89 . N I S I=Y F S DZ=$G(^(I)),I=$O(^(I,0)) Q:I="" 90 . Q 91 S DIY="" I '$D(@(DIC_"Y,0)")) X "I 0" Q 92 I D="B",'DZ,'$D(DO("SCR")),$L(DIX)<30,'$D(DIC("S")),'$D(@(DIC_"Y,-9)")),'$G(DINDEX("OLDSUB")) D ADDKEY I 1 Q 93 D S I D 94 . I DINDEX("FLISTD")["^.01^",DINDEX("#")=1,'DZ,$P(DIY,DIX)="",'$G(DINDEX("OLDSUB")) D Q 95 . . N I S I=$S($G(DILONGX):DICR(DICR,"ORG"),1:DIX) 96 . . S DIY=$P(DIY,I,2,9),DIYX=1 D ADDKEY Q 97 . Q:DIC(0)["Y" 98 . I ($G(DINDEX("#"))>1)!($G(DINDEX("OLDSUB"))) D Q 99 . . D ADDIX^DIC4(.DIFILEI,Y,.DINDEX,.DIX,.DISCREEN) 100 . . D ADDKEY Q 101 . D ADDKEY 102 . I DINDEX("FLISTD")["^.01^",'DZ S DIY="" 103 . Q 104 Q 105 ; 106 S D:'$D(DO) GETFA^DIC1(.DIC,.DO) 107 I $D(@(DIC_"Y,0)")),'$D(^(-9)) S DIY=$P(^(0),U) 108 E S DIY="" Q 109 I '$D(DIC("S")),'$D(DO("SCR")) Q 110 I $G(DINDEX("#"))>1!($G(DINDEX("OLDSUB"))) Q 111 I $G(DILONGX) N DI0NODE,DIVAL D 112 . N % S %=DINDEX(1,"GET") 113 . I %="DIVAL=DINDEX(DISUB)" S DIVAL=X Q 114 . I %["DI0NODE" S DI0NODE=@(DIC_"Y,0)") 115 . N DIFILE S DIFILE=DIFILEI,DIFILE(DIFILE)=DIFILEI(DIFILEI) 116 . N DIEN S DIEN=Y_DIENS 117 . S @% Q 118 N DIAC,DIFILE,DISAVEX,DISAVEY,DISAVED 119 M DISAVEX=X,DISAVEY=Y S DISAVED=D I $D(@(DIC_"Y,0)")) 120 I 1 X:$D(DIC("S")) DIC("S") K DIAC,DIFILE D:$D(DIC("S")) SX Q:'$T 121 I $D(DO("SCR")),$D(@(DIC_"Y,0)")) X DO("SCR") D SX Q:'$T 122 I 1 Q 123 ; 124 SX M X=DISAVEX,Y=DISAVEY S D=DISAVED Q 125 ; 126 ADDKEY ; Put KEY values into output array for display 127 S DIX("F")="" I DIC(0)'["U" S DIX("F")=$G(DINDEX("FLISTD")) 128 Q:'$D(DIFILEI(DIFILEI,"KEY")) Q:DIC(0)["S" 129 N DIKX,DII,DIFLD,DIERR,I 130 M DIKX=DIFILEI(DIFILEI,"KEY",DIFILEI) Q:'$D(DIKX) 131 K DIX("K") 132 F I=0:0 S I=$O(DIKX(I)) Q:'I F DIFLD=0:0 S DIFLD=$O(DIKX(I,DIFLD)) Q:'DIFLD D 133 . I DIFLD=.01,$G(DZ)=0 S DIY="" 134 . S DIX("K",I,DIFLD)=$$GET1^DIQ(DIFILEI,Y_DIFILEI(DIFILEI,"KEY","IEN"),DIFLD,"","","DIERR") Q 135 Q 136 ; 137 K ; Put an IEN into the DS array for display 138 N DZ,I S DZ=$O(DS(0)) F I=DZ:1:DS I +$G(DS(I))=Y,DIC(0)'["C" S I=-1 Q 139 I I'=-1,DIC(0)["T" D 140 . Q:'$D(^TMP($J,"DICSEEN",DIFILEI)) 141 . I $D(^TMP($J,"DICSEEN",DIFILEI,Y)) S I=-1 Q 142 . S ^TMP($J,"DICSEEN",DIFILEI,Y)="" Q 143 I I=-1 S I=DIX K DIX S DIX=I,I=-1 Q 144 I DS-DZ>100 D 145 . N D1,D2 S D2=DZ+19 F D1=DZ:1:D2 K DS(D1),DIY(D1),DIYX(D1) 146 . Q 147 S DS=DS+1 D 148 . S I=DS M DS(DS)=DIX S DS=I,I=DIX K DIX S DIX=I 149 . S DS(DS)=Y_"^"_$P(DIX,X,2,99) Q 150 S DIY(DS)=DIY S:DIY]""&$G(DIYX) DIYX(DS)=1 151 I DS#5-1!(DS=1)!(DIC(0)["Y") Q 152 D Y^DIC1 Q 153 ; 154 ; -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIC5.m
r613 r623 1 DIC5 ;SFISC/XAK,TKW,SEA/TOAD-VA FileMan: Lookup, Part 1 (utilities) ;05/28/2008 2 ;;22.0;VA FileMan;**4,20,31,70,159**;Mar 30, 1999;Build 8 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 NODE75 ; Do after executing 7.5 node on DD, called from ^DIC 5 I $D(X)#2 S (DIVAL,DIVAL(1))=X Q 6 S Y=-1 Q:DIC(0)'["Q"!(DIC(0)'["E") 7 W $C(7) Q:$D(DDS) 8 W !,$$EZBLD^DIALOG(120,$$EZBLD^DIALOG(8090)) Q 9 ; 10 BYIEN1 ; Lookup record by IEN when user enters `n for a number 'n', called from ^DIC 11 S Y=$E(X,2,30) I Y="" S Y=-1 Q 12 N % S %=DINDEX("START") N DINDEX S DINDEX="",DINDEX("#")=1,DINDEX("START")=% 13 D S^DIC3 I '$T S Y=-1 Q 14 N DD,DS,DZ S DS=1,DD=Y,DIX=X D ADDKEY^DIC3,GOT^DIC2 15 Q 16 ; 17 BYIEN2 ; Lookup record by IEN when user enters a numeric lookup value, called from ^DIC 18 Q:DO(2)<0!($D(DF)) 19 N T S T=DINDEX(1,"TYPE") 20 I $D(@(DIC_"X,0)")) D Q:Y>0 21 . N DD S DD=$D(^DD(DIFILEI,.001)) 22 . I 'DD Q:T["N" I '$O(@(DIC_"""A["")")),$O(^("A["))]"" Q 23 . N % S %=DINDEX("START") N DINDEX S DINDEX="",DINDEX("#")=1,DINDEX("START")=% 24 . S Y=X D S^DIC3 I '$T S Y=-1 Q 25 . N DZ,DS,DIX,DIC5D S DIC5D=D,DS=1,DIX=X D ADDKEY^DIC3,GOT^DIC2 Q:Y>0 26 . D DO^DIC1 S D=DIC5D 27 I T["P"!(T["V"),DIC(0)'["U" S DISKIPIX=D 28 Q 29 ; 30 SPACEBAR ; Lookup last record selected by this user when user enters space bar return. Called from ^DIC 31 N % S %=DINDEX("START") N DINDEX S DINDEX="",DINDEX("#")=1,DINDEX("START")=% 32 D S^DIC3 I '$T S Y=-1 Q 33 N DZ,DS,DIX S DS=1,DIX=X D ADDKEY^DIC3,GOT^DIC2 Q 34 ; 35 KEEPON ; If DIC(0)["T", display entries found so far, then check for internal value if index is date, set, pointer, VP. Called from ^DIC3. 36 I DS D Q:Y>0!($G(DTOUT))!($G(DIROUT)) 37 . N I M I=X N X M X=I S I=D N D S D=I K I 38 . I DS=1 D 39 . . S DS("DD")=1 D G^DIC2 Q 40 . E I $G(DS("DD"))'=DS D Y^DIC1 I '$D(DIROUT),$D(DUOUT) K DUOUT ;22*70 41 . K DD,DS,DIX,DIYX S (DD,DS,DS("DD"))=0 42 . S:DIC(0)["E" DS(0,"HDRDSP",DIFILEI)=1 43 . S DS(0)=$S(Y>0:"1^"_+Y,$G(DTOUT):"1^T",$G(DIROUT):"1^U",1:0) 44 . Q 45 Q:DIC(0)["U" I DINDEX=DINDEX("START"),$G(DINDEX("#"))>1 Q 46 N I M I=X N X M X=I S I=D N D S D=I K I 47 D 1^DICM 48 K DD,DS,DIX,DIYX S (DD,DS,DS("DD"))=0 49 S DS(0)=$S(Y>0:"1^"_+Y,$G(DTOUT):"1^T",$G(DIROUT):"1^U",1:0) 50 Q 51 ; 52 PTRID(DO,DIC) ; Build code in DIC("W") to display Identifiers on pointed-to files 53 N DIFILEI,DIGBL,DIOGBL S DIFILEI=+DO(2),DIOGBL=DIC 54 F S DIFILEI=+$P($P($G(^DD(DIFILEI,.01,0)),U,2),"P",2) Q:'DIFILEI S DIGBL=$G(^DIC(DIFILEI,0,"GL")) Q:DIGBL="" D Q 55 Q 56 Q ; Build Identifier code for a single pointed-to file 57 N DIGBL1 S DIGBL1=DIGBL 58 I DIGBL[$C(34) S DIGBL1=$$CONVQQ^DILIBF(DIGBL) 59 N N,O,% S N=$O(DIC("W",999999),-1) 60 S O=$S(N:DIC("W",N),1:DIC("W")) 61 N % S %="I '$G(DICR) S DIEN=+"_DIOGBL_"DIEN,0) I $D("_DIGBL_"DIEN,0)) S DIFILEI="_DIFILEI_",DIGBL="""_DIGBL1_""" D WOV^DICQ1" 62 S DIOGBL=DIGBL 63 I ($L(O)+$L(%))<230 D Q 64 . I 'N S DIC("W")=DIC("W")_" "_% Q 65 . S DIC("W",N)=DIC("W",N)_" "_% Q 66 S N=N+1,DIC("W",N)=% 67 I N=1 S DIC("W")=DIC("W")_" X DIC(""W"",1)" Q 68 S DIC("W",N-1)=DIC("W",N-1)_" X DIC(""W"","_N_")" 69 Q 70 ; 1 DIC5 ;SFISC/XAK,TKW,SEA/TOAD-VA FileMan: Lookup, Part 1 (utilities) ;1:56 PM 19 Sep 2002 2 ;;22.0;VA FileMan;**4,20,31,70**;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 NODE75 ; Do after executing 7.5 node on DD, called from ^DIC 5 I $D(X)#2 S (DIVAL,DIVAL(1))=X Q 6 S Y=-1 Q:DIC(0)'["Q"!(DIC(0)'["E") 7 W $C(7) Q:$D(DDS) 8 W !,$$EZBLD^DIALOG(120,$$EZBLD^DIALOG(8090)) Q 9 ; 10 BYIEN1 ; Lookup record by IEN when user enters `n for a number 'n', called from ^DIC 11 S Y=$E(X,2,30) I Y="" S Y=-1 Q 12 N % S %=DINDEX("START") N DINDEX S DINDEX="",DINDEX("#")=1,DINDEX("START")=% 13 D S^DIC3 I '$T S Y=-1 Q 14 N DD,DS,DZ S DS=1,DD=Y,DIX=X D ADDKEY^DIC3,GOT^DIC2 15 Q 16 ; 17 BYIEN2 ; Lookup record by IEN when user enters a numeric lookup value, called from ^DIC 18 Q:DO(2)<0!($D(DF)) 19 N T S T=DINDEX(1,"TYPE") 20 I $D(@(DIC_"X,0)")) D Q:Y>0 21 . N DD S DD=$D(^DD(DIFILEI,.001)) 22 . I 'DD Q:T["N" I '$O(@(DIC_"""A["")")),$O(^("A["))]"" Q 23 . N % S %=DINDEX("START") N DINDEX S DINDEX="",DINDEX("#")=1,DINDEX("START")=% 24 . S Y=X D S^DIC3 I '$T S Y=-1 Q 25 . N DZ,DS,DIX S DS=1,DIX=X D ADDKEY^DIC3,GOT^DIC2 Q 26 I T["P"!(T["V"),DIC(0)'["U" S DISKIPIX=D 27 Q 28 ; 29 SPACEBAR ; Lookup last record selected by this user when user enters space bar return. Called from ^DIC 30 N % S %=DINDEX("START") N DINDEX S DINDEX="",DINDEX("#")=1,DINDEX("START")=% 31 D S^DIC3 I '$T S Y=-1 Q 32 N DZ,DS,DIX S DS=1,DIX=X D ADDKEY^DIC3,GOT^DIC2 Q 33 ; 34 KEEPON ; If DIC(0)["T", display entries found so far, then check for internal value if index is date, set, pointer, VP. Called from ^DIC3. 35 I DS D Q:Y>0!($G(DTOUT))!($G(DIROUT)) 36 . N I M I=X N X M X=I S I=D N D S D=I K I 37 . I DS=1 D 38 . . S DS("DD")=1 D G^DIC2 Q 39 . E I $G(DS("DD"))'=DS D Y^DIC1 I '$D(DIROUT),$D(DUOUT) K DUOUT ;22*70 40 . K DD,DS,DIX,DIYX S (DD,DS,DS("DD"))=0 41 . S:DIC(0)["E" DS(0,"HDRDSP",DIFILEI)=1 42 . S DS(0)=$S(Y>0:"1^"_+Y,$G(DTOUT):"1^T",$G(DIROUT):"1^U",1:0) 43 . Q 44 Q:DIC(0)["U" I DINDEX=DINDEX("START"),$G(DINDEX("#"))>1 Q 45 N I M I=X N X M X=I S I=D N D S D=I K I 46 D 1^DICM 47 K DD,DS,DIX,DIYX S (DD,DS,DS("DD"))=0 48 S DS(0)=$S(Y>0:"1^"_+Y,$G(DTOUT):"1^T",$G(DIROUT):"1^U",1:0) 49 Q 50 ; 51 PTRID(DO,DIC) ; Build code in DIC("W") to display Identifiers on pointed-to files 52 N DIFILEI,DIGBL,DIOGBL S DIFILEI=+DO(2),DIOGBL=DIC 53 F S DIFILEI=+$P($P($G(^DD(DIFILEI,.01,0)),U,2),"P",2) Q:'DIFILEI S DIGBL=$G(^DIC(DIFILEI,0,"GL")) Q:DIGBL="" D Q 54 Q 55 Q ; Build Identifier code for a single pointed-to file 56 N DIGBL1 S DIGBL1=DIGBL 57 I DIGBL[$C(34) S DIGBL1=$$CONVQQ^DILIBF(DIGBL) 58 N N,O,% S N=$O(DIC("W",999999),-1) 59 S O=$S(N:DIC("W",N),1:DIC("W")) 60 N % S %="I '$G(DICR) S DIEN=+"_DIOGBL_"DIEN,0) I $D("_DIGBL_"DIEN,0)) S DIFILEI="_DIFILEI_",DIGBL="""_DIGBL1_""" D WOV^DICQ1" 61 S DIOGBL=DIGBL 62 I ($L(O)+$L(%))<230 D Q 63 . I 'N S DIC("W")=DIC("W")_" "_% Q 64 . S DIC("W",N)=DIC("W",N)_" "_% Q 65 S N=N+1,DIC("W",N)=% 66 I N=1 S DIC("W")=DIC("W")_" X DIC(""W"",1)" Q 67 S DIC("W",N-1)=DIC("W",N-1)_" X DIC(""W"","_N_")" 68 Q 69 ; -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICATT2.m
r613 r623 1 DICATT2 ;SFISC/GFT,XAK-DEFINING MULTIPLES ;9APR2007 2 ;;22.0;VA FileMan;**89,152**;Mar 30, 1999;Build 10 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 S T=$E(Z) G CHECK^DICATT:$D(DTOUT) 5 F P="I","O","L","x" S:$P(O,U,2)[P Z=$P(Z,U)_P_U_$P(Z,U,2) 6 1 K DS S:$P(Z,U)'["K" V=W[";0" 7 S P=0,N=DICL,DQ=4,DP=6,DQI=" S:$D(X) DINUM=+X",DREF=$F(O,DQI)-1=$L(O),DE(7,0)="NO",DG(7)="N" 8 S:T="*" T=$S($P(Z,U)["S":"S",1:"P") G 1^DICATT22:DA=.001 9 G W:T="W" S:$D(DTIME)[0 DTIME=300 10 I T'["F",T'["S",T'["K",'O!DREF S:DREF DE(7,0)="YES",DG(7)="Y" 11 S F Y=4:1:6 S DQ(Y)=$P($T(DQ+Y),";",3)_F_$P($T(DQ+Y),";",4)_" (Y/N)^RS^Y:YES;N:NO^"_Y_"^Q" I 'V,DA-.01!'N Q 12 S DG(5)="Y",DE(4,0)="NO",DP=-1,DL=1 13 I T["P"!(T["N") S DE(5,0)="YES" 14 I O S DE(6,0)=$E("NY",$P(O,U,2)["M"+1) S:$P(O,U,2)["R" DE(4,0)="Y" I DA=.01,N S P=$O(^DD(J(N-1),"SB",A,0)) S:P="" P=-1 S Y=$P(^DD(J(N-1),P,0),U,2),DE(5,0)=$E("YN",Y["A"+1) 15 K Y S DIFLD=-1 D RE^DIED K DQ,DIFLD G:$D(Y) N^DICATT:$P(Z,U)["X",CHECK^DICATT I $D(DTOUT) K DTOUT G CHECK^DICATT 16 S:DG(5)="N" T=T_"A" I DG(4)="Y",$P(Z,U)'["R" S Z="R"_Z 17 I $D(DG(6)),DG(6)="Y",$P(Z,U)'["M" S Z="M"_Z 18 G S DIZ=Z G ^DICATT22 19 Q ; 20 K T,B,A,J,DA,DIC,E,DR,W,S,Q,P,N,V,I,L,F,DQI,DIK,C,Z,Y,DE,O,DICS,DICL,DDA Q 21 ; 22 W S %=Z["L"+1 W !,"SHALL THIS TEXT NORMALLY APPEAR IN WORD-WRAP MODE" D YN^DICN 23 G CHECK^DICATT:%<0 I % S Z=$P($TR(Z,"L"),U)_$E("L",%=2)_U G WINDOW 24 W !,"ANSWER 'YES' IF THE INTERNALLY-STORED '"_F_"' TEXT" 25 W !?5,"SHOULD NORMALLY BE PRINTED OUT IN FULL LINES, BREAKING AT WORD BOUNDARIES." 26 W !?2,"ANSWER 'NO' IF THE INTERNAL TEXT SHOULD NORMALLY BE PRINTED OUT" 27 W !?5,"LINE-FOR-LINE AS IT STANDS.",! G W 28 ; 29 ; 30 WINDOW S %=2-(Z["x"!'O) W !,"SHALL ""|"" CHARACTERS IN THIS TEXT BE TREATED LIKE ANY OTHER CHARACTERS" D YN^DICN 31 G CHECK^DICATT:%<0 I % S Z=$P($TR(Z,"x"),U)_$E("x",%=1)_U G G 32 W !,"ANSWER 'YES' IF THE INTERNALLY-STORED '"_F_"' TEXT MAY HAVE ""|"" CHARACTERS" 33 W !?3,"IN IT (SUCH AS HL7 MESSAGES) THAT NEED TO DISPLAY EXACTLY AS THEY ARE STORED." 34 W !,"ANSWER 'NO' IF THE INTERNAL TEXT SHOULD NORMALLY BE PRINTED OUT WITH ANYTHING" 35 W !?3,"THAT IS DELIMITED BY ""|"" CHARACTERS INTERPRETED AS VARIABLE TEXT.",! G WINDOW 36 ; 37 ; 38 ; 39 X ; 40 W " (FIELD DEFINITION IS NOT EDITABLE)" S T=$E(^(0)),Z=$P(Y,U,2),Z=$P(Z,"M")_$P(Z,"M",2),Z=$P(Z,"R")_$P(Z,"R",2)_U_$P(Y,U,3),W=$P(Y,U,4),C=$P(Y,U,5,99) S:Z["K" V=0 G N^DICATT:N=6,1 41 ; 42 NO ; 43 W !,$C(7)," <DATA DEFINITION UNCHANGED>" I $P(Z,U)["K"&(DUZ(0)'="@") G N^DICATT 44 TYPE K Y,M,DE,DIE,DQ,DG G Q^DIB:$D(DTOUT) S N=0,DQI=DICL+9,Y=^DD(A,DA,0),F=$P(Y,U),Z="" W !!,"DATA TYPE OF ",F,": " I 'O R X:DTIME S:'$T DTOUT=1 G X^DICATT:X[U!'$T S:DUZ(0)'="@" DIC("S")="I Y-9" S:DA=.001 DIC("S")="I Y<4!(Y=7)" G NEW 45 F N=9:-1:5,1:1:4 Q:$P(Y,U,2)[$E("DNSFWCPVK",N) 46 W $P(^DOPT("DICATT",N,0),U) G X:$P(Y,U,2)["K"&(DUZ(0)'="@") 47 G X:$P(Y,U,2)["X",6^DICATT:N=6 R "// ",X:DTIME S:'$T DTOUT=1 G N^DICATT:X[U!'$T,0^DICATT:X="" S DIC("S")="I Y-6,Y-9"_$P(",Y-5",U,N\2-2!(A=B)!(DA-.01)!$O(^DD(A,DA))>0),DIC("S")=DIC("S")_$S(N=7:",Y-8",N=8:",Y-7",1:"") 48 NEW I 'O,X=" ",E,$P(^DD(A,E,0),U,2)'["P",$P(^(0),U,2)'["V" W " <",$C(7) D E^DICATT W " DUPLICATED>" S DIZ=$S($D(DIZ):DIZ,1:DIZZ) G E^DICATT1 49 S DIC(0)="QEI",DIC="^DOPT(""DICATT""," D ^DIC I Y>0 S:N-Y&O M="",O=$P(O,U,1,2)_U_U_$P(O,U,4) S N=+Y G 0^DICATT 50 I 'O,X["?",E,$P(^DD(A,E,0),U,2)'["P",$P(^(0),U,2)'["V" D DICATT^DIQQQ,E^DICATT W ", JUST HIT THE SPACE KEY" 51 G TYPE 52 ; 53 DQ ;; 54 ; 55 ; 56 ; 57 ;;IS ; ENTRY MANDATORY 58 ;;SHOULD USER SEE AN "ADDING A NEW ;?" MESSAGE FOR NEW ENTRIES 59 ;;HAVING ENTERED OR EDITED ONE ;, SHOULD USER BE ASKED ANOTHER 1 DICATT2 ;SFISC/GFT,XAK-DEFINING MULTIPLES ;02:13 PM 24 Dec 2001 2 ;;22.0;VA FileMan;**89**;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 S T=$E(Z) G CHECK^DICATT:$D(DTOUT) 5 F P="I","O","L" S:$P(O,U,2)[P Z=$P(Z,U)_P_U_$P(Z,U,2) 6 1 K DS S:$P(Z,U)'["K" V=W[";0" 7 S P=0,N=DICL,DQ=4,DP=6,DQI=" S:$D(X) DINUM=+X",DREF=$F(O,DQI)-1=$L(O),DE(7,0)="NO",DG(7)="N" 8 S:T="*" T=$S($P(Z,U)["S":"S",1:"P") G 1^DICATT22:DA=.001 9 G W:T="W" S:$D(DTIME)[0 DTIME=300 10 I T'["F",T'["S",T'["K",'O!DREF S:DREF DE(7,0)="YES",DG(7)="Y" 11 S F Y=4:1:6 S DQ(Y)=$P($T(DQ+Y),";",3)_F_$P($T(DQ+Y),";",4)_" (Y/N)^RS^Y:YES;N:NO^"_Y_"^Q" I 'V,DA-.01!'N Q 12 S DG(5)="Y",DE(4,0)="NO",DP=-1,DL=1 13 I T["P"!(T["N") S DE(5,0)="YES" 14 I O S DE(6,0)=$E("NY",$P(O,U,2)["M"+1) S:$P(O,U,2)["R" DE(4,0)="Y" I DA=.01,N S P=$O(^DD(J(N-1),"SB",A,0)) S:P="" P=-1 S Y=$P(^DD(J(N-1),P,0),U,2),DE(5,0)=$E("YN",Y["A"+1) 15 K Y S DIFLD=-1 D RE^DIED K DQ,DIFLD G:$D(Y) N^DICATT:$P(Z,U)["X",CHECK^DICATT I $D(DTOUT) K DTOUT G CHECK^DICATT 16 S:DG(5)="N" T=T_"A" I DG(4)="Y",$P(Z,U)'["R" S Z="R"_Z 17 I $D(DG(6)),DG(6)="Y",$P(Z,U)'["M" S Z="M"_Z 18 G S DIZ=Z G ^DICATT22 19 Q ; 20 K T,B,A,J,DA,DIC,E,DR,W,S,Q,P,N,V,I,L,F,DQI,DIK,C,Z,Y,DE,O,DICS,DICL,DDA Q 21 ; 22 W S %=Z["L"+1 W !,"SHALL THIS TEXT NORMALLY APPEAR IN WORD-WRAP MODE" D YN^DICN 23 G CHECK^DICATT:%<0 I % S Z=$P($P(Z,"L")_$P(Z,"L",2),U)_$E("L",%=2)_U G G 24 W !?3,"ANSWER 'YES' IF THE INTERNALLY-STORED '"_F_"' TEXT" 25 W !?5,"SHOULD NORMALLY BE PRINTED OUT IN FULL LINES, BREAKING AT WORD BOUNDARIES." 26 W !?2,"ANSWER 'NO' IF THE INTERNAL TEXT SHOULD NORMALLY BE PRINTED OUT" 27 W !?5,"LINE-FOR-LINE AS IT STANDS.",! G W 28 ; 29 X ; 30 W " (FIELD DEFINITION IS NOT EDITABLE)" S T=$E(^(0)),Z=$P(Y,U,2),Z=$P(Z,"M")_$P(Z,"M",2),Z=$P(Z,"R")_$P(Z,"R",2)_U_$P(Y,U,3),W=$P(Y,U,4),C=$P(Y,U,5,99) S:Z["K" V=0 G N^DICATT:N=6,1 31 ; 32 NO ; 33 W !,$C(7)," <DATA DEFINITION UNCHANGED>" I $P(Z,U)["K"&(DUZ(0)'="@") G N^DICATT 34 TYPE K Y,M,DE,DIE,DQ,DG G Q^DIB:$D(DTOUT) S N=0,DQI=DICL+9,Y=^DD(A,DA,0),F=$P(Y,U),Z="" W !!,"DATA TYPE OF ",F,": " I 'O R X:DTIME S:'$T DTOUT=1 G X^DICATT:X[U!'$T S:DUZ(0)'="@" DIC("S")="I Y-9" S:DA=.001 DIC("S")="I Y<4!(Y=7)" G NEW 35 F N=9:-1:5,1:1:4 Q:$P(Y,U,2)[$E("DNSFWCPVK",N) 36 W $P(^DOPT("DICATT",N,0),U) G X:$P(Y,U,2)["K"&(DUZ(0)'="@") 37 G X:$P(Y,U,2)["X",6^DICATT:N=6 R "// ",X:DTIME S:'$T DTOUT=1 G N^DICATT:X[U!'$T,0^DICATT:X="" S DIC("S")="I Y-6,Y-9"_$P(",Y-5",U,N\2-2!(A=B)!(DA-.01)!$O(^DD(A,DA))>0),DIC("S")=DIC("S")_$S(N=7:",Y-8",N=8:",Y-7",1:"") 38 NEW I 'O,X=" ",E,$P(^DD(A,E,0),U,2)'["P",$P(^(0),U,2)'["V" W " <",$C(7) D E^DICATT W " DUPLICATED>" S DIZ=$S($D(DIZ):DIZ,1:DIZZ) G E^DICATT1 39 S DIC(0)="QEI",DIC="^DOPT(""DICATT""," D ^DIC I Y>0 S:N-Y&O M="",O=$P(O,U,1,2)_U_U_$P(O,U,4) S N=+Y G 0^DICATT 40 I 'O,X["?",E,$P(^DD(A,E,0),U,2)'["P",$P(^(0),U,2)'["V" D DICATT^DIQQQ,E^DICATT W ", JUST HIT THE SPACE KEY" 41 G TYPE 42 ; 43 DQ ;; 44 ; 45 ; 46 ; 47 ;;IS ; ENTRY MANDATORY 48 ;;SHOULD USER SEE AN "ADDING A NEW ;?" MESSAGE FOR NEW ENTRIES 49 ;;HAVING ENTERED OR EDITED ONE ;, SHOULD USER BE ASKED ANOTHER -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICM.m
r613 r623 1 DICM ;SFISC/GFT,XAK,TKW-MULTIPLE LOOKUP FOR FLDS WHICH MUST BE TRANSFORMED ;4AUG2007 2 ;;22.0;VA FileMan;**4,20,31,40,149,159**;Mar 30, 1999;Build 8 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 I '$D(DICR(1)),DIC(0)'["T" N DICR S DICR=0 5 I $A(X)=34,X?.E1"""" G N 6 I $G(^DD(+DO(2),0,"LOOK"))]"",^("LOOK")'="SOUNDEX" G @^("LOOK") 7 I DIC(0)["U" S DD=0 G W 8 I DIC(0)["T" G 2 9 R N DIFLAGS S DIFLAGS="4l"_$P("M^",U,DIC(0)["M") 10 N DIFORCE D 11 . S DIFORCE=0 I DIC(0)'["M"!($D(DID)) S DIFORCE=1 12 . S DIFORCE(0)=$S(DIC(0)'["M":DINDEX,$D(DID):DID,1:"*"),DIFORCE(1)=1 13 F D 1 I DINDEX=""!(Y>0)!($G(DTOUT))!($G(DIROUT)) Q 14 G 2 15 ; 16 1 N DS,%Y,DIV 17 I $G(DINDEX("IXFILE")) S Y=DINDEX(1,"FILE"),%Y=DINDEX(1,"FIELD") 18 E S Y=$O(^DD(+DO(2),0,"IX",DINDEX,0)) S:Y="" Y=-1 S %Y=+$O(^(Y,0)) 19 I Y=-1,DINDEX="B" S Y=+DO(2),%Y=.01 20 S:Y="" Y=-1 S:%Y="" %Y=-1 21 I $D(DICR(U,Y,%Y,DINDEX)) S Y=-1 22 E I %Y=.01,DINDEX'="B",Y=+DO(2),$D(DICR(U,Y,%Y,"B")),$G(DINDEX(1,"TRANCODE"))="" S Y=-1 23 I Y'<0 D 24 . S DS=$G(^DD(Y,%Y,0)) I DS="" S Y=-1 Q 25 . S %=DINDEX,DICR(U,Y,%Y,DINDEX)=0 26 . I $D(^DD(Y,%Y,7)) D RS K DS X ^(7) Q 27 . I $G(DINDEX("IXTYPE"))="S" D A,SOU^DICM1,D Q:Y>0 S Y=-1 Q 28 . S DIX=Y,Y=$P(DS,U,2) 29 . S Y=$S(Y["P":"P",Y["D":"D",Y["S":"S",Y["V":"V",1:"") 30 . I Y]"" D A D:'Y ^DICM1,D Q:Y>0 S Y=-1 Q 31 . I $G(DINDEX(1,"TRANCODE"))]"" S Y="T" D A,^DICM1 N DITRANX S DITRANX=1 D D 32 . Q:Y>0 S Y=-1 Q 33 Q:Y>0!(DIC(0)["T") D 34 . K DIV M DIV=X S DIV(1)=X N X,Y 35 . D NXTINDX^DICF2(.DINDEX,.DIFORCE,.DIFILEI,DIFLAGS,.DIV,"*") Q 36 Q 37 ; 38 2 D D^DIC0 S %=D 39 G K:Y>0!($G(DIROUT)) 40 I X?.E1L.E,DIC(0)'["X" D G K:$G(DIROUT) 41 . D % N DIFILEI,DINDEX 42 . S DIC(0)=$TR(DIC(0),"L"),X=$$UP^DILIBF(X) S:$G(DILONGX) DICR(DICR,"ORG")=X 43 . D DIC Q 44 I Y'>0,X["," S DS="",DIX=$P(X,",") I DIC(0)'["X",$L(DIX)<31 D G K:$G(DIROUT) ;COMMA-PIECING 45 . F %=2:1 S DD=$P(X,",",%) I DD'["""" D Q:DD="" 46 . . F Q:$A(DD)-32 S DD=$E(DD,2,999) 47 . . F Q:$A(DD,$L(DD))-32 S DD=$E(DD,1,$L(DD)-1) 48 . . I $L(DD)*2+$L(DS)>200!(DD="") S DD="" Q 49 . . S DS=DS_" I %?.E1P1"""_DD_""".E!(D'=""B""&(%?1"""_DD_""".E))" Q 50 . Q:DS="" S %=D 51 . D % S X=DIX N DILONGX 52 . S DS="S %=$P(^(0),U)"_DS,DIC(0)=DIC(0)_"D" D 7 Q 53 I Y'>0,$L(X)>30 D 54 . N DILONGX S DILONGX=1 55 . S %=D D % S Y="DICR("_DICR_")",DICR(DICR,"ORG")=X 56 . S DS=$S(DIC(0)["X":"I DIVAL="_Y,1:"I '$L($P(DIVAL,"_Y_"))") 57 . S:DIC(0)["O"&(DIC(0)'["E") DS=DS_",'$L($P(DIVAL,"_Y_",2))" 58 . D 7 I Y>0!(X'?.E1L.E)!(DIC(0)["X") K DILONGX Q 59 . S %=D D % S (X,DICR(DICR,"ORG"))=$$UP^DILIBF(X) 60 . S Y="DICR("_DICR_",""ORG"")" 61 . S DS="I '$L($P(DIVAL,"_Y_"))" S:DIC(0)["O"&(DIC(0)'["E") DS=DS_",'$L($P(DIVAL,"_Y_",2))" 62 . D 7 K DILONGX Q 63 ; 64 K S DICR=+$G(DICR),DD=$D(DICR(DICR,6)) K:'DICR DICR 65 I Y>0 K DIC("W") D R^DIC2 Q 66 I $G(DTOUT)!($G(DIROUT)) Q 67 W I @("$O("_DIC_"""A[""))]""""") G NL:DIC(0)["N",DD 68 I DO(2)'["Z" S Y=0 D Q:Y>0!($G(DIROUT)) 69 DINUM .I $G(DINDEX("1","FIELD"))=.01,X?1.15NP,$P($G(^DD(+DO(2),.01,0)),U,5,99)["DINUM=X",$D(@(DIC_"X,0)")) D Q:Y>0 70 ..S Y=X I 1 X:$D(DIC("S")) DIC("S") I S DIY="",DS=1 N DZ,DD D ADDKEY^DIC3,GOT^DIC2 Q 71 ..S Y=0 72 .N DIOUT S DIOUT=0 F DS=1:1 S @("Y=$O("_DIC_"Y))") D Q:DIOUT 73 . . I 'Y S Y=-1,DIOUT=1 Q 74 . . W:DIC(0)["E"&(DS#20=0) ".." 75 . . I $D(@(DIC_Y_",0)")),$P(^(0),U)=X X:$D(DIC("S")) DIC("S") I S DIOUT=1 76 . . I DIOUT S DIY="",DS=1 N DZ,DD D ADDKEY^DIC3,GOT^DIC2 77 . . Q 78 NL I '$G(DICR) D NQ I $T D Q:Y>0!($G(DTOUT))!($G(DIROUT)) 79 . N:'$G(DIASKOK) DIASKOK S (DS,DIASKOK)=1 N DZ,DD 80 . D ADDKEY^DIC3,GOT^DIC2 Q 81 DD S Y=-1 I DD D BAD^DIC1 Q 82 L I DIC(0)["L" K DD G ^DICN 83 B D BAD^DIC1 Q 84 ; 85 N D RS S X=$E(X,2,$L(X)-1),%=D D 86 . I DINDEX("#")>1 S %Y=+$G(DINDEX(1,"FIELD")),DS=$G(^DD(+$G(DINDEX(1,"FILE")),%Y,0)) Q:DS]"" 87 . S DS=^DD(+DO(2),.01,0),%Y=.01 Q 88 F Y="P","D","S","V" I $P(DS,U,2)[Y K:Y="P" DO D ^DICM1 S:$D(X)#2 DS("INT")=X Q 89 I $D(X),DINDEX("#")>1 S X(1)=X 90 S Y=-1 D L:$D(X),E 91 I Y'>0 K DUOUT D BAD^DIC1 Q 92 G 2 93 ; 94 A ; Set variables needed for transforming date/set/ptr/var.ptr 95 S DICR(DICR+1,4)=% 96 D % K DF,DID,DINUM Q 97 ; 98 % ; Set variables up before doing lookup w/transformed value 99 I DIC(0)'["L" S DICR(DICR+1,8)=1 100 E I '$$OKTOADD^DICM0(.DIFILEI,.DINDEX,.DIFINDER) S DICR(DICR+1,8)=1 101 I $G(DINUM)]"" S DICR(DICR+1,10)=DINUM 102 I $D(DF) S DICR(DICR+1,9)=DF S:$G(DID)]"" DICR(DICR+1,9.1)=$G(DID(1))_U_DID 103 RS S DICR=DICR+1,DICR(DICR)=X,DICR(DICR,0)=DIC(0),DIC(0)=$TR(DIC(0),"A"),DIC(0)=$TR(DIC(0),"Q") Q 104 ; 105 D S:$G(DICR(DICR,10))]"" DINUM=DICR(DICR,10) 106 S (D,DF)=DICR(DICR,4) D 107 . N T S T=$P($G(DS),U,2) 108 . S DIC(0)=$TR(DIC(0),"M","") I T["V" S DIC(0)=$TR(DIC(0),"A","") 109 . I D="B",T'["D",'$G(DITRANX) S DIC(0)=DIC(0)_"s" 110 . I T["P"!(T["V")!(T["S") S DIC(0)=DIC(0)_"X" 111 . Q 112 I DICR(DICR,4)=DINDEX N I M I=DINDEX N DINDEX M DINDEX=I K I S DINDEX("START")=DINDEX 113 E N DINDEX D 114 . S (DINDEX,DINDEX("START"))=DICR(DICR,4),DINDEX("WAY")=1 115 . D INDEX^DICUIX(.DIFILEI,DIFLAGS,.DINDEX,"",.DIVALUE) Q 116 I DINDEX("#")>1 S (DINDEX(1),DINDEX(1,"FROM"),DINDEX(1,"PART"))=$G(X) 117 RCR S:'$D(DIDA) DICRS=1 118 DIC ; 119 I $D(DICR(DICR,8)) S DIC(0)=$TR(DIC(0),"L") 120 S Y=-1 I $D(X) D ;*159 WAS: I $D(X),$L(X)<31 D 121 . N DIVAL S (DIVAL,DIVAL(1))=X N X S (X,X(1))=DIVAL 122 . D RENUM^DIC1 K DIDA Q 123 S:DIC(0)["L" DICR(DICR-1,6)=1 K:$D(DICR(DICR,4)) DF 124 E S D="B" Q:'$G(DICR) ;**GFT 125 S %=DICR,X=DICR(%),DIC(0)=DICR(%,0),DICR=%-1 126 S:$G(DICR(%,10))]"" DINUM=DICR(%,10) 127 S:$D(DICR(%,9)) (D,DF)=DICR(%,9) I $G(DICR(%,9.1))]"" S:$P(DICR(%,9.1),U)]"" DID(1)=$P(DICR(%,9.1),U) S DID=$P(DICR(%,9.1),U,2,999) 128 K DICRS,DICR(%) D DO^DIC1:'$D(DO(2)) Q 129 ; 130 NQ I $L(X)<14,X?.NP,+X=X,@("$D("_DIC_"X,0))") S Y=X D S^DIC3 131 Q 132 ; 133 SOUNDEX I DIC(0)["E",'$D(DICRS) W " " D RS,SOU S DIC(0)=$TR(DIC(0),"L") D RCR Q:Y>0 134 G R 135 ; 136 7 S Y=-1 N % S %=$S($D(DIC("S")):DIC("S"),1:1) 137 I $D(DS),'$D(DIC("S1")) D 138 . S DIC("S")=DS I '% S DIC("S")=DIC("S")_" X DIC(""S1"")",DIC("S1")=% 139 . I X]"" D 140 . . N DIVAL S (DIVAL,DIVAL(1))=X,DIVAL(0)=1 N X S (X,X(1))=DIVAL 141 . . N DINDEX,DIFILEI 142 . . S DIC(0)=$TR(DIC(0),"L") D F^DIC 143 . K DIC("S") S:$D(DIC("S1")) DIC("S")=DIC("S1") K DIC("S1") 144 D E Q 145 ; 146 SOU D SOU^DICM1 Q 1 DICM ;SFISC/GFT,XAK,TKW-MULTIPLE LOOKUP FOR FLDS WHICH MUST BE TRANSFORMED ;26JUN2006 2 ;;22.0;VA FileMan;**4,20,31,40,149**;Mar 30, 1999;Build 2 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 I '$D(DICR(1)),DIC(0)'["T" N DICR S DICR=0 5 I $A(X)=34,X?.E1"""" G N 6 I $G(^DD(+DO(2),0,"LOOK"))]"",^("LOOK")'="SOUNDEX" G @^("LOOK") 7 I DIC(0)["U" S DD=0 G W 8 I DIC(0)["T" G 2 9 R N DIFLAGS S DIFLAGS="4l"_$P("M^",U,DIC(0)["M") 10 N DIFORCE D 11 . S DIFORCE=0 I DIC(0)'["M"!($D(DID)) S DIFORCE=1 12 . S DIFORCE(0)=$S(DIC(0)'["M":DINDEX,$D(DID):DID,1:"*"),DIFORCE(1)=1 13 F D 1 I DINDEX=""!(Y>0)!($G(DTOUT))!($G(DIROUT)) Q 14 G 2 15 ; 16 1 N DS,%Y,DIV 17 I $G(DINDEX("IXFILE")) S Y=DINDEX(1,"FILE"),%Y=DINDEX(1,"FIELD") 18 E S Y=$O(^DD(+DO(2),0,"IX",DINDEX,0)) S:Y="" Y=-1 S %Y=+$O(^(Y,0)) 19 I Y=-1,DINDEX="B" S Y=+DO(2),%Y=.01 20 S:Y="" Y=-1 S:%Y="" %Y=-1 21 I $D(DICR(U,Y,%Y,DINDEX)) S Y=-1 22 E I %Y=.01,DINDEX'="B",Y=+DO(2),$D(DICR(U,Y,%Y,"B")),$G(DINDEX(1,"TRANCODE"))="" S Y=-1 23 I Y'<0 D 24 . S DS=$G(^DD(Y,%Y,0)) I DS="" S Y=-1 Q 25 . S %=DINDEX,DICR(U,Y,%Y,DINDEX)=0 26 . I $D(^DD(Y,%Y,7)) D RS K DS X ^(7) Q 27 . I $G(DINDEX("IXTYPE"))="S" D A,SOU^DICM1,D Q:Y>0 S Y=-1 Q 28 . S DIX=Y,Y=$P(DS,U,2) 29 . S Y=$S(Y["P":"P",Y["D":"D",Y["S":"S",Y["V":"V",1:"") 30 . I Y]"" D A D:'Y ^DICM1,D Q:Y>0 S Y=-1 Q 31 . I $G(DINDEX(1,"TRANCODE"))]"" S Y="T" D A,^DICM1 N DITRANX S DITRANX=1 D D 32 . Q:Y>0 S Y=-1 Q 33 Q:Y>0!(DIC(0)["T") D 34 . K DIV M DIV=X S DIV(1)=X N X,Y 35 . D NXTINDX^DICF2(.DINDEX,.DIFORCE,.DIFILEI,DIFLAGS,.DIV,"*") Q 36 Q 37 ; 38 2 D D^DIC0 S %=D 39 G K:Y>0!($G(DIROUT)) 40 I X?.E1L.E,DIC(0)'["X" D G K:$G(DIROUT) 41 . D % N DIFILEI,DINDEX 42 . S DIC(0)=$TR(DIC(0),"L"),X=$$UP^DILIBF(X) S:$G(DILONGX) DICR(DICR,"ORG")=X 43 . D DIC Q 44 I Y'>0,X["," S DS="",DIX=$P(X,",",1) I DIC(0)'["X",$L(DIX)<31 D G K:$G(DIROUT) 45 . F %=2:1 S DD=$P(X,",",%) I DD'["""" D Q:DD="" 46 . . F Q:$A(DD)-32 S DD=$E(DD,2,999) 47 . . F Q:$A(DD,$L(DD))-32 S DD=$E(DD,1,$L(DD)-1) 48 . . I $L(DD)*2+$L(DS)>200!(DD="") S DD="" Q 49 . . S DS=DS_" I %?.E1P1"""_DD_""".E!(D'=""B""&(%?1"""_DD_""".E))" Q 50 . Q:DS="" S %=D 51 . D % S X=DIX N DILONGX 52 . S DS="S %=$P(^(0),U,1)"_DS,DIC(0)=DIC(0)_"D" D 7 Q 53 I Y'>0,$L(X)>30 D 54 . N DILONGX S DILONGX=1 55 . S %=D D % S Y="DICR("_DICR_")",DICR(DICR,"ORG")=X 56 . S DS=$S(DIC(0)["X":"I DIVAL="_Y,1:"I '$L($P(DIVAL,"_Y_"))") 57 . S:DIC(0)["O"&(DIC(0)'["E") DS=DS_",'$L($P(DIVAL,"_Y_",2))" 58 . D 7 I Y>0!(X'?.E1L.E)!(DIC(0)["X") K DILONGX Q 59 . S %=D D % S (X,DICR(DICR,"ORG"))=$$UP^DILIBF(X) 60 . S Y="DICR("_DICR_",""ORG"")" 61 . S DS="I '$L($P(DIVAL,"_Y_"))" S:DIC(0)["O"&(DIC(0)'["E") DS=DS_",'$L($P(DIVAL,"_Y_",2))" 62 . D 7 K DILONGX Q 63 ; 64 K S DD=$D(DICR(DICR,6)) K:'DICR DICR 65 I Y>0 K DIC("W") D R^DIC2 Q 66 I $G(DTOUT)!($G(DIROUT)) Q 67 W I @("$O("_DIC_"""A[""))]""""") G NL:DIC(0)["N",DD 68 I DO(2)'["Z" S Y=0 D Q:Y>0!($G(DIROUT)) 69 . N DIOUT S DIOUT=0 F DS=1:1 S @("Y=$O("_DIC_"Y))") D Q:DIOUT 70 . . I 'Y S Y=-1,DIOUT=1 Q 71 . . W:DIC(0)["E"&(DS#20=0) ".." 72 . . I $D(@(DIC_Y_",0)")),$P(^(0),U)=X X:$D(DIC("S")) DIC("S") I S DIOUT=1 73 . . I DIOUT S DIY="",DS=1 N DZ,DD D ADDKEY^DIC3,GOT^DIC2 74 . . Q 75 NL I '$G(DICR) D NQ I $T D Q:Y>0!($G(DTOUT))!($G(DIROUT)) 76 . N:'$G(DIASKOK) DIASKOK S (DS,DIASKOK)=1 N DZ,DD 77 . D ADDKEY^DIC3,GOT^DIC2 Q 78 DD S Y=-1 I DD D BAD^DIC1 Q 79 L I DIC(0)["L" K DD G ^DICN 80 B D BAD^DIC1 Q 81 ; 82 N D RS S X=$E(X,2,$L(X)-1),%=D D 83 . I DINDEX("#")>1 S %Y=+$G(DINDEX(1,"FIELD")),DS=$G(^DD(+$G(DINDEX(1,"FILE")),%Y,0)) Q:DS]"" 84 . S DS=^DD(+DO(2),.01,0),%Y=.01 Q 85 F Y="P","D","S","V" I $P(DS,U,2)[Y K:Y="P" DO D ^DICM1 S:$D(X)#2 DS("INT")=X Q 86 I $D(X),DINDEX("#")>1 S X(1)=X 87 S Y=-1 D L:$D(X),E 88 I Y'>0 K DUOUT D BAD^DIC1 Q 89 G 2 90 ; 91 A ; Set variables needed for transforming date/set/ptr/var.ptr 92 S DICR(DICR+1,4)=% 93 D % K DF,DID,DINUM Q 94 ; 95 % ; Set variables up before doing lookup w/transformed value 96 I DIC(0)'["L" S DICR(DICR+1,8)=1 97 E I '$$OKTOADD^DICM0(.DIFILEI,.DINDEX,.DIFINDER) S DICR(DICR+1,8)=1 98 I $G(DINUM)]"" S DICR(DICR+1,10)=DINUM 99 I $D(DF) S DICR(DICR+1,9)=DF S:$G(DID)]"" DICR(DICR+1,9.1)=$G(DID(1))_U_DID 100 RS S DICR=DICR+1,DICR(DICR)=X,DICR(DICR,0)=DIC(0),DIC(0)=$TR(DIC(0),"A"),DIC(0)=$TR(DIC(0),"Q") Q 101 ; 102 D S:$G(DICR(DICR,10))]"" DINUM=DICR(DICR,10) 103 S (D,DF)=DICR(DICR,4) D 104 . N T S T=$P($G(DS),U,2) 105 . S DIC(0)=$TR(DIC(0),"M","") I T["V" S DIC(0)=$TR(DIC(0),"A","") 106 . I D="B",T'["D",'$G(DITRANX) S DIC(0)=DIC(0)_"s" 107 . I T["P"!(T["V")!(T["S") S DIC(0)=DIC(0)_"X" 108 . Q 109 I DICR(DICR,4)=DINDEX N I M I=DINDEX N DINDEX M DINDEX=I K I S DINDEX("START")=DINDEX 110 E N DINDEX D 111 . S (DINDEX,DINDEX("START"))=DICR(DICR,4),DINDEX("WAY")=1 112 . D INDEX^DICUIX(.DIFILEI,DIFLAGS,.DINDEX,"",.DIVALUE) Q 113 I DINDEX("#")>1 S (DINDEX(1),DINDEX(1,"FROM"),DINDEX(1,"PART"))=$G(X) 114 RCR S:'$D(DIDA) DICRS=1 115 DIC ; 116 I $D(DICR(DICR,8)) S DIC(0)=$TR(DIC(0),"L") 117 S Y=-1 I $D(X),$L(X)<31 D 118 . N DIVAL S (DIVAL,DIVAL(1))=X N X S (X,X(1))=DIVAL 119 . D RENUM^DIC1 K DIDA Q 120 S:DIC(0)["L" DICR(DICR-1,6)=1 K:$D(DICR(DICR,4)) DF 121 E S D="B",%=DICR,X=DICR(%),DIC(0)=DICR(%,0),DICR=%-1 122 S:$G(DICR(%,10))]"" DINUM=DICR(%,10) 123 S:$D(DICR(%,9)) (D,DF)=DICR(%,9) I $G(DICR(%,9.1))]"" S:$P(DICR(%,9.1),U)]"" DID(1)=$P(DICR(%,9.1),U) S DID=$P(DICR(%,9.1),U,2,999) 124 K DICRS,DICR(%) D DO^DIC1:'$D(DO) Q 125 ; 126 NQ I $L(X)<14,X?.NP,+X=X,@("$D("_DIC_"X,0))") S Y=X D S^DIC3 127 Q 128 ; 129 SOUNDEX I DIC(0)["E",'$D(DICRS) W " " D RS,SOU S DIC(0)=$TR(DIC(0),"L") D RCR Q:Y>0 130 G R 131 ; 132 7 S Y=-1 N % S %=$S($D(DIC("S")):DIC("S"),1:1) 133 I $D(DS),'$D(DIC("S1")) D 134 . S DIC("S")=DS I '% S DIC("S")=DIC("S")_" X DIC(""S1"")",DIC("S1")=% 135 . I X]"" D 136 . . N DIVAL S (DIVAL,DIVAL(1))=X,DIVAL(0)=1 N X S (X,X(1))=DIVAL 137 . . N DINDEX,DIFILEI 138 . . S DIC(0)=$TR(DIC(0),"L") D F^DIC 139 . K DIC("S") S:$D(DIC("S1")) DIC("S")=DIC("S1") K DIC("S1") 140 D E Q 141 ; 142 SOU D SOU^DICM1 Q -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMP0.m
r613 r623 1 DICOMP0 ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;5NOV2007 2 ;;22.0;VA FileMan;**6,76,114,144,152**;;Build 10 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 N DICOMPI 5 SETFUNC I DPS,$D(DPS(DPS,"SET")),'$D(W(DPS)) S T="""",D=$P(X,T)_$P(X,T,2) G BAD:$L(D)+2\5-1!(D'?.UN)!(D?1"D".E)!(DUZ(0)'="@") S X=T_D_T,DICOMPX(D)=D,Y=0 Q 6 LIT I X?1"""".E1"""" S Y=0,%=$E(X,2,$L(X)-1) K:%[""" X "!(%[""" D @") Y S X=""""_$$CONVQQ^DILIBF(%)_"""" Q 7 L S T=DLV,DICN=X 8 TRY G M:'$D(J(T))!'$D(I(T)),M:+J(T)'=J(T),M:$G(^DD(J(T),.01,0))="",UP:$P(^(0),U,2)["W" S DIC="^DD("_J(T)_",",DG=$O(^DD(J(T),0,"NM",0))_" " 9 S DIC("S")=$S(W="["!($E(I,M,M+1)="'[")!$D(DICMX):"I ",1:"S %=$P(^(0),U,2) I '%,%'[""m"",")_"$$SCREEN^DICOMP0" 10 D DICS^DICOMPY:DUZ(0)'="@" 11 R I X?1"#"1.NP S X=$E(X,2,99) D ^DIC G:Y>0 A:DLV,X S X="#"_X 12 D ^DIC G A:Y>0 13 N I $P(X,DG)="",X=DICN S X=$P(X,DG,2,9) G R 14 NUMBER I X="NUMBER" S Y=.001,Y(0)=0 G D 15 UP S T=T-1,X=DICN G M:T<0,TRY:$D(J(T)) F T=T-99:1 G TRY:'$D(J(T+1)) 16 ; 17 A F D=M:1:$L(I)+1 Q:$F(X,$E(I,1,D))-1-D S W=$E(I,D+1) 18 I DICOMP["?",DICN'="#.01",$P(Y,U,2)'=DICN,DG_$P(Y,U,2)'=DICN D G BAD:%<0,N:%-1 19 .W !?3,"By '"_DICN_"', do you mean "_DG_"'"_$P(Y,U,2)_"'" S %=1 D YN^DICN 20 E S DICO("BACK",T)=+Y 21 S M=D 22 X I $D(DICOMPX)#2 S %Y=J(T)_U_+Y_$E(";",1,$L(DICOMPX)) S:";"_DICOMPX_";"'[(";"_%Y) DICOMPX=%Y_DICOMPX 23 D S D=$P(Y(0),"^",2),%=T\100*100,DICN=+Y,DICOMPI=W=")"&$D(DPS($$NEST^DICOMP,"INTERNAL")) D DATE:D["D"&'DICOMPI 24 I D["m"!D D MUL^DICOMPZ(D) Q 25 I $D(DICOMPX(1,J(T),+Y)) S X=DICOMPX(1,J(T),+Y) G O 26 I D["C" S:'$D(DG(%,T,+Y)) DG(%)=DG(%)+1,DG(%,T,+Y)=DG(%) S X=DQI_DG(%,T,+Y)_")" Q:D'["p"!DICOMPI S DICN=+$P(D,"p",2),%Y=$G(^DIC(DICN,0,"GL")) Q:%Y="" G POINT 27 GET I DICOMP["G",T#100=0 S X="$$GET^DDSVAL("_J(T)_",D0,"_+Y_",,"""_$E("E",'DICOMPI)_""")" G O 28 D G^DICOMPY 29 O Q:DICOMPI 30 S T=J(T) 31 S ; 32 S %=DLV0,DG=W=":"&'$D(DPS(DPS,"$S")) 33 OUT I D["O"&(D'["P"!'DG)!(D["V"&'$D(DPS(DPS,"FILE"))) D Q 34 .S X="$$EXTERNAL^DIDU("_T_","_DICN_","""","_X_")",DICO("DIERR")=1 35 SET I D["S" S DG(%)=DG(%)+1,DG(%,DG(%))="$C(59)_$P($G(^DD("_T_","_DICN_",0)),U,3)",X="$P($P("_DQI_DG(%)_"),$C(59)_"_X_"_"":"",2),$C(59))" 36 Q:D'["P" S %Y=U_$P(Y(0),U,3),DICN=+$P(@(%Y_"0)"),U,2) 37 POINT I W=":" G MR:'$$OKFILE^DICOMPX(DICN,DICOMP) 38 I W'=":" S D=$P($G(^DD(DICN,.01,0)),U,2) I D'["V",D'["S",D'["P" D DATE:D["D" S X="$P($G("_%Y_"+"_X_",0)),U)" Q 39 P G P^DICOMPX 40 ; 41 M S T=$F(X," IN ") I T S X=$E(X,1,T-5),W=":",M=T-4,I=X_W_$E(I,T,999),T=$F(I," FILE",M) S:T&$F(DPUNC,$E(I,T)) I=$E(I,1,T-6)_$E(I,T,999) G DICOMP0 42 G MR:$L(X)>30 S DICF=X,T=$O(^DD("FUNC","B",X,0)) 43 G LITDATE:'$D(^DD("FUNC",+T,3)),LITDATE:^(3) 44 I $G(^(1))'="" D 2^DICOMP S Y(0)=0,K=K+1,K(K)=X D DATE:$G(^(2))?1"D".E,DPS^DICOMPW Q 45 G MR:X'?1"PRIOR"4.U S Y=X,X="$P($$LAST^DIAUTL("_J(DLV0)_",D0,""*""),U)" I Y["USER",$D(^VA(200)) S $E(X,$L(X))=",2)",DICN=200,%Y="^VA(200," G POINT 46 G DATE 47 ; 48 LITDATE S %DT="T" I $L(X)>2 D ^%DT I Y>0 S X=Y,Y(0)=0 D DATE Q ;may be a literal date 49 BACKPNT S T=$O(^DIC("B",X)) I T]"",$P(T,X)=""!$D(^(X)),$D(J(0)) S T=DLV0 D ^DICOMPV I D>0 Q ;try backwards-pointer TOOK OFF CHECK FOR DICOMPW VARIABLE 3/28/2000 50 MR I M'>$L(I),+X'=X D MR^DICOMP G L:X]"" 51 BAD K Y Q 52 ; 53 DATE ; 54 S DATE(K+1)=1 Q 55 ; 56 SCREEN() ;Screen out certain fields as we process an atom 57 I $D(DICO("BACK"))=11,$G(DICO("BACK",T))=Y Q 0 58 I Y=DA,DICO(1)=T Q 0 ;Computed field cannot refer to itself! 59 I $P(^(0),U,2) Q '$G(DBOOL) ;A multiple cannot be manipulated as a Boolean! 60 I $P(^(0),U,2)'["P" Q 1 61 N P S P=$P(^(0),U,3) I P]"",$D(@(U_P_"0)")) Q 1 ;Only allow a pointer that points to an existing file! 62 Q 0 1 DICOMP0 ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;2DEC2006 2 ;;22.0;VA FileMan;**6,76,114,144**;;Build 5 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 N DICOMPI 5 SETFUNC I DPS,$D(DPS(DPS,"SET")),'$D(W(DPS)) S T="""",D=$P(X,T)_$P(X,T,2) G BAD:$L(D)+2\5-1!(D'?.UN)!(D?1"D".E)!(DUZ(0)'="@") S X=T_D_T,DICOMPX(D)=D,Y=0 Q 6 LIT I X?1"""".E1"""" S Y=0,%=$E(X,2,$L(X)-1) K:%[""" X "!(%[""" D @") Y S X=""""_$$CONVQQ^DILIBF(%)_"""" Q 7 L S T=DLV,DICN=X 8 TRY G M:'$D(J(T))!'$D(I(T)),M:+J(T)'=J(T),M:$D(^DD(J(T)))<9 S DIC="^DD("_J(T)_",",DG=$O(^DD(J(T),0,"NM",0))_" " 9 S DIC("S")=$S(W="["!($E(I,M,M+1)="'[")!$D(DICMX):"I ",1:"S %=$P(^(0),U,2) I '%,%'[""m"",")_"$$SCREEN^DICOMP0" 10 D DICS^DICOMPY:DUZ(0)'="@" 11 R I X?1"#"1.NP S X=$E(X,2,99) D ^DIC G:Y>0 A:DLV,X S X="#"_X 12 D ^DIC G A:Y>0 13 N I $P(X,DG)="",X=DICN S X=$P(X,DG,2,9) G R 14 NUMBER I X="NUMBER" S Y=.001,Y(0)=0 G D 15 S T=T-1,X=DICN G M:T<0,TRY:$D(J(T)) F T=T-99:1 G TRY:'$D(J(T+1)) 16 ; 17 A F D=M:1:$L(I)+1 Q:$F(X,$E(I,1,D))-1-D S W=$E(I,D+1) 18 I DICOMP["?",DICN'="#.01",$P(Y,U,2)'=DICN,DG_$P(Y,U,2)'=DICN D G BAD:%<0,N:%-1 19 .W !?3,"By '"_DICN_"', do you mean "_DG_"'"_$P(Y,U,2)_"'" S %=1 D YN^DICN 20 E S DICO("BACK",T)=+Y 21 S M=D 22 X I $D(DICOMPX)#2 S %Y=J(T)_U_+Y_$E(";",1,$L(DICOMPX)) S:";"_DICOMPX_";"'[(";"_%Y) DICOMPX=%Y_DICOMPX 23 D S D=$P(Y(0),"^",2),%=T\100*100,DICN=+Y,DICOMPI=W=")"&$D(DPS($$NEST^DICOMP,"INTERNAL")) D DATE:D["D"&'DICOMPI 24 I D["m"!D D MUL^DICOMPZ(D) Q 25 I $D(DICOMPX(1,J(T),+Y)) S X=DICOMPX(1,J(T),+Y) G O 26 I D["C" S:'$D(DG(%,T,+Y)) DG(%)=DG(%)+1,DG(%,T,+Y)=DG(%) S X=DQI_DG(%,T,+Y)_")" Q:D'["p"!DICOMPI S DICN=+$P(D,"p",2),%Y=$G(^DIC(DICN,0,"GL")) Q:%Y="" G POINT 27 GET I DICOMP["G",T#100=0 S X="$$GET^DDSVAL("_J(T)_",D0,"_+Y_",,"""_$E("E",'DICOMPI)_""")" G O 28 D G^DICOMPY 29 O Q:DICOMPI 30 S T=J(T) 31 S ; 32 S %=DLV0,DG=W=":"&'$D(DPS(DPS,"$S")) 33 I D["O"&(D'["P"!'DG)!(D["V"&'$D(DPS(DPS,"FILE"))) D DIMP^DICOMPZ("N C S Y="_X_",C="""_D_""" D:$D(^DD("_T_","_DICN_",0)) Y^DIQ") S X=X_" S X=Y" Q 34 SET I D["S" S DG(%)=DG(%)+1,DG(%,DG(%))="$C(59)_$P($G(^DD("_T_","_DICN_",0)),U,3)",X="$P($P("_DQI_DG(%)_"),$C(59)_"_X_"_"":"",2),$C(59))" 35 Q:D'["P" S %Y=U_$P(Y(0),U,3),DICN=+$P(@(%Y_"0)"),U,2) 36 POINT I W=":" G MR:'$$OKFILE^DICOMPX(DICN,DICOMP) 37 I W'=":" S D=$P($G(^DD(DICN,.01,0)),U,2) I D'["V",D'["S",D'["P" D DATE:D["D" S X="$P($G("_%Y_"+"_X_",0)),U)" Q 38 P G P^DICOMPX 39 ; 40 M S T=$F(X," IN ") I T S X=$E(X,1,T-5),W=":",M=T-4,I=X_W_$E(I,T,999),T=$F(I," FILE",M) S:T&$F(DPUNC,$E(I,T)) I=$E(I,1,T-6)_$E(I,T,999) G DICOMP0 41 G MR:$L(X)>30 S DICF=X,T=$O(^DD("FUNC","B",X,0)) 42 G LITDATE:'$D(^DD("FUNC",+T,3)),LITDATE:^(3) 43 I $G(^(1))'="" D 2^DICOMP S Y(0)=0,K=K+1,K(K)=X D DATE:$G(^(2))?1"D".E,DPS^DICOMPW Q 44 G MR:X'?1"PRIOR"4.U S Y=X,X="$P($$LAST^DIAUTL("_J(DLV0)_",D0,""*""),U)" I Y["USER",$D(^VA(200)) S $E(X,$L(X))=",2)",DICN=200,%Y="^VA(200," G POINT 45 G DATE 46 ; 47 LITDATE S %DT="T" I $L(X)>2 D ^%DT I Y>0 S X=Y,Y(0)=0 D DATE Q ;may be a literal date 48 BACKPNT S T=$O(^DIC("B",X)) I T]"",$P(T,X)=""!$D(^(X)),$D(J(0)) S T=DLV0 D ^DICOMPV I D>0 Q ;try backwards-pointer TOOK OFF CHECK FOR DICOMPW VARIABLE 3/28/2000 49 MR I M'>$L(I),+X'=X D MR^DICOMP G L:X]"" 50 BAD K Y Q 51 ; 52 DATE ; 53 S DATE(K+1)=1 Q 54 ; 55 SCREEN() ;Screen out certain fields as we process an atom 56 I $D(DICO("BACK"))=11,$G(DICO("BACK",T))=Y Q 0 57 I Y=DA,DICO(1)=T Q 0 ;Computed field cannot refer to itself! 58 I $P(^(0),U,2) Q '$G(DBOOL) ;A multiple cannot be manipulated as a Boolean! 59 I $P(^(0),U,2)'["P" Q 1 60 N P S P=$P(^(0),U,3) I P]"",$D(@(U_P_"0)")) Q 1 ;Only allow a pointer that points to an existing file! 61 Q 0 -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMP1.m
r613 r623 1 DICOMP1 ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;19JUNE20072 ;;22.0;VA FileMan;**6,44,76,152**;Mar 30, 1999;Build 10 3 ;Per VHA Directive 2004-038, this routine should not be modified.4 5 6 INIT 7 NN 8 9 10 11 12 13 AS 14 15 16 17 18 P 19 20 21 DATE 22 23 2 24 25 26 27 28 DTC 29 30 A 31 K1 32 S 33 34 0 35 36 37 38 39 40 41 Q 42 I $D(X) S:$D(DICO("DIERR")) X="N DIERR "_X I $G(DICOMPQI) S X="N Y "_X43 Y 44 45 46 47 48 49 ST 50 51 52 X 53 54 55 56 C 57 58 59 60 61 62 63 64 65 66 VP 67 OV 68 69 70 71 M 72 EXTRASB 73 74 SS 75 76 EX 77 78 SX 79 1 DICOMP1 ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;12:45 PM 9 Sep 2002 2 ;;22.0;VA FileMan;**6,44,76**;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 F Q:'$D(DPS(DPS,"ST")) D DPS^DICOMPW S K=K+1,K(K)=X 5 G 0:DPS 6 INIT S T=99,DLV0=0,X="",K=1 D ST ;ST will build code to get top=level values 7 NN I $D(K(K,1)) S DLV0=K(K,1) K K(K,1) D ST ;'1' flags a change in levels 8 I $D(K(K,9)) F %=1:1:K K DATE(%) 9 G S:$D(K(K))[0,K1:K(K)="" 10 I " "[$E(K(K)) D 11 .Q:X="" 12 .I K(K)?1" S ".E D Q 13 AS ..D EX I $L(K(K))+$L(X)>160 D M Q 14 ..S K(K)=$E(K(K),4,999),X=X_"," 15 .D EX:W,M:$L(X)+$L(K(K))>180 16 E I 'W D M:$L(X)+$L(K(K))>165 S X=X_" S X=",W=6 17 D:K(K)?1P 18 P .I "\/"[K(K),$G(K(K+1))'?.NP S K=K+1,K(K)=",X=$S("_K(K)_":X"_K(K-1)_K(K)_",1:""*******"")" 19 .I $L(X)>150,$F(DPUNC,K(K))>3 D M,SX 20 G A:'$D(DATE(K)) 21 DATE I $G(K(K-1))="_",X?.E1"_" S X=$E(X,1,$L(X)-1) D EXTRASB S Y=$$DGI^DICOMP,X=X_" S "_Y_"=X,X="_K(K)_" S Y=X X ^DD(""DD"") S X="_Y_"_Y",K(K)="" G A 22 S Y=1 I $G(K(K-1))="+" S X=X_"0,X2=X,X1="_K(K) G DTC 23 2 G A:$D(K(K+2))[0 24 K DATE(K) 25 I $D(DATE(K+2))[0,$F("+-",K(K+1))>1 S X=X_K(K)_",X1=X,X2="_K(K+1)_K(K+2),DATE(K+2)=1 26 E G A:K(K+1)'="-" K DATE(K+2) S X=X_K(K)_",X1=X,X2="_K(K+2),Y=0 27 S K=K+2 28 DTC S K=K+1,X=X_",X="""" D"_$P(":X2 ^ C",U,Y+1)_"^%DTC:X1" G S:'$D(K(K)) D SX G NN:'Y S K=K-1,K(K)="" G 2 29 ; 30 A S W='$D(K(K,2)),X=X_K(K) 31 K1 S K=K+1 G NN:$D(K(K))#2 32 S S I="" F S I=$O(M(I)),W=0 Q:I="" D M:$L(X)>235 S K=$O(M(I,"")),X=X_" S D"_I_"="_$S(DA:DQI_(K+80),1:"I("_K_",0")_")" 33 S I=-1 D SS S:X?.E1" S X=X" X=$E(X,1,$L(X)-6) I X'?1"S X="1N.NP!(DICOMP["Z") G Q 34 0 ;NO GOT! Come here when parsing fails 35 K X,DIM,DATE I DUZ(0)="@",DICOMP'["X" D 36 .Q:DICO'[" " 37 .S DIM=1 I $L(DICO," ")=2 F Y="OPEN","CLOSE","BREAK","USE" D I '$D(DIM) Q 38 ..I $E(Y)=$P(DICO," ")!(Y=$P(DICO," ")) K DIM 39 .I $D(DIM) S X=DICO D ^DIM 40 S DICOMP="",DLV=DICO(1) 41 Q I DICOMP'["S" S K=DICO(1) F S K=$O(I(K)) Q:K="" K I(K),J(K) 42 I $G(DICOMPQI),$D(X) S X="N Y "_X 43 Y K Y I $D(DICO("RCR")) S Y=DICO("RCR") 44 E S Y=DLV_$E("W",$D(DPS("W")))_$S($G(DBOOL)=1:"B",$D(DATE)>9:"D",1:"")_$E("X",$D(DIM))_$E("L",$D(DICO(2))) 45 S Y=Y_DIMW 46 I $D(DICO("PT")) S Y=Y_"p"_DICO("PT") 47 K K,DLV,DICOMP,DICMX Q 48 ; 49 ST S W=0,DG="" F S DG=$O(DG(DLV0,DG)),Y=$P(DG,U,2) Q:DG="" D 50 .I Y]"" S:+Y'=Y Y=""""_Y_"""" S I=DQI_DG(DLV0,DG)_")=$S($D(^(" D:T-DG!(DG<DLV0) S I=I_Y_")):^("_Y_"),1:"""")" G VP 51 ..N T,QI,% 52 X ..S I=$P(I,U),%=DG\100*100 53 ..F T=0:1:DG#100 S QI=I(%) S I=I_QI_$E(",",1,T)_$S(DICOMP["T"&(DG<DICO(0)):"I("_%_",0)",1:"D"_T)_",",%=%+1 54 ..K DG(DLV0,DG) 55 ..;do not change above code to use "$G" until you change E2+4^DIP0 ! 56 C .F S %=$O(DG(DLV0,DG,0)) Q:'% D K DG(DLV0,DG,%) ;for Computed Fields 57 ..S I=" X ""N I,Y ""_$P(^DD("_J(DG)_","_%_",0),U,5,99)" 58 ..I DICOMP["T",DG<DICO(0) D 59 ...N W,SV S SV=X,X="N D0 S D0=I("_DG_",0)"_I D EXTRASB S I=X,X=SV 60 ..S I=I_" S "_DQI_DG(DLV0,DG,%)_")=X" 61 ..D EX:W,M:$L(X)+$L(I)>180 S X=X_I 62 .Q:$D(DG(DLV0,DG))[0 63 .S I=DG(DLV0,DG) I I?.N S I=$S(DA:DQI_(DLV0+I+80),1:"I("_(DLV0+I)_",0")_")=$G(D"_I_")" 64 .E S I=DQI_+DG_")="_I 65 .K DG(DLV0,DG) G OV:DG?.N1A 66 VP .I $G(DICV)["V" S I=I_"_$C(59)_"""_$E(I(0),2,99)_"""" 67 OV .I $L(I)+$L(X)>180 D M 68 .S:'W X=X_" S " S X=X_I_",",W=2 69 D EX S W=0 Q 70 ; 71 M D SS,EX 72 EXTRASB D DIMP^DICOMPZ(X) S W=0 Q 73 ; 74 SS Q:$A(X)-32 S X=$E(X,2,999) G SS 75 ; 76 EX S X=$E(X,1,$L(X)-W+1) Q 77 ; 78 SX S X=X_" S X=X",W=1 79 Q -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMPZ.m
r613 r623 1 DICOMPZ ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;9APR2007 2 ;;22.0;VA FileMan;**6,76,114,152**;Mar 30, 1999;Build 10 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 PRIOR ;from DICOMP -- PRIOR.. Functions get archived values 6 N DIC,DICOMPSP,DICOMPXE,DICOPS 7 S X=$E(X,6,99),DICOMPSP=$E("D",X="DATE"),DICOMPXE="D "_X_"^DIAUTL(",W=$F(I,")",M) S:X="USER"&$D(^VA(200)) DICO("PT")=200,DICOMPSP="p200" I 'W!'$D(DICMX)!'$D(J(0)) K Y Q 8 S X=$E(I,M+1,W-2),M=W,W=$E(I,M) S:X?1"#"1.NP X=$E(X,2,999) 9 S DIC="^DD("_J(DLV)_",",DIC(0)="",DIC("S")="I '$P(^(0),U,2),$P(^(0),U,2)'[""C""" D DICS^DICOMPY,^DIC K DIC I Y<0 K Y Q ;Find Field that is the argument of PRIOR function 10 S DICOMPXE=DICOMPXE_+J(DLV)_","_+Y_")" 11 S DICOPS="><[]=",DIMW="m" 12 G INSERT 13 ; 14 BACKPNT ;from DICOMPV -- Backwards Pointer 15 N DICOPS,D 16 S DICOPS="><[]=" 17 G COLON 18 ; 19 MUL(DICOMPSP) ;DICOMPSP is the SPECIFIER of the Field we have encountered 20 N DICOXR,DICOMPXE,DICOPS S DICOPS="><][=" 21 I DICOMPSP S X=$P(^DD(+DICOMPSP,.01,0),U,2) G WP:X["W" D S DLV=DLV+1,I(DLV)=""""_$P($P(Y(0),U,4),";")_"""",J(DLV)=+DICOMPSP D X G FOR 22 .I T<DLV S DLV0=DLV0+100,%=DLV0-(T\100*100) F DLV=DLV0:1 S I(DLV)=I(DLV-%),J(DLV)=J(DLV-%),DG(DLV-%,DLV0-%)=DLV#100 I DLV-%=T S K(K+1,1)=DLV0,(T,DG(DLV0))=DLV Q 23 S Y=+$P(DICOMPSP,"p",2),DIMW="m"_$E("w",DICOMPSP["w"),DICOMPXE=$P(Y(0),U,5,99) 24 I Y S (%,DLV,DLV0)=DLV0+100,I(%)=^DIC(Y,0,"GL"),J(%)=Y D X^DICOMPV(Y,.01) 25 INSERT N DICOMX S D=DICOMPXE,DICOMX=DICMX D CONTAINS Q:'$D(Y) I DICOMX=DICMX D 26 .I DICOMPSP["D" S DICMX="S Y=X X ^DD(""DD"") S X=Y "_DICMX 27 .I DICOMPSP["p" S DICMX="S X=$$CP^DIQ1("""_DICOMPSP_""",X) "_DICMX 28 N F,Z,I S Z="" 29 S F=$F(DICMX,"X DICMX") I F D 30 .S Z="N DICOMPM S DICOMPM=$G(DICMX,""Q"") " 31 .S DICMX=$E(DICMX,1,F-6)_"DICOMPM"_$E(DICMX,F,999) 32 D DIMP(DICMX) S Z=Z_"N DICMX S DICMX="_$$DA_$$DIMC_")" 33 D DIMP(D),DICOXR S Z=Z_X 34 D DIMP(Z) S X=X_" S X=X" Q 35 ; 36 WP S DIMW="m"_$E("w",X'["L"),DICOPS="[" 37 M S X="S X=^(0)" 38 FOR N DICOR,DICOT 39 S DICOMPXE=X,DICOT=Y(0) D CONTAINS Q:'$D(Y) 40 S Y=T#100+1,D=$P($P(DICOT,U,4),";") I +D'=D S D=""""_D_"""" 41 S DICOMPXE="D,0))#2 "_DICOMPXE_" "_DICMX_" Q:'$D(D) S D=D"_Y 42 S DICOR=$$REF(T)_","_D_",",D="F D=0:0 S (D,D"_Y_")=$O("_DICOR 43 I W=")",$D(DPS(DPS,"INTERNAL")) S D="S D=$G(DIWF) N DIWF S DIWF=D_""XL"" "_D ;**DI*22*152 44 S %=+$P(DICOT,U,2) 45 I $P($G(^DD(%,.01,0)),U,2)["W"!'$D(^DD(%,0,"IX","B",%,.01)) 46 E I '$D(^DD(%,.01,1,1,0)) 47 E I $P(^(0),U,3)]"" 48 I S D=D_"D)) Q:D'>0 I $D(^("_DICOMPXE ;We will go thru the muliple by ien 49 E D DIMP(D_"""B"",DICOB,D)) Q:D'>0 I $D("_DICOR_DICOMPXE) S D="N DICOB S DICOB="""" F S DICOB=$O("_DICOR_"""B"",DICOB)) Q:DICOB="""" "_X_" Q:'$D(D)" ;We will go thru the multiple using the B X-ref 50 D DIMP($$I(Y)_D) 51 S (T,DG(DLV0))=DG(DLV0)+1,K(K+1,2)=1,K(K+2,1)=DLV0,DG(DLV0,T)=Y,M(Y,DLV0+Y)=T 52 S X=X_":D"_(Y-1)_">0" 53 DICOXR S X=X_" S X="_$S(DIMW["m"!'$D(DICOXR):"""""",1:DICOXR) 54 Q 55 ; 56 CONTAINS N DICON 57 S DICON=W="'",%=$E(I,M+DICON) I %=""!(W=")") S Y=0 Q 58 I DICOPS[% S DICOPS=% D R($E(I,M+DICON+1,999)) Q:'$D(Y) D Q 59 .S DICOXR=$$DGI^DICOMP 60 .D DIMP("S Y=X "_X_" I Y"_DICOPS_"X S "_DICOXR_"="_'DICON_" K D") S DICMX=X 61 .S K(K+1)=" S "_DICOXR_"="_DICON,K=K+1 62 .S DBOOL=1,DIMW="" 63 COLON I W'=":" Q:W="" S DICOMPX("X")="X",I="X"_$E(I,M,999),M=0 I DICOPS="[" K Y Q 64 N DQI D R($E(I,M+1,999)) Q:'$D(Y) I '$D(DICO("RCR")) S DICO("RCR")=Y 65 I Y#100=0 S W=$G(J(+Y)) I W S DICO("PT")=W 66 S DICMX=X_" "_$G(DICMX) Q ;The 'X" code that we got back from RCR becomes what we eXecute for every multiple! 67 ; 68 R(DICORM) N DICOLEFT,DICOX S DICOLEFT="",DICOX=0 F %=1:1 S W=$E(DICORM,%) Q:W="" S:W="(" DICOX=DICOX+1 I W=")" S DICOX=DICOX-1 I DICOX<0 S DICOLEFT=$E(DICORM,%,999),DICORM=$E(DICORM,1,%-1) 69 S DICOX=$G(X) D RCR(DICORM) 70 S W="",M=0,I=DICOLEFT S:'$D(Y) I=DICORM,X=DICOX Q 71 ; 72 RCR(W) ;Tricky and important! What we get from this recursion will be inserted into the larger expression. 73 N D 74 S:+W=W W=""""_W_"""" S D="ZXM"_$$DIMC_" S"_DICOMP D ;Don't allow MUMPS. Remember where to start more nodes in X array. Allow simple numeric. 75 .N X,DICOMP,DLV,DICMXSV,K 76 .S X=W,DICOMP=D I $D(DICMX) S DICMXSV=DICMX 77 DQI .I $D(DQI) S %=DQI N DQI S DQI=%_$$DIMC_"," 78 .D EN1^DICOMP ;Here is the recursion! I & J, the context, will be preserved by this entry point 79 .I '$D(X) K Y Q 80 .K W M W=X 81 .I Y["m" K DICMXSV 82 .I $D(DICMXSV) S DICMX=DICMXSV 83 I $D(Y) M X=W D DIMP(X),DATE^DICOMP0:Y["D" ;Remember if it's a DATE 84 Q 85 ; 86 DIMP(D) ; 87 N DIM 88 S DIM=$$DIMC,DIM=DIM+$S(DIM<9.8:.1,1:.01) 89 S X(DIM)=D,X=" X "_$$DA_DIM_")" Q 90 ; 91 DA() Q $S(DA:"^DD("_A_","_DA_",",1:DA) 92 ; 93 DIMC() N DIM 94 S DIM=$O(X(99),-1) I 'DIM S DIM=+$P(DICOMP,"M",2) I 'DIM S DIM=9.1 95 Q DIM 96 ; 97 X ; 98 S X="S X=$P(^(0),U)"_$S(X["D"&'$D(DPS($$NEST^DICOMP,"INTERNAL")):",Y=X X ^DD(""DD"") S X=Y",X["P":" S:$D(^"_$P(^(0),U,3)_"+X,0)) X=$P(^(0),U)",X["S":",Y=$F(^DD("_+D_",.01,0),X_$C(58)) S:Y X=$P($E(^(0),Y,999),$C(59),1)",1:""),DIMW="m" Q 99 ; 100 I(LEV) N S 101 S S=DLV0+LEV I DICOMP'["I"!'$D(I(S)) Q "" 102 Q "S I("_S_")="""_$$CONVQQ^DILIBF(I(S))_""",J("_S_")="_J(S)_" " 103 ; 104 REF(T) ; 105 N L,D,X,V 106 F L=T\100*100:1:T S D=I(L) S X=$G(X)_D_$E(",",$D(X))_$S(L<DLV0:"I("_L_",0)",1:"D"_(L#100))_"," 107 Q $E(X,1,$L(X)-1) 1 DICOMPZ ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;05:07 PM 16 Jan 2003 2 ;;22.0;VA FileMan;**6,76,114**;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 PRIOR ;from DICOMP -- PRIOR.. Functions get archived values 6 N DIC,DICOMPSP,DICOMPXE,DICOPS 7 S X=$E(X,6,99),DICOMPSP=$E("D",X="DATE"),DICOMPXE="D "_X_"^DIAUTL(",W=$F(I,")",M) S:X="USER"&$D(^VA(200)) DICO("PT")=200,DICOMPSP="p200" I 'W!'$D(DICMX)!'$D(J(0)) K Y Q 8 S X=$E(I,M+1,W-2),M=W,W=$E(I,M) S:X?1"#"1.NP X=$E(X,2,999) 9 S DIC="^DD("_J(DLV)_",",DIC(0)="",DIC("S")="I '$P(^(0),U,2),$P(^(0),U,2)'[""C""" D DICS^DICOMPY,^DIC K DIC I Y<0 K Y Q ;Find Field that is the argument of PRIOR function 10 S DICOMPXE=DICOMPXE_+J(DLV)_","_+Y_")" 11 S DICOPS="><[]=",DIMW="m" 12 G INSERT 13 ; 14 BACKPNT ;from DICOMPV -- Backwards Pointer 15 N DICOPS,D 16 S DICOPS="><[]=" 17 G COLON 18 ; 19 MUL(DICOMPSP) ;DICOMPSP is the SPECIFIER of the Field we have encountered 20 N DICOXR,DICOMPXE,DICOPS S DICOPS="><][=" 21 I DICOMPSP S X=$P(^DD(+DICOMPSP,.01,0),U,2) G WP:X["W" D S DLV=DLV+1,I(DLV)=""""_$P($P(Y(0),U,4),";")_"""",J(DLV)=+DICOMPSP D X G FOR 22 .I T<DLV S DLV0=DLV0+100,%=DLV0-(T\100*100) F DLV=DLV0:1 S I(DLV)=I(DLV-%),J(DLV)=J(DLV-%),DG(DLV-%,DLV0-%)=DLV#100 I DLV-%=T S K(K+1,1)=DLV0,(T,DG(DLV0))=DLV Q 23 S Y=+$P(DICOMPSP,"p",2),DIMW="m"_$E("w",DICOMPSP["w"),DICOMPXE=$P(Y(0),U,5,99) 24 I Y S (%,DLV,DLV0)=DLV0+100,I(%)=^DIC(Y,0,"GL"),J(%)=Y D X^DICOMPV(Y,.01) 25 INSERT N DICOMX S D=DICOMPXE,DICOMX=DICMX D CONTAINS Q:'$D(Y) I DICOMX=DICMX D 26 .I DICOMPSP["D" S DICMX="S Y=X X ^DD(""DD"") S X=Y "_DICMX 27 .I DICOMPSP["p" S DICMX="S X=$$CP^DIQ1("""_DICOMPSP_""",X) "_DICMX 28 N F,Z,I S Z="" 29 S F=$F(DICMX,"X DICMX") I F D 30 .S Z="N DICOMPM S DICOMPM=$G(DICMX,""Q"") " 31 .S DICMX=$E(DICMX,1,F-6)_"DICOMPM"_$E(DICMX,F,999) 32 D DIMP(DICMX) S Z=Z_"N DICMX S DICMX="_$$DA_$$DIMC_")" 33 D DIMP(D),DICOXR S Z=Z_X 34 D DIMP(Z) S X=X_" S X=X" Q 35 ; 36 WP S DIMW="m"_$E("w",X'["L"),DICOPS="[" 37 M S X="S X=^(0)" 38 FOR N DICOR,DICOT 39 S DICOMPXE=X,DICOT=Y(0) D CONTAINS Q:'$D(Y) 40 S Y=T#100+1,D=$P($P(DICOT,U,4),";") I +D'=D S D=""""_D_"""" 41 S DICOMPXE="D,0))#2 "_DICOMPXE_" "_DICMX_" Q:'$D(D) S D=D"_Y 42 S DICOR=$$REF(T)_","_D_",",D="F D=0:0 S (D,D"_Y_")=$O("_DICOR 43 S %=+$P(DICOT,U,2) 44 I $P($G(^DD(%,.01,0)),U,2)["W"!'$D(^DD(%,0,"IX","B",%,.01)) 45 E I '$D(^DD(%,.01,1,1,0)) 46 E I $P(^(0),U,3)]"" 47 I S D=D_"D)) Q:D'>0 I $D(^("_DICOMPXE ;We will go thru the muliple by ien 48 E D DIMP(D_"""B"",DICOB,D)) Q:D'>0 I $D("_DICOR_DICOMPXE) S D="N DICOB S DICOB="""" F S DICOB=$O("_DICOR_"""B"",DICOB)) Q:DICOB="""" "_X_" Q:'$D(D)" ;We will go thru the multiple using the B X-ref 49 D DIMP($$I(Y)_D) 50 S (T,DG(DLV0))=DG(DLV0)+1,K(K+1,2)=1,K(K+2,1)=DLV0,DG(DLV0,T)=Y,M(Y,DLV0+Y)=T 51 S X=X_":D"_(Y-1)_">0" 52 DICOXR S X=X_" S X="_$S(DIMW["m"!'$D(DICOXR):"""""",1:DICOXR) 53 Q 54 ; 55 CONTAINS N DICON 56 S DICON=W="'",%=$E(I,M+DICON) I %="" S Y=0 Q 57 I DICOPS[% S DICOPS=% D R($E(I,M+DICON+1,999)) Q:'$D(Y) D Q 58 .S DICOXR=$$DGI^DICOMP 59 .D DIMP("S Y=X "_X_" I Y"_DICOPS_"X S "_DICOXR_"="_'DICON_" K D") S DICMX=X 60 .S K(K+1)=" S "_DICOXR_"="_DICON,K=K+1 61 .S DBOOL=1,DIMW="" 62 COLON I W'=":" Q:W="" S DICOMPX("X")="X",I="X"_$E(I,M,999),M=0 I DICOPS="[" K Y Q 63 N DQI D R($E(I,M+1,999)) Q:'$D(Y) I '$D(DICO("RCR")) S DICO("RCR")=Y 64 I Y#100=0 S W=$G(J(+Y)) I W S DICO("PT")=W 65 S DICMX=X_" "_$G(DICMX) Q ;The 'X" code that we got back from RCR becomes what we eXecute for every multiple! 66 ; 67 R(DICORM) N DICOLEFT,DICOX S DICOLEFT="",DICOX=0 F %=1:1 S W=$E(DICORM,%) Q:W="" S:W="(" DICOX=DICOX+1 I W=")" S DICOX=DICOX-1 I DICOX<0 S DICOLEFT=$E(DICORM,%,999),DICORM=$E(DICORM,1,%-1) 68 S DICOX=$G(X) D RCR(DICORM) 69 S W="",M=0,I=DICOLEFT S:'$D(Y) I=DICORM,X=DICOX Q 70 ; 71 RCR(W) ;Tricky and important! What we get from this recursion will be inserted into the larger expression. 72 N D 73 S:+W=W W=""""_W_"""" S D="ZXM"_$$DIMC_" S"_DICOMP D ;Don't allow MUMPS. Remember where to start more nodes in X array. Allow simple numeric. 74 .N X,DICOMP,DLV,DICMXSV,K 75 .S X=W,DICOMP=D I $D(DICMX) S DICMXSV=DICMX 76 DQI .I $D(DQI) S %=DQI N DQI S DQI=%_$$DIMC_"," 77 .D EN1^DICOMP ;Here is the recursion! I & J, the context, will be preserved by this entry point 78 .I '$D(X) K Y Q 79 .K W M W=X 80 .I Y["m" K DICMXSV 81 .I $D(DICMXSV) S DICMX=DICMXSV 82 I $D(Y) M X=W D DIMP(X),DATE^DICOMP0:Y["D" ;Remember if it's a DATE 83 Q 84 ; 85 DIMP(D) ; 86 N DIM 87 S DIM=$$DIMC,DIM=DIM+$S(DIM<9.8:.1,1:.01) 88 S X(DIM)=D,X=" X "_$$DA_DIM_")" Q 89 ; 90 DA() Q $S(DA:"^DD("_A_","_DA_",",1:DA) 91 ; 92 DIMC() N DIM 93 S DIM=$O(X(99),-1) I 'DIM S DIM=+$P(DICOMP,"M",2) I 'DIM S DIM=9.1 94 Q DIM 95 ; 96 X ; 97 S X="S X=$P(^(0),U)"_$S(X["D"&'$D(DPS($$NEST^DICOMP,"INTERNAL")):",Y=X X ^DD(""DD"") S X=Y",X["P":" S:$D(^"_$P(^(0),U,3)_"+X,0)) X=$P(^(0),U)",X["S":",Y=$F(^DD("_+D_",.01,0),X_$C(58)) S:Y X=$P($E(^(0),Y,999),$C(59),1)",1:""),DIMW="m" Q 98 ; 99 I(LEV) N S 100 S S=DLV0+LEV I DICOMP'["I"!'$D(I(S)) Q "" 101 Q "S I("_S_")="""_$$CONVQQ^DILIBF(I(S))_""",J("_S_")="_J(S)_" " 102 ; 103 REF(T) ; 104 N L,D,X,V 105 F L=T\100*100:1:T S D=I(L) S X=$G(X)_D_$E(",",$D(X))_$S(L<DLV0:"I("_L_",0)",1:"D"_(L#100))_"," 106 Q $E(X,1,$L(X)-1) -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DID1.m
r613 r623 1 DID1 ;SFISC/XAK,JLT-STD DD LIST ;9APR2007 2 ;;22.0;VA FileMan;**7,76,105,152**;Mar 30, 1999;Build 10 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 S DJ(Z)=D0,DDL1=14,DDL2=32 G B 5 ; 6 L S DJ(Z)=0 7 A S DJ(Z)=$O(^DD(F(Z),DJ(Z))) I DJ(Z)'>0 S:DJ(Z)="" DJ(Z)=-1 W !! S Z=Z-1 Q 8 B S N=^DD(F(Z),DJ(Z),0) K DDF I $D(DIGR),Z<2!(DJ(Z)-.01) X DIGR E G ND 9 D HD:$Y+6>IOSL Q:M=U W !!,F(Z),",",DJ(Z) 10 W ?(Z+Z+12),$P(N,U,1),?DDL2+4," "_$P(N,U,4) 11 S X=$P(N,U,2) 12 WP I X,$D(^DD(+X,.01,0)) S W=$P(^(0),U,2) I W["W" D 13 .S X="WORD-PROCESSING #"_+X D S X="(NOWRAP)" D:W["L" S X="(IGNORE ""|"")" D:W["X"!(W["x") S X="(UNEDITABLE)" D:W["I" S X="" 14 ..W:$L(X)+$X+5>IOM !?18 W " ",X 15 F W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","K","VARIABLE POINTER","p" I X[$E(W) D VP^DIDX:$E(W)="V" S:W="K" W="MUMPS" S:W="p" W="POINTER" W ?40," "_W G ND:M=U 16 I +X S W=" Multiple" S W=W_" #"_+X D W G ND:M=U 17 I X["V" S I=0 F S I=$O(^DD(F(Z),D0,"V",I)) Q:I'>0 S %Y=$P(^(I,0),U) I $D(^DIC(%Y,0)),$D(@(^(0,"GL")_"0)")) S ^UTILITY($J,"P",$E($P(^(0),U),1,30),0)=%Y,^(F(Z),DJ(Z))=0 18 S:I="" I=-1 G MP:X'["P"!X S Y=$P(N,U,3) I Y]"",$D(@("^"_Y_"0)")) S %Y=+$P(X,"P",2),W=" TO "_$P(^(0),U,1)_" FILE (#"_%Y_")",^UTILITY($J,"P",$E($P(^(0),U,1),1,30),0)=%Y,^(F(Z),DJ(Z))=0 D W G ND:M=U,MP 19 S W=" ** TO AN UNDEFINED FILE ** " W:($L(W)+$X)'<IOM ! D W G ND:M=U 20 MP I X'["V" D RT^DIDX G:M=U ND 21 S I X["S" D G ND:M=U 22 . N N1 23 . S N1=$P(N,U,3) F %1=1:1 S Y=$P(N1,";",%1) Q:Y="" W ! S W="'"_$P(Y,":",1)_"' FOR "_$P(Y,":",2)_"; " D W Q:M=U 24 G RD:$D(DINM) I X["C" S W=$P(N,U,5,99) W !?DDL1,"MUMPS CODE: " D W G ND:M=U G RD 25 I "Q"'[$P(N,U,5) W !?DDL1,"INPUT TRANSFORM:" S W=$P(N,U,5,99) D W G ND:M=U 26 I $D(^DD(F(Z),DJ(Z),2))#2 W !?DDL1,"OUTPUT TRANSFORM:" S W=$S($D(^DD(F(Z),DJ(Z),2.1)):^(2.1),1:^(2)) D W G ND:M=U 27 RD D ^DID2:$O(^DD(F(Z),DJ(Z),2.99))]"" G ND:M=U I 'X S W="UNEDITABLE" W:X["I" ! D W:X["I" G N 28 I $O(^DD(+X,0,"ID",""))]"" W !?DDL1,"IDENTIFIED BY:" S W="" F %=0:0 S %=$O(^DD(+X,0,"ID",%)) S:%>0 W=W_$P(^DD(+X,%,0),U)_"(#"_%_")"_$S($P(^(0),U,2)["R":"[R]",1:"")_", " I %'>0 S:W?.E1", " W=$E(W,1,$L(W)-2) D W G ND:M=U Q 29 ; 30 ;Print "WRITE" identifiers 31 I '$D(DINM) S %=" " F S %=$O(^DD(+X,0,"ID",%)) Q:%="" D Q:M=U 32 . N DIDLN,DIDPG 33 . S DIDLN(1)=$G(^DD(+X,0,"ID",%)) Q:DIDLN(1)?."^" 34 . S DIDLN(0)=""""_%_""": " 35 . S DIDLN(0)=$J("",DDL2-DDL1-$L(DIDLN(0)))_DIDLN(0) 36 . S DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1" 37 . D WRPHI^DIKCP1(.DIDLN,IOM-1-DDL2,DDL1,DDL2-DDL1,1,.DIDPG) 38 G:M=U ND 39 ; 40 I $D(^DD("KEY","B",+X)) D G:M=U ND 41 . N DIDPG 42 . S DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1" 43 . D PRINT^DIKKP(+X,"","L"_DDL1_"C"_(DDL2-DDL1),.DIDPG) 44 I $D(^DD("IX","B",+X)) D G:M=U ND 45 . N DIDPG 46 . S DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1" 47 . D LIST^DIKCP(+X,"","L"_DDL1_"C"_(DDL2-DDL1),.DIDPG) 48 S Z=Z+1,DDL1=DDL1+2,DDL2=DDL2+2,F(Z)=+X 49 D L 50 N K DDN1 I X["X" S DDN1=1 W !,?DDL1,"NOTES:",?DDL2,"XXXX--CAN'T BE ALTERED EXCEPT BY PROGRAMMER" W ! G ND:M=U 51 S W=0 I $O(^DD(F(Z),DJ(Z),5,W))'="",'$D(DDN1) W !?DDL1,"NOTES:" 52 TR S W=$O(^DD(F(Z),DJ(Z),5,W)) S:W="" W=-1 G IX:W'>0 S I=^(W,0),%=+I I '$D(^DD(%,$P(I,U,2),0))!$D(W(I)) K ^DD(F(Z),DJ(Z),5,W) G TR 53 S W(I)=0 S WS=W D WR^DIDH1 W ! S W=WS K WS G TR 54 IX S F=0 F G ND:M=U S F=$O(^DD(F(Z),DJ(Z),1,F)) Q:F'>0 W !?DDL1,"CROSS-REFERENCE:" D IX1 55 S:F="" F=-1 56 I $D(^DD("IX","F",F(Z),DJ(Z))) D S:M=U DN=0 57 . N DIDPG,DIDFLAG 58 . S DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1" 59 . S DIDFLAG="L"_DDL1_"C"_(DDL2-DDL1)_"T1" 60 . D PRINT^DIKCP(F(Z),DJ(Z),$E("R",$G(DIDRANGE))_"FS"_DIDFLAG_$E("N",$D(DINM)#2),.DIDPG) Q:M=U 61 . D:'$G(DIDRANGE) LIST^DIKCP(F(Z),DJ(Z),"RS"_DIDFLAG,.DIDPG) 62 ND S X="" G:M'=U A:Z>1 Q 63 IX1 S W=^(F,0)_" " K DDF W ?DDL2,W,! G ND:M=U D TP:$P(W,U,3)["TRIG" I '$D(DINM) S X=0 F %=0:0 S X=$O(^DD(F(Z),DJ(Z),1,F,X)) Q:X="" I X'="%D",X'="DT" S W=^(X) S:$L(W)<248 W=X_")= "_W K:X=3 DDF D W W ! G ND:M=U 64 Q:'$D(^("%D")) 65 ; 66 N DIDI,DIDN,DIDZ,DIWF,DIWL,DIWR,X 67 K ^UTILITY($J,"W") 68 S DIWF="W",DIWL=DDL2+1,DIWR=IOM,DIDZ=Z 69 S DIDN=$P($G(^DD(F(DIDZ),DJ(DIDZ),1,F,"%D",0)),U,3),DIDI=0 70 F S DIDI=$O(^DD(F(DIDZ),DJ(DIDZ),1,F,"%D",DIDI)) Q:'DIDI!(DIDN&(DIDI>DIDN)) S X=^(DIDI,0) D ^DIWP I $D(DN),'DN S M=U Q 71 I M'=U D ^DIWW I $D(DN),'DN S M=U 72 I M'=U W ! 73 E K DIOEND 74 S Z=DIDZ 75 K ^UTILITY($J,"W") 76 Q 77 ; 78 TP S X=+$P(^(0),U,4) I F(Z)-X,$D(^DIC(X,0))#2 S ^UTILITY($J,"P",$E($P(^(0),U,1),1,30),0)=X,^(F(Z),DJ(Z))=6 79 Q 80 W F K=0:0 W:$D(DDF) ! S:(($L(W)+DDL2)>IOM) DDL2=32 W ?DDL2 S %Y=$E(W,IOM-$X,999) W $E(W,1,IOM-$X-1) Q:%Y="" S W=%Y,DDF=1 81 K:'X DDF Q:$Y+6<IOSL 82 HD S DC=DC+1 D ^DIDH Q 1 DID1 ;SFISC/XAK,JLT-STD DD LIST ;1:53 PM 6 Mar 2002 2 ;;22.0;VA FileMan;**7,76,105**;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 S DJ(Z)=D0,DDL1=14,DDL2=32 G B 5 ; 6 L S DJ(Z)=0 7 A S DJ(Z)=$O(^DD(F(Z),DJ(Z))) I DJ(Z)'>0 S:DJ(Z)="" DJ(Z)=-1 W !! S Z=Z-1 Q 8 B S N=^DD(F(Z),DJ(Z),0) K DDF I $D(DIGR),Z<2!(DJ(Z)-.01) X DIGR E G ND 9 D HD:$Y+6>IOSL Q:M=U W !!,F(Z),",",DJ(Z) 10 W ?(Z+Z+12),$P(N,U,1),?DDL2+4," "_$P(N,U,4) 11 S X=$P(N,U,2) I X,$D(^DD(+X,.01,0)) S W=$P(^(0),U,2) I W["W" W " WORD-PROCESSING #",+X W:W["L" " (NOWRAP)" S X="" 12 F W="BOOLEAN","COMPUTED","FREE TEXT","SET","DATE","NUMBER","POINTER","K","VARIABLE POINTER","p" I X[$E(W) D VP^DIDX:$E(W)="V" S:W="K" W="MUMPS" S:W="p" W="POINTER" W ?40," "_W G ND:M=U 13 I +X S W=" Multiple" S W=W_" #"_+X D W G ND:M=U 14 I X["V" S I=0 F S I=$O(^DD(F(Z),D0,"V",I)) Q:I'>0 S %Y=$P(^(I,0),U) I $D(^DIC(%Y,0)),$D(@(^(0,"GL")_"0)")) S ^UTILITY($J,"P",$E($P(^(0),U),1,30),0)=%Y,^(F(Z),DJ(Z))=0 15 S:I="" I=-1 G MP:X'["P"!X S Y=$P(N,U,3) I Y]"",$D(@("^"_Y_"0)")) S %Y=+$P(X,"P",2),W=" TO "_$P(^(0),U,1)_" FILE (#"_%Y_")",^UTILITY($J,"P",$E($P(^(0),U,1),1,30),0)=%Y,^(F(Z),DJ(Z))=0 D W G ND:M=U,MP 16 S W=" ** TO AN UNDEFINED FILE ** " W:($L(W)+$X)'<IOM ! D W G ND:M=U 17 MP I X'["V" D RT^DIDX G:M=U ND 18 S I X["S" D G ND:M=U 19 . N N1 20 . S N1=$P(N,U,3) F %1=1:1 S Y=$P(N1,";",%1) Q:Y="" W ! S W="'"_$P(Y,":",1)_"' FOR "_$P(Y,":",2)_"; " D W Q:M=U 21 G RD:$D(DINM) I X["C" S W=$P(N,U,5,99) W !?DDL1,"MUMPS CODE: " D W G ND:M=U G RD 22 I "Q"'[$P(N,U,5) W !?DDL1,"INPUT TRANSFORM:" S W=$P(N,U,5,99) D W G ND:M=U 23 I $D(^DD(F(Z),DJ(Z),2))#2 W !?DDL1,"OUTPUT TRANSFORM:" S W=$S($D(^DD(F(Z),DJ(Z),2.1)):^(2.1),1:^(2)) D W G ND:M=U 24 RD D ^DID2:$O(^DD(F(Z),DJ(Z),2.99))]"" G ND:M=U I 'X S W="UNEDITABLE" W:X["I" ! D W:X["I" G N 25 I $O(^DD(+X,0,"ID",""))]"" W !?DDL1,"IDENTIFIED BY:" S W="" F %=0:0 S %=$O(^DD(+X,0,"ID",%)) S:%>0 W=W_$P(^DD(+X,%,0),U)_"(#"_%_")"_$S($P(^(0),U,2)["R":"[R]",1:"")_", " I %'>0 S:W?.E1", " W=$E(W,1,$L(W)-2) D W G ND:M=U Q 26 ; 27 ;Print "WRITE" identifiers 28 I '$D(DINM) S %=" " F S %=$O(^DD(+X,0,"ID",%)) Q:%="" D Q:M=U 29 . N DIDLN,DIDPG 30 . S DIDLN(1)=$G(^DD(+X,0,"ID",%)) Q:DIDLN(1)?."^" 31 . S DIDLN(0)=""""_%_""": " 32 . S DIDLN(0)=$J("",DDL2-DDL1-$L(DIDLN(0)))_DIDLN(0) 33 . S DIDPG("H")="W """" D H^DIDH S:M=U PAGE(U)=1" 34 . D WRPHI^DIKCP1(.DIDLN,IOM-1-DDL2,DDL1,DDL2-DDL1,1,.DIDPG) 35 G:M=U ND 36 ; 37 I $D(^DD("KEY","B",+X)) D G:M=U ND 38 . N DIDPG 39 . S DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1" 40 . D PRINT^DIKKP(+X,"","L"_DDL1_"C"_(DDL2-DDL1),.DIDPG) 41 I $D(^DD("IX","B",+X)) D G:M=U ND 42 . N DIDPG 43 . S DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1" 44 . D LIST^DIKCP(+X,"","L"_DDL1_"C"_(DDL2-DDL1),.DIDPG) 45 S Z=Z+1,DDL1=DDL1+2,DDL2=DDL2+2,F(Z)=+X 46 D L 47 N K DDN1 I X["X" S DDN1=1 W !,?DDL1,"NOTES:",?DDL2,"XXXX--CAN'T BE ALTERED EXCEPT BY PROGRAMMER" W ! G ND:M=U 48 S W=0 I $O(^DD(F(Z),DJ(Z),5,W))'="",'$D(DDN1) W !?DDL1,"NOTES:" 49 TR S W=$O(^DD(F(Z),DJ(Z),5,W)) S:W="" W=-1 G IX:W'>0 S I=^(W,0),%=+I I '$D(^DD(%,$P(I,U,2),0))!$D(W(I)) K ^DD(F(Z),DJ(Z),5,W) G TR 50 S W(I)=0 S WS=W D WR^DIDH1 W ! S W=WS K WS G TR 51 IX S F=0 F G ND:M=U S F=$O(^DD(F(Z),DJ(Z),1,F)) Q:F'>0 W !?DDL1,"CROSS-REFERENCE:" D IX1 52 S:F="" F=-1 53 I $D(^DD("IX","F",F(Z),DJ(Z))) D S:M=U DN=0 54 . N DIDPG,DIDFLAG 55 . S DIDPG("H")="W """" S DC=DC+1 D ^DIDH1 S:M=U PAGE(U)=1" 56 . S DIDFLAG="L"_DDL1_"C"_(DDL2-DDL1)_"T1" 57 . D PRINT^DIKCP(F(Z),DJ(Z),$E("R",$G(DIDRANGE))_"FS"_DIDFLAG_$E("N",$D(DINM)#2),.DIDPG) Q:M=U 58 . D:'$G(DIDRANGE) LIST^DIKCP(F(Z),DJ(Z),"RS"_DIDFLAG,.DIDPG) 59 ND S X="" G:M'=U A:Z>1 Q 60 IX1 S W=^(F,0)_" " K DDF W ?DDL2,W,! G ND:M=U D TP:$P(W,U,3)["TRIG" I '$D(DINM) S X=0 F %=0:0 S X=$O(^DD(F(Z),DJ(Z),1,F,X)) Q:X="" I X'="%D",X'="DT" S W=^(X) S:$L(W)<248 W=X_")= "_W K:X=3 DDF D W W ! G ND:M=U 61 Q:'$D(^("%D")) 62 ; 63 N DIDI,DIDN,DIDZ,DIWF,DIWL,DIWR,X 64 K ^UTILITY($J,"W") 65 S DIWF="W",DIWL=DDL2+1,DIWR=IOM,DIDZ=Z 66 S DIDN=$P($G(^DD(F(DIDZ),DJ(DIDZ),1,F,"%D",0)),U,3),DIDI=0 67 F S DIDI=$O(^DD(F(DIDZ),DJ(DIDZ),1,F,"%D",DIDI)) Q:'DIDI!(DIDN&(DIDI>DIDN)) S X=^(DIDI,0) D ^DIWP I $D(DN),'DN S M=U Q 68 I M'=U D ^DIWW I $D(DN),'DN S M=U 69 I M'=U W ! 70 E K DIOEND 71 S Z=DIDZ 72 K ^UTILITY($J,"W") 73 Q 74 ; 75 TP S X=+$P(^(0),U,4) I F(Z)-X,$D(^DIC(X,0))#2 S ^UTILITY($J,"P",$E($P(^(0),U,1),1,30),0)=X,^(F(Z),DJ(Z))=6 76 Q 77 W F K=0:0 W:$D(DDF) ! S:(($L(W)+DDL2)>IOM) DDL2=32 W ?DDL2 S %Y=$E(W,IOM-$X,999) W $E(W,1,IOM-$X-1) Q:%Y="" S W=%Y,DDF=1 78 K:'X DDF Q:$Y+6<IOSL 79 HD S DC=DC+1 D ^DIDH Q -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIE.m
r613 r623 1 DIE ;SFISC/GFT,XAK-PROC.DR-STR ;28MAR2006 2 ;;22.0;VA FileMan;**1,4,8,11,59,95,159**;Mar 30, 1999;Build 8 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 N DG,DNM,DICRREC K DB I DIE S DIE=^DIC(DIE,0,"GL") 5 Q:$D(@(DIE_DA_",-9)")) Q:'$D(@(DIE_"0)")) S U="^",DP=+$P(^(0),U,2) Q:$P($G(^DD($$FNO^DILIBF(DP),0,"DI")),U,2)["Y"&'$D(DIOVRD)&'$G(DIFROM) 6 GO Q:DIE?1"^DIA(".E Q:DA'>0 K DE,DOV,DIOV,DIEC,DTOUT N DIEDA D 7 . N % 8 . F %=1:1 Q:'$G(DA(%)) S DIEDA(%)=DA(%) 9 . S DIEDA=DA 10 . Q 11 I $D(DIETMP)[0 N DIETMP S DIETMP=$$GETTMP^DIKC1("DIE") 12 N DIEFXREF,DIIENS,DIE1,DIE1N K DIEFIRE,DIEBADK,DIESP S DIIENS=$$IENS^DIKCU(DP,.DA) 13 S DL=1,DIE1=1,D0=DA,DI=DP,DR(1,DP)=DR D INI I $E(DR)'="[" D DR^DIE17 14 S DP=DI,DA=D0,(DQ,DIEL,DK,DP(0))=0 K DIC("S") 15 MR S DK=DK+1,DH=$P(DR,";",DK) I +DH=DH S (DI,DM)=DH G S:$D(^DD(DP,DI)),MR 16 S DI=$P(DH,":",1) I 'DI G K:DI=0,PB 17 J I DH["//" S DE(DQ+1,0)=$P(DH,"//",2,9),DI=$P(DI,"//",1),DH="" 18 G K:+DI=DI S DM=+DI,Y=$P(DI,DM,2,99),DI=DM G MR:Y=""!'$D(^DD(DP,DI,0)) S DQ=DQ+1,(DZ,DQ(DQ))=^(0),DIFLD(DQ)=DI 19 SPC F %=1:1 S DIESP=$P(Y,$C(126),%) Q:DIESP="" D 20 .I DIESP="d"!(DIESP="R") S $P(DZ,U,2)=$P(DZ,U,2)_DIESP Q 21 .I DIESP="T"!(DIESP="t") S:$G(^DD(DP,DI,.1))]"" $P(DZ,U)=^(.1) Q 22 .S $P(DZ,U)=DIESP,DQ(DQ,"CAPTION")=DIESP 23 S:DH'[$C(126) DH=DH_$C(126) S DQ(DQ)=DZ K DZ G Y 24 ; 25 K S DM=$P(DH,":",2),DM=$S(DM:DM,1:DI) I DI,$D(^DD(DP,DI)) G S 26 NX S DI=$O(^DD(DP,DI)) S:DI="" DI=-1 G MR:DI'>0,MR:DI>DM 27 S I DQ'<50,'$D(DE(DQ+1)) G H 28 S DQ=DQ+1,DQ(DQ)=^(DI,0),DIFLD(DQ)=DI 29 Y S Y=$P(DQ(DQ),"^",4),DG=$P(Y,";",1) 30 ;Determine whether field has a xref defined in the Index file 31 S DIEXREF=0 F S DIEXREF=$O(^DD("IX","F",DP,DI,DIEXREF)) Q:'DIEXREF I $P($G(^DD("IX",DIEXREF,0)),U) S DIEXREF=1 Q 32 I $D(^DD(DP,DI,1))!($P(DQ(DQ),U,2)["a")!DIEXREF S DE=0,DB=DM,DM=0,DE(Y)=DQ K DIEXREF F DW=1:1 S DE=$O(^DD(DP,DI,1,DE)) Q:DE<1 S DE(Y,DW,1)=^(DE,1),DE(Y,DW,2)=^(2) 33 I S:DE="" DE=-1 34 I $P(DQ(DQ),U,2)["a" S DE(Y,DW,2)="S DIIX=2_U_DIFLD(DE(DQ)) D AUDIT^DIET",DE(Y,DW,1)="S DIIX=3_U_DIFLD(DE(DQ)) D AUDIT^DIET",DE(Y)=DQ I ^DD(DP,DI,"AUDIT")="e" S DE(Y,DW,1)="I $D(DE(DE(DQ)))#2 "_DE(Y,DW,1) 35 S Y=$P(Y,";",2) I DU'=DG S D="",DU=DG,@DC G M:Y=0,B:DU=" ",EQ:DW[0 S D=^(DG) 36 I Y S:$P(D,"^",Y)]"" DE(DQ)=$P(D,"^",Y) 37 E S Y=$E(D,+$E(Y,2,9),$P(Y,",",2)) S:Y'?." " DE(DQ)=Y 38 EQ G MR:DI=DM,NX:DM S DM=DB K DB G D 39 ; 40 INI K DIC("S") S DIC=DIE,DU=-1,DC="DW=$D("_DIE_DA_",DG))" 41 Q Q 42 ; 43 ; 44 MORE ;from ^DIE1 45 D INI G MR:DI=DM,NX:DI'[U,MR:'$D(^DD(DP,+DI)) S %=$P(DI,U,2),DI=+DI S:%]"" DQ(DQ+1,"CAPTION")=% G S 46 ; 47 ; 48 JMP ;from ^DIE0 49 D INI G J 50 ; 51 PB I DH="" G D:$D(DR(DIE1,DP))<9 S:'$D(DOV) DOV=0,DR(DIE1,DP)=DR S DOV=$O(DR(DIE1,DP,DOV)) S:DOV="" DOV=-1 G D:DOV'>0 S DR=DR(DIE1,DP,DOV),DK=0 G MR 52 G MR:DH?1"@".N I 'DQ G TEM:DH?1"[".E S:"Q"'=DH DQ=1,DQ(0,1)=DH G MR:$A(DH)-94 S DC=$P(DH,U,1,4) X $P(DH,U,5,999) D DIE1N G O^DIE0 53 E S DK=DK-1,(DI,DM)=1 54 D G DQ^DIED 55 ; 56 H S DI=DI_U G D 57 ;Multiple field 58 M S Y=$P(DQ(DQ),U,2)_U_DG G DC:DW<9 59 I $D(DSC(+Y))#2,$P(DSC(+Y),"I $D(^UTILITY(",1)="" S D=DIEL+1 D D1 X DSC(+Y) S D=$O(^(0)) S:D="" D=-1 S @DC S DC=$O(^(DG,0)) S:DC="" DC=-1 G DE 60 I $D(^(DG,0)) S D=$P(^(0),U,3,4) S:$P(^(0),U,2)'=$P(Y,U) $P(^(0),U,2)=$P(Y,U) ;HMMM 61 E S D=$O(^(0)) S:D="" D=-1 62 DE I D>0 S Y=Y_U_D I DP(0)-Y!($P(DP(0),U,2)-DK),$D(^(+D,0)) S DE(DQ)=$P(^(0),U) ;Default value if this isn't same multiple we were down in before 63 DC S DC=$P(^DD(+Y,0),U,4)_U_Y,%=DQ(DQ),Y=^(.01,0) 64 MUL I $P(Y,U,2)'["W" S DQ(DQ)=$P($$EZBLD^DIALOG(8042,$G(DQ(DQ,"CAPTION"),$P(Y,U))),": ")_U_1_$P(Y,U,2,99) D DIE1N G D ;MULTIPLE-FIELD LABEL 65 I DQ>1 K DQ(DQ) G E:$D(DE(DQ,0)),H 66 D 67 .Q:DH'[$C(126) 68 .N DIEA S DIEA=$P($P(DH,+DH,2),$C(126)) Q:DIEA=""!(DIEA="d")!(DIEA="R") 69 .I DIEA="T"!(DIEA="t") S:$D(^DD(+$P(%,U,2),.01,.1)) DQ(DQ,"CAPTION")=^(.1) Q 70 .S DQ(DQ,"CAPTION")=DIEA 71 DIWE S Y=$G(DQ(DQ,"CAPTION"),$P(%,U))_U_$P(Y,U,2) D DIEN^DIWE K DQ,DG,DE S DQ=0 G QY^DIE1:$D(DTOUT) G MORE ;WORD-PROCESSING FIELD LABEL 72 ; 73 D1 Q:D'>0 S:'$D(@("D"_D)) @("D"_D)=0 S D=D-1 G D1 74 ; 75 DIE1N N M,I S DIE1N="" F I=DK,DK+1 S M=$P(DR,";",I) I M?1"^"1.NP S DIE1N=$P(M,U,2) S:I>DK DK=DK+1 Q ;WPB-0804-30857 76 Q 77 ; 78 ; 79 B K DQ(DQ) S DQ=DQ-1,DU=-9 G EQ 80 ; 81 TEM K:$D(DIETMP)#2 @DIETMP,DIETMP 82 S Y=0 F S Y=$O(^DIE("B",$P($E(DR,2,99),"]",1),Y)) S:Y="" Y=-1 G Q:Y=-1,Q:'$D(^DIE(+Y,0)) Q:$P(^(0),U,4)=DP 83 S $P(^(0),U,7)=DT I $G(^("ROU"))[U,$$ROUEXIST^DILIBF($P(^("ROU"),U,2)) G @^DIE(+Y,"ROU") 84 S:$D(^("W")) DIE("W")=^("W") S %X="^DIE(+Y,""DR"",",%Y="DR(" D %XY^%RCR 85 S DIE("^")=DR,DR=$S($D(^DIE(Y,"DR"))#2:^("DR"),1:DR(1,DP)) D DIE K DR S DR=DIE(U) 86 Q 87 ; 88 ;Silent call concerning editing and filing of data. 89 ; 90 FILE(DIEFFLAG,DIEFAR,DIEFOUT) ; 91 G FILEX^DIEF 92 ; 93 WP(DIEFF,DIEFIEN,DIEFFLD,DIEFWPFL,DIEFTSRC,DIEFOUT) ; 94 G WPX^DIEFW 95 ; 96 HELP(DIEHF,DIEHIEN,DIEHFLD,DIEHFLG,DIEHOUT) ; 97 G GETX^DIEH 98 ; 99 VAL(DIEVF,DIEVIEN,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIEVFAR,DIOUTAR) ; 100 G VALX^DIEV 101 ; 102 KEYVAL(DIVKFLAG,DIVKFDA,DIVKOUT) ; 103 G KEYVALX^DIEVK 104 ; 105 VALS(DIVSFLAG,DIVSEFDA,DIVSIFDA,DIVSMSG) ; 106 G VALSX^DIEVS 107 ; 108 CHK(DIEVF,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIOUTAR) ; 109 G CHKX^DIEV 110 ; 111 UPDATE(DIFLAGS,DIFDA,DIEN,DIMSGA) ;SEA/TOAD 112 ; ENTRY POINT--update database 113 ; procedure, all passed by value 114 G ADDX^DICA 115 ; 1 DIE ;SFISC/GFT,XAK-PROC.DR-STR ;2:40 PM 17 Sep 2002 2 ;;22.0;VA FileMan;**1,4,8,11,59,95**;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 N DG,DNM,DICRREC K DB I DIE S DIE=^DIC(DIE,0,"GL") 5 Q:$D(@(DIE_DA_",-9)")) Q:'$D(@(DIE_"0)")) S U="^",DP=+$P(^(0),U,2) Q:$P($G(^DD($$FNO^DILIBF(DP),0,"DI")),U,2)["Y"&'$D(DIOVRD)&'$G(DIFROM) 6 GO Q:DIE?1"^DIA(".E K DE,DOV,DIOV,DIEC,DTOUT N DIEDA D 7 . N % 8 . F %=1:1 Q:'$G(DA(%)) S DIEDA(%)=DA(%) 9 . S DIEDA=DA 10 . Q 11 I $D(DIETMP)[0 N DIETMP S DIETMP=$$GETTMP^DIKC1("DIE") 12 N DIEFXREF,DIIENS K DIEFIRE,DIEBADK S DIIENS=$$IENS^DIKCU(DP,.DA) 13 S DL=1,D0=DA,DI=DP,DR(1,DP)=DR D INI I $E(DR)'="[" D DR^DIE17 14 S DP=DI,DA=D0,(DQ,DIEL,DK,DP(0))=0 K DIC("S") 15 MR S DK=DK+1,DH=$P(DR,";",DK) I +DH=DH S (DI,DM)=DH G S:$D(^DD(DP,DI)),MR 16 S DI=$P(DH,":",1) I 'DI G K:DI=0,PB 17 J I DH["//" S DE(DQ+1,0)=$P(DH,"//",2,9),DI=$P(DI,"//",1),DH="" 18 G K:+DI=DI S DM=+DI,Y=$P(DI,DM,2,99),DI=DM G MR:Y=""!'$D(^DD(DP,DI,0)) S DQ=DQ+1,(DZ,DQ(DQ))=^(0),DIFLD(DQ)=DI 19 F %=1:1 S DIG=$P(Y,$C(126),%) Q:DIG="" S DZ=$S(DIG="d"!(DIG="R"):$P(DZ,U,1,2)_DIG_U_$P(DZ,U,3,99),DIG="T":$S($D(^(.1)):^(.1),1:$P(DZ,U))_U_$P(DZ,U,2,99),1:DIG_U_$P(DZ,U,2,99)) 20 S:DH'[$C(126) DH=DH_$C(126) S DQ(DQ)=DZ K DZ,DIG G Y 21 K S DM=$P(DH,":",2),DM=$S(DM:DM,1:DI) I DI,$D(^DD(DP,DI)) G S 22 NX S DI=$O(^DD(DP,DI)) S:DI="" DI=-1 G MR:DI'>0,MR:DI>DM 23 S I DQ'<50,'$D(DE(DQ+1)) G H 24 S DQ=DQ+1,DQ(DQ)=^(DI,0),DIFLD(DQ)=DI 25 Y S Y=$P(DQ(DQ),"^",4),DG=$P(Y,";",1) 26 ;Determine whether field has a xref defined in the Index file 27 S DIEXREF=0 F S DIEXREF=$O(^DD("IX","F",DP,DI,DIEXREF)) Q:'DIEXREF I $P($G(^DD("IX",DIEXREF,0)),U) S DIEXREF=1 Q 28 I $D(^DD(DP,DI,1))!($P(DQ(DQ),U,2)["a")!DIEXREF S DE=0,DB=DM,DM=0,DE(Y)=DQ K DIEXREF F DW=1:1 S DE=$O(^DD(DP,DI,1,DE)) Q:DE<1 S DE(Y,DW,1)=^(DE,1),DE(Y,DW,2)=^(2) 29 I S:DE="" DE=-1 30 I $P(DQ(DQ),U,2)["a" S DE(Y,DW,2)="S DIIX=2_U_DIFLD(DE(DQ)) D AUDIT^DIET",DE(Y,DW,1)="S DIIX=3_U_DIFLD(DE(DQ)) D AUDIT^DIET",DE(Y)=DQ I ^DD(DP,DI,"AUDIT")="e" S DE(Y,DW,1)="I $D(DE(DE(DQ)))#2 "_DE(Y,DW,1) 31 S Y=$P(Y,";",2) I DU'=DG S D="",DU=DG,@DC G M:Y=0,B:DU=" ",EQ:DW[0 S D=^(DG) 32 I Y S:$P(D,"^",Y)]"" DE(DQ)=$P(D,"^",Y) 33 E S Y=$E(D,+$E(Y,2,9),$P(Y,",",2)) S:Y'?." " DE(DQ)=Y 34 EQ G MR:DI=DM,NX:DM S DM=DB K DB G D 35 ; 36 INI K DIC("S") S DIC=DIE,DU=-1,DC="DW=$D("_DIE_DA_",DG))" 37 Q Q 38 MORE ; 39 D INI G MR:DI=DM,NX:DI'[U S DI=+DI G S:$D(^DD(DP,DI)),MR 40 JMP ; 41 D INI G J 42 ; 43 PB I DH="" G D:$D(DR(DL,DP))<9 S:'$D(DOV) DOV=0,DR(DL,DP)=DR S DOV=$O(DR(DL,DP,DOV)) S:DOV="" DOV=-1 G D:DOV'>0 S DR=DR(DL,DP,DOV),DK=0 G MR 44 G MR:DH?1"@".N I 'DQ G TEM:DH?1"[".E S:"Q"'=DH DQ=1,DQ(0,1)=DH G MR:$A(DH)-94 S DC=$P(DH,U,1,4) X $P(DH,U,5,999) G O^DIE0 45 E S DK=DK-1,(DI,DM)=1 46 D G DQ^DIED 47 H S DI=DI_U G D 48 M S Y=$P(DQ(DQ),U,2)_U_DG G DC:DW<9 49 I $D(DSC(+Y))#2,$P(DSC(+Y),"I $D(^UTILITY(",1)="" S D=DIEL+1 D D1 X DSC(+Y) S D=$O(^(0)) S:D="" D=-1 S @DC S DC=$O(^(DG,0)) S:DC="" DC=-1 G DE 50 I $D(^(DG,0)) S D=$P(^(0),U,3,4) S:$P(^(0),U,2)'=$P(Y,U) $P(^(0),U,2)=$P(Y,U) 51 E S D=$O(^(0)) S:D="" D=-1 52 DE I D>0 S Y=Y_U_D I DP(0)-Y,$D(^(+D,0)) S DE(DQ)=$P(^(0),U,1) 53 DC S DC=$P(^DD(+Y,0),U,4)_U_Y,%=DQ(DQ),Y=^(.01,0) I $P(Y,U,2)'["W" S DQ(DQ)="Select "_$P(Y,U,1)_U_1_$P(Y,U,2,99) G D 54 I DQ>1 K DQ(DQ) G E:$D(DE(DQ,0)),H 55 D 56 .Q:DH'[$C(126) 57 .N DIEA S DIEA=$P($P(DH,+DH,2),$C(126)) Q:DIEA=""!(DIEA="d")!(DIEA="R") 58 .S $P(%,U)=$S(DIEA="T"&$D(^DD(+$P(%,U,2),.01,.1)):^(.1),1:DIEA) 59 .Q 60 S Y=$P(%,U,1)_U_$P(Y,U,2) D DIEN^DIWE K DQ,DG,DE S DQ=0 G QY^DIE1:$D(DTOUT) G MORE 61 ; 62 D1 Q:D'>0 S:'$D(@("D"_D)) @("D"_D)=0 S D=D-1 G D1 63 ; 64 B K DQ(DQ) S DQ=DQ-1,DU=-9 G EQ 65 ; 66 TEM K:$D(DIETMP)#2 @DIETMP,DIETMP 67 S Y=0 F S Y=$O(^DIE("B",$P($E(DR,2,99),"]",1),Y)) S:Y="" Y=-1 G Q:Y=-1,Q:'$D(^DIE(+Y,0)) Q:$P(^(0),U,4)=DP 68 S $P(^(0),U,7)=DT I $G(^("ROU"))[U,$$ROUEXIST^DILIBF($P(^("ROU"),U,2)) G @^DIE(+Y,"ROU") 69 S:$D(^("W")) DIE("W")=^("W") S %X="^DIE(+Y,""DR"",",%Y="DR(" D %XY^%RCR 70 S DIE("^")=DR,DR=$S($D(^DIE(Y,"DR"))#2:^("DR"),1:DR(1,DP)) D DIE K DR S DR=DIE(U) 71 Q 72 ; 73 ;Silent call concerning editing and filing of data. 74 ; 75 FILE(DIEFFLAG,DIEFAR,DIEFOUT) ; 76 G FILEX^DIEF 77 ; 78 WP(DIEFF,DIEFIEN,DIEFFLD,DIEFWPFL,DIEFTSRC,DIEFOUT) ; 79 G WPX^DIEFW 80 ; 81 HELP(DIEHF,DIEHIEN,DIEHFLD,DIEHFLG,DIEHOUT) ; 82 G GETX^DIEH 83 ; 84 VAL(DIEVF,DIEVIEN,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIEVFAR,DIOUTAR) ; 85 G VALX^DIEV 86 ; 87 KEYVAL(DIVKFLAG,DIVKFDA,DIVKOUT) ; 88 G KEYVALX^DIEVK 89 ; 90 VALS(DIVSFLAG,DIVSEFDA,DIVSIFDA,DIVSMSG) ; 91 G VALSX^DIEVS 92 ; 93 CHK(DIEVF,DIEVFLD,DIEVFLG,DIEVAL,DIEVANS,DIOUTAR) ; 94 G CHKX^DIEV 95 ; 96 UPDATE(DIFLAGS,DIFDA,DIEN,DIMSGA) ;SEA/TOAD 97 ; ENTRY POINT--update database 98 ; procedure, all passed by value 99 G ADDX^DICA 100 ; -
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 -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIE1.m
r613 r623 1 DIE1 ;SFISC/GFT-FILE DATA, XREF IT, GO UP AND DOWN MULTIPLES ;28MAY2008 2 ;;22.0;VA FileMan;**1,4,11,159**;Mar 30, 1999;Build 8 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 K DQ,DB G E1:$D(DG)<9 I DP<0 K DG S DQ=0 Q 5 S DQ="",DU=-2,DG="$D("_DIE_DA_",DU))" 6 Y S DQ=$O(DG(DQ)),DW=$P(DQ,";",2) G DE:$P(DQ,";")=DU 7 I DU'<0 S ^(DU)=DV,DU=-2 8 G IX:DQ="" S DU=$P(DQ,";",1),DV="" I @DG S DV=^(DU) 9 DE I 'DW S DW=$E(DW,2,99),DE=DW-$L(DV)-1,%=$P(DW,",",2)+1,X=$E(DV,%,999),DV=$E(DV,0,DW-1)_$J("",$S(DE>0:DE,1:0))_DG(DQ) S:X'?." " DV=DV_$J("",%-DW-$L(DG(DQ)))_X G Y 10 PC S $P(DV,"^",DW)=DG(DQ) G Y 11 ; 12 IX S DICRREC="LOADXR^DIED",DQ=$O(DE(" ")) G E1:DQ="",E1:'$D(DG(DQ)) I $D(DE(DE(DQ)))#2 F DG=1:1 Q:'$D(DE(DQ,DG)) S DIC=DIE,X=DE(DE(DQ)) X DE(DQ,DG,2) 13 S X="" I DG(DQ)]"" F DG=1:1 Q:'$D(DE(DQ,DG)) S DIC=DIE,X=DG(DQ) X DE(DQ,DG,1) 14 D:$D(DIEFXREF) FIREFLD 15 E1 K DICRREC,DIFLD,DG,DB,DE,DIANUM S DQ=0 Q 16 ; 17 B ; 18 I '$D(DB(DQ)) S X="?BAD" G ^DIEQ 19 S DC=DQ,DIK="",DL=1 20 OUT ; 21 D DIE1 S Y(DC)=DIK G UP:DL>1,Q:DC=0,QY 22 ; 23 E ; 24 I DP'<0 S DC=$S($D(X)#2:X,1:"") D DIE1 S X=DC G G:DI>0,UP:DL>1 25 Q K Y 26 QY I $D(DTOUT),$D(DIEDA) D 27 . N % K DA 28 . F %=1:1 Q:'$D(DIEDA(%)) S DA(%)=DIEDA(%) 29 . S DA=DIEDA 30 . Q 31 K:$D(DTOUT) DG,DQ 32 I $D(DIETMP)#2 D FIREREC K @DIETMP,DIETMP 33 K DIEBADK,DIEFIRE,DIEXREF,DIEFXREF,DIIENS,DIE1,DIESP 34 K DIP,DB,DE,DM,DK,DL,DH,DU,DV,DW,DP,DC,DIK,DOV,DIEL,DIFLD Q 35 ; 36 M ; 37 S DD=X,DIC(0)="LM"_$S($D(DB(DQ)):"X",1:"QE"),DO(2)=$P(DC,"^",2),DO=$P($P(DQ(DQ),U)," ",2,99)_"^"_DO(2)_"^"_$P(DC,"^",4,5) D DOWN I @("'$D("_DIC_"0))") S ^(0)="^"_DO(2) 38 E I DO(2)["I" S %=0,DIC("W")="" D W^DIC1 39 K DIC("PTRIX") M DIC("PTRIX")=DIE("PTRIX") 40 DIC S D="B",DLAYGO=DP\1,X=DD D K DIC("PTRIX") 41 .N DIETMP,DICR D X^DIC 42 I Y>0 S DA=+Y,DI=0,X=$P(Y,U,2) S:$D(DIETMP)#2 $P(DIIENS,",")=DA S:+DR=.01!(DR="")&$P(Y,U,3) DI=.01,DK=1,DM=$P($P(DR,";",1),":",2),DM=$S(DR="":9999999,DM="":+DR,1:DM) G D1 43 S DI(DL-1)=DI(DL-1)_U K DUOUT,DTOUT G U1 44 ; 45 DOWN D S,DIE1,DDA S DIE=DIC Q 46 ; 47 S ;CALLED BY O+1^DIE0 48 S DIOV(DL)=$G(DOV,0) K DOV 49 S DIE1N(DL)=$G(DIE1N),DP(DL)=DP,DP=+$P(DC,"^",2),DI(DL)=$S(DV'["M":DI,$D(DSC(DP))!$D(DB(DQ)):DI,1:DI_U_$G(DQ(DQ,"CAPTION"))),DIE(DL)=DIE,DK(DL)=DK,DR(DL)=DR 50 S DM(DL)=DM,DK=0,DIE1(DL)=DIE1,DL=DL+1,DIE1=$S($G(DIE1N):DIE1N,1:DL),DIEL=DIEL+1,DM=9999999,DR="" 51 I $D(DR(DIE1,DP)) S DM=0,DR=DR(DIE1,DP) 52 Q 53 ; 54 DDA N T,X 55 S T=$T 56 F X=+$O(DA(" "),-1):-1:1 K DA(X+1) S:$D(DA(X))#2 DA(X+1)=DA(X) 57 K DA(1) S:$D(DA)#2 DA(1)=DA 58 S DIC=DIE_DA_","""_$P(DC,U,3)_"""," 59 S:$D(DIETMP)#2 DIIENS=","_DIIENS 60 I T 61 Q 62 ; 63 UDA N T,X 64 S T=$T 65 S DA=$G(DA(1)) ;K DA(1) 66 F X=2:1:+$O(DA(" "),-1) I $D(DA(X))#2 S DA(X-1)=DA(X) K DA(X) 67 S:$D(DIETMP)#2 DIIENS=$P(DIIENS,",",2,999) 68 I T 69 Q 70 N ; 71 D DOWN S DA=$P(DC,U,4),DI=.01 S:$D(DIETMP)#2 $P(DIIENS,",")=DA S ^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_DA 72 D1 S @("D"_DIEL)=DA 73 G G MORE^DIE 74 ; 75 UP ; 76 Q:$D(DTOUT) 77 S DP(0)=DP_U_DK(DL-1) I $D(DIEC(DL)) D DIEC G U 78 U1 D UDA S DIEL=DIEL-1 79 U S DQ=0,DL=DL-1,DIE1N=DIE1N(DL),DIE=DIE(DL),DM=DM(DL),DI=DI(DL),DP=DP(DL),DR=DR(DL),DK=DK(DL),DIE1=DIE1(DL) I $D(DIOV(DL)) S DOV=DIOV(DL) K DIOV(DL) 80 G G 81 ; 82 DIEC K DA S DA=DIEC(DL) F %=1:1 Q:'$D(DIEC(DL,%)) S DA(%)=DIEC(DL,%) 83 F DIEL=0:1 Q:'$D(DIEC(DL,0,DIEL)) S @("D"_DIEL)=DIEC(DL,0,DIEL) 84 S:$D(DIETMP)#2 DIIENS=DIEC(DL,"IENS") 85 S DIEL=DIEL-1 K DIEC(DL) 86 Q 87 ; 88 FIREFLD ;Fire field-level xrefs stored in DIEFXREF 89 D:$D(DIEFXREF)>2 FIRE^DIKC(DP,.DA,"KS","DIEFXREF","O","",$E("C",$G(DIOPER)="A")) 90 K DIEFXREF 91 Q 92 ; 93 FIREREC ;Fire record-level xrefs accumulated in ^TMP 94 Q:$D(DIETMP)[0 Q:$D(@DIETMP@("R"))<2 95 N DP,DIIENS,DIE,DA,DIKEY,Y 96 ; 97 S DP=0 F S DP=$O(@DIETMP@("R",DP)) Q:'DP D 98 . S DIIENS=" " F S DIIENS=$O(@DIETMP@("R",DP,DIIENS)) Q:DIIENS="" D 99 .. D DA^DILF(DIIENS,.DA) 100 .. D FIRE^DIKC(DP,.DA,"KS",$NA(@DIETMP@("R")),"F^^K",.DIKEY,$E("C",$G(DIOPER)="A")) 101 ; 102 ;If any keys are invalid, restore values 103 D:$D(DIKEY)>9 RESTORE(.DIKEY,DIETMP) 104 ; 105 K DIEFIRE,@DIETMP@("R"),@DIETMP@("V") 106 Q 107 ; 108 RESTORE(DIKEY,DIETMP) ;Restore key fields to their pre-edited values 109 N DA 110 K DIEBADK 111 S:$D(DIEFIRE)#2 X="BADKEY" 112 ; 113 ;Set "write" and "restore" flags 114 N DIEWR,DIEREST 115 I '$D(ZTQUEUED),'$D(DDS),$D(DIEFIRE)[0!($G(DIEFIRE)["M") S DIEWR=1 116 E S DIEWR=0 117 I $D(DIEFIRE)#2,DIEFIRE'["R" S DIEREST=0 118 E S DIEREST=1 119 I '$G(DIEWR),'$G(DIEREST),$G(DIEFIRE)'["L" Q 120 ; 121 N DIEFDA,DIEKK,DIEMSG,DIFIL,DIFLD,DIFLDI,DIIENS,DIIENSA 122 N DINEW,DIOLD,DIRFIL,X 123 ; 124 ;Loop through all keys that are not unique and build FDA 125 K DIEFDA 126 S DIRFIL=0 F S DIRFIL=$O(DIKEY(DIRFIL)) Q:'DIRFIL D 127 . S DIEKK=0 F S DIEKK=$O(DIKEY(DIRFIL,DIEKK)) Q:'DIEKK D 128 .. Q:$D(^DD("KEY",DIEKK,0))[0 129 .. K DIFLD 130 .. S DIFLDI=0 F S DIFLDI=$O(^DD("KEY",DIEKK,2,DIFLDI)) Q:'DIFLDI D 131 ... S DIFLD=$P($G(^DD("KEY",DIEKK,2,DIFLDI,0)),U),DIFIL=$P($G(^(0)),U,2) 132 ... Q:'DIFLD!'DIFIL 133 ... S DIFLD(DIFIL,DIFLD)=$$FLEVDIFF^DIKCU(DIRFIL,DIFIL) 134 .. S DIIENS=" " S DIIENS=$O(DIKEY(DIRFIL,DIEKK,DIIENS)) Q:DIIENS="" D 135 ... S DIFIL=0 F S DIFIL=$O(DIFLD(DIFIL)) Q:'DIFIL D 136 .... S DIFLD=0 F S DIFLD=$O(DIFLD(DIFIL,DIFLD)) Q:'DIFLD D 137 ..... Q:$D(^DD(DIFIL,DIFLD,0))[0 138 ..... S DIIENSA=$P(DIIENS,",",DIFLD(DIFIL,DIFLD)+1,999) 139 ..... Q:$D(@DIETMP@("V",DIFIL,DIIENSA,DIFLD,"F"))[0!$D(^("4/")) S DIOLD=^("F") 140 ..... K DA D DA^DILF(DIIENSA,.DA) 141 ..... S X=$$DEC^DIKC2(DIFIL,DIFLD) Q:X="" X X S DINEW=X 142 ..... I DIEREST S DIEFDA(DIFIL,DIIENSA,DIFLD)=DIOLD 143 ..... I DIEWR!($G(DIEFIRE)["L") D 144 ...... S DIEBADK(DIRFIL,DIEKK,DIFIL,DIIENSA,DIFLD,"O")=DIOLD 145 ...... S DIEBADK(DIRFIL,DIEKK,DIFIL,DIIENSA,DIFLD,"N")=DINEW 146 ; 147 I DIEREST,$D(DIEFDA) D FILE^DIE("U","DIEFDA","DIEMSG") K DIERR 148 I DIEWR,$D(DIEBADK) D MSG^DIEKMSG(.DIEBADK,DIEREST) 149 ; 150 I $G(DIEFIRE)'["L" K DIEBADK 151 Q 1 DIE1 ;SFISC/GFT-FILE DATA, XREF IT, GO UP AND DOWN MULTIPLES ;2:51 PM 21 Oct 1999 2 ;;22.0;VA FileMan;**1,4,11**;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 K DQ,DB G E1:$D(DG)<9 I DP<0 K DG S DQ=0 Q 5 S DQ="",DU=-2,DG="$D("_DIE_DA_",DU))" 6 Y S DQ=$O(DG(DQ)),DW=$P(DQ,";",2) G DE:$P(DQ,";",1)=DU 7 I DU'<0 S ^(DU)=DV,DU=-2 8 G IX:DQ="" S DU=$P(DQ,";",1),DV="" I @DG S DV=^(DU) 9 DE I 'DW S DW=$E(DW,2,99),DE=DW-$L(DV)-1,%=$P(DW,",",2)+1,X=$E(DV,%,999),DV=$E(DV,0,DW-1)_$J("",$S(DE>0:DE,1:0))_DG(DQ) S:X'?." " DV=DV_$J("",%-DW-$L(DG(DQ)))_X G Y 10 PC S $P(DV,"^",DW)=DG(DQ) G Y 11 ; 12 IX S DICRREC="LOADXR^DIED",DQ=$O(DE(" ")) G E1:DQ="",E1:'$D(DG(DQ)) I $D(DE(DE(DQ)))#2 F DG=1:1 Q:'$D(DE(DQ,DG)) S DIC=DIE,X=DE(DE(DQ)) X DE(DQ,DG,2) 13 S X="" I DG(DQ)]"" F DG=1:1 Q:'$D(DE(DQ,DG)) S DIC=DIE,X=DG(DQ) X DE(DQ,DG,1) 14 D:$D(DIEFXREF) FIREFLD 15 E1 K DICRREC,DIFLD,DG,DB,DE,DIANUM S DQ=0 Q 16 ; 17 B ; 18 I '$D(DB(DQ)) S X="?BAD" G ^DIEQ 19 S DC=DQ,DIK="",DL=1 20 OUT ; 21 D DIE1 S Y(DC)=DIK G UP:DL>1,Q:DC=0,QY 22 ; 23 E ; 24 I DP'<0 S DC=$S($D(X)#2:X,1:"") D DIE1 S X=DC G G:DI>0,UP:DL>1 25 Q K Y 26 QY I $D(DTOUT),$D(DIEDA) D 27 . N % K DA 28 . F %=1:1 Q:'$D(DIEDA(%)) S DA(%)=DIEDA(%) 29 . S DA=DIEDA 30 . Q 31 K:$D(DTOUT) DG,DQ 32 I $D(DIETMP)#2 D FIREREC K @DIETMP,DIETMP 33 K DIEBADK,DIEFIRE,DIEXREF,DIEFXREF,DIIENS 34 K DIP,DB,DE,DM,DK,DL,DH,DU,DV,DW,DP,DC,DIK,DOV,DIEL,DIFLD Q 35 ; 36 M ; 37 S DD=X,DIC(0)="LM"_$S($D(DB(DQ)):"X",1:"QE"),DO(2)=$P(DC,"^",2),DO=$E($P(DQ(DQ),"^",1),8,99)_"^"_DO(2)_"^"_$P(DC,"^",4,5) D DOWN I @("'$D("_DIC_"0))") S ^(0)="^"_DO(2) 38 E I DO(2)["I" S %=0,DIC("W")="" D W^DIC1 39 K DIC("PTRIX") M DIC("PTRIX")=DIE("PTRIX") 40 K DICR S D="B",DLAYGO=DP\1,X=DD D X^DIC K DIC("PTRIX") 41 I Y>0 S DA=+Y,DI=0,X=$P(Y,U,2) S:$D(DIETMP)#2 $P(DIIENS,",")=DA S:+DR=.01!(DR="")&$P(Y,U,3) DI=.01,DK=1,DM=$P($P(DR,";",1),":",2),DM=$S(DR="":9999999,DM="":+DR,1:DM) G D1 42 S DI(DL-1)=DI(DL-1)_U K DUOUT,DTOUT G U1 43 ; 44 DOWN D S,DIE1,DDA S DIE=DIC Q 45 ; 46 S S DIOV(DL)=$S('$D(DOV):0,1:DOV) K DOV 47 S DP(DL)=DP,DP=+$P(DC,"^",2),DI(DL)=$S(DV'["M":DI,$D(DSC(DP))!$D(DB(DQ)):DI,1:DI_U),DIE(DL)=DIE,DK(DL)=DK,DR(DL)=DR,DM(DL)=DM,DK=0,DL=DL+1,DIEL=DIEL+1,DM=9999999,DR="" I $D(DR(DL,DP)) S DM=0,DR=DR(DL,DP) 48 Q 49 ; 50 DDA N T,X 51 S T=$T 52 F X=+$O(DA(" "),-1):-1:1 K DA(X+1) S:$D(DA(X))#2 DA(X+1)=DA(X) 53 K DA(1) S:$D(DA)#2 DA(1)=DA 54 S DIC=DIE_DA_","""_$P(DC,U,3)_"""," 55 S:$D(DIETMP)#2 DIIENS=","_DIIENS 56 I T 57 Q 58 ; 59 UDA N T,X 60 S T=$T 61 S DA=$G(DA(1)) ;K DA(1) 62 F X=2:1:+$O(DA(" "),-1) I $D(DA(X))#2 S DA(X-1)=DA(X) K DA(X) 63 S:$D(DIETMP)#2 DIIENS=$P(DIIENS,",",2,999) 64 I T 65 Q 66 N ; 67 D DOWN S DA=$P(DC,U,4),DI=.01 S:$D(DIETMP)#2 $P(DIIENS,",")=DA S ^DISV(DUZ,$E(DIC,1,28))=$E(DIC,29,999)_DA 68 D1 S @("D"_DIEL)=DA 69 G G MORE^DIE 70 ; 71 UP ; 72 Q:$D(DTOUT) S DP(0)=DP I $D(DIEC(DL)) D DIEC G U 73 U1 D UDA S DIEL=DIEL-1 74 U S DQ=0,DL=DL-1,DIE=DIE(DL),DM=DM(DL),DI=DI(DL),DP=DP(DL),DR=DR(DL),DK=DK(DL) I $D(DIOV(DL)) S DOV=DIOV(DL) K DIOV(DL) 75 G G 76 ; 77 DIEC K DA S DA=DIEC(DL) F %=1:1 Q:'$D(DIEC(DL,%)) S DA(%)=DIEC(DL,%) 78 F DIEL=0:1 Q:'$D(DIEC(DL,0,DIEL)) S @("D"_DIEL)=DIEC(DL,0,DIEL) 79 S:$D(DIETMP)#2 DIIENS=DIEC(DL,"IENS") 80 S DIEL=DIEL-1 K DIEC(DL) 81 Q 82 ; 83 FIREFLD ;Fire field-level xrefs stored in DIEFXREF 84 D:$D(DIEFXREF)>2 FIRE^DIKC(DP,.DA,"KS","DIEFXREF","O","",$E("C",$G(DIOPER)="A")) 85 K DIEFXREF 86 Q 87 ; 88 FIREREC ;Fire record-level xrefs accumulated in ^TMP 89 Q:$D(DIETMP)[0 Q:$D(@DIETMP@("R"))<2 90 N DP,DIIENS,DIE,DA,DIKEY,Y 91 ; 92 S DP=0 F S DP=$O(@DIETMP@("R",DP)) Q:'DP D 93 . S DIIENS=" " F S DIIENS=$O(@DIETMP@("R",DP,DIIENS)) Q:DIIENS="" D 94 .. D DA^DILF(DIIENS,.DA) 95 .. D FIRE^DIKC(DP,.DA,"KS",$NA(@DIETMP@("R")),"F^^K",.DIKEY,$E("C",$G(DIOPER)="A")) 96 ; 97 ;If any keys are invalid, restore values 98 D:$D(DIKEY)>9 RESTORE(.DIKEY,DIETMP) 99 ; 100 K DIEFIRE,@DIETMP@("R"),@DIETMP@("V") 101 Q 102 ; 103 RESTORE(DIKEY,DIETMP) ;Restore key fields to their pre-edited values 104 N DA 105 K DIEBADK 106 S:$D(DIEFIRE)#2 X="BADKEY" 107 ; 108 ;Set "write" and "restore" flags 109 N DIEWR,DIEREST 110 I '$D(ZTQUEUED),'$D(DDS),$D(DIEFIRE)[0!($G(DIEFIRE)["M") S DIEWR=1 111 E S DIEWR=0 112 I $D(DIEFIRE)#2,DIEFIRE'["R" S DIEREST=0 113 E S DIEREST=1 114 I '$G(DIEWR),'$G(DIEREST),$G(DIEFIRE)'["L" Q 115 ; 116 N DIEFDA,DIEKK,DIEMSG,DIFIL,DIFLD,DIFLDI,DIIENS,DIIENSA 117 N DINEW,DIOLD,DIRFIL,X 118 ; 119 ;Loop through all keys that are not unique and build FDA 120 K DIEFDA 121 S DIRFIL=0 F S DIRFIL=$O(DIKEY(DIRFIL)) Q:'DIRFIL D 122 . S DIEKK=0 F S DIEKK=$O(DIKEY(DIRFIL,DIEKK)) Q:'DIEKK D 123 .. Q:$D(^DD("KEY",DIEKK,0))[0 124 .. K DIFLD 125 .. S DIFLDI=0 F S DIFLDI=$O(^DD("KEY",DIEKK,2,DIFLDI)) Q:'DIFLDI D 126 ... S DIFLD=$P($G(^DD("KEY",DIEKK,2,DIFLDI,0)),U),DIFIL=$P($G(^(0)),U,2) 127 ... Q:'DIFLD!'DIFIL 128 ... S DIFLD(DIFIL,DIFLD)=$$FLEVDIFF^DIKCU(DIRFIL,DIFIL) 129 .. S DIIENS=" " S DIIENS=$O(DIKEY(DIRFIL,DIEKK,DIIENS)) Q:DIIENS="" D 130 ... S DIFIL=0 F S DIFIL=$O(DIFLD(DIFIL)) Q:'DIFIL D 131 .... S DIFLD=0 F S DIFLD=$O(DIFLD(DIFIL,DIFLD)) Q:'DIFLD D 132 ..... Q:$D(^DD(DIFIL,DIFLD,0))[0 133 ..... S DIIENSA=$P(DIIENS,",",DIFLD(DIFIL,DIFLD)+1,999) 134 ..... Q:$D(@DIETMP@("V",DIFIL,DIIENSA,DIFLD,"F"))[0!$D(^("4/")) S DIOLD=^("F") 135 ..... K DA D DA^DILF(DIIENSA,.DA) 136 ..... S X=$$DEC^DIKC2(DIFIL,DIFLD) Q:X="" X X S DINEW=X 137 ..... I DIEREST S DIEFDA(DIFIL,DIIENSA,DIFLD)=DIOLD 138 ..... I DIEWR!($G(DIEFIRE)["L") D 139 ...... S DIEBADK(DIRFIL,DIEKK,DIFIL,DIIENSA,DIFLD,"O")=DIOLD 140 ...... S DIEBADK(DIRFIL,DIEKK,DIFIL,DIIENSA,DIFLD,"N")=DINEW 141 ; 142 I DIEREST,$D(DIEFDA) D FILE^DIE("U","DIEFDA","DIEMSG") K DIERR 143 I DIEWR,$D(DIEBADK) D MSG^DIEKMSG(.DIEBADK,DIEREST) 144 ; 145 I $G(DIEFIRE)'["L" K DIEBADK 146 Q -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIETED.m
r613 r623 1 DIETED ;SFISC/GFT SCREEN-EDIT AN INPUT TEMPLATE ;22MAY2006 2 ;;22.0;VA FileMan;**111,159**;Mar 30, 1999;Build 8 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 N DIC,DIET,DRK,DIETED,I,J,DDSCHG 5 S DIC=.402,DIC(0)="AEQ" D ^DIC Q:Y<1 6 S DIET=+Y D E 7 D PUT 8 K K ^UTILITY("DIETEDIAB",$J),^UTILITY("DIETED",$J) 9 Q 10 ; 11 EDIT(DIET) ; Edit Template using Screen Editor 12 N DRK,DIETED,I,J 13 E N DUOUT,DTOUT,DP,DI,D0,DIETROW,DIETEDER,DIETH,DR,F,L,DB 14 X ^%ZOSF("EON") 15 I '$D(^DIE(DIET,0)) W !,"NO TEMPLATE SELECTED",! Q 16 S DIETED="Input Template """_$P(^(0),U)_"""" 17 W "..." 18 D GET("^TMP(""DIETED"",$J)") 19 S DIETH="Editing "_DIETED,DIETROW=1,DRK=$P(^DIE(DIET,0),U,4) 20 DDW D EDIT^DDW("^TMP(""DIETED"",$J)","M",DIETH,"(File "_DRK_")",DIETROW) 21 I $D(DUOUT)!$D(DTOUT) K DR G KL 22 D K K I,J 23 D PROCESS("^TMP(""DIETED"",$J)") 24 X ^%ZOSF("EON") 25 S DIETROW=$O(DIETEDER(0)) I DIETROW S DIETH="ERROR! Re-editing "_DIETED K DIETEDER G DDW 26 S DDSCHG=1 27 KL K ^TMP("DIETED",$J) 28 I '$D(DR) W $C(7),$$EZBLD^DIALOG(8077) Q 29 M ^UTILITY("DIETED",$J)=DR 30 Q 31 ; 32 GET(DIETA,DIT) ;put displayable template into @DIETA 33 N DIAO,DIETREL,DIETAD,DB,DIAT,I,J,L,DIAR,DIAB 34 K @DIETA 35 I '$D(DIT) S DIT=$NA(^DIE(DIET)) 36 S (DR,DIAT)="",(DIETAD,L,DIAO,DB,DIAR)=0,F=-1 37 S J(0)=$P(@DIT@(0),U,4) 38 M DI=^("DIAB") S DI=J(0) 39 D DOWN 40 1 S Y=$P(DIAT,";",DB) I "Q"[Y G NDB:Y="" S DB=DB+1 G 1 41 S %=+Y I Y?.NP,$P(Y,":",2),Y'["/" S Y=+Y_"-"_$P(Y,":",2),%="" 42 I %_"T~"=Y!(%_"t~"=Y),$P($G(^DD(DI,%,0)),U,2) S Y=% ;HWH-1103-40934 -- ignore TITLE of MULTIPLE 43 S DIETREL="",DIAB=$G(DI(DB,DIAR-1,DI,DIAO)) E S:Y?1"^".E DIETREL=Y S:DIAB]"" Y=DIAB 44 I Y?1"]".E S Y=$E(Y,2,999) 45 I DIAB="",%,$D(^DD(DI,%,0)) S Y=$P(^(0),U)_$P(Y,%,2,999) 46 S DB=DB+1,DIETAD=DIETAD+1,@DIETA@(DIETAD)=$J("",F*3)_Y I DIETREL]"" D G 1 ;Put it in! 47 .S L=L\100+1*100,(J(L),DI)=$P(DIETREL,U,2) D DOWN ;Relational jump 48 I % S %=+$P($G(^DD(DI,%,0)),U,2) I %,$P($G(^DD(%,.01,0)),U,2)'["W" S L=L+1,(J(L),DI)=% D DOWN ;Down to a multiple 49 I Y="ALL" G UP 50 G 1 51 ; 52 DOWN S F=F+1,DIAR(F)=DIAR,DIAR=DIAR+1,%=$P(DIAT,";",DB) S:%?1"^"1.NP DB=DB+1,DIAR=$P(%,U,2) 53 S DB(F)=DB,DB=1,DIAO(F)=DIAO,DIAO=0 54 DIAT S DIAT=$G(@DIT@("DR",DIAR,DI),"ALL") Q 55 ; 56 NDB I DIAO'<0 S DIAO=DIAO+1 I $D(@DIT@("DR",DIAR,DI,DIAO)) S DIAT=^(DIAO),DB=1 G 1 57 S DIAO=-1 58 UP Q:'F K I(L),J(L) S L=$O(J(L),-1) 59 S DIAR=DIAR(F),DB=DB(F),DIAO=DIAO(F),DI=J(L),DIAT=$S(DIAO<0:"",DIAO:@DIT@("DR",DIAR,J(L),DIAO),1:$G(@DIT@("DR",DIAR,DI))),F=F-1 G 1 60 ; 61 ; 62 ; 63 ; 64 PROCESS(DIETA) ;puts nodes into ^UTILITY("DIETED") 65 N DIAB,LINE,DXS,L,DIAP,DIETSL,DQI,DIETSAVE,DIETAB,ERR,DIAR 66 K DR S F=0,(DI,J(0))=DRK,I(0)=^DIC(J(0),0,"GL"),DIAP="",(L,DIETAB)=0,DXS=1,DIAR=1 67 F LINE=1:1 Q:'$D(@DIETA@(LINE)) K ERR S X=^(LINE) D 68 .I X?1"^".E S LINE=999999999 K DR Q 69 .D LINE(X) 70 .I $D(ERR) W "LINE ",LINE S DIETEDER(LINE)=ERR,LINE=-LINE Q ;stop if we find one error 71 I LINE<0 W " ERROR!" 72 Q 73 ; 74 LINE(X) ;Process one LINE from the screen 75 N D,DIC,DICMX,DV,DATE,Y,DICOMPX,DICOMP,DRR 76 F D=$L(X):-1:1 Q:$A(X,D)>32 S X=$E(X,1,D-1) 77 F D=0:1 Q:$A(X)-32 S X=$E(X,2,999) ;strip off 'D' leading spaces 78 Q:X="" 79 OUT I D<DIETAB,L K I(L),J(L) S L=$O(J(L),-1),DIAP=DIAP(F),DIAR=DIAR(F),DIETAB=$G(DIETAB(F),D),F=F-1,DI=J(L) G OUT ;out-dentation means go up a level (or more) 80 S DIETAB=D 81 I X?1"@"1.N S Y=X G DR 82 ALL D DICS^DIA I X="ALL" D Q 83 .S ^UTILITY("DIETEDIAB",$J,1,DIAR-1,DI,DIAP\1000)=X 84 .N D,DA,DG D RANGE^DIA1 85 S DV="",J=$P(X,"-",2) I +J=J,$P(X,"-")=+X,J>X D G X:Y="",DR 86 .N D,DA,DG S D(F)=J D RANGE^DIA1 S Y=DA 87 SEMIC I X[";" S Y=X,X=$P(X,";") D G X:'$D(Y) S DIAB=Y 88 .F %=2:1:$L(Y,";") S D=$P(Y,";",%),D=$S(D="DUP":"d",D="REQ":"R","""R""d"""[D:"",$A(D)=34:$E(D,2,$F(D,"""",2)-2),D="T":D,1:""),DV=D_$C(126)_DV I $A(D)>45&($A(D)<58)!(D[":")!(D="") K Y Q 89 DIC S DIC(0)="OZ",DIC="^DD(DI," D ^DIC 90 I Y>0 S Y=+Y_DV D DR S %=+$P(Y(0),U,2) D:% Q 91 .I $P($G(^DD(+%,.01,0)),U,2)["W" Q 92 .S L=L+1,(DI,J(L))=+%,I(L)=""""_$P($P(Y(0),U,4),";")_"""" D D 93 S (Y,DIETSAVE)=X I DUZ(0)="@",X'?.E1":" S X=$S(X["//^":$P(X,"//^",2),1:X),X=$S(X[";":$P(X,";"),1:X) D ^DIM G:$D(X) DR:X=DIETSAVE I DIETSAVE["//^",'$D(X) G X 94 F DIETSL="///+","//+","///","//" I DIETSAVE[DIETSL S DP=$P(DIETSAVE,DIETSL,2,9) I DP'?1"/".E&(DP'?1"^".E)!(DUZ(0)="@") G DEF 95 I DIETSAVE?.E1":" S:'$D(DIAB) DIAB=DIETSAVE K X S X=DIETSAVE,DICOMP=L_"WE",DQI="Y(",DA="DR(99,"_DXS_",",DICMX=1 D ^DICOMPW G L:$D(X) ;as in E^DIA3 96 X S ERR=1 Q 97 ; 98 L I $D(X)>1 M DR(99,DXS)=X S DXS=DXS+1 99 S %=-1,L=$S(Y>L:+Y,1:L\100+1*100),Y=U_DP_U_U_X_" S X=$S(D(0)>0:D(0),1:"""")" K X 100 D DR S DI=+DP D D 101 Q 102 ; 103 D N % S F=F+1,DIAR(F)=DIAR F %=F+1:.01 Q:'$D(DR(%,DI)) 104 S:%["." @DRR=@DRR_U_%_";",DIAP=DIAP+1 S DIAR=% 105 S DIAP(F)=DIAP,DIAP=0,DIETAB(F)=DIETAB Q 106 ; 107 DEF S X=DIETSAVE D S X=$P(DIETSAVE,DIETSL),DV=DV_DIETSL_DP G X:DV[";",DIC ;as in DEF^DIA3 108 .S X="DA,DV,DWLC,0)=X" F J=L:-1 Q:I(J)[U S X="DA("_(L-J+1)_"),"_I(J)_","_X 109 .S DICMX="S DWLC=DWLC+1,"_I(J)_X,DA="DR(99,"_DXS_",",X=DP,DQI="X(",DICOMP=L_"T" 110 .D EN^DICOMP,DICS^DIA 111 XEC .I $D(X),Y["m" S DIC("S")="S %=$P(^(0),U,2) I %,$D(^DD(+%,.01,0)),$P(^(0),U,2)[""W"",$D(^DD(DI,Y,0)) "_DIC("S") ;as in XEC^DIA3 112 .S Y=0 F S Y=$O(X(Y)) Q:Y="" S @(DA_"Y)=X(Y)") 113 .S Y=-1 I $D(X) S Y="Q",DXS=DXS+1,DP=U_X D 114 ..D S:'$D(DIAB) DIAB=DIETSAVE ;assume "YOU MEAN as a VARIABLE" 115 ...N DIAB D DR 116 .I DP="@",DIETSL="//" S DA=U_U 117 .Q 118 ; 119 DR ;takes 'Y' and puts it into 'DR' array 120 N %,B 121 S (DRR,B)=$NA(DR(DIAR,DI)),%=$O(@DRR@(""),-1) 122 I % S DRR=$NA(@DRR@(%)) 123 I '$D(@DRR) S @DRR="",DIAP=0 124 I $L(Y)+$L(@DRR)>230 S DRR=$NA(@B@(%+1)),DIAP=DIAP\1000+1*1000,@DRR="" 125 S @DRR=@DRR_Y_";" 126 S DIAP=DIAP+1 127 DIAB I $D(DIAB) S ^UTILITY("DIETEDIAB",$J,DIAP#1000,DIAR-1,DI,DIAP\1000)=DIAB K DIAB 128 Q 129 ; 130 PUT ;save template 131 I '$D(^UTILITY("DIETED",$J)) Q 132 N DIC 133 S DIC("B")=DIET 134 SAVEAS S DIC=.402,DIC("A")="Save revised "_DIETED_" as: ",DIC(0)="AEQL",DIC("S")="I $P(^(0),U,4)=DRK" 135 D ^DIC 136 Q:Y<0 I $O(^DIE(+Y,0))]"" W !,$C(7),"Are you sure you want to overwrite this '",$P(Y,U,2)," 'Template" S %=1 D YN^DICN I %-1 Q:%<2 K DIC("B") G SAVEAS 137 L +^DIE(+Y) 138 S ^DIE("F"_J(0),$P(Y,U,2),+Y)=1 139 S $P(^DIE(+Y,0),U,4)=J(0) 140 L -^DIE(+Y) 141 D SAVEFLDS(+Y) 142 Q 143 ; 144 SAVEFLDS(Y) ; 145 N X,DP,DMAX 146 Q:'$D(^UTILITY("DIETED",$J))!'$G(Y) 147 NOW D NOW^%DTC S $P(^DIE(Y,0),U,2)=+$J(%,0,4) 148 S $P(^DIE(Y,0),U,5)=$G(DUZ) 149 K ^DIE(Y,"DR") M ^DIE(+Y,"DR")=^UTILITY("DIETED",$J) 150 K ^DIE(Y,"DIAB") M ^DIE(+Y,"DIAB")=^UTILITY("DIETEDIAB",$J) 151 S X=$S('$D(^DIE(+Y,"ROU")):1,^("ROU")'[U:1,$D(^("ROUOLD")):^("ROUOLD"),1:1),DP=+$P(^(0),U,4),DMAX=^DD("ROU") I X'=1,$D(^DD("OS",DISYS,"ZS")) D EN^DIEZ 152 D K 153 Q 1 DIETED ;SFISC/GFT SCREEN-EDIT AN INPUT TEMPLATE ;07:04 PM 15 Jul 2002 2 ;;22.0;VA FileMan;**111**;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 N DIC,DIET,DRK,DIETED,I,J,DDSCHG 5 S DIC=.402,DIC(0)="AEQ" D ^DIC Q:Y<1 6 S DIET=+Y D E 7 D PUT 8 K K ^UTILITY("DIETEDIAB",$J),^UTILITY("DIETED",$J) 9 Q 10 ; 11 EDIT(DIET) ; Edit Template using Screen Editor 12 N DRK,DIETED,I,J 13 E N DUOUT,DTOUT,DP,DI,D0,DIETROW,DIETEDER,DIETH,DR,F,L,DB 14 X ^%ZOSF("EON") 15 I '$D(^DIE(DIET,0)) W !,"NO TEMPLATE SELECTED",! Q 16 S DIETED="Input Template """_$P(^(0),U)_"""" 17 W "..." 18 D GET("^TMP(""DIETED"",$J)") 19 S DIETH="Editing "_DIETED,DIETROW=1,DRK=$P(^DIE(DIET,0),U,4) 20 DDW D EDIT^DDW("^TMP(""DIETED"",$J)","M",DIETH,"(File "_DRK_")",DIETROW) 21 I $D(DUOUT)!$D(DTOUT) K DR G KL 22 D K K I,J 23 D PROCESS("^TMP(""DIETED"",$J)") 24 X ^%ZOSF("EON") 25 S DIETROW=$O(DIETEDER(0)) I DIETROW S DIETH="ERROR! Re-editing "_DIETED K DIETEDER G DDW 26 S DDSCHG=1 27 KL K ^TMP("DIETED",$J) 28 I '$D(DR) W $C(7),$$EZBLD^DIALOG(8077) Q 29 M ^UTILITY("DIETED",$J)=DR 30 Q 31 ; 32 GET(DIETA) ;put displayable template into @DIETA 33 N DIAO,DIETREL,DIETAD,DB,DIAT,I,J,L 34 K @DIETA 35 S DR="",(DIETAD,L,DIAO,DB)=0,F=-1 36 S (DI,J(0))=$P(^DIE(DIET,0),U,4) 37 M DI=^("DIAB") 38 D DOWN 39 1 S Y=$P(DIAT,";",DB) I "Q"[Y G NDB:Y="" S DB=DB+1 G 1 40 S %=+Y I Y?.NP,$P(Y,":",2),Y'["/" S Y=+Y_"-"_$P(Y,":",2),%="" 41 S DIETREL="" I $D(DI(DB,F,DI,DIAO)) S:Y?1"^".E DIETREL=Y S Y=DI(DB,F,DI,DIAO),%=+Y 42 I Y?1"]".E S Y=$E(Y,2,999) 43 I %,$D(^DD(DI,%,0)) S Y=$P(^(0),U)_$P(Y,%,2,999) 44 S DB=DB+1,DIETAD=DIETAD+1,@DIETA@(DIETAD)=$J("",F*3)_Y I DIETREL]"" D G 1 45 .S L=L\100+1*100,(J(L),DI)=$P(DIETREL,U,2) D DOWN 46 I % S %=+$P($G(^DD(DI,%,0)),U,2) I %,$P($G(^DD(%,.01,0)),U,2)'["W" S L=L+1,(J(L),DI)=% D DOWN 47 I Y="ALL" G UP 48 G 1 49 DOWN S F=F+1,DB(F)=DB,DB=1,DIAO(F)=DIAO,DIAO=0 50 DIAT S DIAT=$G(^DIE(DIET,"DR",F+1,DI),"ALL") Q 51 ; 52 NDB I DIAO'<0 S DIAO=DIAO+1 I $D(^DIE(DIET,"DR",F+1,DI,DIAO)) S DIAT=^(DIAO),DB=1 G 1 53 S DIAO=-1 54 UP Q:'F K I(L),J(L) S L=$O(J(L),-1) 55 S DB=DB(F),DIAO=DIAO(F),DI=J(L),DIAT=$S(DIAO<0:"",DIAO:^DIE(DIET,"DR",F,J(L),DIAO),1:$G(^DIE(DIET,"DR",F,DI))),F=F-1 G 1 56 ; 57 PROCESS(DIETA) ;puts nodes into ^UTILITY("DIETED") 58 N DIAB,LINE,DXS,L,DIAP,DIETSL,DQI,DIETSAVE,DIETAB,ERR 59 K DR S F=0,(DI,J(0))=DRK,I(0)=^DIC(J(0),0,"GL"),DIAP="",(L,DIETAB)=0,DXS=1 60 F LINE=1:1 Q:'$D(@DIETA@(LINE)) K ERR S X=^(LINE) D 61 .I X?1"^".E S LINE=999999999 K DR Q 62 .D LINE(X) 63 .I $D(ERR) W "LINE ",LINE S DIETEDER(LINE)=ERR,LINE=-LINE Q ;stop if we find one error 64 I LINE<0 W " ERROR!" 65 Q 66 LINE(X) ;Process one LINE from the screen 67 N D,DIC,DICMX,DV,DATE,Y,DICOMPX,DICOMP 68 F D=$L(X):-1:1 Q:$A(X,D)>32 S X=$E(X,1,D-1) 69 F D=0:1 Q:$A(X)-32 S X=$E(X,2,999) ;strip off 'D' leading spaces 70 Q:X="" 71 I D<DIETAB,L K I(L),J(L) S L=$O(J(L),-1),DIAP=DIAP(F),F=F-1,DI=J(L) ;out-dentation means go up a level 72 S DIETAB=D 73 I X?1"@"1.N S Y=X G DR 74 D DICS^DIA I X="ALL" D Q 75 .N D,DA,DG S ^UTILITY("DIETEDIAB",$J,1,F,DI,DIAP\1000)=X,%=DI D A^DIA1 ; 'ALL' fields 76 S DV="",J=$P(X,"-",2) I +J=J,$P(X,"-")=+X,J>X D G X:Y="",DR 77 .N D,DA,DG S D(F)=J D RANGE^DIA1 S Y=DA 78 SEMIC I X[";" S Y=X,X=$P(X,";") D G X:'$D(Y) S DIAB=Y 79 .F %=2:1:$L(Y,";") S D=$P(Y,";",%),D=$S(D="DUP":"d",D="REQ":"R","""R""d"""[D:"",$A(D)=34:$E(D,2,$F(D,"""",2)-2),1:D),DV=D_$C(126)_DV I $A(D)>45&($A(D)<58)!(D[":")!(D="") K Y Q 80 DIC S DIC(0)="OZ",DIC="^DD(DI," D ^DIC 81 I Y>0 S Y=+Y_DV D DR S %=+$P(Y(0),U,2) D:% Q 82 .I $P($G(^DD(+%,.01,0)),U,2)["W" Q 83 .S L=L+1,(DI,J(L))=+%,I(L)=""""_$P($P(Y(0),U,4),";")_"""" D D 84 S (Y,DIETSAVE)=X I DUZ(0)="@",X'?.E1":" S X=$S(X["//^":$P(X,"//^",2),1:X),X=$S(X[";":$P(X,";"),1:X) D ^DIM G:$D(X) DR:X=DIETSAVE I DIETSAVE["//^",'$D(X) G X 85 F DIETSL="///+","//+","///","//" I DIETSAVE[DIETSL S DP=$P(DIETSAVE,DIETSL,2,9) I DP'?1"/".E&(DP'?1"^".E)!(DUZ(0)="@") G DEF 86 I DIETSAVE?.E1":" S:'$D(DIAB) DIAB=DIETSAVE K X S X=DIETSAVE,DICOMP=L_"WE",DQI="Y(",DA="DR(99,"_DXS_",",DICMX=1 D ^DICOMPW G L:$D(X) ;as in E^DIA3 87 X S ERR=1 Q 88 ; 89 L I $D(X)>1 M DR(99,DXS)=X S DXS=DXS+1 90 S %=-1,L=$S(Y>L:+Y,1:L\100+1*100),Y=U_DP_U_U_X_" S X=$S(D(0)>0:D(0),1:"""")" K X 91 D DR,D 92 S DI=+DP Q 93 ; 94 D S F=F+1,DIAP(F)=DIAP,DIAP=0 Q 95 ; 96 DEF S X=DIETSAVE D S X=$P(DIETSAVE,DIETSL),DV=DV_DIETSL_DP G X:DV[";",DIC ;as in DEF^DIA3 97 .S X="DA,DV,DWLC,0)=X" F J=L:-1 Q:I(J)[U S X="DA("_(L-J+1)_"),"_I(J)_","_X 98 .S DICMX="S DWLC=DWLC+1,"_I(J)_X,DA="DR(99,"_DXS_",",X=DP,DQI="X(",DICOMP=L_"T" 99 .D EN^DICOMP,DICS^DIA 100 XEC .I $D(X),Y["m" S DIC("S")="S %=$P(^(0),U,2) I %,$D(^DD(+%,.01,0)),$P(^(0),U,2)[""W"",$D(^DD(DI,Y,0)) "_DIC("S") ;as in XEC^DIA3 101 .S Y=0 F S Y=$O(X(Y)) Q:Y="" S @(DA_"Y)=X(Y)") 102 .S Y=-1 I $D(X) S Y="Q",DXS=DXS+1,DP=U_X D 103 ..D S:'$D(DIAB) DIAB=DIETSAVE ;assume "YOU MEAN as a VARIABLE" 104 ...N DIAB D DR 105 .I DP="@",DIETSL="//" S DA=U_U 106 .Q 107 ; 108 DR ;takes 'Y' and puts it into 'DR' array 109 N %,N,B 110 S (N,B)=$NA(DR(F+1,DI)),%=$O(@N@(""),-1) 111 I % S N=$NA(@N@(%)) 112 I '$D(@N) S @N="",DIAP=0 113 I $L(Y)+$L(@N)>230 S N=$NA(@B@(%+1)),DIAP=DIAP\1000+1*1000,@N="" 114 S @N=@N_Y_";" 115 S DIAP=DIAP+1 116 DIAB I $D(DIAB) S ^UTILITY("DIETEDIAB",$J,DIAP#1000,F,DI,DIAP\1000)=DIAB K DIAB 117 Q 118 ; 119 PUT ;save template 120 I '$D(^UTILITY("DIETED",$J)) Q 121 N DIC 122 S DIC("B")=DIET 123 SAVEAS S DIC=.402,DIC("A")="Save revised "_DIETED_" as: ",DIC(0)="AEQL",DIC("S")="I $P(^(0),U,4)=DRK" 124 D ^DIC 125 Q:Y<0 I $O(^DIE(+Y,0))]"" W !,$C(7),"Are you sure you want to overwrite this '",$P(Y,U,2)," 'Template" S %=1 D YN^DICN I %-1 Q:%<2 K DIC("B") G SAVEAS 126 L +^DIE(+Y) 127 S ^DIE("F"_J(0),$P(Y,U,2),+Y)=1 128 S $P(^DIE(+Y,0),U,4)=J(0) 129 L -^DIE(+Y) 130 D SAVEFLDS(+Y) 131 Q 132 ; 133 SAVEFLDS(Y) ; 134 N X,DP,DMAX 135 Q:'$D(^UTILITY("DIETED",$J))!'$G(Y) 136 NOW D NOW^%DTC S $P(^DIE(Y,0),U,2)=+$J(%,0,4) 137 S $P(^DIE(Y,0),U,5)=$G(DUZ) 138 K ^DIE(Y,"DR") M ^DIE(+Y,"DR")=^UTILITY("DIETED",$J) 139 K ^DIE(Y,"DIAB") M ^DIE(+Y,"DIAB")=^UTILITY("DIETEDIAB",$J) 140 S X=$S('$D(^DIE(+Y,"ROU")):1,^("ROU")'[U:1,$D(^("ROUOLD")):^("ROUOLD"),1:1),DP=+$P(^(0),U,4),DMAX=^DD("ROU") I X'=1,$D(^DD("OS",DISYS,"ZS")) D EN^DIEZ 141 D K 142 Q -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIEZ.m
r613 r623 1 DIEZ ;SFISC/GFT-COMPILE INPUT TEMPLATE ;13SEP20042 ;;22.0;VA FileMan;**1,11,159**;Mar 30, 1999;Build 8 3 ;Per VHA Directive 2004-038, this routine should not be modified.4 5 EN1 6 7 8 TEM 9 10 11 12 EN 13 14 15 16 17 18 19 K DOV,^DIE(DIEZ,"RD"),DR S DR=^("DR",1,DP),(DIER,DL)=1,DIEZL=0,DIEZAB=U20 21 22 23 24 25 26 NEWROU 27 28 29 30 31 32 33 34 EN2(Y,DIEZFLGS,X,DMAX,DIEZRLA,DIEZZMSG) 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 EN2E 67 68 69 70 RECOMP 71 72 73 K 74 75 76 77 78 79 UNCAF(DIEZ) 80 81 82 83 84 85 UNC(DIEZ,DIFLAGS) 86 87 88 89 90 91 92 93 94 95 96 97 1 DIEZ ;SFISC/GFT-COMPILE INPUT TEMPLATE ;2:00 PM 30 Jul 1999 2 ;;22.0;VA FileMan;**1,11**;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 I $G(DUZ(0))'="@" W $C(7),$$EZBLD^DIALOG(101) G K 5 EN1 D:'$D(DISYS) OS^DII I '$D(^DD("OS",DISYS,"ZS")) W $$EZBLD^DIALOG(820),$C(7) G K 6 S U="^" S:'$G(DTIME) DTIME=300 N L,DNM 7 D SIZ^DIPZ0(8033) G:$D(DTOUT)!($D(DUOUT))!('X) K S DMAX=X Q:$D(DIX) 8 TEM K DIC S DIC="^DIE(",DIC(0)="AEQ",DIC("W")="W ?40,""FILE #"",$P(^(0),U,4) W:$D(^(""ROU"")) ?60,^(""ROU"")",DIC("S")="I Y'<1" D ^DIC G:'$D(^DIE(+Y,"DR")) K S DIPZ=+Y 9 D RNM^DIPZ0(8033) G:$D(DTOUT)!($D(DUOUT))!(X="") K S DNM=X K DIC 10 W ! S DIR(0)="Y",DIR("A")=$$EZBLD^DIALOG(8020) D ^DIR K DIR G:'Y!($D(DIRUT)) K 11 S X=DNM,Y=DIPZ K DIPZ 12 EN ; 13 W:'$G(DIEZS) ! K ^UTILITY($J),DRN N L,DIEZQ,DIR S DMAX=DMAX-2150,DNM=X,DIEZ=+Y,DRN="",DRD=0,DIEZQ=0 14 S DP=$P(^DIE(DIEZ,0),U,4),DIE=^DIC(DP,0,"GL") 15 I '$D(^DIE(DIEZ,"DR",1,DP)) S ^DIE(DIEZ,"DR",1,DP)=^DIE(DIEZ,"DR") 16 D DT^DICRW S X=-1 17 K T S T(1)=$P(^DIE(DIEZ,0),U),T(2)=$$EZBLD^DIALOG(8033),T(3)=DP D BLD^DIALOG(8024,.T,"","DIR") W:'$G(DIEZS) !,DIR K T 18 D UNCAF(DIEZ) 19 K DOV,^DIE(DIEZ,"RD"),DR S DR=^("DR",1,DP),DL=1,DIEZL=0,DIEZAB=U 20 D NEWROU F %=0:0 S %=$O(^DIE(DIEZ,"DR",99,%)) Q:%="" F %Y=0:0 S %Y=$O(^DIE(DIEZ,"DR",99,%,%Y)) Q:%Y="" S F=0,Q=^DIE(DIEZ,"DR",99,%,%Y) D QFF^DIEZ2 S X=" S DR(99,"_%_","_%Y_")="_Q D L^DIEZ2 21 S X=" N DIEZTMP,DIEZAR,DIEZRXR,DIIENS,DIXR K DIEFIRE,DIEBADK S DIEZTMP=$$GETTMP^DIKC1(""DIEZ"")" D L^DIEZ2 22 S X=" M DIEZAR=^DIE("_DIEZ_",""AR"") S DICRREC=""TRIG^DIE17""" D L^DIEZ2 23 N DIEZTMP S DIEZTMP=$$GETTMP^DIKC1("DIEZ") 24 S X=" S:$D(DTIME)[0 DTIME=300 S D0=DA,DIIENS=DA_"","",DIEZ="_DIEZ_",U=""^""" G ^DIEZ0 25 ; 26 NEWROU ; 27 K ^UTILITY($J,0) S DQ=0,T=99,L=3 28 S ^UTILITY($J,0,1)=DNM_DRN_" ; "_$P("GENERATED FROM '"_$P(^DIE(DIEZ,0),U,1)_"' INPUT TEMPLATE(#"_DIEZ_"), FILE "_DP,U,DRN="")_";"_$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3) 29 S ^UTILITY($J,0,2)=" D DE G BEGIN" 30 S ^UTILITY($J,0,3)="BEGIN S DNM="""_DNM_DRN_""",DQ=1" 31 I '$D(DRN(+DRN)) S DRN(+DRN)=U 32 Q 33 ; 34 EN2(Y,DIEZFLGS,X,DMAX,DIEZRLA,DIEZZMSG) ;Silent or Talking with parameter passing 35 ;and optionally return list of routines built and if successful 36 ;IEN,FLAGS,ROUTINE,RTNMAXSIZE,RTNLISTARRAY,MSGARRAY 37 ;Y=TEMPLATE IEN (required) 38 ;FLAGS="T"alk (optional) 39 ;X=ROUTINE NAME (required) 40 ;DMAX=ROUTINE SIZE (optional) 41 ;DIEZRLA=ROUTINE LIST ARRAY, by value (optional) 42 ;DIEZZMSG=MESSAGE ARRAY (optional) (default ^TMP) 43 ;* 44 ;DIEZS will be used to indicate "silent" if set to 1 45 ;Write statements are made conditional, if not "silent" 46 ;* 47 N DIEZS,DNM,DIQUIET,DIEZRIEN,DIEZRLAZ,DIEZRLAF 48 N DIK,DIC,%I,DICS 49 S DIEZS=$G(DIEZFLGS)'["T" 50 S:DIEZS DIQUIET=1 51 I '$D(DIFM) N DIFM S DIFM=1 D 52 .N Y,DIEZFLGS,X,DMAX,DIEZRLA,DIEZS 53 .D INIZE^DIEFU 54 I $G(Y)'>0 D BLD^DIALOG(1700,"IEN for Edit Template missing or invalid") G EN2E 55 I '$D(^DIE(Y,0)) D BLD^DIALOG(1700,"No Edit Template on file with IEN="_Y) G EN2E 56 I $G(X)']"" D BLD^DIALOG(1700,"Routine name missing this Edit Template, IEN="_Y) G EN2E 57 I X'?1U.NU&(X'?1"%"1U.NU) D BLD^DIALOG(1700,"Routine name invalid") G EN2E 58 I $L(X)>7 D BLD^DIALOG(1700,"Routine name too long") G EN2E 59 S DIEZRLA=$G(DIEZRLA,"DIEZRLAZ"),DIEZRIEN=Y 60 S:DIEZRLA="" DIEZRLA="DIEZRLAZ" S:$G(DMAX)<2500!($G(DMAX)>^DD("ROU")) DMAX=^DD("ROU") 61 S DIEZRLAF="" 62 K @DIEZRLA 63 D EN 64 G:'DIEZS!(DIEZRLAF) EN2E 65 D BLD^DIALOG(1700,"Compiling Edit Template (IEN="_DIEZRIEN_")"_$S(DIEZRLAF=0:", routine name too long",1:"")) 66 EN2E I 'DIEZS D MSG^DIALOG() Q 67 I $G(DIEZZMSG)]"" D CALLOUT^DIEFU(DIEZZMSG) 68 Q 69 ; 70 RECOMP S DIX=1 D DIEZ Q:'$D(DIX) N DIMAX S DIMAX=DMAX 71 F DIX=0:0 S DIX=$O(^DIE(DIX)) Q:DIX'>0 I $D(^(DIX,0)),$D(^("ROU")) S %=$P(^(0),"^",1),X=$E(^("ROU"),2,99) I X]"" S Y=DIX,DMAX=DIMAX D EN 72 ; 73 K K %,DDH,DIC,DIX,DIPZ,DMAX,DNM,DTOUT,DIRUT,DIROUT,DUOUT,X,Y Q 74 ;DIALOG #101 'only those with programmer's access' 75 ; #820 'no way to save routines on the system' 76 ; #8020 'Should the compilation run now?' 77 ; #8024 'Compiling template name Input template of file n' 78 ; #8033 'Input template' 79 UNCAF(DIEZ) ; 80 ; for one compiled input template (DIEZ), delete its "AF" entries 81 N %,X S X="" 82 F S X=$O(^DIE("AF",X)) Q:X="" K:'X ^(X,DIEZ) S %=0 F S %=$O(^DIE("AF",X,%)) Q:%'>0 K:$D(^(%,DIEZ)) ^(DIEZ) 83 Q 84 ; 85 UNC(DIEZ,DIFLAGS) ; 86 ; DBS: silent entry point to uncompile an input template 87 ; DIEZ = IEN of input template to uncompile 88 ; DIFLAGS = flags: 89 ; D = compiled routines are also deleted 90 K ^DIE(DIEZ,"ROU") 91 D UNCAF(DIEZ) 92 I $G(DIFLAGS)["D" D 93 . N DINAME S DINAME=$G(^DIE(DIEZ,"ROUOLD")) Q:DINAME="" 94 . N DIROU,DISUF F DISUF="",1:1 D Q:DIROU="" 95 . . S DIROU=DINAME_DISUF I '$$ROUEXIST^DILIBF(DIROU) S DIROU="" Q 96 . . N X S X=DIROU X ^%ZOSF("DEL") 97 Q -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIEZ0.m
r613 r623 1 DIEZ0 ;SFISC/GFT-COMPILE INPUT TEMPLATE ;13SEP20042 ;;22.0;VA FileMan;**159**;Mar 30, 1999;Build 8 3 ;Per VHA Directive 2004-038, this routine should not be modified.4 5 DL 6 MR 7 8 9 10 11 12 K 13 NX 14 15 S 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 X 39 40 41 42 43 44 PB I DH="" S:'$D(DOV(DL)) DOV(DL)=0 S DOV(DL)=$O(^DIE(DIEZ,"DR",DIER,DP,DOV(DL))) S:DOV(DL)="" DOV(DL)=-1 G UP:DOV(DL)<0 S DR=^(DOV(DL)),DK=0 G MR45 46 47 I DH?1"^".E S F=0,X=X_$P(DH,U,5,999),Q=$P(DH,U,1,3) D L,DRN,QFF^DIEZ2,DIERN^DIEZ2 S X=" S DGO=""^"_DNM_%_""",DC="_Q_" G DIEZ^DIE0",DRN(%)=$P(DH,U,2)_U_DIERN_U_$P(DH,U,3)_U_U_DQ_U_DRN D L S X="R"_DQ_" D DE G A" D L S X=" ;" G M48 49 M 50 51 UP 52 LV 53 S X=DRN(Y) G LV:X=U S DRN=Y,DP=+X,DIER=$P(X,U,2),DL=DIER\1,DIE=U_$P(X,U,3),DIEZL=+$P(X,U,4),DIEZAB=$P(X,U,5)_U_DNM_$P(X,U,6),DR=$S($D(^DIE(DIEZ,"DR",DIER,DP)):^(DP),1:"0:9999999"),DRN(Y)=U D N S:+DR=.01!(DR?1"0:".E) ^(3)=^(3)_"+D G B" G DL54 55 PR 56 57 58 L 59 60 SV 61 62 N 63 64 DRN 1 DIEZ0 ;SFISC/GFT-COMPILE INPUT TEMPLATE ;12:47 PM 24 Apr 1997 2 ;;22.0;VA FileMan;;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 D L 5 DL S DQ=0,DK=0,DQFF=0 6 MR S DK=DK+1,DH=$P(DR,";",DK),DI=$P(DH,":",1),(DIEZP,DIEZDUP,DIEZR)="" G:'DI K:DI=0,PB S DPR=$P(DH,"//",2,99),DM=+DI S:DPR]"" DI=$P(DI,"//",1),DH="" 7 G K:DM=DI S Y=$P(DI,DM,2,99) G MR:Y=""!'$D(^DD(DP,DM,0)) F %=1:1 S X=$P(Y,$C(126),%) Q:X="" S:X="d" DIEZDUP=X S:X="R" DIEZR=X S:X'="d"&(X'="R")&(X'="T") DIEZP=X D:X="T" 8 .I $D(^DD(DP,DM,.1)) S DIEZP=^(.1) Q 9 .I +$P(^DD(DP,DM,0),U,2),$P(^DD(+$P(^(0),U,2),.01,0),U,2)["W",$D(^(.1)) S DIEZP=^(.1) 10 .Q 11 S (DI,DM)=+DI G S 12 K S DM=$P(DH,":",2),DM=$S(DM:DM,1:+DI) I DI,$D(^DD(DP,+DI)) G S 13 NX ; 14 S DI=$O(^DD(DP,+DI)),DIEZP="" S:DI="" DI=-1 G MR:DI'>0,MR:DI>DM 15 S S Y=^DD(DP,+DI,0),DV=$P(Y,U,2)_$E("#",Y["DINUM")_DIEZR_DIEZDUP S:DIEZP=""&'DV DIEZP=$P(Y,U,1) 16 S X=DIEZP,DW=$P(Y,U,4) G NX:$A(DW)=32 I T>DMAX D SV G:DIEZQ K^DIEZ2 G S 17 W:'$G(DIEZS) "." S DQ=DQ+1,DI=+DI,DU=$P(Y,U,3),%=" S " 18 K DIEZOT I DV["O",$D(^(2)) D O^DIEZ2 19 I DQFF S %=" D:$D(DG)>9 F^DIE17,DE S DQ="_DQ_",",DQFF=0 20 I DV S Y=X,X=DQ_%_"D=0 K DE(1) ;"_DI D L,DRN G MUL^DIEZ2 21 S ^UTILITY($J,U,$P(DW,";",1),$P(DW,";",2),DQ)="",T=T+35,X=DQ_%_"DW="""_DW_""",DV="""_DV_""",DU="""",DLB="""_X_""",DIFLD="_DI D L 22 I $D(DIEZOT) S X=DIEZOT D L K DIEZOT 23 S DIEZXREF=$O(^DD("IX","F",DP,DI,0)) 24 I $O(^DD(DP,DI,1,0))>0!(DV["a")!DIEZXREF D 25 . S DQFF=1,X=" S DE(DW)=""C"_DQ_U_DNM_DRN_"""" 26 . S:DIEZXREF X=X_",DE(DW,""INDEX"")=1" 27 . ;Determine whether this field is part of a field-level key. 28 . ;Also, build list: DIEZKEY(uniquenessIndex)="" 29 . ;for those indexes that are uniqueness indexes for keys. 30 . N DIEZK,DIEZUI 31 . K DIEZKEY S DIEZK=0 32 . F S DIEZK=$O(^DD("KEY","F",DP,DI,DIEZK)) Q:'DIEZK D 33 .. S DIEZUI=$P($G(^DD("KEY",DIEZK,0)),U,4) Q:'DIEZUI 34 .. S:$P($G(^DD("IX",DIEZUI,0)),U,6)="F" DIEZKEY(DIEZUI)="" 35 . S:$D(DIEZKEY) X=X_",DE(DW,""KEY"")=""$$K"_DQ_"""" 36 . D L 37 K DIEZXREF 38 X D PR,XREF^DIEZ2:DQFF S %=$P(Y,U,5,99),X=$F(%,"%DT=""") I X,DPR?1"/".E S Y=$F(%,"E",X) I Y S %=$E(%,1,Y-2)_$E(%,Y,999) 39 I DPR?1"//".E S %="" 40 D AF^DIEZ2 S X="X"_DQ_" " I "Q"[% S X=X_"Q" D L G NX 41 S X=X_% D L I DV["F" S X=" I $D(X),X'?.ANP K X" D L 42 S X=" Q" D L S X=" ;" D L G NX 43 ; 44 PB I DH="" S:'$D(DOV(DL)) DOV(DL)=0 S DOV(DL)=$O(^DIE(DIEZ,"DR",DL,DP,DOV(DL))) S:DOV(DL)="" DOV(DL)=-1 G UP:DOV(DL)<0 S DR=^(DOV(DL)),DK=0 G MR 45 S DQ=DQ+1 I DH?1"@".N S X=DQ_" S DQ="_(DQ+1)_" ;"_DH,^UTILITY($J,"AB",DIEZAB,DH)=DQ_U_DNM_DRN G M 46 S X=DQ_" D:$D(DG)>9 F^DIE17,DE S Y=U,DQ="_DQ_" " I "Q"[DH S X=X_"G A" G M 47 I DH?1"^".E S F=0,X=X_$P(DH,U,5,999),Q=$P(DH,U,1,3) D L,DRN,QFF^DIEZ2 S X=" S DGO=""^"_DNM_%_""",DC="_Q_" G DIEZ^DIE0",DRN(%)=$P(DH,U,2)_U_(DL+1)_U_$P(DH,U,3)_U_U_DQ_U_DRN D L S X="R"_DQ_" D DE G A" D L S X=" ;" G M 48 S X=X_"D X"_DQ_" D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)=""F"",DW=DQ G OUT^DIE17" D L S X="X"_DQ_" "_DH D L S X=" Q" 49 M D L G MR 50 ; 51 UP S DQ=DQ+1,X=DQ_" G "_(DL>1)_"^DIE17" D L,^DIEZ1 G:DIEZQ K^DIEZ2 S Y=0 52 LV S Y=$O(DRN(Y)) S:Y="" Y=-1 I Y<0 G ^DIEZ2 53 S X=DRN(Y) G LV:X=U S DRN=Y,DP=+X,DL=$P(X,U,2),DIE=U_$P(X,U,3),DIEZL=+$P(X,U,4),DIEZAB=$P(X,U,5)_U_DNM_$P(X,U,6),DR=$S($D(^DIE(DIEZ,"DR",DL,DP)):^(DP),1:"0:9999999"),DRN(Y)=U D N S:+DR=.01!(DR?1"0:".E) ^(3)=^(3)_"+D G B" G DL 54 ; 55 PR ; 56 D DU^DIEZ2:DU]"" S X=" G RE" I DW="0;1",DL>1,DQ=1 S X=X_":'D S DQ=2 G 2" 57 D PR^DIEZ2:DPR]"" 58 L S L=L+1,^UTILITY($J,0,L)=X,T=T+$L(X)+2 S:X?1N.E T=T+15 Q 59 ; 60 SV D DRN 61 S X=DQ+1_" D:$D(DG)>9 F^DIE17 G ^"_DNM_%,DQ=% D L,^DIEZ1 Q:DIEZQ 62 N G NEWROU^DIEZ 63 ; 64 DRN F %=DRN+1:1 Q:'$D(DRN(%)) -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIEZ2.m
r613 r623 1 DIEZ2 ;SFISC/GFT-COMPILE INPUT TEMPLATE ;20SEP2004 2 ;;22.0;VA FileMan;**11,95,159**;Mar 30, 1999;Build 8 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 K DIEZAR D RECXR^DIEZ4(.DIEZAR) 5 K ^DIE(DIEZ,"AR") M:$D(DIEZAR) ^DIE(DIEZ,"AR")=DIEZAR 6 S %X="^UTILITY($J,""AF"",",%Y="^DIE(""AF""," D %XY^%RCR 7 K ^DIE(DIEZ,"AB") S %X="^UTILITY($J,""AB"",",%Y="^DIE(DIEZ,""AB""," D %XY^%RCR 8 S ^DIE(DIEZ,"ROUOLD")=DNM,^("ROU")=U_DNM 9 K K ^DIBT(.402,1,DIEZ),^UTILITY($J) 10 K @DIEZTMP,DIEZTMP,DIEZAR,DIER,DIERN 11 K DIE,DINC,DK,DL,DMAX,DNR,DP,DQ,DQFF,DRD,DS,DSN,DV,DW,DI,DH,%,%X,%Y,%H,X,Y 12 K DIEZ,DIEZDUP,DIEZR,Q,DPP,DPR,DM,DR,DU,T,F,DRN,DOV,DIEZL,DIEZP,DIEZAB 13 Q 14 ; 15 XREF ; 16 N DIEZR,DIEZX,DIEZLN 17 S X="C"_DQ_" G C"_DQ_"S:$D(DE("_DQ_"))[0 K DB" D L 18 S DIEZX=L,DIEZLN=0 ;remember cross-refs will start after 'L' 19 F %=0:0 S %=$O(^DD(DP,DI,1,%)) Q:%'>0 S DW=^(%,2),X=" S X=DE("_DQ_"),DIC=DIE" D SK ;first build the KILL XREFS 20 I DV["a" S X=" S X=DE("_DQ_"),DIIX=2_U_DIFLD D AUDIT^DIET" D X 21 ;I X]"" S X="C"_DQ_" ;" D L 22 D OVERFLO 23 S X="C"_DQ_"S S X="""" G:DG(DQ)=X C"_DQ_"F1 K DB" D L S X="" 24 S DIEZX=L,DIEZLN=L 25 F %=0:0 S %=$O(^DD(DP,DI,1,%)) Q:%'>0 S DW=^(%,1),X=X_" S X=DG(DQ),DIC=DIE" D SK ;then the SET XREFS 26 I DV["a" S X=X_" I $D(DE("_DQ_"))'[0!(^DD(DP,DIFLD,""AUDIT"")'=""e"") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET" D X 27 D OVERFLO 28 ;Build index code and code to check key 29 D INDEX 30 S X=X_" Q" D L 31 I $D(DIEZKEY) D GETKEY^DIEZ3(DP,DI,.DIEZKEY,DQ) K DIEZKEY 32 Q 33 ; 34 SK D X I "Q"[DW S X=" ;" G X 35 I DW["Q",^DD(DP,DI,1,%,0)["MUMPS" S Q=DW,F=0 D QFF S X=" X "_Q G X 36 S X=" "_DW 37 X D L S DIEZLN=DIEZLN+$L(X),X="" Q 38 ; 39 OVERFLO I DIEZLN+T+100<DMAX!'DIEZLN Q 40 K ^UTILITY($J,"DIEZXR") M ^UTILITY($J,"DIEZXR")=^UTILITY($J,0) 41 S DIEZR=DRN,(DIEZR(1),DRN)=$O(DRN(""),-1)+1 D 42 .N T,DQ,L 43 .D NEWROU^DIEZ ;make a new routine holding just the X-REFS 44 .F T=2:1 S DIEZX=DIEZX+1 Q:'$D(^UTILITY($J,"DIEZXR",DIEZX)) S ^UTILITY($J,0,T)=^(DIEZX) K ^UTILITY($J,"DIEZXR",DIEZX) 45 .F K ^UTILITY($J,0,T) S T=$O(^(T)) Q:'T 46 .D SAVE^DIEZ1 47 K ^UTILITY($J,0) M ^UTILITY($J,0)=^UTILITY($J,"DIEZXR") 48 S DRN=DIEZR,T=T-DIEZLN,X=" D ^"_DNM_DIEZR(1) D L 49 Q 50 ; 51 MUL ; 52 S DNR=%,DW=$P(DW,";",1),X=$P(^DD(+DV,0),U,4)_U_DV_U_DW_U,%=^(.01,0),DV=+DV_$P(%,U,2) 53 G 1:DV'["W" I DPR]"" S F=0,Q=DPR D QFF S X=" S DE(1,0)="_Q D L 54 S X=" S Y="""_$S(DIEZP]"":DIEZP_U_$P(%,U,2,9),1:%)_""",DG="""_DW_""",DC=""^"_+DV_""" D DIEN^DIWE K DE(1) G A" D L S X=" ;" D L,AF 55 S ^UTILITY($J,"AF",+DV,.01,DIEZ)="" D AB G NX^DIEZ0 56 ; 57 1 S X=" S DIFLD="_DI_",DGO=""^"_DNM_DNR_""",DC="""_X_""",DV="""_DV_""",DW=""0;1"",DOW="""_$S(DIEZP]"":DIEZP,1:$P(^(0),U))_""",DLB=$P($$EZBLD^DIALOG(8042,DOW),"": "") S:D DC=DC_D",DPP=DV["M",DU=$P(^(0),U,3) D L,DU:DU]"" 58 S X=$P(" G RE:D",U,DPP)_" I $D(DSC("_+DV_"))#2,$P(DSC("_+DV_"),""I $D(^UTILITY("",1)="""" X DSC("_+DV_") S D=$O(^(0)) S:D="""" D=-1 G M"_DQ D L 59 S:+DW'=DW DW=""""_DW_"""" S X=" S D=$S($D("_DIE_"DA,"_DW_",0)):$P(^(0),U,3,4),$O(^(0))'="""":$O(^(0)),1:-1)" D L 60 S X="M"_DQ_" I D>0 S DC=DC_D I $D("_DIE_"DA,"_DW_",+D,0)) S DE("_DQ_")=$P(^(0),U,1)" D L 61 D PR^DIEZ0 S X="R"_DQ_" D DE" D L 62 S X=$S(DPP:" S D=$S($D("_DIE_"DA,"_DW_",0)):$P(^(0),U,3,4),1:1) G "_DQ_"+1",1:" G A") D L S X=" ;" D L,AF,DIERN 63 S DRN(DNR)=+DV_U_DIERN_DIE_"D"_DIEZL_","_DW_","_U_(DIEZL+1)_U_DQ_U_DRN G NX^DIEZ0 64 ; 65 DIERN ; 66 N M S DIERN=DL+1,M=$P(DR,";",DK+1) S:M?1"^"1.NP DK=DK+1,DIERN=$P(M,U,2) Q 67 ; 68 AF ; 69 S ^UTILITY($J,"AF",DP,DI,DIEZ)="" 70 AB I '$D(^UTILITY($J,"AB",DIEZAB,DI)) S ^(DI)=DQ_U_DNM_DRN S:DPR?1"/".E ^(DI,"///")="" 71 Q 72 ; 73 DU S F=0,Q=DU D QFF S X=" S DU="_Q,DU="" 74 L S L=L+1,^UTILITY($J,0,L)=X,T=T+$L(X)+2 Q 75 ; 76 O ; 77 S F=0,Q=^(2) D QFF S DIEZOT=" S DQ("_DQ_",2)="_Q Q 78 ; 79 PR ; 80 F %=1,2,3 Q:$E(DPR,%)'="/" 81 S X=$E(DPR,%,999),Q=X,F=0 D QFF I $A(X)-94 S X=" S Y="_Q 82 E S X=" "_$E(X,2,999) D L S X=" S Y=X" 83 D L S X=" G Y" I %>1 S DPP=0,X=" S X=Y,DB(DQ)=1"_$S(%=3:",DE(DW,""4/"")=""""",1:"")_" G:X="""" N^DIE17:DV,A I $D(DE(DQ)),DV[""I""!(DV[""#"") D E^DIE0 G A:'$D(X)" D L S X=" G "_$S(%=3:"RD:X=""@"",Z",1:"RD") 84 Q 85 QF ; 86 S F=0,Q=DIE 87 QFF ; 88 S F=$F(Q,"""",F) I F S Q=$E(Q,1,F-1)_$E(Q,F-1,999),F=F+1 G QFF 89 S Q=""""_Q_"""" 90 Q 91 ; 92 INDEX ;Build code field and record level cross references. 93 ;In: 94 ; DP = file # 95 ; DI = field # 96 ; DIEZKEY(xref#) = "" : for each xref that is a Uniqueness Index 97 ; for a simple (single-field key) 98 N DIEZCNT,DIEZFLST,DIEZI,DIEZRLST,DIEZXR,DIEZXREF 99 S DIEZCNT=0 100 ; 101 ;Get field- and record-level xrefs 102 D LOADFLD^DIKC1(DP,DI,"KS","","@DIEZTMP@(""V"",","DIEZXREF",$NA(@DIEZTMP@("R")),.DIEZFLST,.DIEZRLST) 103 I DIEZFLST="",DIEZRLST="" S X="C"_DQ_"F1" Q 104 ; 105 ;Build code for each field-level xref 106 ;Save DIEZKEY(uniquenessIndex)=index tag # (DIEZCNT) 107 I DIEZFLST]"" S DIEZXR=0 F S DIEZXR=$O(DIEZXREF(DP,DIEZXR)) Q:'DIEZXR D 108 . D GETXR(DIEZXR,.DIEZCNT) 109 . S:$D(DIEZKEY(DIEZXR))#2 DIEZKEY(DIEZXR)=DIEZCNT 110 ; 111 ;Build code to set the DIEZRXR array for each record-level xref 112 S X="C"_DQ_"F"_(DIEZCNT+1) 113 Q:DIEZRLST="" 114 S X=X_" S DIEZRXR("_DP_",DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))" D L 115 S X=" F DIXR="_$TR(DIEZRLST,U,",")_" S DIEZRXR("_DP_",DIXR)=""""" D L 116 S DIEZI=0 F S DIEZI=$O(DIEZRLST(DIEZI)) Q:'DIEZI D 117 . S X=" F DIXR="_$TR(DIEZRLST(DIEZI),U,",")_" S DIEZRXR("_DP_",DIEZIENS)=""""" D L 118 ; 119 S X="" 120 Q 121 ; 122 GETXR(DIEZXR,DIEZCNT) ;Get code for one index DIEZXR 123 N DIEZCOD,DIEZF,DIEZKLOG,DIEZNSS,DIEZSLOG,DIEZO 124 S DIEZCNT=$G(DIEZCNT)+1 125 ; 126 ;Build code to call subroutine to set X array 127 S X="C"_DQ_"F"_DIEZCNT_$S(DIEZCNT=1:" N X,X1,X2",1:"")_" S DIXR="_DIEZXR_" D C"_DQ_"X"_DIEZCNT_"(U) K X2 M X2=X D C"_DQ_"X"_DIEZCNT_"(""O"") K X1 M X1=X" 128 D L 129 ; 130 ;Build code to check for null subscripts 131 S DIEZNSS="",DIEZO=0 132 F S DIEZO=$O(DIEZXREF(DP,DIEZXR,DIEZO)) Q:'DIEZO D 133 . Q:'$G(DIEZXREF(DP,DIEZXR,DIEZO,"SS")) 134 . I DIEZNSS="" S DIEZNSS="$G(X("_DIEZO_"))]""""" 135 . E S DIEZNSS=DIEZNSS_",$G(X("_DIEZO_"))]""""" 136 I DIEZNSS]"" S DIEZNSS=" I "_DIEZNSS_" D" 137 E S DIEZNSS=" D" 138 ; 139 ;Get kill logic and condition 140 S DIEZKLOG=$G(DIEZXREF(DP,DIEZXR,"K")) 141 I DIEZKLOG'?."^" D 142 . S X=DIEZNSS D L 143 . ;Get kill condition code 144 . S DIEZCOD=$G(DIEZXREF(DP,DIEZXR,"KC")) 145 . I DIEZCOD'?."^" D 146 .. S X=" . N DIEXARR M DIEXARR=X S DIEZCOND=1" D L 147 .. S X=" . "_DIEZCOD D L 148 .. S X=" . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND" D L 149 . ;Get kill logic 150 . S X=" . "_DIEZKLOG D L 151 ; 152 ;Get set logic and condition 153 S DIEZSLOG=$G(DIEZXREF(DP,DIEZXR,"S")) 154 I DIEZSLOG'?."^" D 155 . S X=" K X M X=X2"_DIEZNSS D L 156 . ;Get set condition code 157 . S DIEZCOD=$G(DIEZXREF(DP,DIEZXR,"SC")) 158 . I DIEZCOD'?."^" D 159 .. S X=" . N DIEXARR M DIEXARR=X S DIEZCOND=1" D L 160 .. S X=" . "_DIEZCOD D L 161 .. S X=" . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND" D L 162 . ;Get set logic 163 . S X=" . "_DIEZSLOG D L 164 ; 165 S X=" G C"_DQ_"F"_(DIEZCNT+1) D L 166 ; 167 ;Build code to set X array 168 S DIEZF=$O(DIEZXREF(DP,DIEZXR,0)) 169 S X="C"_DQ_"X"_DIEZCNT_"(DION) K X" D L 170 S DIEZO=0 171 F S DIEZO=$O(DIEZXREF(DP,DIEZXR,DIEZO)) Q:'DIEZO D 172 . D BLDDEC(DP,DIEZXR,DIEZO) 173 S X=" S X=$G(X("_DIEZF_"))" D L 174 S X=" Q" D L 175 Q 176 ; 177 BLDDEC(DP,DIEZXR,DIEZO) ;Build data extraction code 178 N CODE,NODE,TRANS 179 ; 180 S CODE=$G(DIEZXREF(DP,DIEZXR,DIEZO)) Q:CODE?."^" 181 S TRANS=$G(DIEZXREF(DP,DIEZXR,DIEZO,"T")) 182 I TRANS'?."^" D 183 . S X=" "_CODE D L 184 . D DOTLINE(" I $D(X)#2 "_TRANS) 185 . S X=" S:$D(X)#2 X("_DIEZO_")=X" D L 186 E I $D(DIEZXREF(DP,DIEZXR,DIEZO,"F"))#2,CODE?1"S X=".E D 187 . S X=" S X("_DIEZO_")"_$E(CODE,4,999) D L 188 E D 189 . S X=" "_CODE D L 190 . S X=" S:$D(X)#2 X("_DIEZO_")=X" D L 191 Q 192 ; 193 DOTLINE(CODE) ; 194 I CODE[" Q"!(CODE[" Q:") D 195 . S X=" D" D L 196 . S X=" ."_CODE D L 197 E S X=CODE D L 198 Q 1 DIEZ2 ;SFISC/GFT-COMPILE INPUT TEMPLATE ;12:45 PM 17 Sep 2002 2 ;;22.0;VA FileMan;**11,95**;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 K DIEZAR D RECXR^DIEZ4(.DIEZAR) 5 K ^DIE(DIEZ,"AR") M:$D(DIEZAR) ^DIE(DIEZ,"AR")=DIEZAR 6 S %X="^UTILITY($J,""AF"",",%Y="^DIE(""AF""," D %XY^%RCR 7 K ^DIE(DIEZ,"AB") S %X="^UTILITY($J,""AB"",",%Y="^DIE(DIEZ,""AB""," D %XY^%RCR 8 S ^DIE(DIEZ,"ROUOLD")=DNM,^("ROU")=U_DNM 9 K K ^DIBT(.402,1,DIEZ),^UTILITY($J) 10 K @DIEZTMP,DIEZTMP,DIEZAR 11 K DIE,DINC,DK,DL,DMAX,DNR,DP,DQ,DQFF,DRD,DS,DSN,DV,DW,DI,DH,%,%X,%Y,%H,X,Y 12 K DIEZ,DIEZDUP,DIEZR,Q,DPP,DPR,DM,DR,DU,T,F,DRN,DOV,DIEZL,DIEZP,DIEZAB 13 Q 14 ; 15 XREF ; 16 N DIEZR,DIEZX,DIEZLN 17 S X="C"_DQ_" G C"_DQ_"S:$D(DE("_DQ_"))[0 K DB" D L 18 S DIEZX=L,DIEZLN=0 ;remember cross-refs will start after 'L' 19 F %=0:0 S %=$O(^DD(DP,DI,1,%)) Q:%'>0 S DW=^(%,2),X=" S X=DE("_DQ_"),DIC=DIE" D SK ;first build the KILL XREFS 20 I DV["a" S X=" S X=DE("_DQ_"),DIIX=2_U_DIFLD D AUDIT^DIET" D X 21 ;I X]"" S X="C"_DQ_" ;" D L 22 D OVERFLO 23 S X="C"_DQ_"S S X="""" G:DG(DQ)=X C"_DQ_"F1 K DB" D L S X="" 24 S DIEZX=L,DIEZLN=L 25 F %=0:0 S %=$O(^DD(DP,DI,1,%)) Q:%'>0 S DW=^(%,1),X=X_" S X=DG(DQ),DIC=DIE" D SK ;then the SET XREFS 26 I DV["a" S X=X_" I $D(DE("_DQ_"))'[0!(^DD(DP,DIFLD,""AUDIT"")'=""e"") S X=DG(DQ),DIIX=3_U_DIFLD D AUDIT^DIET" D X 27 D OVERFLO 28 ;Build index code and code to check key 29 D INDEX 30 S X=X_" Q" D L 31 I $D(DIEZKEY) D GETKEY^DIEZ3(DP,DI,.DIEZKEY,DQ) K DIEZKEY 32 Q 33 ; 34 SK D X I "Q"[DW S X=" ;" G X 35 I DW["Q",^DD(DP,DI,1,%,0)["MUMPS" S Q=DW,F=0 D QFF S X=" X "_Q G X 36 S X=" "_DW 37 X D L S DIEZLN=DIEZLN+$L(X),X="" Q 38 ; 39 OVERFLO I DIEZLN+T+100<DMAX!'DIEZLN Q 40 K ^UTILITY($J,"DIEZXR") M ^UTILITY($J,"DIEZXR")=^UTILITY($J,0) 41 S DIEZR=DRN,(DIEZR(1),DRN)=$O(DRN(""),-1)+1 D 42 .N T,DQ,L 43 .D NEWROU^DIEZ ;make a new routine holding just the X-REFS 44 .F T=2:1 S DIEZX=DIEZX+1 Q:'$D(^UTILITY($J,"DIEZXR",DIEZX)) S ^UTILITY($J,0,T)=^(DIEZX) K ^UTILITY($J,"DIEZXR",DIEZX) 45 .F K ^UTILITY($J,0,T) S T=$O(^(T)) Q:'T 46 .D SAVE^DIEZ1 47 K ^UTILITY($J,0) M ^UTILITY($J,0)=^UTILITY($J,"DIEZXR") 48 S DRN=DIEZR,T=T-DIEZLN,X=" D ^"_DNM_DIEZR(1) D L 49 Q 50 ; 51 MUL ; 52 S DNR=%,DW=$P(DW,";",1),X=$P(^DD(+DV,0),U,4)_U_DV_U_DW_U,%=^(.01,0),DV=+DV_$P(%,U,2) 53 G 1:DV'["W" I DPR]"" S F=0,Q=DPR D QFF S X=" S DE(1,0)="_Q D L 54 S X=" S Y="""_$S(DIEZP]"":DIEZP_U_$P(%,U,2,9),1:%)_""",DG="""_DW_""",DC=""^"_+DV_""" D DIEN^DIWE K DE(1) G A" D L S X=" ;" D L,AF 55 S ^UTILITY($J,"AF",+DV,.01,DIEZ)="" D AB G NX^DIEZ0 56 ; 57 1 S X=" S DIFLD="_DI_",DGO=""^"_DNM_DNR_""",DC="""_X_""",DV="""_DV_""",DW=""0;1"",DOW="""_$S(DIEZP]"":DIEZP,1:$P(^(0),U,1))_""",DLB=""Select ""_DOW S:D DC=DC_D",DPP=DV["M",DU=$P(^(0),U,3) D L,DU:DU]"" 58 S X=$P(" G RE:D",U,DPP)_" I $D(DSC("_+DV_"))#2,$P(DSC("_+DV_"),""I $D(^UTILITY("",1)="""" X DSC("_+DV_") S D=$O(^(0)) S:D="""" D=-1 G M"_DQ D L 59 S:+DW'=DW DW=""""_DW_"""" S X=" S D=$S($D("_DIE_"DA,"_DW_",0)):$P(^(0),U,3,4),$O(^(0))'="""":$O(^(0)),1:-1)" D L 60 S X="M"_DQ_" I D>0 S DC=DC_D I $D("_DIE_"DA,"_DW_",+D,0)) S DE("_DQ_")=$P(^(0),U,1)" D L 61 D PR^DIEZ0 S X="R"_DQ_" D DE" D L 62 S X=$S(DPP:" S D=$S($D("_DIE_"DA,"_DW_",0)):$P(^(0),U,3,4),1:1) G "_DQ_"+1",1:" G A") D L S X=" ;" D L,AF 63 S DRN(DNR)=+DV_U_(DL+1)_DIE_"D"_DIEZL_","_DW_","_U_(DIEZL+1)_U_DQ_U_DRN G NX^DIEZ0 64 ; 65 AF ; 66 S ^UTILITY($J,"AF",DP,DI,DIEZ)="" 67 AB I '$D(^UTILITY($J,"AB",DIEZAB,DI)) S ^(DI)=DQ_U_DNM_DRN S:DPR?1"/".E ^(DI,"///")="" 68 Q 69 ; 70 DU S F=0,Q=DU D QFF S X=" S DU="_Q,DU="" 71 L S L=L+1,^UTILITY($J,0,L)=X,T=T+$L(X)+2 Q 72 ; 73 O ; 74 S F=0,Q=^(2) D QFF S DIEZOT=" S DQ("_DQ_",2)="_Q Q 75 ; 76 PR ; 77 F %=1,2,3 Q:$E(DPR,%)'="/" 78 S X=$E(DPR,%,999),Q=X,F=0 D QFF I $A(X)-94 S X=" S Y="_Q 79 E S X=" "_$E(X,2,999) D L S X=" S Y=X" 80 D L S X=" G Y" I %>1 S DPP=0,X=" S X=Y,DB(DQ)=1"_$S(%=3:",DE(DW,""4/"")=""""",1:"")_" G:X="""" N^DIE17:DV,A I $D(DE(DQ)),DV[""I""!(DV[""#"") D E^DIE0 G A:'$D(X)" D L S X=" G "_$S(%=3:"RD:X=""@"",Z",1:"RD") 81 Q 82 QF ; 83 S F=0,Q=DIE 84 QFF ; 85 S F=$F(Q,"""",F) I F S Q=$E(Q,1,F-1)_$E(Q,F-1,999),F=F+1 G QFF 86 S Q=""""_Q_"""" 87 Q 88 ; 89 INDEX ;Build code field and record level cross references. 90 ;In: 91 ; DP = file # 92 ; DI = field # 93 ; DIEZKEY(xref#) = "" : for each xref that is a Uniqueness Index 94 ; for a simple (single-field key) 95 N DIEZCNT,DIEZFLST,DIEZI,DIEZRLST,DIEZXR,DIEZXREF 96 S DIEZCNT=0 97 ; 98 ;Get field- and record-level xrefs 99 D LOADFLD^DIKC1(DP,DI,"KS","","@DIEZTMP@(""V"",","DIEZXREF",$NA(@DIEZTMP@("R")),.DIEZFLST,.DIEZRLST) 100 I DIEZFLST="",DIEZRLST="" S X="C"_DQ_"F1" Q 101 ; 102 ;Build code for each field-level xref 103 ;Save DIEZKEY(uniquenessIndex)=index tag # (DIEZCNT) 104 I DIEZFLST]"" S DIEZXR=0 F S DIEZXR=$O(DIEZXREF(DP,DIEZXR)) Q:'DIEZXR D 105 . D GETXR(DIEZXR,.DIEZCNT) 106 . S:$D(DIEZKEY(DIEZXR))#2 DIEZKEY(DIEZXR)=DIEZCNT 107 ; 108 ;Build code to set the DIEZRXR array for each record-level xref 109 S X="C"_DQ_"F"_(DIEZCNT+1) 110 Q:DIEZRLST="" 111 S X=X_" S DIEZRXR("_DP_",DIIENS)=$$OREF^DILF($NA(@$$CREF^DILF(DIE)))" D L 112 S X=" F DIXR="_$TR(DIEZRLST,U,",")_" S DIEZRXR("_DP_",DIXR)=""""" D L 113 S DIEZI=0 F S DIEZI=$O(DIEZRLST(DIEZI)) Q:'DIEZI D 114 . S X=" F DIXR="_$TR(DIEZRLST(DIEZI),U,",")_" S DIEZRXR("_DP_",DIEZIENS)=""""" D L 115 ; 116 S X="" 117 Q 118 ; 119 GETXR(DIEZXR,DIEZCNT) ;Get code for one index DIEZXR 120 N DIEZCOD,DIEZF,DIEZKLOG,DIEZNSS,DIEZSLOG,DIEZO 121 S DIEZCNT=$G(DIEZCNT)+1 122 ; 123 ;Build code to call subroutine to set X array 124 S X="C"_DQ_"F"_DIEZCNT_$S(DIEZCNT=1:" N X,X1,X2",1:"")_" S DIXR="_DIEZXR_" D C"_DQ_"X"_DIEZCNT_"(U) K X2 M X2=X D C"_DQ_"X"_DIEZCNT_"(""O"") K X1 M X1=X" 125 D L 126 ; 127 ;Build code to check for null subscripts 128 S DIEZNSS="",DIEZO=0 129 F S DIEZO=$O(DIEZXREF(DP,DIEZXR,DIEZO)) Q:'DIEZO D 130 . Q:'$G(DIEZXREF(DP,DIEZXR,DIEZO,"SS")) 131 . I DIEZNSS="" S DIEZNSS="$G(X("_DIEZO_"))]""""" 132 . E S DIEZNSS=DIEZNSS_",$G(X("_DIEZO_"))]""""" 133 I DIEZNSS]"" S DIEZNSS=" I "_DIEZNSS_" D" 134 E S DIEZNSS=" D" 135 ; 136 ;Get kill logic and condition 137 S DIEZKLOG=$G(DIEZXREF(DP,DIEZXR,"K")) 138 I DIEZKLOG'?."^" D 139 . S X=DIEZNSS D L 140 . ;Get kill condition code 141 . S DIEZCOD=$G(DIEZXREF(DP,DIEZXR,"KC")) 142 . I DIEZCOD'?."^" D 143 .. S X=" . N DIEXARR M DIEXARR=X S DIEZCOND=1" D L 144 .. S X=" . "_DIEZCOD D L 145 .. S X=" . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND" D L 146 . ;Get kill logic 147 . S X=" . "_DIEZKLOG D L 148 ; 149 ;Get set logic and condition 150 S DIEZSLOG=$G(DIEZXREF(DP,DIEZXR,"S")) 151 I DIEZSLOG'?."^" D 152 . S X=" K X M X=X2"_DIEZNSS D L 153 . ;Get set condition code 154 . S DIEZCOD=$G(DIEZXREF(DP,DIEZXR,"SC")) 155 . I DIEZCOD'?."^" D 156 .. S X=" . N DIEXARR M DIEXARR=X S DIEZCOND=1" D L 157 .. S X=" . "_DIEZCOD D L 158 .. S X=" . S DIEZCOND=$G(X) K X M X=DIEXARR Q:'DIEZCOND" D L 159 . ;Get set logic 160 . S X=" . "_DIEZSLOG D L 161 ; 162 S X=" G C"_DQ_"F"_(DIEZCNT+1) D L 163 ; 164 ;Build code to set X array 165 S DIEZF=$O(DIEZXREF(DP,DIEZXR,0)) 166 S X="C"_DQ_"X"_DIEZCNT_"(DION) K X" D L 167 S DIEZO=0 168 F S DIEZO=$O(DIEZXREF(DP,DIEZXR,DIEZO)) Q:'DIEZO D 169 . D BLDDEC(DP,DIEZXR,DIEZO) 170 S X=" S X=$G(X("_DIEZF_"))" D L 171 S X=" Q" D L 172 Q 173 ; 174 BLDDEC(DP,DIEZXR,DIEZO) ;Build data extraction code 175 N CODE,NODE,TRANS 176 ; 177 S CODE=$G(DIEZXREF(DP,DIEZXR,DIEZO)) Q:CODE?."^" 178 S TRANS=$G(DIEZXREF(DP,DIEZXR,DIEZO,"T")) 179 I TRANS'?."^" D 180 . S X=" "_CODE D L 181 . D DOTLINE(" I $D(X)#2 "_TRANS) 182 . S X=" S:$D(X)#2 X("_DIEZO_")=X" D L 183 E I $D(DIEZXREF(DP,DIEZXR,DIEZO,"F"))#2,CODE?1"S X=".E D 184 . S X=" S X("_DIEZO_")"_$E(CODE,4,999) D L 185 E D 186 . S X=" "_CODE D L 187 . S X=" S:$D(X)#2 X("_DIEZO_")=X" D L 188 Q 189 ; 190 DOTLINE(CODE) ; 191 I CODE[" Q"!(CODE[" Q:") D 192 . S X=" D" D L 193 . S X=" ."_CODE D L 194 E S X=CODE D L 195 Q -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIL11.m
r613 r623 1 DIL11 ;SFISC/GFT-TURN PRINT FLDS INTO CODE ;5APR2007 2 ;;22.0;VA FileMan;**152**;Mar 30, 1999;Build 10 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 DOWN ; 5 I W>0,'$D(^DD(DP,+W,0)) Q ;IN CASE FIELD IS GONE FOR SOME REASON! 6 S DN=-6,DY(DM)=DY,DP(DM)=DP,DI(DM)=DI G F:W'>0 S X=^DD(DP,+W,0),DU=$P($P(X,U,4),";") S:+DU'=DU DU=""""_DU_"""" 7 S W=$P(W,","),DY="D"_(DIL-DIL0+1),DI=DI_","_DU_","_DY,%=":0 Q:$O("_DI_"))'>0 ",DP=+$P(X,U,2),M(DP)=1,D=$P("""""",U,+DU'=DU),D=" S I("_(DIL+1)_")="_D_DU_D_",J("_(DIL+1)_")="_DP,Y=" S "_DY_"=$O(^("_DY_"))" 8 W I $P(^DD(DP,.01,0),U,2)["W" D:$P(^(0),U,2)["x"!($P(^(0),U,2)["X") G P ;**DI*22*152** 9 .S D=D_",D"_(DIL+1)_"=$G(DIWF) N DIWF S DIWF=D"_(DIL+1)_"_""X""" 10 I DHT+1 F X=1:1 G P:X>DPP,DPP:+DPP(X)=DP!$D(DPP(X,DP)) 11 DPP S %=%_" X:$D(DSC("_DP_")) DSC("_DP_")",Y=Y_" Q:"_DY_"'>0" I $T,"@"[$P(DPP(X),U,4),$P(DPP(X),U,2)=0 S DPP(X,U)="" G R:$D(DPP(X,"F")) 12 S Y=Y_" " 13 P S Y=D_" F "_DY_"=0"_%_Y_$S($D(DIARP(DP)):" X DIARP("_DP_") I $T",1:"") 14 G S 15 R S V=$P(DPP(X,"T"),U),Y=D_" F "_DY_"="_$P(DPP(X,"F"),U)_%_Y_$S(V:"!("_DY_">"_V_") ",1:" ") 16 S S:($G(DDXP)'=4) %=" D:$X>"_DG,Y=Y_%_$S($D(DIWR):" NX^DIWW",1:" T Q:'DN ") I DHT>0 S ^UTILITY($J,DV)="I "_DY_"'>0 S "_DY_"=0 "_$P(Y," ",2,9),DV=DV+1 17 G D^DIL 18 ; 19 F ; 20 S DP=-W,X=$P(W,U,2),DD=DD+1,M(DP)=1,DIL(DM)=DIL,DIL(DM,0)=DIL0,Y=0,DIL0=DIL0+100,%=X["(" I % S (X,DI)=U_X,DIL=DIL0 21 E S DI=DI(DM)_","""_X_""",",DIL=DIL+101 22 QT S Y=$F(X,"""",Y) I Y S X=$E(X,1,Y-1)_$E(X,Y-1,999),Y=Y+1 G QT 23 S Y=" S I("_DIL_")="""_X_""",J("_DIL_")="_DP 24 S X=" "_$P($P(W,U,4,99),";") 25 S DY="D"_(DIL-DIL0),DI=DI_DY,DIL=DIL-1 I $P(W,U,3)="" S W=+W,Y=Y_X_" S D0=D(0) I D0>0" G D^DIL 26 S %="I("_(DIL0-100)_",0)=D0" I X'[% S X=","_%_X 27 I DHT=-1 D DREL^DIPZ1 G END 28 F %=900:1 I '$D(^UTILITY($J,99,%)) S ^(%)="I 1 X:$D(DSC("_DP_")) DSC("_DP_") I D T:$X>"_DG_" Q:'DN "_Y,Y=" S (DIXX,DIXX("_(DM+1)_"))="_%_X,W=+W D D^DIL K R(DX) Q 29 END S (F(DM-1),DX)=%,R(%)=DP(DM-1),R(%,1)=M(DP(DM-1)) 30 Q 1 DIL11 ;SFISC/GFT-TURN PRINT FLDS INTO CODE ;11/20/92 09:28 2 ;;22.0;VA FileMan;;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 DOWN ; 5 S DN=-6,DY(DM)=DY,DP(DM)=DP,DI(DM)=DI G F:W'>0 S X=^DD(DP,+W,0),DU=$P($P(X,U,4),";",1) S:+DU'=DU DU=""""_DU_"""" 6 S W=$P(W,C,1),DY="D"_(DIL-DIL0+1),DI=DI_C_DU_C_DY,%=":0 Q:$O("_DI_"))'>0 ",DP=+$P(X,U,2),M(DP)=1,D=$P("""""",U,+DU'=DU),D=" S I("_(DIL+1)_")="_D_DU_D_",J("_(DIL+1)_")="_DP,Y=" S "_DY_"=$O(^("_DY_"))" 7 G P:$P(^DD(DP,.01,0),U,2)["W" 8 I DHT+1 F X=1:1 G P:X>DPP,DPP:+DPP(X)=DP!$D(DPP(X,DP)) 9 DPP S %=%_" X:$D(DSC("_DP_")) DSC("_DP_")",Y=Y_" Q:"_DY_"'>0" I $T,"@"[$P(DPP(X),U,4),$P(DPP(X),U,2)=0 S DPP(X,U)="" G R:$D(DPP(X,"F")) 10 S Y=Y_" " 11 P S Y=D_" F "_DY_"=0"_%_Y_$S($D(DIARP(DP)):" X DIARP("_DP_") I $T",1:"") 12 G S 13 R S V=$P(DPP(X,"T"),U),Y=D_" F "_DY_"="_$P(DPP(X,"F"),U)_%_Y_$S(V:"!("_DY_">"_V_") ",1:" ") 14 S S:($G(DDXP)'=4) %=" D:$X>"_DG,Y=Y_%_$S($D(DIWR):" NX^DIWW",1:" T Q:'DN ") I DHT>0 S ^UTILITY($J,DV)="I "_DY_"'>0 S "_DY_"=0 "_$P(Y," ",2,9),DV=DV+1 15 G D^DIL 16 ; 17 F ; 18 S DP=-W,X=$P(W,U,2),DD=DD+1,M(DP)=1,DIL(DM)=DIL,DIL(DM,0)=DIL0,Y=0,DIL0=DIL0+100,%=X["(" I % S (X,DI)=U_X,DIL=DIL0 19 E S DI=DI(DM)_","""_X_""",",DIL=DIL+101 20 QT S Y=$F(X,"""",Y) I Y S X=$E(X,1,Y-1)_$E(X,Y-1,999),Y=Y+1 G QT 21 S Y=" S I("_DIL_")="""_X_""",J("_DIL_")="_DP 22 S X=" "_$P($P(W,U,4,99),";",1) 23 S DY="D"_(DIL-DIL0),DI=DI_DY,DIL=DIL-1 I $P(W,U,3)="" S W=+W,Y=Y_X_" S D0=D(0) I D0>0" G D^DIL 24 S %="I("_(DIL0-100)_",0)=D0" I X'[% S X=C_%_X 25 I DHT=-1 D DREL^DIPZ1 G END 26 F %=900:1 I '$D(^UTILITY($J,99,%)) S ^(%)="I 1 X:$D(DSC("_DP_")) DSC("_DP_") I D T:$X>"_DG_" Q:'DN "_Y,Y=" S (DIXX,DIXX("_(DM+1)_"))="_%_X,W=+W D D^DIL K R(DX) Q 27 END S (F(DM-1),DX)=%,R(%)=DP(DM-1),R(%,1)=M(DP(DM-1)) 28 Q -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DINIT0F0.m
r613 r623 1 DINIT0F0 ;SFISC/MKO-DATA FOR FORM AND BLOCK FILES ;4APR20072 ;;22.0;VA FileMan;**152**;Mar 30, 1999;Build 10 3 ;Per VHA Directive 2004-038, this routine should not be modified.4 5 6 7 ENTRY 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 ;;=2.5^^4,2^^^1^8,78 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 1 DINIT0F0 ;SFISC/MKO-DATA FOR FORM AND BLOCK FILES ;10:49 AM 30 Mar 1999 2 ;;22.0;VA FileMan;;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 D PRE^DINIT29P 5 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT0F1 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y 6 Q 7 ENTRY ; 8 ;;^DIST(.403,.001,0) 9 ;;=DICATT^@^@^^2981031.1257^2990319.1306^^1^0^1^1 10 ;;^DIST(.403,.001,1) 11 ;;=2000000 12 ;;^DIST(.403,.001,3) 13 ;;=3000000 14 ;;^DIST(.403,.001,4) 15 ;;=N 16 ;;^DIST(.403,.001,5) 17 ;;=Y 18 ;;^DIST(.403,.001,6) 19 ;;=N 20 ;;^DIST(.403,.001,7) 21 ;;=N 22 ;;^DIST(.403,.001,15,0) 23 ;;=^^36^36^2981214 24 ;;^DIST(.403,.001,15,1,0) 25 ;;=Pages: 1 Main form 26 ;;^DIST(.403,.001,15,2,0) 27 ;;= 1.1, 1.2 DESCRIPTION and TECHNICAL DESCRIPTION text 28 ;;^DIST(.403,.001,15,3,0) 29 ;;= 2.1-2.8 TYPE-specific (2.1=DATE, etc) 30 ;;^DIST(.403,.001,15,4,0) 31 ;;= 3 SUBSCRIPT & PIECE-position 32 ;;^DIST(.403,.001,15,5,0) 33 ;;= 4 SUBSCRIPT & SUB-DICTIONARY NUMBER 34 ;;^DIST(.403,.001,15,6,0) 35 ;;= 5 Multiples 36 ;;^DIST(.403,.001,15,7,0) 37 ;;= 6 SCREEN for Pointers & Sets 38 ;;^DIST(.403,.001,15,8,0) 39 ;;= 8 VARIABLE-POINTER extra fields for each pointer 40 ;;^DIST(.403,.001,15,9,0) 41 ;;= 9 "ARE YOU SURE YOU WANT TO DELETE THE ENTIRE FIELD?" 42 ;;^DIST(.403,.001,15,10,0) 43 ;;= 10 Multiple-field 44 ;;^DIST(.403,.001,15,11,0) 45 ;;= 46 ;;^DIST(.403,.001,15,12,0) 47 ;;= 48 ;;^DIST(.403,.001,15,13,0) 49 ;;= 50 ;;^DIST(.403,.001,15,14,0) 51 ;;=Branching logic: 52 ;;^DIST(.403,.001,15,15,0) 53 ;;= From Field 20.5 ("MULTIPLE?") 54 ;;^DIST(.403,.001,15,16,0) 55 ;;= IS THIS FIELD NEW AND IS THE USER A PROGRAMMER? 56 ;;^DIST(.403,.001,15,17,0) 57 ;;= | | 58 ;;^DIST(.403,.001,15,18,0) 59 ;;= NO YES 60 ;;^DIST(.403,.001,15,19,0) 61 ;;= | | 62 ;;^DIST(.403,.001,15,20,0) 63 ;;= | IS FIELD MULTIPLE? 64 ;;^DIST(.403,.001,15,21,0) 65 ;;= | | | 66 ;;^DIST(.403,.001,15,22,0) 67 ;;= | YES NO 68 ;;^DIST(.403,.001,15,23,0) 69 ;;= | | | 70 ;;^DIST(.403,.001,15,24,0) 71 ;;=IS FIELD EDITABLE & MULTIPLE? | | 72 ;;^DIST(.403,.001,15,25,0) 73 ;;= | | | | 74 ;;^DIST(.403,.001,15,26,0) 75 ;;= | YES ---------> Page 5 Page 3 76 ;;^DIST(.403,.001,15,27,0) 77 ;;= | | | 78 ;;^DIST(.403,.001,15,28,0) 79 ;;= | PROGRAMMER? | 80 ;;^DIST(.403,.001,15,29,0) 81 ;;= | | | | 82 ;;^DIST(.403,.001,15,30,0) 83 ;;= | YES NO | 84 ;;^DIST(.403,.001,15,31,0) 85 ;;= | | | | 86 ;;^DIST(.403,.001,15,32,0) 87 ;;= | Page 4 | | 88 ;;^DIST(.403,.001,15,33,0) 89 ;;= | | | | 90 ;;^DIST(.403,.001,15,34,0) 91 ;;= --------------------------------->|<------------------ 92 ;;^DIST(.403,.001,15,35,0) 93 ;;= | 94 ;;^DIST(.403,.001,15,36,0) 95 ;;= Field 98 (HELP-PROMPT) 96 ;;^DIST(.403,.001,20) 97 ;;=D POST^DICATTDE 98 ;;^DIST(.403,.001,40,0) 99 ;;=^.4031I^21^18 100 ;;^DIST(.403,.001,40,1,0) 101 ;;=1^^1,1 102 ;;^DIST(.403,.001,40,1,1) 103 ;;=Page 1 104 ;;^DIST(.403,.001,40,1,40,0) 105 ;;=^.4032IP^.00101^1 106 ;;^DIST(.403,.001,40,1,40,.00101,0) 107 ;;=.00101^1^1,1^e 108 ;;^DIST(.403,.001,40,1,40,.00101,11) 109 ;;=D PRE^DICATTD 110 ;;^DIST(.403,.001,40,2,0) 111 ;;=2.1^^4,3^^^1^12,70 112 ;;^DIST(.403,.001,40,2,1) 113 ;;=Page 2.1 114 ;;^DIST(.403,.001,40,2,12) 115 ;;=D POST1^DICATTD1 116 ;;^DIST(.403,.001,40,2,40,0) 117 ;;=^.4032IP^.00102^1 118 ;;^DIST(.403,.001,40,2,40,.00102,0) 119 ;;=.00102^1^2,3^e 120 ;;^DIST(.403,.001,40,3,0) 121 ;;=2.2^^4,3^^^1^9,70 122 ;;^DIST(.403,.001,40,3,1) 123 ;;=Page 2.2 124 ;;^DIST(.403,.001,40,3,12) 125 ;;=D POST2^DICATTD2 126 ;;^DIST(.403,.001,40,3,40,0) 127 ;;=^.4032IP^.00103^1 128 ;;^DIST(.403,.001,40,3,40,.00103,0) 129 ;;=.00103^1^2,3^e 130 ;;^DIST(.403,.001,40,6,0) 131 ;;=2.4^^3,8^^^1^7,67 132 ;;^DIST(.403,.001,40,6,1) 133 ;;=Page 2.4 134 ;;^DIST(.403,.001,40,6,12) 135 ;;=D POST4^DICATTD4 136 ;;^DIST(.403,.001,40,6,40,0) 137 ;;=^.4032IP^.00104^1 138 ;;^DIST(.403,.001,40,6,40,.00104,0) 139 ;;=.00104^1^1,1^e 140 ;;^DIST(.403,.001,40,7,0) 141 ;;=2.5^^4,6^^^1^6,75 142 ;;^DIST(.403,.001,40,7,1) 143 ;;=Page 2.5 144 ;;^DIST(.403,.001,40,7,40,0) 145 ;;=^.4032IP^.00105^1 146 ;;^DIST(.403,.001,40,7,40,.00105,0) 147 ;;=.00105^1^1,1^e 148 ;;^DIST(.403,.001,40,8,0) 149 ;;=2.6^^3,2^^^1^11,77 150 ;;^DIST(.403,.001,40,8,1) 151 ;;=Page 2.6 152 ;;^DIST(.403,.001,40,8,12) 153 ;;=D POST6^DICATTD6 154 ;;^DIST(.403,.001,40,8,40,0) 155 ;;=^.4032IP^.00106^1 156 ;;^DIST(.403,.001,40,8,40,.00106,0) 157 ;;=.00106^1^1,1^e 158 ;;^DIST(.403,.001,40,9,0) 159 ;;=2.7^^3,2^^^1^8,75 160 ;;^DIST(.403,.001,40,9,1) 161 ;;=Page 2.7 162 ;;^DIST(.403,.001,40,9,12) 163 ;;=D POST7^DICATTD7 164 ;;^DIST(.403,.001,40,9,40,0) 165 ;;=^.4032IP^.00107^1 166 ;;^DIST(.403,.001,40,9,40,.00107,0) 167 ;;=.00107^1^1,1^e 168 ;;^DIST(.403,.001,40,10,0) 169 ;;=2.8^^3,3^^^1^11,77 170 ;;^DIST(.403,.001,40,10,1) 171 ;;=Page 2.8 172 ;;^DIST(.403,.001,40,10,40,0) 173 ;;=^.4032IP^.00108^1 174 ;;^DIST(.403,.001,40,10,40,.00108,0) 175 ;;=.00108^1^1,1^e 176 ;;^DIST(.403,.001,40,11,0) 177 ;;=2.3^^3,6^^^1^17,70 178 ;;^DIST(.403,.001,40,11,1) 179 ;;=Page 2.3 180 ;;^DIST(.403,.001,40,11,12) 181 ;;=D POST3^DICATTD3 182 ;;^DIST(.403,.001,40,11,40,0) 183 ;;=^.4032IP^.00109^1 184 ;;^DIST(.403,.001,40,11,40,.00109,0) 185 ;;=.00109^1^1,1^e 186 ;;^DIST(.403,.001,40,12,0) 187 ;;=1.1^^1,1^^1 188 ;;^DIST(.403,.001,40,12,1) 189 ;;=Page 1.1 190 ;;^DIST(.403,.001,40,12,40,0) 191 ;;=^.4032IP^.0011^1 192 ;;^DIST(.403,.001,40,12,40,.0011,0) 193 ;;=.0011^1^1,1^e 194 ;;^DIST(.403,.001,40,12,40,.0011,11) 195 ;;=D WORD^DICATTD0(21) 196 ;;^DIST(.403,.001,40,13,0) 197 ;;=1.2^^1,1 198 ;;^DIST(.403,.001,40,13,1) 199 ;;=Page 1.2 200 ;;^DIST(.403,.001,40,13,40,0) 201 ;;=^.4032IP^.00111^1 202 ;;^DIST(.403,.001,40,13,40,.00111,0) 203 ;;=.00111^1^1,1^e 204 ;;^DIST(.403,.001,40,15,0) 205 ;;=3^^4,8^^^1^7,64 206 ;;^DIST(.403,.001,40,15,1) 207 ;;=Page 3 208 ;;^DIST(.403,.001,40,15,12) 209 ;;=D POST^DICATTDM 210 ;;^DIST(.403,.001,40,15,40,0) 211 ;;=^.4032IP^.00112^1 212 ;;^DIST(.403,.001,40,15,40,.00112,0) 213 ;;=.00112^1^2,2^e 214 ;;^DIST(.403,.001,40,16,0) 215 ;;=9^^3,10^^^1^7,70 216 ;;^DIST(.403,.001,40,16,1) 217 ;;=Page 9 218 ;;^DIST(.403,.001,40,16,40,0) 219 ;;=^.4032IP^.00113^1 220 ;;^DIST(.403,.001,40,16,40,.00113,0) 221 ;;=.00113^1^1,1^e 222 ;;^DIST(.403,.001,40,17,0) 223 ;;=4^^9,5^^^1^12,75 224 ;;^DIST(.403,.001,40,17,1) 225 ;;=Page 4 226 ;;^DIST(.403,.001,40,17,40,0) 227 ;;=^.4032IP^.00114^1 228 ;;^DIST(.403,.001,40,17,40,.00114,0) 229 ;;=.00114^1^1,1^e -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DINIT0F5.m
r613 r623 1 DINIT0F5 ;SFISC/MKO-DATA FOR FORM AND BLOCK FILES ;9APR2007 2 ;;22.0;VA FileMan;**76,152**;Mar 30, 1999;Build 10 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT0F6 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y 5 Q 6 ENTRY ; 7 ;;^DIST(.404,.00102,40,4,20) 8 ;;=Y 9 ;;^DIST(.404,.00102,40,4,21,0) 10 ;;=^^1^1^2981102 11 ;;^DIST(.404,.00102,40,4,21,1,0) 12 ;;=Can user enter time along with date, as in 'FEB23, 1999@7:30' 13 ;;^DIST(.404,.00102,40,5,0) 14 ;;=25^CAN SECONDS BE ENTERED^2^^SECONDS 15 ;;^DIST(.404,.00102,40,5,2) 16 ;;=5,29^3^5,5 17 ;;^DIST(.404,.00102,40,5,3) 18 ;;=!M 19 ;;^DIST(.404,.00102,40,5,3.1) 20 ;;=S Y=$E("NY",$P(DICATT5,"""",2)["S"+1) 21 ;;^DIST(.404,.00102,40,5,20) 22 ;;=Y 23 ;;^DIST(.404,.00102,40,6,0) 24 ;;=26^IS TIME REQUIRED^2^^IS TIME REQUIRED 25 ;;^DIST(.404,.00102,40,6,2) 26 ;;=6,29^3^6,11 27 ;;^DIST(.404,.00102,40,6,3) 28 ;;=!M 29 ;;^DIST(.404,.00102,40,6,3.1) 30 ;;=S Y=$E("NY",$P(DICATT5,"""",2)["R"+1) 31 ;;^DIST(.404,.00102,40,6,20) 32 ;;=Y 33 ;;^DIST(.404,.00102,40,6,21,0) 34 ;;=^^1^1^2981102 35 ;;^DIST(.404,.00102,40,6,21,1,0) 36 ;;=Must user enter TIME along with DATE? 37 ;;^DIST(.404,.00103,0) 38 ;;=DICATT2^1 39 ;;^DIST(.404,.00103,40,0) 40 ;;=^.4044I^4^4 41 ;;^DIST(.404,.00103,40,1,0) 42 ;;=31^INCLUSIVE LOWER BOUND^2^^LOWER BOUND 43 ;;^DIST(.404,.00103,40,1,2) 44 ;;=1,38^20^1,15 45 ;;^DIST(.404,.00103,40,1,3) 46 ;;=!M 47 ;;^DIST(.404,.00103,40,1,3.1) 48 ;;=I DICATT5["X<" S Y=+$P(DICATT5,"X<",2) 49 ;;^DIST(.404,.00103,40,1,4) 50 ;;=1 51 ;;^DIST(.404,.00103,40,1,20) 52 ;;=F^^1:20 53 ;;^DIST(.404,.00103,40,1,21,0) 54 ;;=^^1^1^2990219 55 ;;^DIST(.404,.00103,40,1,21,1,0) 56 ;;=Enter the lowest allowable number 57 ;;^DIST(.404,.00103,40,1,22) 58 ;;=K:+X'=X!(X'["."&($L(X)>15))!(X["."&($L($P(+X,"."))+$L($P(+X,".",2))>15)) X 59 ;;^DIST(.404,.00103,40,2,0) 60 ;;=32^INCLUSIVE UPPER BOUND^2^^UPPER BOUND 61 ;;^DIST(.404,.00103,40,2,2) 62 ;;=2,38^20^2,15 63 ;;^DIST(.404,.00103,40,2,3) 64 ;;=!M 65 ;;^DIST(.404,.00103,40,2,3.1) 66 ;;=I DICATT5["X>" S Y=+$P(DICATT5,"X>",2) 67 ;;^DIST(.404,.00103,40,2,4) 68 ;;=1 69 ;;^DIST(.404,.00103,40,2,20) 70 ;;=F^^1:20 71 ;;^DIST(.404,.00103,40,2,21,0) 72 ;;=^^1^1^2990219 73 ;;^DIST(.404,.00103,40,2,21,1,0) 74 ;;=Enter the highest allowable number 75 ;;^DIST(.404,.00103,40,2,22) 76 ;;=K:+X'=X!(X'["."&($L(X)>15))!(X["."&($L($P(+X,"."))+$L($P(+X,"."))>15)) X 77 ;;^DIST(.404,.00103,40,3,0) 78 ;;=33^IS THIS A DOLLAR AMOUNT^2^^DOLLAR AMOUNT 79 ;;^DIST(.404,.00103,40,3,2) 80 ;;=3,38^3^3,13 81 ;;^DIST(.404,.00103,40,3,3) 82 ;;=!M 83 ;;^DIST(.404,.00103,40,3,3.1) 84 ;;=S Y=$E("NY",DICATT5["""$"""+1) 85 ;;^DIST(.404,.00103,40,3,12) 86 ;;=I X=1 D PUT^DDSVALF(34,,,2,"") S DDSBR="COM" 87 ;;^DIST(.404,.00103,40,3,20) 88 ;;=Y 89 ;;^DIST(.404,.00103,40,4,0) 90 ;;=34^MAXIMUM NUMBER OF FRACTIONAL DIGITS^2^^FRACTIONAL DIGITS 91 ;;^DIST(.404,.00103,40,4,2) 92 ;;=4,38^1^4,1 93 ;;^DIST(.404,.00103,40,4,3) 94 ;;=!M 95 ;;^DIST(.404,.00103,40,4,3.1) 96 ;;=S Y=$S(DICATT5["""$""":2,1:$P(DICATT5,"1"".""",2)-1) S:Y<0 Y=0 97 ;;^DIST(.404,.00103,40,4,4) 98 ;;=0 99 ;;^DIST(.404,.00103,40,4,20) 100 ;;=N^^0:9 101 ;;^DIST(.404,.00104,0) 102 ;;=DICATT4^1 103 ;;^DIST(.404,.00104,40,0) 104 ;;=^.4044I^3^3 105 ;;^DIST(.404,.00104,40,1,0) 106 ;;=68^MINIMUM LENGTH^2^^MINIMUM LENGTH 107 ;;^DIST(.404,.00104,40,1,2) 108 ;;=2,27^3^2,11 109 ;;^DIST(.404,.00104,40,1,3) 110 ;;=!M 111 ;;^DIST(.404,.00104,40,1,3.1) 112 ;;=S Y=+$P(DICATT5,"$L(X)<",2) 113 ;;^DIST(.404,.00104,40,1,4) 114 ;;=1 115 ;;^DIST(.404,.00104,40,1,20) 116 ;;=N^^1:250:0 117 ;;^DIST(.404,.00104,40,2,0) 118 ;;=69^MAXIMUM LENGTH^2^^MAXIMUM LENGTH 119 ;;^DIST(.404,.00104,40,2,2) 120 ;;=3,27^3^3,11 121 ;;^DIST(.404,.00104,40,2,3) 122 ;;=!M 123 ;;^DIST(.404,.00104,40,2,3.1) 124 ;;=S Y=+$P(DICATT5,"$L(X)>",2) 125 ;;^DIST(.404,.00104,40,2,4) 126 ;;=1 127 ;;^DIST(.404,.00104,40,2,20) 128 ;;=N^^1:250:0 129 ;;^DIST(.404,.00104,40,3,0) 130 ;;=70^PATTERN MATCH (IN 'X')^2^^PATTERN MATCH 131 ;;^DIST(.404,.00104,40,3,2) 132 ;;=4,27^30^4,3 133 ;;^DIST(.404,.00104,40,3,3) 134 ;;=!M 135 ;;^DIST(.404,.00104,40,3,3.1) 136 ;;=D PRE4^DICATTD4 137 ;;^DIST(.404,.00104,40,3,20) 138 ;;=F^U^3:80 139 ;;^DIST(.404,.00104,40,3,21,0) 140 ;;=^^1^1^2981104 141 ;;^DIST(.404,.00104,40,3,21,1,0) 142 ;;=Example: "X?1.A" or "X'?.P" 143 ;;^DIST(.404,.00105,0) 144 ;;=DICATT5^1 145 ;;^DIST(.404,.00105,40,0) 146 ;;=^.4044I^2^2 147 ;;^DIST(.404,.00105,40,1,0) 148 ;;=75^SHALL THIS TEXT NORMALLY APPEAR IN WORD-WRAP MODE^2^^WORD-WRAP 149 ;;^DIST(.404,.00105,40,1,2) 150 ;;=2,53^3^2,2 151 ;;^DIST(.404,.00105,40,1,3) 152 ;;=!M 153 ;;^DIST(.404,.00105,40,1,3.1) 154 ;;=S Y=$E("YN",DICATT2["L"+1) 155 ;;^DIST(.404,.00105,40,1,12) 156 ;;=S DICATTMN="",DICATT2N="W"_$TR($G(DICATT2N),"WL")_$E("L",'X) 157 ;;^DIST(.404,.00105,40,1,20) 158 ;;=Y 159 ;;^DIST(.404,.00105,40,1,21,0) 160 ;;=^^4^4^2981120 161 ;;^DIST(.404,.00105,40,1,21,1,0) 162 ;;=Answer 'YES' if the text should normally be printed out in full lines, 163 ;;^DIST(.404,.00105,40,1,21,2,0) 164 ;;=breaking at word boundaries. 165 ;;^DIST(.404,.00105,40,1,21,3,0) 166 ;;=Answer 'NO' if the text should normally be printed out line-for-line as 167 ;;^DIST(.404,.00105,40,1,21,4,0) 168 ;;=it was entered. 169 ;;^DIST(.404,.00105,40,2,0) 170 ;;=76^SHALL "|" CHARACTERS IN THIS TEXT BE TREATED LIKE ANY OTHER CHARACTERS^2^^"|" 171 ;;^DIST(.404,.00105,40,2,2) 172 ;;=3,74^3^3,2 173 ;;^DIST(.404,.00105,40,2,3) 174 ;;=!M 175 ;;^DIST(.404,.00105,40,2,3.1) 176 ;;=S Y=$S(DICATT2["X"!(DICATT2["x")!(DICATT2=""):"Y",1:"N") 177 ;;^DIST(.404,.00105,40,2,12) 178 ;;=S DICATTMN="",DICATT2N="W"_$TR($G(DICATT2N),"WxX")_$E("x",X>0) I DUZ(0)="@",DICATT4="" S DDSSTACK=4 179 ;;^DIST(.404,.00105,40,2,20) 180 ;;=Y 181 ;;^DIST(.404,.00105,40,2,21,0) 182 ;;=^^4^4^2981120 183 ;;^DIST(.404,.00105,40,2,21,1,0) 184 ;;=Answer 'YES' if the internally-stored text may have "|" characters in it 185 ;;^DIST(.404,.00105,40,2,21,2,0) 186 ;;=(such as HL7 messages) that need to display exactly as they are stored. 187 ;;^DIST(.404,.00105,40,2,21,3,0) 188 ;;=Answer 'NO' if the internal text should normally be printed out with 189 ;;^DIST(.404,.00105,40,2,21,4,0) 190 ;;=anything that is delimited by "|" characters interpreted as variable. 191 ;;^DIST(.404,.00106,0) 192 ;;=DICATT6^1 193 ;;^DIST(.404,.00106,40,0) 194 ;;=^.4044I^8^8 195 ;;^DIST(.404,.00106,40,1,0) 196 ;;=78^^2^^COMPUTED EXPRESSION 197 ;;^DIST(.404,.00106,40,1,2) 198 ;;=3,2^73 199 ;;^DIST(.404,.00106,40,1,3) 200 ;;=!M 201 ;;^DIST(.404,.00106,40,1,3.1) 202 ;;=S Y=$G(^DD(DICATTA,DICATTF,9.1)) 203 ;;^DIST(.404,.00106,40,1,4) 204 ;;=1 205 ;;^DIST(.404,.00106,40,1,13) 206 ;;=D VAL6^DICATTD6 207 ;;^DIST(.404,.00106,40,1,20) 208 ;;=F^U^1:250 209 ;;^DIST(.404,.00106,40,1,21,0) 210 ;;=^^3^3^2981118 211 ;;^DIST(.404,.00106,40,1,21,1,0) 212 ;;=A Computed Expression consists of Field Names, Operators (including "_" 213 ;;^DIST(.404,.00106,40,1,21,2,0) 214 ;;=for concatenation), Functions, and literal strings (e.g., "Name: ") and 215 ;;^DIST(.404,.00106,40,1,21,3,0) 216 ;;=digits. 217 ;;^DIST(.404,.00106,40,2,0) 218 ;;=77^COMPUTED-FIELD EXPRESSION:^1^^COMP 219 ;;^DIST(.404,.00106,40,2,2) 220 ;;=^^2,2 221 ;;^DIST(.404,.00106,40,3,0) 222 ;;=80^NUMBER OF FRACTIONAL DIGITS TO OUTPUT^2^^FRACTIONAL DIGITS 223 ;;^DIST(.404,.00106,40,3,2) 224 ;;=5,65^1^5,26 225 ;;^DIST(.404,.00106,40,3,3) 226 ;;=!M 227 ;;^DIST(.404,.00106,40,3,3.1) 228 ;;=S Y=$P($P(DICATT2,"J",2),",",2),Y=$S(Y?1N.E:+Y,1:"") 229 ;;^DIST(.404,.00106,40,3,20) 230 ;;=N^^0:9:0 231 ;;^DIST(.404,.00106,40,3,21,0) 232 ;;=^^2^2^2981118 233 ;;^DIST(.404,.00106,40,3,21,1,0) 234 ;;=Enter the number of digits that should normally appear to the 235 ;;^DIST(.404,.00106,40,3,21,2,0) 236 ;;=right of the decimal point when this Field's value is displayed. 237 ;;^DIST(.404,.00106,40,4,0) 238 ;;=79^TYPE OF RESULT^2^^COMPTYPE 239 ;;^DIST(.404,.00106,40,4,2) 240 ;;=4,29^17^4,13 241 ;;^DIST(.404,.00106,40,4,10) 242 ;;=D BR79^DICATTD6 243 ;;^DIST(.404,.00106,40,4,20) 244 ;;=S^M^D:DATE;N:NUMERIC;B:BOOLEAN;S:STRING;m:MULTIPLE-VALUED;mp:MULTIPLE POINTER;p:POINTER 245 ;;^DIST(.404,.00106,40,4,21,0) 246 ;;=^^4^4^2981118 247 ;;^DIST(.404,.00106,40,4,21,1,0) 248 ;;=The typical Computed Field is STRING-valued, i.e., alphanumeric. 249 ;;^DIST(.404,.00106,40,4,21,2,0) 250 ;;=If NUMERIC, the indented questions will be asked. 251 ;;^DIST(.404,.00106,40,4,21,3,0) 252 ;;=BOOLEAN values are "true-false". 253 ;;^DIST(.404,.00106,40,4,21,4,0) 254 ;;=If the computation returns a number that is actually an Entry number in a File, call it a POINTER. 255 ;;^DIST(.404,.00106,40,8,0) 256 ;;=83.1^POINT TO FILE^2 257 ;;^DIST(.404,.00106,40,8,2) 258 ;;=8,46^27^8,30 259 ;;^DIST(.404,.00106,40,8,3) 260 ;;=!M 261 ;;^DIST(.404,.00106,40,8,3.1) 262 ;;=S Y=+$P(DICATT2,"p",2),Y=$S(Y:$P($G(^DIC(Y,0)),U),1:"") 263 ;;^DIST(.404,.00106,40,8,20) 264 ;;=P^^1:EOFIZ 265 ;;^DIST(.404,.00106,40,8,24) 266 ;;=S DIR("S")="I $$OKFILE^DICOMPX(Y,""W"")" 1 DINIT0F5 ;SFISC/MKO-DATA FOR FORM AND BLOCK FILES ;05:51 PM 23 Mar 2001 2 ;;22.0;VA FileMan;**76**;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 F I=1:2 S X=$T(ENTRY+I) G:X="" ^DINIT0F6 S Y=$E($T(ENTRY+I+1),5,999),X=$E(X,4,999),@X=Y 5 Q 6 ENTRY ; 7 ;;^DIST(.404,.00102,40,4,20) 8 ;;=Y 9 ;;^DIST(.404,.00102,40,4,21,0) 10 ;;=^^1^1^2981102 11 ;;^DIST(.404,.00102,40,4,21,1,0) 12 ;;=Can user enter time along with date, as in 'FEB23, 1999@7:30' 13 ;;^DIST(.404,.00102,40,5,0) 14 ;;=25^CAN SECONDS BE ENTERED^2^^SECONDS 15 ;;^DIST(.404,.00102,40,5,2) 16 ;;=5,29^3^5,5 17 ;;^DIST(.404,.00102,40,5,3) 18 ;;=!M 19 ;;^DIST(.404,.00102,40,5,3.1) 20 ;;=S Y=$E("NY",$P(DICATT5,"""",2)["S"+1) 21 ;;^DIST(.404,.00102,40,5,20) 22 ;;=Y 23 ;;^DIST(.404,.00102,40,6,0) 24 ;;=26^IS TIME REQUIRED^2^^IS TIME REQUIRED 25 ;;^DIST(.404,.00102,40,6,2) 26 ;;=6,29^3^6,11 27 ;;^DIST(.404,.00102,40,6,3) 28 ;;=!M 29 ;;^DIST(.404,.00102,40,6,3.1) 30 ;;=S Y=$E("NY",$P(DICATT5,"""",2)["R"+1) 31 ;;^DIST(.404,.00102,40,6,20) 32 ;;=Y 33 ;;^DIST(.404,.00102,40,6,21,0) 34 ;;=^^1^1^2981102 35 ;;^DIST(.404,.00102,40,6,21,1,0) 36 ;;=Must user enter TIME along with DATE? 37 ;;^DIST(.404,.00103,0) 38 ;;=DICATT2^1 39 ;;^DIST(.404,.00103,40,0) 40 ;;=^.4044I^4^4 41 ;;^DIST(.404,.00103,40,1,0) 42 ;;=31^INCLUSIVE LOWER BOUND^2^^LOWER BOUND 43 ;;^DIST(.404,.00103,40,1,2) 44 ;;=1,38^20^1,15 45 ;;^DIST(.404,.00103,40,1,3) 46 ;;=!M 47 ;;^DIST(.404,.00103,40,1,3.1) 48 ;;=I DICATT5["X<" S Y=+$P(DICATT5,"X<",2) 49 ;;^DIST(.404,.00103,40,1,4) 50 ;;=1 51 ;;^DIST(.404,.00103,40,1,20) 52 ;;=F^^1:20 53 ;;^DIST(.404,.00103,40,1,21,0) 54 ;;=^^1^1^2990219 55 ;;^DIST(.404,.00103,40,1,21,1,0) 56 ;;=Enter the lowest allowable number 57 ;;^DIST(.404,.00103,40,1,22) 58 ;;=K:+X'=X!(X'["."&($L(X)>15))!(X["."&($L($P(+X,"."))+$L($P(+X,".",2))>15)) X 59 ;;^DIST(.404,.00103,40,2,0) 60 ;;=32^INCLUSIVE UPPER BOUND^2^^UPPER BOUND 61 ;;^DIST(.404,.00103,40,2,2) 62 ;;=2,38^20^2,15 63 ;;^DIST(.404,.00103,40,2,3) 64 ;;=!M 65 ;;^DIST(.404,.00103,40,2,3.1) 66 ;;=I DICATT5["X>" S Y=+$P(DICATT5,"X>",2) 67 ;;^DIST(.404,.00103,40,2,4) 68 ;;=1 69 ;;^DIST(.404,.00103,40,2,20) 70 ;;=F^^1:20 71 ;;^DIST(.404,.00103,40,2,21,0) 72 ;;=^^1^1^2990219 73 ;;^DIST(.404,.00103,40,2,21,1,0) 74 ;;=Enter the highest allowable number 75 ;;^DIST(.404,.00103,40,2,22) 76 ;;=K:+X'=X!(X'["."&($L(X)>15))!(X["."&($L($P(+X,"."))+$L($P(+X,"."))>15)) X 77 ;;^DIST(.404,.00103,40,3,0) 78 ;;=33^IS THIS A DOLLAR AMOUNT^2^^DOLLAR AMOUNT 79 ;;^DIST(.404,.00103,40,3,2) 80 ;;=3,38^3^3,13 81 ;;^DIST(.404,.00103,40,3,3) 82 ;;=!M 83 ;;^DIST(.404,.00103,40,3,3.1) 84 ;;=S Y=$E("NY",DICATT5["""$"""+1) 85 ;;^DIST(.404,.00103,40,3,12) 86 ;;=I X=1 D PUT^DDSVALF(34,,,2,"") S DDSBR="COM" 87 ;;^DIST(.404,.00103,40,3,20) 88 ;;=Y 89 ;;^DIST(.404,.00103,40,4,0) 90 ;;=34^MAXIMUM NUMBER OF FRACTIONAL DIGITS^2^^FRACTIONAL DIGITS 91 ;;^DIST(.404,.00103,40,4,2) 92 ;;=4,38^1^4,1 93 ;;^DIST(.404,.00103,40,4,3) 94 ;;=!M 95 ;;^DIST(.404,.00103,40,4,3.1) 96 ;;=S Y=$S(DICATT5["""$""":2,1:$P(DICATT5,"1"".""",2)-1) S:Y<0 Y=0 97 ;;^DIST(.404,.00103,40,4,4) 98 ;;=0 99 ;;^DIST(.404,.00103,40,4,20) 100 ;;=N^^0:9 101 ;;^DIST(.404,.00104,0) 102 ;;=DICATT4^1 103 ;;^DIST(.404,.00104,40,0) 104 ;;=^.4044I^3^3 105 ;;^DIST(.404,.00104,40,1,0) 106 ;;=68^MINIMUM LENGTH^2^^MINIMUM LENGTH 107 ;;^DIST(.404,.00104,40,1,2) 108 ;;=2,27^3^2,11 109 ;;^DIST(.404,.00104,40,1,3) 110 ;;=!M 111 ;;^DIST(.404,.00104,40,1,3.1) 112 ;;=S Y=+$P(DICATT5,"$L(X)<",2) 113 ;;^DIST(.404,.00104,40,1,4) 114 ;;=1 115 ;;^DIST(.404,.00104,40,1,20) 116 ;;=N^^1:250:0 117 ;;^DIST(.404,.00104,40,2,0) 118 ;;=69^MAXIMUM LENGTH^2^^MAXIMUM LENGTH 119 ;;^DIST(.404,.00104,40,2,2) 120 ;;=3,27^3^3,11 121 ;;^DIST(.404,.00104,40,2,3) 122 ;;=!M 123 ;;^DIST(.404,.00104,40,2,3.1) 124 ;;=S Y=+$P(DICATT5,"$L(X)>",2) 125 ;;^DIST(.404,.00104,40,2,4) 126 ;;=1 127 ;;^DIST(.404,.00104,40,2,20) 128 ;;=N^^1:250:0 129 ;;^DIST(.404,.00104,40,3,0) 130 ;;=70^PATTERN MATCH (IN 'X')^2^^PATTERN MATCH 131 ;;^DIST(.404,.00104,40,3,2) 132 ;;=4,27^30^4,3 133 ;;^DIST(.404,.00104,40,3,3) 134 ;;=!M 135 ;;^DIST(.404,.00104,40,3,3.1) 136 ;;=D PRE4^DICATTD4 137 ;;^DIST(.404,.00104,40,3,20) 138 ;;=F^U^3:80 139 ;;^DIST(.404,.00104,40,3,21,0) 140 ;;=^^1^1^2981104 141 ;;^DIST(.404,.00104,40,3,21,1,0) 142 ;;=Example: "X?1.A" or "X'?.P" 143 ;;^DIST(.404,.00105,0) 144 ;;=DICATT5^1 145 ;;^DIST(.404,.00105,40,0) 146 ;;=^.4044I^1^1 147 ;;^DIST(.404,.00105,40,1,0) 148 ;;=75^SHALL THIS TEXT NORMALLY APPEAR IN WORD-WRAP MODE^2^^WORD-WRAP 149 ;;^DIST(.404,.00105,40,1,2) 150 ;;=2,56^3^2,5 151 ;;^DIST(.404,.00105,40,1,3) 152 ;;=!M 153 ;;^DIST(.404,.00105,40,1,3.1) 154 ;;=S Y=$E("YN",DICATT2["L"+1) 155 ;;^DIST(.404,.00105,40,1,12) 156 ;;=S DICATTMN="" S:'X DICATT2N="WL" I DUZ(0)="@",DICATT4="" S DDSSTACK=4 157 ;;^DIST(.404,.00105,40,1,20) 158 ;;=Y 159 ;;^DIST(.404,.00105,40,1,21,0) 160 ;;=^^4^4^2981120 161 ;;^DIST(.404,.00105,40,1,21,1,0) 162 ;;=Answer 'YES' if the text should normally be printed out in full lines, 163 ;;^DIST(.404,.00105,40,1,21,2,0) 164 ;;=breaking at word boundaries. 165 ;;^DIST(.404,.00105,40,1,21,3,0) 166 ;;=Answer 'NO' if the text should normally be printed out line-for-line as 167 ;;^DIST(.404,.00105,40,1,21,4,0) 168 ;;=it was entered. 169 ;;^DIST(.404,.00106,0) 170 ;;=DICATT6^1 171 ;;^DIST(.404,.00106,40,0) 172 ;;=^.4044I^8^8 173 ;;^DIST(.404,.00106,40,1,0) 174 ;;=78^^2^^COMPUTED EXPRESSION 175 ;;^DIST(.404,.00106,40,1,2) 176 ;;=3,2^73 177 ;;^DIST(.404,.00106,40,1,3) 178 ;;=!M 179 ;;^DIST(.404,.00106,40,1,3.1) 180 ;;=S Y=$G(^DD(DICATTA,DICATTF,9.1)) 181 ;;^DIST(.404,.00106,40,1,4) 182 ;;=1 183 ;;^DIST(.404,.00106,40,1,13) 184 ;;=D VAL6^DICATTD6 185 ;;^DIST(.404,.00106,40,1,20) 186 ;;=F^U^1:250 187 ;;^DIST(.404,.00106,40,1,21,0) 188 ;;=^^3^3^2981118 189 ;;^DIST(.404,.00106,40,1,21,1,0) 190 ;;=A Computed Expression consists of Field Names, Operators (including "_" 191 ;;^DIST(.404,.00106,40,1,21,2,0) 192 ;;=for concatenation), Functions, and literal strings (e.g., "Name: ") and 193 ;;^DIST(.404,.00106,40,1,21,3,0) 194 ;;=digits. 195 ;;^DIST(.404,.00106,40,2,0) 196 ;;=77^COMPUTED-FIELD EXPRESSION:^1^^COMP 197 ;;^DIST(.404,.00106,40,2,2) 198 ;;=^^2,2 199 ;;^DIST(.404,.00106,40,3,0) 200 ;;=80^NUMBER OF FRACTIONAL DIGITS TO OUTPUT^2^^FRACTIONAL DIGITS 201 ;;^DIST(.404,.00106,40,3,2) 202 ;;=5,65^1^5,26 203 ;;^DIST(.404,.00106,40,3,3) 204 ;;=!M 205 ;;^DIST(.404,.00106,40,3,3.1) 206 ;;=S Y=$P($P(DICATT2,"J",2),",",2),Y=$S(Y?1N.E:+Y,1:"") 207 ;;^DIST(.404,.00106,40,3,20) 208 ;;=N^^0:9:0 209 ;;^DIST(.404,.00106,40,3,21,0) 210 ;;=^^2^2^2981118 211 ;;^DIST(.404,.00106,40,3,21,1,0) 212 ;;=Enter the number of digits that should normally appear to the 213 ;;^DIST(.404,.00106,40,3,21,2,0) 214 ;;=right of the decimal point when this Field's value is displayed. 215 ;;^DIST(.404,.00106,40,4,0) 216 ;;=79^TYPE OF RESULT^2^^COMPTYPE 217 ;;^DIST(.404,.00106,40,4,2) 218 ;;=4,29^17^4,13 219 ;;^DIST(.404,.00106,40,4,10) 220 ;;=D BR79^DICATTD6 221 ;;^DIST(.404,.00106,40,4,20) 222 ;;=S^M^D:DATE;N:NUMERIC;B:BOOLEAN;S:STRING;m:MULTIPLE-VALUED;mp:MULTIPLE POINTER;p:POINTER 223 ;;^DIST(.404,.00106,40,4,21,0) 224 ;;=^^4^4^2981118 225 ;;^DIST(.404,.00106,40,4,21,1,0) 226 ;;=The typical Computed Field is STRING-valued, i.e., alphanumeric. 227 ;;^DIST(.404,.00106,40,4,21,2,0) 228 ;;=If NUMERIC, the indented questions will be asked. 229 ;;^DIST(.404,.00106,40,4,21,3,0) 230 ;;=BOOLEAN values are "true-false". 231 ;;^DIST(.404,.00106,40,4,21,4,0) 232 ;;=If the computation returns a number that is actually an Entry number in a File, call it a POINTER. 233 ;;^DIST(.404,.00106,40,8,0) 234 ;;=83.1^POINT TO FILE^2 235 ;;^DIST(.404,.00106,40,8,2) 236 ;;=8,46^27^8,30 237 ;;^DIST(.404,.00106,40,8,3) 238 ;;=!M 239 ;;^DIST(.404,.00106,40,8,3.1) 240 ;;=S Y=+$P(DICATT2,"p",2),Y=$S(Y:$P($G(^DIC(Y,0)),U),1:"") 241 ;;^DIST(.404,.00106,40,8,20) 242 ;;=P^^1:EOFIZ 243 ;;^DIST(.404,.00106,40,8,24) 244 ;;=S DIR("S")="I $$OKFILE^DICOMPX(Y,""W"")" -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWE1.m
r613 r623 1 DIWE1 ;SFISC/GFT-WORD PROCESSING FUNCTION ;4JUN2008 2 ;;22.0;VA FileMan;**159**;Mar 30, 1999;Build 8 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 G X:$D(DTOUT) I '$D(DWL) S I=DWLC,J=$S(I<11:1,1:I-8) W:J>1 ?7,". . .",!?7,". . ." D LL 5 1 G X:$D(DTOUT) R !,"EDIT Option: ",X:DTIME S:'$T DTOUT=1 G X:U[X!(X=".") 6 LC I X?1L S X=$C($A(X)-32) 7 S J="^DOPT(""DIWE1""," I X?1U S I=$F(DWO,X)-1 I I>0 S ^DISV(DUZ,J)=I S I=I*2-1 G OPT 8 I X=" ",$D(^DISV(DUZ,J)) S I=^(J),X=$E(DWO,I) I X]"" W X S I=I*2-1 G OPT 9 I X?1N.N S I=9 D LN G E2:X W "OR" 10 W !?5,"Choose, by first letter, a Word Processing Command" 11 I X?2"?".E W " from the following:" F I=1:2 S Y=$T(OPT+I),J=$E(Y,1) Q:J=" " I DWO[J W !?10,$P(Y,";",4) 12 W !?5,"or type a Line Number to edit that line." G 1 13 ; 14 OPT Q:$D(DTOUT) S X1=$T(OPT+I),X=$P(X1,";",3) W $E(X,'$X)_$E(X,2,99) G @$E(X1,1) 15 A ;;Add lines;Add Lines to End of Text 16 D ^DIWE2 S (DWL,DWLC)=DWI,@(DIC_"0)=DWLC") G 1:DWLC,X 17 B ;;Break line: ;Break a Line into Two; 18 D RD G B^DIWE4 19 C ;;Change every: ;Change Every String to Another in a Range of Lines; 20 G C^DIWE2 21 D ;;Delete from line: ;Delete Line(s); 22 D RD G D^DIWE3 23 E ;;Edit line: ;Edit a Line (Replace __ With __); 24 D RD G OPT:X="",1:X=U,LC:X?1A,E2 25 G ;;Get Data from Another Source ;Get Data from Another Source 26 G X^DIWE5 27 I ;;Insert after line: ;Insert Line(s) after an Existing Line; 28 D RD G I^DIWE2 29 J ;;Join line: ;Join Line to the One Following; 30 D RD G J^DIWE4 31 L ;;List line: ;List a Range of Lines; 32 S DIWELAST=$S($G(DIWELAST):DIWELAST,1:1) W DIWELAST_"//" R X:DTIME S:'$T X=U,DTOUT=1 S:X="" X=DIWELAST D LN G LIST:X,1:X=U W !,$P(X1,";",3) G L 33 M ;;Move line: ;Move Lines to New Location within Text; 34 D RD G M^DIWE3 35 P ;;Print from Line: 1//;Print Lines as Formatted Output; 36 R X:DTIME S:'$T X=U,DTOUT=1 S:X="" X=1 D LN,^DIWE4:X G 1 37 R ;;Repeat line: ;Repeat Lines at a New Location 38 D RD G R^DIWE3 39 S ;;Search for: ;Search for a String 40 G S^DIWE2 41 T ;;Transfer incoming text after line: ;Transfer Lines From Another Document 42 D RD,Z^DIWE3 G DIWE1 43 U ;;Utilities in Word-Processing;Utility Sub-Menu 44 D ^DIWE11 G 1 45 Y ;;Y;Y-Programmer Edit; 46 G Y^DIWE4 47 ;; 48 E2 S Y=^(0) S:Y="" Y=" " W !,$J(DWL,3)_">"_Y,! S DIRWP=1 D RW^DIR2 K DIRWP G E2:X?1."?",X:X?1."^" 49 TAB I X[$C(9) S X=$P(X,$C(9),1)_$C(124)_"TAB"_$C(124)_$P(X,$C(9),2,999) G TAB 50 S:X]"" ^(0)=X 51 ;check if line is greater than max, DWLW, break line up and treat as an insert 52 I $L(X)>DWLW D 53 . N I,J,DIC1 54 . K ^UTILITY($J,"W") S DIC1=DIC,DIC="^UTILITY($J,""W"",",@(DIC_"0)")="" 55 . F DWI=1:1 Q:$L(X)'>DWLW S J=$F(X," ",DWLW-7),J=$S(J<1!(J>DWLW):DWLW,1:J),@(DIC_"DWI,0)")=$E(X,1,J-1),X=$E(X,J,256) 56 . S @(DIC_"DWI,0)")=X 57 . W !,(DWI-1)_" line"_$E("s",DWI>2)_" inserted.." 58 . X "F J=DWL+1:1:DWLC S DWI=DWI+1,"_DIC_"DWI,0)="_DIC1_"J,0) W "".""" 59 . S I=DWL X "F J=1:1 Q:'$D("_DIC_"J,0)) S "_DIC1_"I,0)=^(0),I=I+1 W "".""" 60 . S DWLC=I-1,DIC=DIC1 K ^UTILITY($J,"W") 61 E I X="@" S (DW1,DW2)=DWL W "DELETED..." D DEL^DIWE3 62 W ! S I=9 G OPT 63 ; 64 RD R X:DTIME S:'$T DTOUT=1 I X?1."?" W !?5,"Enter a line number from 1 through "_DWLC,!!,$P(X1,";",3) G RD 65 LN I U[X!(X=".") S X=U Q 66 Q:I=9&(X?1A) I 'DWLC,I<27,I-13 S X=U W " THERE ARE NO LINES!",$C(7),! Q 67 I "+- "[$E(X,1),X?1P.N,$D(DWL) S:X?1P X=X_1 S X=X+DWL W " "_X 68 E S X=+X 69 I (I=13!(I=27)&(X=0))!$D(@(DIC_"X,0)")) S DWL=X Q 70 S X="" G LNQ^DIWE5 71 ; 72 X K DIWELAST 73 G X^DIWE 74 ; 75 LIST W " to: "_DWLC_"// " R I:DTIME S:'$T DTOUT=1 S I=$S(I="":DWLC,1:I) I I,I>DWLC!(I<1) S I=DWLC 76 S J=X,DIWELAST=$S(DWLC=I:1,1:I) D LL G 1 77 LL X "F J=J:1:I W !,$J(J,3)_"">""_"_DIC_"J,0)" 1 DIWE1 ;SFISC/GFT-WORD PROCESSING FUNCTION ;7/29/94 09:18 2 ;;22.0;VA FileMan;;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 G X:$D(DTOUT) I '$D(DWL) S I=DWLC,J=$S(I<11:1,1:I-8) W:J>1 ?7,". . .",!?7,". . ." D LL 5 1 G X:$D(DTOUT) R !,"EDIT Option: ",X:DTIME S:'$T DTOUT=1 G X:U[X!(X=".") 6 LC I X?1L S X=$C($A(X)-32) 7 S J="^DOPT(""DIWE1""," I X?1U S I=$F(DWO,X)-1 I I>0 S ^DISV(DUZ,J)=I S I=I*2-1 G OPT 8 I X=" ",$D(^DISV(DUZ,J)) S I=^(J),X=$E(DWO,I) I X]"" W X S I=I*2-1 G OPT 9 I X?1N.N S I=9 D LN G E2:X W "OR" 10 W !?5,"Choose, by first letter, a Word Processing Command" 11 I X?2"?".E W " from the following:" F I=1:2 S Y=$T(OPT+I),J=$E(Y,1) Q:J=" " I DWO[J W !?10,$P(Y,";",4) 12 W !?5,"or type a Line Number to edit that line." G 1 13 ; 14 OPT Q:$D(DTOUT) S X1=$T(OPT+I),X=$P(X1,";",3) W $E(X,'$X)_$E(X,2,99) G @$E(X1,1) 15 A ;;Add lines;Add Lines to End of Text 16 D ^DIWE2 S (DWL,DWLC)=DWI,@(DIC_"0)=DWLC") G 1:DWLC,X 17 B ;;Break line: ;Break a Line into Two; 18 D RD G B^DIWE4 19 C ;;Change every: ;Change Every String to Another in a Range of Lines; 20 G C^DIWE2 21 D ;;Delete from line: ;Delete Line(s); 22 D RD G D^DIWE3 23 E ;;Edit line: ;Edit a Line (Replace __ With __); 24 D RD G OPT:X="",1:X=U,LC:X?1A,E2 25 G ;;Get Data from Another Source ;Get Data from Another Source 26 G X^DIWE5 27 I ;;Insert after line: ;Insert Line(s) after an Existing Line; 28 D RD G I^DIWE2 29 J ;;Join line: ;Join Line to the One Following; 30 D RD G J^DIWE4 31 L ;;List line: ;List a Range of Lines; 32 S DIWELAST=$S($G(DIWELAST):DIWELAST,1:1) W DIWELAST_"//" R X:DTIME S:'$T X=U,DTOUT=1 S:X="" X=DIWELAST D LN G LIST:X,1:X=U W !,$P(X1,";",3) G L 33 M ;;Move line: ;Move Lines to New Location within Text; 34 D RD G M^DIWE3 35 P ;;Print from Line: 1//;Print Lines as Formatted Output; 36 R X:DTIME S:'$T X=U,DTOUT=1 S:X="" X=1 D LN,^DIWE4:X G 1 37 R ;;Repeat line: ;Repeat Lines at a New Location 38 D RD G R^DIWE3 39 S ;;Search for: ;Search for a String 40 G S^DIWE2 41 T ;;Transfer incoming text after line: ;Transfer Lines From Another Document 42 D RD,Z^DIWE3 G DIWE1 43 U ;;Utilities in Word-Processing;Utility Sub-Menu 44 D ^DIWE11 G 1 45 Y ;;Y;Y-Programmer Edit; 46 G Y^DIWE4 47 ;; 48 E2 S Y=^(0) S:Y="" Y=" " W !,$J(DWL,3)_">"_Y,! S DIRWP=1 D RW^DIR2 K DIRWP G E2:X?1."?",X:X?1."^" 49 TAB I X[$C(9) S X=$P(X,$C(9),1)_$C(124)_"TAB"_$C(124)_$P(X,$C(9),2,999) G TAB 50 S:X]"" ^(0)=X I X="@" S (DW1,DW2)=DWL W "DELETED..." D DEL^DIWE3 51 W ! S I=9 G OPT 52 ; 53 RD R X:DTIME S:'$T DTOUT=1 I X?1."?" W !?5,"Enter a line number from 1 through "_DWLC,!!,$P(X1,";",3) G RD 54 LN I U[X!(X=".") S X=U Q 55 Q:I=9&(X?1A) I 'DWLC,I<27,I-13 S X=U W " THERE ARE NO LINES!",$C(7),! Q 56 I "+- "[$E(X,1),X?1P.N,$D(DWL) S:X?1P X=X_1 S X=X+DWL W " "_X 57 E S X=+X 58 I (I=13!(I=27)&(X=0))!$D(@(DIC_"X,0)")) S DWL=X Q 59 S X="" G LNQ^DIWE5 60 ; 61 X K DIWELAST 62 G X^DIWE 63 ; 64 LIST W " to: "_DWLC_"// " R I:DTIME S:'$T DTOUT=1 S I=$S(I="":DWLC,1:I) I I,I>DWLC!(I<1) S I=DWLC 65 S J=X,DIWELAST=$S(DWLC=I:1,1:I) D LL G 1 66 LL X "F J=J:1:I W !,$J(J,3)_"">""_"_DIC_"J,0)" -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWP.m
r613 r623 1 DIWP ;SFISC/GFT-ASSEMBLE WP LINE ;10JUN2005 2 ;;22.0;VA FileMan;**46,152**;Mar 30, 1999;Build 10 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ;The DIWF variable contains a string of one-letter codes to control W-P output. 5 ;"|" in DIWF means that "|"-windows are not to be evaluated, but are to be printed as 6 ; they stand. 7 ;"X" means eXactly line-for-line, with "||" printed as "||" 8 ;"W" in DIWF means that formatted text will be written out to 9 ; the current device as it is assembled. 10 ;"N" means NOWRAP-- text is assembled line-for-line 11 ;"R" means text will be assembled Right-justified 12 ;"D" means text will be double-spaced 13 ;"L" means internal line numbers appear at the left margin 14 ;"C" followed by a number will cause formatting of text in a column 15 ; width specified by the number. 16 ;"I" followed by a number will cause text to be indented that number 17 ; of columns. 18 ;"?" means that, if user's terminal is available, "|"-windows that cannot 19 ; be evaluated will be asked from the user's terminal. 20 ;"B" followed by number causes new page when output gets within that 21 ; number of lines from the bottom of the page (as defined by IOSL). 22 ; 23 ;DIWTC is a Boolean -- Are we printing out in LINE MODE? 24 S:'$L(X) X=" " 25 S DIWTC=X[($C(124)_"TAB") S:'$D(DN) DN=1 26 LN S:'$D(DIWF) DIWF="" S:'DIWTC DIWTC=DIWF["N" S DIWX=X,DIW=$C(124),I=$P(DIWF,"C",2) I I S DIWR=DIWL+I-1 27 I '$D(^UTILITY($J,"W",DIWL)) S ^(DIWL)=1 K DIWFU,DIWFWU,DIWLL D DIWI S:'$D(DIWT) DIWT="5,10,15,20,25" G DIW 28 S I=^(DIWL),DIWI=^(DIWL,I,0) I DIWI="" D DIWI G Z 29 D NEW:DIWTC 30 Z S Z=X?.P!DIWTC I X?1" ".E!Z S DIWTC=1 D NEW:DIWI]"" S DIWTC=Z 31 DIW ;from RCR+5^DIWW 32 I DIWF["X" S DIWTC=1,X=DIWX,DIWX="" D C G D ;**DI*22*152** Leave line unaltered 33 S X=$P(DIWX,DIW,1) D C:X]"" S X=$P(DIWX,DIW,1),DIWX=$P(DIWX,DIW,2,999) G D:DIWX="" I $D(DIWP),X'?.E1" " D ST 34 S X=$P(DIWX,DIW,1) I $P(X,"TAB",1)="" D TAB G N 35 I X="TOP" D PUT S ^("X")="S DIFF=1 X:$D(^UTILITY($J,1)) ^(1)" D NEW G N 36 I DIWF'[DIW G U:X="_" D PUT,RCR^DIWW G N:$D(X) 37 S X=DIW_$P(DIWX,DIW,1)_DIW D C 38 N K X S DIWX=$P(DIWX,DIW,2,99) I DIWX]"" D ST:$D(DIWP) G DIW 39 D K DIWP D PUT,PRE:DIWTC S:DIWTC DIWI="" Q 40 ; 41 ST S DIWI=$E(DIWI,1,$L(DIWI)-1) K DIWP Q 42 ; 43 DIWI S DIWI=$J("",+$P(DIWF,"I",2)) I DIWF["L",$D(D)#2 S DIWLL=D 44 Q 45 PUT S I=^UTILITY($J,"W",DIWL),^(DIWL,I,0)=DIWI I DIWF["L",$D(DIWLL) S ^("L")=DIWLL 46 Q 47 L ; 48 S DIWTC=1 G LN 49 ; 50 TAB I X="" S X=DIW G C 51 S J=$P(DIWT,",",DIWTC),DIWTC=DIWTC+1 S:X?3A1P.P.N.E J=$E(X,5,9) S:J?1"""".E1"""" J=$E(J,2,$L(J)-1) 52 I J'>0 S %=$P(DIWX,DIW,2) Q:%="" S J=$S(J<0:1-$L(%)-J,J="C":DIWR-DIWL-$L(%)\2,1:0) 53 S J=J-1-$L(DIWI) Q:J<1 S X=$J("",J) 54 C K DIWP I DIWTC S DIWI=DIWI_X Q 55 B S Z=DIWR-DIWL+1-$L(DIWI) G FULL:$F(X," ")-1>Z F %=Z:-1 I " "[$E(X,%) S:$E(X,%+1)=" " %=%+1 Q 56 S Z=$E(X,1,%-1),X=$E(X,%+1,999) I Z]"" S DIWI=DIWI_Z G S:X]"" S %=$E(Z,$L(Z)) S:%'=" " DIWI=DIWI_$J("",%="."+1),DIWP=1 Q 57 FULL I $P(DIWF,"I",2)'<$L(DIWI) S DIWI=DIWI_$P(X," ",1),X=$P(X," ",2,999) 58 S D PUT,NEW G B:X]"" Q 59 ; 60 U S I=^UTILITY($J,"W",DIWL) I $D(DIWFU) S ^(DIWL,I,"U",$L(DIWI)+1)="" K DIWFU G N 61 S ^(DIWL,I,"U",$L(DIWI)+1)=X,DIWFU=1 G N 62 ; 63 NEW D DIWI 64 PRE S I=^UTILITY($J,"W",DIWL),^(DIWL)=I+1,^(DIWL,I+1,0)="" I DIWF["D" S ^(0)=" ",^UTILITY($J,"W",DIWL)=I+2,^(DIWL,I+2,0)="" 65 I $D(DIWFU) S ^("U",1+$P(DIWF,"I",2))="_" 66 G P:DIWF'["R"!DIWTC K % Q:'$D(^UTILITY($J,"W",DIWL,I,0)) 67 S Y=^(0),%=$L(Y) F %=%:-1 Q:$A(Y,%)-32 68 S Y=$E(Y,1,%),J=DIWR-DIWL-%+1,%X=0 G P:J<1 69 F %=1:1 S %(%)=$P(Y," ",1),Y=$P(Y," ",2,999) G:Y="" PAD:%-1,P I $E(%(%),$L(%(%)))?.P S:%=1&(%(%)="") %=0,%X=%X+1 S:%&J J=J-1,%(%)=%(%)_" " 70 PAD I J F Y=%\2+1:1:%-1,%\2:-1 S %(Y)=%(Y)_" ",J=J-1 G PAD:Y=1!'J 71 S Y=%(%) F %=%-1:-1:1 S Y=%(%)_" "_Y 72 S ^(0)=$J("",%X)_Y K % 73 P I DIWF["W" G NX^DIWW 1 DIWP ;SFISC/GFT-ASSEMBLE WP LINE ;12:15 PM 5 Jun 2000 2 ;;22.0;VA FileMan;**46**;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 S:'$L(X) X=" " 5 S DIWTC=X[($C(124)_"TAB") S:'$D(DN) DN=1 6 LN S:'$D(DIWF) DIWF="" S:'DIWTC DIWTC=DIWF["N" S DIWX=X,DIW=$C(124),I=$P(DIWF,"C",2) I I S DIWR=DIWL+I-1 7 I '$D(^UTILITY($J,"W",DIWL)) S ^(DIWL)=1 K DIWFU,DIWFWU,DIWLL D DIWI S:'$D(DIWT) DIWT="5,10,15,20,25" G DIW 8 S I=^(DIWL),DIWI=^(DIWL,I,0) I DIWI="" D DIWI G Z 9 D NEW:DIWTC 10 Z S Z=X?.P!DIWTC I X?1" ".E!Z S DIWTC=1 D NEW:DIWI]"" S DIWTC=Z 11 DIW ; 12 S X=$P(DIWX,DIW,1) D C:X]"" S X=$P(DIWX,DIW,1),DIWX=$P(DIWX,DIW,2,999) G D:DIWX="" I $D(DIWP),X'?.E1" " D ST 13 S X=$P(DIWX,DIW,1) I $P(X,"TAB",1)="" D TAB G N 14 I X="TOP" D PUT S ^("X")="S DIFF=1 X:$D(^UTILITY($J,1)) ^(1)" D NEW G N 15 I DIWF'[DIW G U:X="_" D PUT,RCR^DIWW G N:$D(X) 16 S X=DIW_$P(DIWX,DIW,1)_DIW D C 17 N K X S DIWX=$P(DIWX,DIW,2,99) I DIWX]"" D ST:$D(DIWP) G DIW 18 D K DIWP D PUT,PRE:DIWTC S:DIWTC DIWI="" Q 19 ; 20 ST S DIWI=$E(DIWI,1,$L(DIWI)-1) K DIWP Q 21 ; 22 DIWI S DIWI=$J("",+$P(DIWF,"I",2)) I DIWF["L",$D(D)#2 S DIWLL=D 23 Q 24 PUT S I=^UTILITY($J,"W",DIWL),^(DIWL,I,0)=DIWI I DIWF["L",$D(DIWLL) S ^("L")=DIWLL 25 Q 26 L ; 27 S DIWTC=1 G LN 28 ; 29 TAB I X="" S X=DIW G C 30 S J=$P(DIWT,",",DIWTC),DIWTC=DIWTC+1 S:X?3A1P.P.N.E J=$E(X,5,9) S:J?1"""".E1"""" J=$E(J,2,$L(J)-1) 31 I J'>0 S %=$P(DIWX,DIW,2) Q:%="" S J=$S(J<0:1-$L(%)-J,J="C":DIWR-DIWL-$L(%)\2,1:0) 32 S J=J-1-$L(DIWI) Q:J<1 S X=$J("",J) 33 C K DIWP I DIWTC S DIWI=DIWI_X Q 34 B S Z=DIWR-DIWL+1-$L(DIWI) G FULL:$F(X," ")-1>Z F %=Z:-1 I " "[$E(X,%) S:$E(X,%+1)=" " %=%+1 Q 35 S Z=$E(X,1,%-1),X=$E(X,%+1,999) I Z]"" S DIWI=DIWI_Z G S:X]"" S %=$E(Z,$L(Z)) S:%'=" " DIWI=DIWI_$J("",%="."+1),DIWP=1 Q 36 FULL I $P(DIWF,"I",2)'<$L(DIWI) S DIWI=DIWI_$P(X," ",1),X=$P(X," ",2,999) 37 S D PUT,NEW G B:X]"" Q 38 ; 39 U S I=^UTILITY($J,"W",DIWL) I $D(DIWFU) S ^(DIWL,I,"U",$L(DIWI)+1)="" K DIWFU G N 40 S ^(DIWL,I,"U",$L(DIWI)+1)=X,DIWFU=1 G N 41 ; 42 NEW D DIWI 43 PRE S I=^UTILITY($J,"W",DIWL),^(DIWL)=I+1,^(DIWL,I+1,0)="" I DIWF["D" S ^(0)=" ",^UTILITY($J,"W",DIWL)=I+2,^(DIWL,I+2,0)="" 44 I $D(DIWFU) S ^("U",1+$P(DIWF,"I",2))="_" 45 G P:DIWF'["R"!DIWTC K % Q:'$D(^UTILITY($J,"W",DIWL,I,0)) 46 S Y=^(0),%=$L(Y) F %=%:-1 Q:$A(Y,%)-32 47 S Y=$E(Y,1,%),J=DIWR-DIWL-%+1,%X=0 G P:J<1 48 F %=1:1 S %(%)=$P(Y," ",1),Y=$P(Y," ",2,999) G:Y="" PAD:%-1,P I $E(%(%),$L(%(%)))?.P S:%=1&(%(%)="") %=0,%X=%X+1 S:%&J J=J-1,%(%)=%(%)_" " 49 PAD I J F Y=%\2+1:1:%-1,%\2:-1 S %(Y)=%(Y)_" ",J=J-1 G PAD:Y=1!'J 50 S Y=%(%) F %=%-1:-1:1 S Y=%(%)_" "_Y 51 S ^(0)=$J("",%X)_Y K % 52 P I DIWF["W" G NX^DIWW -
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIWW.m
r613 r623 1 DIWW ;SFISC/GFT-OUTPUT WP LINE ;5NOV20072 ;;22.0;VA FileMan;**64,144,152**;Mar 30, 1999;Build 10 3 4 5 T 6 B 7 8 9 10 11 A 12 13 14 NX 15 16 0 17 18 1 19 20 21 W 22 23 O 24 X 25 K 26 27 U 28 29 UU 30 31 32 UUU 33 Q 34 QQ 35 36 RCR 37 38 39 40 41 42 43 44 45 46 BACK 47 48 49 DIQ 50 S DIWF=$E("N",C["L")_"W"_$E("|X",C["X"!(C["x")+1),DIWL=2,DIWR=IOM,X=O_": " K ^UTILITY($J,"W")51 52 53 54 55 56 H 57 DT 58 59 N 1 DIWW ;SFISC/GFT-OUTPUT WP LINE ;02:59 PM 18 Apr 2002 2 ;;22.0;VA FileMan;**64,144**;Mar 30, 1999;Build 5 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 F I=0:1 G:$D(DN) QQ:'DN Q:$D(^UTILITY($J,"W"))<9 D T G:$D(DN) QQ:'DN D 0 5 T W:$X ! 6 B Q:$S($D(DN):'DN,1:0) I '$D(DIWF) S DIWF="" 7 I '$D(DIOT(2)),$D(IOSL),$Y+$S($P(DIWF,"B",2):$P(DIWF,"B",2),1:2)'<IOSL,$D(^UTILITY($J,1))#2,^(1)?1U1P1E.E X ^(1) I $D(DN),'DN S D0="zzzzzz",W=9999999 Q 8 F I=$Y+2:1:+$P(DIWF,"T",2) W ! 9 Q 10 ; 11 A ; 12 D 0 G DIWW 13 ; 14 NX ; 15 W:$X+1>DIWL ! D B G:$D(DN) Q:'DN 16 0 ; 17 S I=999999,%="" F S %=$O(^UTILITY($J,"W",%)) Q:%="" S:$O(^(%,""))<I I=$O(^("")) 18 1 S %="" F S %=$O(^UTILITY($J,"W",%)) Q:%="" I $D(^(%,I)) D W I $D(^UTILITY($J,"W",%))<9 K ^(%) I $O(^(""))="" K DIWI,DIWX,DIWTC 19 S:%="" %=-1 G Q 20 ; 21 W G X:^(I,0)="",O:'$D(DIWF) I DIWF[" " S DIWF=$P(DIWF," ",1)_$P(DIWF," ",2) G X:^(0)?." " 22 W:$X+(%>0)>% ! I DIWF["L",$D(^("L")) W $E(^("L")_" ",1,4) 23 O W ?%-1,^(0) 24 X D U:$D(^("U")) I $D(^("X")) S Y=^("X") D K X Y Q 25 K K ^UTILITY($J,"W",%,I) Q 26 ; 27 U Q:'$D(IOST) Q:IOST'?1"P".E W $C(13) F DE=1:1:$S($D(^("L")):%+3,1:%-1) W " " 28 S DE=1 29 UU S %Y=$O(^UTILITY($J,"W",%,I,"U","")) I %Y="" S %Y=$L(^UTILITY($J,"W",%,I,0))+1 S:'$D(DIWFWU) DIWFWU=" " D UUU K DIWFWU Q 30 S Y=^(%Y) K ^(%Y) I Y="" D UUU K DIWFWU G UU 31 S DIWFWU=Y F DE=DE:1 G UU:DE'<%Y W " " 32 UUU I $D(DIWFWU) F DE=DE:1 Q:DE'<%Y W DIWFWU 33 Q Q 34 QQ K DIWI,DIWX,DIWTC Q 35 ; 36 RCR ; 37 N DA,M,DQI,DA 38 F M="DIWX","DICMX","DIC","D","D0","D1","D2","D3","D4","D5","D6","D7","Y","I","J" M %=@M N @M M @M=% 39 S DQI="Y(",DA="X(",DICMX="X DICMX",DICOMP="ST" S:$D(DIA("P"))#2 J(0)=DIA("P") D EN1^DICOMP 40 I '$D(X) Q:DIWF'["?"!(IO(0)=IO)!$D(IO("C")) U IO(0) W $C(7),!,$P(@(I(0)_"D0,0)"),U),"---",!?4,$P(DIWX,DIW)_": " R X:DTIME,! U IO G BACK 41 I Y["m" S DICMX=$S(Y["w":"D ^DIWP",1:"S DIWX=X,DIWTC=1 D DIW^DIWP S DIWI=$J("""","_$L(DIWI)_")") X X S X="" G BACK 42 I Y["X" S X=DIW_X_DIW G BACK 43 I $P(DIWX,"SETPAGE(",1)="" S ^(DIWL,^UTILITY($J,"W",DIWL),"X")=X,X="" G BACK 44 S DICMX=Y["D" X X I DICMX S Y=X X ^DD("DD") S X=Y 45 I $P(DIWX,"INDENT(")="" S X=$J(X,$P(DIWF,"I",2)-$L(DIWI)-1) 46 BACK D C^DIWP:X]"" S X="" 47 Q 48 ; 49 DIQ ; 50 S DIWF=$E("N",C["L")_"W|",DIWL=2,DIWR=IOM,X=O_": " K ^UTILITY($J,"W") 51 S W=0 F D S W=$O(@(D(DL-1)_"W)")) Q:W'>0!(S=0) S X=^(W,0) 52 .D ^DIWP 53 .N W D LF^DIQ 54 G DIWW 55 ; 56 H G H^DIO2 57 DT G DT^DIO2 58 ; 59 N W ! G B
Note:
See TracChangeset
for help on using the changeset viewer.
